/********************************************************************
NAME : ExpandFuncCall
DESCRIPTION : This function is a wrap-around for a normal
function call. It preexamines the argument
expression list and expands any references to the
sequence operator. It builds a copy of the
function call expression with these new arguments
inserted and evaluates the function call.
INPUTS : A data object buffer
RETURNS : Nothing useful
SIDE EFFECTS : Expressions alloctaed/deallocated
Function called and arguments evaluated
EvaluationError set on errors
NOTES : None
*******************************************************************/
globle void ExpandFuncCall(
void *theEnv,
DATA_OBJECT *result)
{
EXPRESSION *newargexp,*fcallexp;
struct FunctionDefinition *func;
/* ======================================================================
Copy the original function call's argument expression list.
Look for expand$ function callsexpressions and replace those
with the equivalent expressions of the expansions of evaluations
of the arguments.
====================================================================== */
newargexp = CopyExpression(theEnv,GetFirstArgument()->argList);
ExpandFuncMultifield(theEnv,result,newargexp,&newargexp,
(void *) FindFunction(theEnv,"expand$"));
/* ===================================================================
Build the new function call expression with the expanded arguments.
Check the number of arguments, if necessary, and call the thing.
=================================================================== */
fcallexp = get_struct(theEnv,expr);
fcallexp->type = GetFirstArgument()->type;
fcallexp->value = GetFirstArgument()->value;
fcallexp->nextArg = NULL;
fcallexp->argList = newargexp;
if (fcallexp->type == FCALL)
{
func = (struct FunctionDefinition *) fcallexp->value;
if (CheckFunctionArgCount(theEnv,ValueToString(func->callFunctionName),
func->restrictions,CountArguments(newargexp)) == FALSE)
{
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
ReturnExpression(theEnv,fcallexp);
return;
}
}
#if DEFFUNCTION_CONSTRUCT
else if (fcallexp->type == PCALL)
{
if (CheckDeffunctionCall(theEnv,fcallexp->value,
CountArguments(fcallexp->argList)) == FALSE)
{
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
ReturnExpression(theEnv,fcallexp);
SetEvaluationError(theEnv,TRUE);
return;
}
}
#endif
EvaluateExpression(theEnv,fcallexp,result);
ReturnExpression(theEnv,fcallexp);
}
/*************************************************************
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);
}
/*************************************************************
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);
}
int x86ThreadArchInit(struct x86ArchThread *thread, void *entry, unsigned long *argv, unsigned char priv)
{
unsigned long *stack;
int argc = CountArguments((char **)argv);
argv[argc] = 0; // Set last argument + 1 to NULL
if(argc < 0)
argc = 0;
/** @note Following structures are allocated in process' parent:
- The process struct;
- The process queue.
*/
thread->kernel_stack_base = (unsigned long)kmalloc_a(KERNEL_STACK_SIZE);
if(thread->kernel_stack_base == 0)
return -ENOMEM;
memset((void *)thread->kernel_stack_base, 0, KERNEL_STACK_SIZE);
thread->kernel_stack = thread->kernel_stack_base + KERNEL_STACK_SIZE; // Create kernel stack
if(priv == PRIV_USER) {
// Apenas aloca memória de user se for preciso
thread->stack_base = (unsigned long)umalloc_a(USER_STACK_SIZE);
if(thread->stack_base == 0) {
kfree((void *)thread->kernel_stack_base);
return -ENOMEM;
}
memset((void *)thread->stack_base, 0, USER_STACK_SIZE);
thread->stack = thread->stack_base + USER_STACK_SIZE; // Allocate 4 kilobytes of space for user
} else {
thread->stack_base = thread->kernel_stack_base;
thread->stack = thread->kernel_stack;
}
stack = (unsigned long*)thread->stack; // Expand down stack
// We expect all threads to have this layout:
// ThreadMain(int argc, char **argv);
// The kernel will not crash if the thread is different (i guess)
*--stack = (unsigned long)argv; // Argv
*--stack = argc; // Argc
*--stack = (unsigned long)&x86ThreadExitEntry;
// Pushed by iret
if(priv == PRIV_USER) { // User threads have special stack
*--stack = 0x23; // SS
*--stack = thread->stack - 12; // ESP
}
*--stack = 0x202; // EFLAGS
*--stack = ((priv == PRIV_USER) ? (0x1b) : 0x08); // CS
*--stack = (unsigned long)entry; // EIP
// Pushed by pusha
*--stack = 0; // EDI
*--stack = 0; // ESI
*--stack = 0; // EBP
*--stack = 0; // NULL
*--stack = 0; // EBX
*--stack = 0; // EDX
*--stack = 0; // ECX
*--stack = 0; // EAX
// Pushed by asm handler
*--stack = ((priv == PRIV_USER) ? (0x23) : 0x10); // DS
*--stack = ((priv == PRIV_USER) ? (0x23) : 0x10); // ES
*--stack = ((priv == PRIV_USER) ? (0x23) : 0x10); // FS
*--stack = ((priv == PRIV_USER) ? (0x23) : 0x10); // GS
thread->stack = (unsigned long)stack;
return ESUCCESS;
}
/***********************************************************************************
NAME : GenericDispatch
DESCRIPTION : Executes the most specific applicable method
INPUTS : 1) The generic function
2) The method to start after in the search for an applicable
method (ignored if arg #3 is not NULL).
3) A specific method to call (NULL if want highest precedence
method to be called)
4) The generic function argument expressions
5) The caller's result value buffer
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic function arguments
Any side-effects of evaluating query functions on method parameter
restrictions when determining the core (see warning #1)
Any side-effects of actual execution of methods (see warning #2)
Caller's buffer set to the result of the generic function call
In case of errors, the result is false, otherwise it is the
result returned by the most specific method (which can choose
to ignore or return the values of more general methods)
NOTES : WARNING #1: Query functions on method parameter restrictions
should not have side-effects, for they might be evaluated even
for methods that aren't applicable to the generic function call.
WARNING #2: Side-effects of method execution should not always rely
on only being executed once per generic function call. Every
time a method calls (shadow-call) the same next-most-specific
method is executed. Thus, it is possible for a method to be
executed multiple times per generic function call.
***********************************************************************************/
void GenericDispatch(
void *theEnv,
DEFGENERIC *gfunc,
DEFMETHOD *prevmeth,
DEFMETHOD *meth,
EXPRESSION *params,
DATA_OBJECT *result)
{
DEFGENERIC *previousGeneric;
DEFMETHOD *previousMethod;
int oldce;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
struct CLIPSBlock gcBlock;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
EvaluationData(theEnv)->EvaluationError = false;
if (EvaluationData(theEnv)->HaltExecution)
return;
CLIPSBlockStart(theEnv,&gcBlock);
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,true);
previousGeneric = DefgenericData(theEnv)->CurrentGeneric;
previousMethod = DefgenericData(theEnv)->CurrentMethod;
DefgenericData(theEnv)->CurrentGeneric = gfunc;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
gfunc->busy++;
PushProcParameters(theEnv,params,CountArguments(params),
EnvGetDefgenericName(theEnv,(void *) gfunc),
"generic function",UnboundMethodErr);
if (EvaluationData(theEnv)->EvaluationError)
{
gfunc->busy--;
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
CLIPSBlockEnd(theEnv,&gcBlock,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
return;
}
if (meth != NULL)
{
if (IsMethodApplicable(theEnv,meth))
{
meth->busy++;
DefgenericData(theEnv)->CurrentMethod = meth;
}
else
{
PrintErrorID(theEnv,"GENRCEXE",4,false);
EnvSetEvaluationError(theEnv,true);
DefgenericData(theEnv)->CurrentMethod = NULL;
EnvPrintRouter(theEnv,WERROR,"Generic function ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WERROR," method #");
PrintLongInteger(theEnv,WERROR,(long long) meth->index);
EnvPrintRouter(theEnv,WERROR," is not applicable to the given arguments.\n");
}
}
else
DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,gfunc,prevmeth);
if (DefgenericData(theEnv)->CurrentMethod != NULL)
{
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,BEGIN_TRACE);
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,BEGIN_TRACE);
#endif
if (DefgenericData(theEnv)->CurrentMethod->system)
{
EXPRESSION fcall;
fcall.type = FCALL;
fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
fcall.nextArg = NULL;
fcall.argList = GetProcParamExpressions(theEnv);
EvaluateExpression(theEnv,&fcall,result);
}
else
{
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&DefgenericData(theEnv)->CurrentMethod->usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
result,UnboundMethodErr);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
}
DefgenericData(theEnv)->CurrentMethod->busy--;
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,END_TRACE);
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,END_TRACE);
#endif
}
else if (! EvaluationData(theEnv)->EvaluationError)
{
PrintErrorID(theEnv,"GENRCEXE",1,false);
EnvPrintRouter(theEnv,WERROR,"No applicable methods for ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WERROR,".\n");
EnvSetEvaluationError(theEnv,true);
}
gfunc->busy--;
ProcedureFunctionData(theEnv)->ReturnFlag = false;
PopProcParameters(theEnv);
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
CLIPSBlockEnd(theEnv,&gcBlock,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
}
/***********************************************************************************
NAME : GenericDispatch
DESCRIPTION : Executes the most specific applicable method
INPUTS : 1) The generic function
2) The method to start after in the search for an applicable
method (ignored if arg #3 is not NULL).
3) A specific method to call (NULL if want highest precedence
method to be called)
4) The generic function argument expressions
5) The caller's result value buffer
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic function arguments
Any side-effects of evaluating query functions on method parameter
restrictions when determining the core (see warning #1)
Any side-effects of actual execution of methods (see warning #2)
Caller's buffer set to the result of the generic function call
In case of errors, the result is false, otherwise it is the
result returned by the most specific method (which can choose
to ignore or return the values of more general methods)
NOTES : WARNING #1: Query functions on method parameter restrictions
should not have side-effects, for they might be evaluated even
for methods that aren't applicable to the generic function call.
WARNING #2: Side-effects of method execution should not always rely
on only being executed once per generic function call. Every
time a method calls (shadow-call) the same next-most-specific
method is executed. Thus, it is possible for a method to be
executed multiple times per generic function call.
***********************************************************************************/
void GenericDispatch(
Environment *theEnv,
Defgeneric *gfunc,
Defmethod *prevmeth,
Defmethod *meth,
Expression *params,
UDFValue *returnValue)
{
Defgeneric *previousGeneric;
Defmethod *previousMethod;
bool oldce;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
GCBlock gcb;
returnValue->value = FalseSymbol(theEnv);
EvaluationData(theEnv)->EvaluationError = false;
if (EvaluationData(theEnv)->HaltExecution)
return;
GCBlockStart(theEnv,&gcb);
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,true);
previousGeneric = DefgenericData(theEnv)->CurrentGeneric;
previousMethod = DefgenericData(theEnv)->CurrentMethod;
DefgenericData(theEnv)->CurrentGeneric = gfunc;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
gfunc->busy++;
PushProcParameters(theEnv,params,CountArguments(params),
DefgenericName(gfunc),
"generic function",UnboundMethodErr);
if (EvaluationData(theEnv)->EvaluationError)
{
gfunc->busy--;
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
GCBlockEndUDF(theEnv,&gcb,returnValue);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
return;
}
if (meth != NULL)
{
if (IsMethodApplicable(theEnv,meth))
{
meth->busy++;
DefgenericData(theEnv)->CurrentMethod = meth;
}
else
{
PrintErrorID(theEnv,"GENRCEXE",4,false);
SetEvaluationError(theEnv,true);
DefgenericData(theEnv)->CurrentMethod = NULL;
WriteString(theEnv,STDERR,"Generic function '");
WriteString(theEnv,STDERR,DefgenericName(gfunc));
WriteString(theEnv,STDERR,"' method #");
PrintUnsignedInteger(theEnv,STDERR,meth->index);
WriteString(theEnv,STDERR," is not applicable to the given arguments.\n");
}
}
else
DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,gfunc,prevmeth);
if (DefgenericData(theEnv)->CurrentMethod != NULL)
{
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,BEGIN_TRACE);
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,BEGIN_TRACE);
#endif
if (DefgenericData(theEnv)->CurrentMethod->system)
{
Expression fcall;
fcall.type = FCALL;
fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
fcall.nextArg = NULL;
fcall.argList = GetProcParamExpressions(theEnv);
EvaluateExpression(theEnv,&fcall,returnValue);
}
else
{
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&DefgenericData(theEnv)->CurrentMethod->header.usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
returnValue,UnboundMethodErr);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
}
DefgenericData(theEnv)->CurrentMethod->busy--;
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,END_TRACE);
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,END_TRACE);
#endif
}
else if (! EvaluationData(theEnv)->EvaluationError)
{
PrintErrorID(theEnv,"GENRCEXE",1,false);
WriteString(theEnv,STDERR,"No applicable methods for '");
WriteString(theEnv,STDERR,DefgenericName(gfunc));
WriteString(theEnv,STDERR,"'.\n");
SetEvaluationError(theEnv,true);
}
gfunc->busy--;
ProcedureFunctionData(theEnv)->ReturnFlag = false;
PopProcParameters(theEnv);
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
GCBlockEndUDF(theEnv,&gcb,returnValue);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
}
globle void StoreInMultifield(
void *theEnv,
DATA_OBJECT *returnValue,
EXPRESSION *expptr,
int garbageSegment)
{
DATA_OBJECT val_ptr;
DATA_OBJECT *val_arr;
struct multifield *theMultifield;
struct multifield *orig_ptr;
long start, end, i,j, k, argCount;
unsigned long seg_size;
argCount = CountArguments(expptr);
/*=========================================*/
/* If no arguments are given return a NULL */
/* multifield of length zero. */
/*=========================================*/
if (argCount == 0)
{
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,0);
if (garbageSegment) theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,0L);
else theMultifield = (struct multifield *) CreateMultifield2(theEnv,0L);
SetpValue(returnValue,(void *) theMultifield);
return;
}
else
{
/*========================================*/
/* Get a new segment with length equal to */
/* the total length of all the arguments. */
/*========================================*/
val_arr = (DATA_OBJECT *) gm3(theEnv,(long) sizeof(DATA_OBJECT) * argCount);
seg_size = 0;
for (i = 1; i <= argCount; i++, expptr = expptr->nextArg)
{
EvaluateExpression(theEnv,expptr,&val_ptr);
if (EvaluationData(theEnv)->EvaluationError)
{
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,0);
if (garbageSegment)
{ theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,0L); }
else theMultifield = (struct multifield *) CreateMultifield2(theEnv,0L);
SetpValue(returnValue,(void *) theMultifield);
rm3(theEnv,val_arr,(long) sizeof(DATA_OBJECT) * argCount);
return;
}
SetpType(val_arr+i-1,GetType(val_ptr));
if (GetType(val_ptr) == MULTIFIELD)
{
SetpValue(val_arr+i-1,GetpValue(&val_ptr));
start = GetDOBegin(val_ptr);
end = GetDOEnd(val_ptr);
}
else if (GetType(val_ptr) == RVOID)
{
SetpValue(val_arr+i-1,GetValue(val_ptr));
start = 1;
end = 0;
}
else
{
SetpValue(val_arr+i-1,GetValue(val_ptr));
start = end = -1;
}
seg_size += (unsigned long) (end - start + 1);
SetpDOBegin(val_arr+i-1,start);
SetpDOEnd(val_arr+i-1,end);
}
if (garbageSegment)
{ theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,seg_size); }
else theMultifield = (struct multifield *) CreateMultifield2(theEnv,seg_size);
/*========================================*/
/* Copy each argument into new segment. */
/*========================================*/
for (k = 0, j = 1; k < argCount; k++)
{
if (GetpType(val_arr+k) == MULTIFIELD)
{
start = GetpDOBegin(val_arr+k);
end = GetpDOEnd(val_arr+k);
orig_ptr = (struct multifield *) GetpValue(val_arr+k);
for (i = start; i < end + 1; i++, j++)
{
SetMFType(theMultifield,j,(GetMFType(orig_ptr,i)));
SetMFValue(theMultifield,j,(GetMFValue(orig_ptr,i)));
}
}
else if (GetpType(val_arr+k) != RVOID)
{
SetMFType(theMultifield,j,(short) (GetpType(val_arr+k)));
SetMFValue(theMultifield,j,(GetpValue(val_arr+k)));
j++;
}
}
/*=========================*/
/* Return the new segment. */
/*=========================*/
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,(long) seg_size);
SetpValue(returnValue,(void *) theMultifield);
rm3(theEnv,val_arr,(long) sizeof(DATA_OBJECT) * argCount);
return;
}
}
static PAL_Boolean _AddEvents(
_In_ FILE * out,
_In_ OIEvent * events)
{
char buf[BUFFER_SIZE];
OIEvent * current = events;
while(current)
{
OIEvent * next = current->next;
OIArgument * arg;
int ArgCount = CountArguments(current->Argument);
int wrote;
{
int i = 0;
char plist1[BUFFER_SIZE];
char plist2[BUFFER_SIZE];
plist1[0] = 0;
plist2[0] = 0;
arg = current->Argument;
while(arg)
{
char param1[BUFFER_SIZE];
char param2[BUFFER_SIZE];
const char * argType = arg->Type;
char * formatString1 = "a%d";
char * formatString2 = formatString1;
param1[0] = 0;
param2[0] = 0;
if (_isTStringType(argType))
{
formatString2 = "tcs(a%d)";
}
else if (__isStringType(argType))
{
formatString2 = "scs(a%d)";
}
#if defined(CONFIG_OS_WINDOWS)
wrote = sprintf_s(param1, BUFFER_SIZE, formatString1, i);
wrote = sprintf_s(param2, BUFFER_SIZE, formatString2, i);
#else
wrote = sprintf(param1, formatString1, i);
wrote = sprintf(param2, formatString2, i);
#endif
if (wrote >= BUFFER_SIZE)
goto error;
if (Strcat(plist1, BUFFER_SIZE, param1) == 0)
goto error;
if (Strcat(plist2, BUFFER_SIZE, param2) == 0)
goto error;
// add a comma if this is NOT the last argument
arg = arg->next;
i++;
if (arg)
{
if (Strcat(plist1, BUFFER_SIZE, ", ") == 0)
goto error;
if (Strcat(plist2, BUFFER_SIZE, ", ") == 0)
goto error;
}
}
buf[0] = 0;
#if defined(CONFIG_OS_WINDOWS)
wrote = sprintf_s(buf, BUFFER_SIZE, (ArgCount == 0)? FILECALLIMPL0 : FILECALLIMPLN,
#else
wrote = sprintf(buf, (ArgCount == 0)? FILECALLIMPL0 : FILECALLIMPLN,
#endif
current->Name, plist1, current->Name, plist2, current->Name, plist1, current->Name, plist2);
fprintf(out, "%s", buf);
}
buf[0] = 0;
#if defined(CONFIG_OS_WINDOWS)
wrote = sprintf_s(buf, BUFFER_SIZE, UseDebugMacro(current->Priority) ? FILEEVENTD : FILEEVENT, ArgCount);
#else
wrote = sprintf(buf, UseDebugMacro(current->Priority) ? FILEEVENTD : FILEEVENT, ArgCount );
#endif
if (wrote >= BUFFER_SIZE)
goto error;
if (Strcat(buf, BUFFER_SIZE, current->EventId) == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, ", ") == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, current->Name) == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, "_Impl") == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, ", ") == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, current->Priority) == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, ", PAL_T(") == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, current->Format) == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, ")") == 0)
goto error;
arg = current->Argument;
while(arg)
{
OIArgument * next = arg->next;
if (Strcat(buf, BUFFER_SIZE, ", ") == 0)
goto error;
if (Strcat(buf, BUFFER_SIZE, arg->Type) == 0)
goto error;
arg = next;
}
if (Strcat(buf, BUFFER_SIZE, ")") == 0)
goto error;
/* buf may contain %d which we need to preserve */
fprintf(out, "%s", buf);
fprintf(out, NL);
current = next;
}
return PAL_TRUE;
error:
OIERROR1("Out of buffer space while generating! Buffer so far was [%s]", buf);
return PAL_FALSE;
}
/*****************************************************
NAME : PerformMessage
DESCRIPTION : Calls core framework for a message
INPUTS : 1) Caller's result buffer
2) Message argument expressions
(including implicit object)
3) Message name
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of message execution
and caller's result buffer set
NOTES : None
*****************************************************/
static void PerformMessage(
DATA_OBJECT *result,
EXPRESSION *args,
SYMBOL_HN *mname)
{
int oldce;
HANDLER_LINK *oldCore;
DEFCLASS *cls = NULL;
INSTANCE_TYPE *ins = NULL;
SYMBOL_HN *oldName;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
result->type = SYMBOL;
result->value = FalseSymbol;
EvaluationError = FALSE;
if (HaltExecution)
return;
oldce = ExecutingConstruct();
SetExecutingConstruct(TRUE);
oldName = CurrentMessageName;
CurrentMessageName = mname;
CurrentEvaluationDepth++;
PushProcParameters(args,CountArguments(args),
ValueToString(CurrentMessageName),"message",
UnboundHandlerErr);
if (EvaluationError)
{
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
if (ProcParamArray->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) ProcParamArray->value;
if (ins->garbage == 1)
{
StaleInstanceAddress("send",0);
SetEvaluationError(TRUE);
}
else if (DefclassInScope(ins->cls,(struct defmodule *) GetCurrentModule()) == FALSE)
NoInstanceError(ValueToString(ins->name),"send");
else
{
cls = ins->cls;
ins->busy++;
}
}
else if (ProcParamArray->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol((SYMBOL_HN *) ProcParamArray->value);
if (ins == NULL)
{
PrintErrorID("MSGPASS",2,FALSE);
PrintRouter(WERROR,"No such instance ");
PrintRouter(WERROR,ValueToString((SYMBOL_HN *) ProcParamArray->value));
PrintRouter(WERROR," in function send.\n");
SetEvaluationError(TRUE);
}
else
{
ProcParamArray->value = (void *) ins;
ProcParamArray->type = INSTANCE_ADDRESS;
cls = ins->cls;
ins->busy++;
}
}
else if ((cls = PrimitiveClassMap[ProcParamArray->type]) == NULL)
{
SystemError("MSGPASS",1);
ExitRouter(EXIT_FAILURE);
}
if (EvaluationError)
{
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
oldCore = TopOfCore;
TopOfCore = FindApplicableHandlers(cls,mname);
if (TopOfCore != NULL)
{
HANDLER_LINK *oldCurrent,*oldNext;
oldCurrent = CurrentCore;
oldNext = NextInCore;
#if IMPERATIVE_MESSAGE_HANDLERS
if (TopOfCore->hnd->type == MAROUND)
{
CurrentCore = TopOfCore;
NextInCore = TopOfCore->nxt;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
else
#endif /* IMPERATIVE_MESSAGE_HANDLERS */
{
CurrentCore = NULL;
NextInCore = TopOfCore;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
#endif
CallHandlers(result);
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
DestroyHandlerLinks(TopOfCore);
CurrentCore = oldCurrent;
NextInCore = oldNext;
}
TopOfCore = oldCore;
ReturnFlag = FALSE;
if (ins != NULL)
ins->busy--;
/* ==================================
Restore the original calling frame
================================== */
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PropagateReturnValue(result);
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
if (EvaluationError)
{
result->type = SYMBOL;
result->value = FalseSymbol;
}
}
/********************************************************
NAME : CallNextHandler
DESCRIPTION : This function allows around-handlers
to execute the rest of the core frame.
It also allows primary handlers
to execute shadowed primaries.
The original handler arguments are
left intact.
INPUTS : The caller's result-value buffer
RETURNS : Nothing useful
SIDE EFFECTS : The core frame is called and any
appropriate changes are made when
used in an around handler
See CallHandlers()
But when call-next-handler is called
from a primary, the same shadowed
primary is called over and over
again for repeated calls to
call-next-handler.
NOTES : H/L Syntax: (call-next-handler) OR
(override-next-handler <arg> ...)
********************************************************/
globle void CallNextHandler(
DATA_OBJECT *result)
{
EXPRESSION args;
int overridep;
HANDLER_LINK *oldNext,*oldCurrent;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
SetpType(result,SYMBOL);
SetpValue(result,FalseSymbol);
EvaluationError = FALSE;
if (HaltExecution)
return;
if (NextHandlerAvailable() == FALSE)
{
PrintErrorID("MSGPASS",1,FALSE);
PrintRouter(WERROR,"Shadowed message-handlers not applicable in current context.\n");
SetEvaluationError(TRUE);
return;
}
if (CurrentExpression->value == (void *) FindFunction("override-next-handler"))
{
overridep = 1;
args.type = (short) ProcParamArray[0].type;
if (args.type != MULTIFIELD)
args.value = (void *) ProcParamArray[0].value;
else
args.value = (void *) &ProcParamArray[0];
args.nextArg = GetFirstArgument();
args.argList = NULL;
PushProcParameters(&args,CountArguments(&args),
ValueToString(CurrentMessageName),"message",
UnboundHandlerErr);
if (EvaluationError)
{
ReturnFlag = FALSE;
return;
}
}
else
overridep = 0;
oldNext = NextInCore;
oldCurrent = CurrentCore;
if (CurrentCore->hnd->type == MAROUND)
{
if (NextInCore->hnd->type == MAROUND)
{
CurrentCore = NextInCore;
NextInCore = NextInCore->nxt;
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
#endif
}
else
CallHandlers(result);
}
else
{
CurrentCore = NextInCore;
NextInCore = NextInCore->nxt;
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
#endif
}
NextInCore = oldNext;
CurrentCore = oldCurrent;
if (overridep)
PopProcParameters();
ReturnFlag = FALSE;
}
globle int CheckExpressionAgainstRestrictions(
void *theEnv,
struct expr *theExpression,
char *restrictions,
char *functionName)
{
char theChar[2];
int i = 0, j = 1;
int number1, number2;
int argCount;
char defaultRestriction, argRestriction;
struct expr *argPtr;
int theRestriction;
theChar[0] = '0';
theChar[1] = '\0';
/*============================================*/
/* If there are no restrictions, then there's */
/* no need to check the function. */
/*============================================*/
if (restrictions == NULL) return(FALSE);
/*=========================================*/
/* Count the number of function arguments. */
/*=========================================*/
argCount = CountArguments(theExpression->argList);
/*======================================*/
/* Get the minimum number of arguments. */
/*======================================*/
theChar[0] = restrictions[i++];
if (isdigit(theChar[0]))
{ number1 = atoi(theChar); }
else if (theChar[0] == '*')
{ number1 = -1; }
else
{ return(FALSE); }
/*======================================*/
/* Get the maximum number of arguments. */
/*======================================*/
theChar[0] = restrictions[i++];
if (isdigit(theChar[0]))
{ number2 = atoi(theChar); }
else if (theChar[0] == '*')
{ number2 = 10000; }
else
{ return(FALSE); }
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (number1 == number2)
{
if (argCount != number1)
{
ExpectedCountError(theEnv,functionName,EXACTLY,number1);
return(TRUE);
}
}
else if (argCount < number1)
{
ExpectedCountError(theEnv,functionName,AT_LEAST,number1);
return(TRUE);
}
else if (argCount > number2)
{
ExpectedCountError(theEnv,functionName,NO_MORE_THAN,number2);
return(TRUE);
}
/*=======================================*/
/* Check for the default argument types. */
/*=======================================*/
defaultRestriction = restrictions[i];
if (defaultRestriction == '\0')
{ defaultRestriction = 'u'; }
else if (defaultRestriction == '*')
{
defaultRestriction = 'u';
i++;
}
else
{ i++; }
/*======================*/
/* Check each argument. */
/*======================*/
for (argPtr = theExpression->argList;
argPtr != NULL;
argPtr = argPtr->nextArg)
{
argRestriction = restrictions[i];
if (argRestriction == '\0')
{ argRestriction = defaultRestriction; }
else
{ i++; }
if (argRestriction != '*')
{ theRestriction = (int) argRestriction; }
else
{ theRestriction = (int) defaultRestriction; }
if (CheckArgumentAgainstRestriction(theEnv,argPtr,theRestriction))
{
ExpectedTypeError1(theEnv,functionName,j,GetArgumentTypeName(theRestriction));
return(TRUE);
}
j++;
}
return(FALSE);
}
globle struct expr *Function2Parse(
void *theEnv,
char *logicalName,
char *name)
{
struct FunctionDefinition *theFunction;
struct expr *top;
#if DEFGENERIC_CONSTRUCT
void *gfunc;
#endif
#if DEFFUNCTION_CONSTRUCT
void *dptr;
#endif
/*=========================================================*/
/* Module specification cannot be used in a function call. */
/*=========================================================*/
if (FindModuleSeparator(name))
{
IllegalModuleSpecifierMessage(theEnv);
return(NULL);
}
/*================================*/
/* Has the function been defined? */
/*================================*/
theFunction = FindFunction(theEnv,name);
#if DEFGENERIC_CONSTRUCT
gfunc = (void *) LookupDefgenericInScope(theEnv,name);
#endif
#if DEFFUNCTION_CONSTRUCT
if ((theFunction == NULL)
#if DEFGENERIC_CONSTRUCT
&& (gfunc == NULL)
#endif
)
dptr = (void *) LookupDeffunctionInScope(theEnv,name);
else
dptr = NULL;
#endif
/*=============================*/
/* Define top level structure. */
/*=============================*/
#if DEFFUNCTION_CONSTRUCT
if (dptr != NULL)
top = GenConstant(theEnv,PCALL,dptr);
else
#endif
#if DEFGENERIC_CONSTRUCT
if (gfunc != NULL)
top = GenConstant(theEnv,GCALL,gfunc);
else
#endif
if (theFunction != NULL)
top = GenConstant(theEnv,FCALL,theFunction);
else
{
PrintErrorID(theEnv,"EXPRNPSR",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Missing function declaration for ");
EnvPrintRouter(theEnv,WERROR,name);
EnvPrintRouter(theEnv,WERROR,".\n");
return(NULL);
}
/*=======================================================*/
/* Check to see if function has its own parsing routine. */
/*=======================================================*/
PushRtnBrkContexts(theEnv);
ExpressionData(theEnv)->ReturnContext = FALSE;
ExpressionData(theEnv)->BreakContext = FALSE;
#if DEFGENERIC_CONSTRUCT || DEFFUNCTION_CONSTRUCT
if (top->type == FCALL)
#endif
{
if (theFunction->parser != NULL)
{
top = (*theFunction->parser)(theEnv,top,logicalName);
PopRtnBrkContexts(theEnv);
if (top == NULL) return(NULL);
if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
FindFunction(theEnv,"expand$")))
{
ReturnExpression(theEnv,top);
return(NULL);
}
return(top);
}
}
/*========================================*/
/* Default parsing routine for functions. */
/*========================================*/
top = CollectArguments(theEnv,top,logicalName);
PopRtnBrkContexts(theEnv);
if (top == NULL) return(NULL);
if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
FindFunction(theEnv,"expand$")))
{
ReturnExpression(theEnv,top);
return(NULL);
}
/*============================================================*/
/* If the function call uses the sequence expansion operator, */
/* its arguments cannot be checked until runtime. */
/*============================================================*/
if (top->value == (void *) FindFunction(theEnv,"(expansion-call)"))
{ return(top); }
/*============================*/
/* Check for argument errors. */
/*============================*/
if ((top->type == FCALL) && EnvGetStaticConstraintChecking(theEnv))
{
if (CheckExpressionAgainstRestrictions(theEnv,top,theFunction->restrictions,name))
{
ReturnExpression(theEnv,top);
return(NULL);
}
}
#if DEFFUNCTION_CONSTRUCT
else if (top->type == PCALL)
{
if (CheckDeffunctionCall(theEnv,top->value,CountArguments(top->argList)) == FALSE)
{
ReturnExpression(theEnv,top);
return(NULL);
}
}
#endif
/*========================*/
/* Return the expression. */
/*========================*/
return(top);
}
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);
}
/****************************************************
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);
}
