This is function.c in view mode; [Download] [Up]
/****************************************************************************
**
*A function.c GAP source Martin Schoenert
**
*H @(#)$Id: function.c,v 3.12 1994/01/31 11:54:28 fceller Rel $
**
*Y Copyright 1990-1992, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany
**
** This package contains the functions that mainly deal with functions.
**
*H $Log: function.c,v $
*H Revision 3.12 1994/01/31 11:54:28 fceller
*H added 'Apply'Func'
*H
*H Revision 3.11 1993/12/20 13:23:47 mschoene
*H fixed 'EvFunccall' to check for void arguments in arg functions
*H
*H Revision 3.10 1993/03/19 17:30:30 martin
*H changed to of stack frames to 'T_EXEC'
*H
*H Revision 3.9 1993/02/04 10:51:10 martin
*H changed to use 'plist' interface
*H
*H Revision 3.8 1992/04/03 16:08:23 martin
*H renamed 'Trace' to 'TraceFunc'
*H
*H Revision 3.7 1992/01/06 14:25:43 martin
*H changed 'EvFuncCall', '~' must not be changed to early
*H
*H Revision 3.6 1992/01/06 14:03:27 martin
*H changed the implementation of '~' slightly
*H
*H Revision 3.5 1991/06/17 08:05:09 martin
*H fixed 'PrReturn' to print return statements without expressions
*H
*H Revision 3.4 1991/04/30 16:12:19 martin
*H initial revision under RCS
*H
*H Revision 3.3 1990/12/07 12:00:00 martin
*H added prototypes for function tables
*H
*H Revision 3.2 1990/10/02 12:00:00 martin
*H added 'quit'
*H
*H Revision 3.1 1990/10/02 12:00:00 martin
*H fixed 'Trace' for functions without local vars
*H
*H Revision 3.0 1990/08/31 12:00:00 martin
*H changed profiling of local functions
*/
#include "system.h" /* system dependent functions */
#include "gasman.h" /* dynamic storage manager */
#include "scanner.h" /* reading of tokens and printing */
#include "eval.h" /* evaluator main dispatcher */
#include "integer.h" /* arbitrary size integers */
#include "list.h" /* generic list package */
#include "plist.h" /* plain list package */
#include "record.h" /* 'HdTilde' */
#include "statemen.h" /* 'HdStat', 'StrStat' */
#include "function.h" /* declaration file of the package */
/****************************************************************************
**
*V HdExec . . . . . . . . . . . . . . . handle of the topmost execution bag
**
** 'HdExec' is the handle of the topmost execution bag on the execution bag
** linked list. For every active function there is one execution bag on
** this list. 'HdExec' is the execution bag of the current function.
**
** The execution bag list is the equivalent of the stack in programming
** languages like C or Pascal. 'HdExec' is therefor the equivalent of the
** Stackpointer in those languages.
**
** To be precise a function execute bag has the following form:
**
** handle 0: handle of enclosing environment.
** handle 1: handle 'HdTrue' if this frame is current.
** handle 2: handle of function definition.
** handle 3: handle of function call bag, debug only.
** handle 4: handle of calling enviroment, debug only.
** handle 5..n+4: handles of old arguments.
** handle n+5..n+m+4: handles of old local variables.
** handle n+m+5..2*n+m+4: handles of new arguments.
*/
TypHandle HdExec;
/****************************************************************************
**
*V IsProfiling . . . . . . . . . . . . . . is 1 if profiling is switched on
*V HdTimes . . . handle of the list that contains the profiling information
*V Timesum . . total time spent in all functions that have completed so far
**
** 'IsProfiling' is 1 if profiling is enabled and 0 otherwise.
**
** 'HdTimes' is the handle of the list that contains the profiling
** information. This list contains for every function the following entries
**
** <function> handle of the function bag (or body of the function)
** <name> handle of the first entry in the function call
** <count> number of times this function was called
** <time> time spent in this function without its children
** <total> time spent in this function with its childer
**
** 'Timesum' is the total time spent in all functions that have completed so
** far. When a function is called the current value of 'Timesum' is
** remembered. When the function completes 'Timesum' - <old> is the time
** spent in all childeren of this function. If this is subtracted from the
** total time spent in this function we have the time spent in this function
** without its children.
*/
long IsProfiling;
TypHandle HdTimes;
unsigned long Timesum;
/****************************************************************************
**
*F ChangeEnv( <hdEnv> ) . . . . change the environment for a function call
**
** 'ChangeEnv' changes the environment for a function call. A *environment*
** is the set of bindings of identifiers to variables. GAP has lexical
** binding, i.e., the environment in effect when a function is created, the
** so called *definition environment*, determines the variable bindings.
** Thus when a function is called its definition environment is made the
** current environment. When the function terminates the old environment,
** the so called *execution environment* is made current again.
**
** An environment is stored as a linked list of exec-bags. Every exec-bag
** contains, among other things, the changes that a certain function made to
** the environment. I.e., when a function is called it introduces a set of
** new arguments and local variables. If the function was already active,
** i.e., if the call was recursive, the exec-bag remembers the old values of
** the variables. If the function was not already active, the exec-bag
** remembers the fact that the variables had no values prior to the call.
**
** The following picture should make the operation of 'ChangeEnv' clear:
**
** <hdEnv> -> <exec 1> -> <exec 2> -\
** \
** 'HdExec' -> <exec 3> -> <exec 4> ---+-> <exec 5> -> <exec 6> ... -> 0
**
** 'HdExec' is the handle of the current environment. <hdEnv> is the handle
** of an environment of a function that is just beeing called. 'ChangeEnv'
** must now change the environment from 'HdExec' to <hdEnv>. To do so it
** must undo the changes stored in <exec 3> and <exec 4> and then must redo
** the changes stored in <exec 2> and <exec 1>, in that order.
**
** Note that functions which are defined globally can not access non-local,
** non-global variables. Therefor it makes no difference in which such a
** function is executed. In this case 'EvFunccall' does not change the
** environment at all. Thus instead of:
**
** <hdEnv> -> <exec 1> -------------\
** \
** 'HdExec' -> <exec 3> -> <exec 4> --+-> 0
**
** 'EvFuncall' acts as if the situation was:
**
** <hdEnv> -> <exec 1> -\
** \
** 'HdExec' --------------+-> <exec 3> -> <exec 4> -> 0
*/
void ChangeEnv ( hdEnv )
TypHandle hdEnv;
{
register TypHandle hdDo, hdComm, hdTmp, hdUndo;
register TypHandle * ptUndo, * ptDef, * ptDo;
register short nr, i;
/* first walk down the new chain until we find a active exec bag */
/* we reverse the links, so we can walk back later */
hdDo = 0;
hdComm = hdEnv;
while ( hdComm != 0 && PTR(hdComm)[1] != HdTrue ) {
hdTmp = PTR(hdComm)[0];
PTR(hdComm)[0] = hdDo;
hdDo = hdComm;
hdComm = hdTmp;
}
/* then we undo all changes from the topmost down to the common exec */
hdUndo = HdExec;
while ( hdUndo != hdComm ) {
ptUndo = PTR(hdUndo);
ptDef = PTR(ptUndo[2]);
nr = (SIZE(ptUndo[2])-2*sizeof(short)-2*SIZE_HD)/SIZE_HD;
for ( i = 1; i <= nr; ++i ) {
hdTmp = ptUndo[i+4];
ptUndo[i+4] = PTR(ptDef[i])[0];
PTR(ptDef[i])[0] = hdTmp;
}
ptUndo[1] = HdFalse;
hdUndo = ptUndo[0];
}
/* then we redo all changes from the common up to the new topmost exec */
while ( hdDo != 0 ) {
ptDo = PTR(hdDo);
ptDef = PTR(ptDo[2]);
nr = (SIZE(ptDo[2])-2*sizeof(short)-2*SIZE_HD)/SIZE_HD;
for ( i = 1; i <= nr; ++i ) {
hdTmp = ptDo[i+4];
ptDo[i+4] = PTR(ptDef[i])[0];
PTR(ptDef[i])[0] = hdTmp;
}
ptDo[1] = HdTrue;
hdTmp = ptDo[0];
ptDo[0] = hdComm;
hdComm = hdDo;
hdDo = hdTmp;
}
/* reflect the new environment in HdExec */
HdExec = hdComm;
}
/****************************************************************************
**
*F EvFunccall( <hdCall> ) . . . . . . . . . . . . evaluates a function call
**
** 'EvFunccall' evaluates the function call with the handle <hdCall> and
** returns the value returned by the function or 'HdVoid' if the function
** did not return any value at all.
**
** The function call bag <hdCall> has the following form:
**
** handle 0: handle of the function definition bag.
** handle 1.. : handles of arguments (not yet evaluated).
**
** 'EvFunccall' first creates a new execute bag. Then it evaluates the new
** arguments, and puts the values in the execute bag. Then it saves the old
** values of the arguments and local variables in the execute bag. Then it
** calles 'ChangeEnv' to copy the new values from the execute bag into the
** variables. Now the binding is complete, and 'EvFunccall' executes the
** statement sequence. After that 'EvFunccall' calls 'ChangeEnv' again to
** restore the old values from the execute bag.
*/
TypHandle EvFunccall ( hdCall )
TypHandle hdCall;
{
TypHandle hdDef, hdExec, hdRes = 0, hdOld;
TypHandle hdStat, hd;
TypHandle hdTilde;
short nrArg, nrLoc, i, trace;
unsigned long time = 0, sime = 0;
/* remember the old value of HdStat to recover later */
hdStat = HdStat;
/* Get the handle of the function definition */
hdDef = EVAL( PTR(hdCall)[0] );
if ( TYPE(hdDef) != T_FUNCTION && TYPE(hdDef) != T_FUNCINT )
return Error("Function: <function> must be a function",0L,0L);
/* treat the special case of internal functions */
if ( TYPE(hdDef) == T_FUNCINT ) {
if ( IsProfiling ) {
IsProfiling = 1;
time = SyTime()-Timesum;
for ( i = 0; i < SIZE(HdTimes)/SIZE_HD; i += 5 ) {
if ( PTR(HdTimes)[i] == hdDef ) {
sime = SyTime() - HD_TO_INT( PTR(HdTimes)[i+4] );
break;
}
}
if ( i == SIZE(HdTimes)/SIZE_HD ) {
sime = SyTime();
}
}
hdRes = (** (TypHandle(**)P(()))PTR(hdDef)) ( hdCall );
if ( IsProfiling == 1 ) {
time = SyTime()-Timesum-time; Timesum += time;
for ( i = 0; i < SIZE(HdTimes)/SIZE_HD; i += 5 ) {
if ( PTR(HdTimes)[i] == hdDef ) {
PTR(HdTimes)[i+2]=INT_TO_HD(HD_TO_INT(PTR(HdTimes)[i+2])+1);
PTR(HdTimes)[i+3]=INT_TO_HD(HD_TO_INT(PTR(HdTimes)[i+3])+time);
PTR(HdTimes)[i+4]=INT_TO_HD(SyTime()-sime);
break;
}
}
if ( i == SIZE(HdTimes)/SIZE_HD ) {
Resize( HdTimes, SIZE(HdTimes) + 5*SIZE_HD );
PTR(HdTimes)[i] = hdDef;
PTR(HdTimes)[i+1] = PTR(hdCall)[0];
PTR(HdTimes)[i+2] = INT_TO_HD(1);
PTR(HdTimes)[i+3] = INT_TO_HD(time);
PTR(HdTimes)[i+4] = INT_TO_HD(SyTime()-sime);
}
while ( 0 < i
&& (long)PTR(HdTimes)[i-2] < (long)PTR(HdTimes)[i+3] ) {
hd = PTR(HdTimes)[i-5];
PTR(HdTimes)[i-5] = PTR(HdTimes)[i];
PTR(HdTimes)[i] = hd;
hd = PTR(HdTimes)[i-4];
PTR(HdTimes)[i-4] = PTR(HdTimes)[i+1];
PTR(HdTimes)[i+1] = hd;
hd = PTR(HdTimes)[i-3];
PTR(HdTimes)[i-3] = PTR(HdTimes)[i+2];
PTR(HdTimes)[i+2] = hd;
hd = PTR(HdTimes)[i-2];
PTR(HdTimes)[i-2] = PTR(HdTimes)[i+3];
PTR(HdTimes)[i+3] = hd;
hd = PTR(HdTimes)[i-1];
PTR(HdTimes)[i-1] = PTR(HdTimes)[i+4];
PTR(HdTimes)[i+4] = hd;
i -= 5;
}
}
return( hdRes );
}
/* tell Gasman that we are entering the kernel */
EnterKernel();
/* compute the number of arguments and locals */
trace = 0;
nrArg = ((short*)((char*)PTR(hdDef) + SIZE(hdDef)))[ -2 ];
nrLoc = ((short*)((char*)PTR(hdDef) + SIZE(hdDef)))[ -1 ];
if ( nrArg == -1 ) {
hdRes = NewBag( T_LIST, SIZE_PLEN_PLIST( SIZE(hdCall)/SIZE_HD-1 ) );
SET_LEN_PLIST( hdRes, SIZE(hdCall)/SIZE_HD-1 );
for ( i = 1; i < SIZE(hdCall)/SIZE_HD; i++ ) {
hd = EVAL( PTR(hdCall)[i] );
if ( TYPE(hd) == T_VOID )
hd = Error("illegal void argument",0L,0L);
SET_ELM_PLIST( hdRes, i, hd );
}
nrArg = 1;
trace = 2;
}
else if ( nrArg != SIZE(hdCall) / SIZE_HD - 1 )
return Error("Function: number of args must be %d",(long)nrArg,0L);
/* check if the function is to be traced */
if ( nrLoc < 0 ) {
trace |= 1; nrLoc = -nrLoc-1;
Pr("\n%2>",0L,0L); Print( PTR(hdCall)[0] ); Pr("%<( ",0L,0L);
}
/* Now create the new execute bag */
hdExec = NewBag( T_EXEC, SIZE_HD*(2*nrArg+nrLoc+5) );
/* enter all relevant information into the execbag */
if ( PTR(hdDef)[nrArg+nrLoc+1] == 0 ) PTR(hdExec)[0] = HdExec;
else PTR(hdExec)[0] = PTR(hdDef)[nrArg+nrLoc+1];
PTR(hdExec)[1] = HdFalse; /* this frame is not yet current */
PTR(hdExec)[2] = hdDef; /* function definition */
PTR(hdExec)[3] = hdCall; /* function call, for debug only */
PTR(hdExec)[4] = HdExec; /* calling environment, dbg only */
/* enter the new evaluated arguments in the execbag */
for ( i = 1; i <= nrArg; ++i ) {
if ( ! (trace & 2) )
hdRes = EVAL( PTR(hdCall)[i] );
if ( TYPE(hdRes) == T_VOID )
hdRes = Error("illegal void argument",0L,0L);
PTR(hdExec)[i+4] = hdRes;
PTR(hdExec)[nrArg+nrLoc+i+4] = hdRes;
if ( trace & 1 ) {
Pr("%>",0L,0L); Print( hdRes );
if ( i < nrArg ) Pr("%<, ",0L,0L);
else Pr("%< )",0L,0L);
}
}
/* And now change the environment */
hdOld = HdExec;
ChangeEnv( hdExec );
/* If there are timed functions compute the timing */
if ( IsProfiling ) {
IsProfiling = 1;
time = SyTime()-Timesum;
for ( i = 0; i < SIZE(HdTimes)/SIZE_HD; i += 5 ) {
if ( PTR(HdTimes)[i] == PTR(hdDef)[0] ) {
sime = SyTime() - HD_TO_INT( PTR(HdTimes)[i+4] );
break;
}
}
if ( i == SIZE(HdTimes)/SIZE_HD ) {
sime = SyTime();
}
}
StrStat = ""; HdStat = PTR(hdDef)[0];
/* remember the old value of '~' to recover later */
hdTilde = PTR(HdTilde)[0];
PTR(HdTilde)[0] = 0;
/* well here's what all is about */
hdRes = EVAL( PTR(hdDef)[0] );
if ( hdRes == HdReturn )
hdRes = PTR(hdRes)[0];
else
hdRes = HdVoid;
/* If there are timed functions compute the timing */
if ( IsProfiling == 1 ) {
time = SyTime()-Timesum-time; Timesum += time;
for ( i = 0; i < SIZE(HdTimes)/SIZE_HD; i += 5 ) {
if ( PTR(HdTimes)[i] == PTR(hdDef)[0] ) {
PTR(HdTimes)[i+2]=INT_TO_HD(HD_TO_INT(PTR(HdTimes)[i+2])+1);
PTR(HdTimes)[i+3]=INT_TO_HD(HD_TO_INT(PTR(HdTimes)[i+3])+time);
PTR(HdTimes)[i+4]=INT_TO_HD(SyTime()-sime);
break;
}
}
if ( i == SIZE(HdTimes)/SIZE_HD ) {
Resize( HdTimes, SIZE(HdTimes) + 5*SIZE_HD );
PTR(HdTimes)[i] = PTR(hdDef)[0];
PTR(HdTimes)[i+1] = PTR(hdCall)[0];
PTR(HdTimes)[i+2] = INT_TO_HD(1);
PTR(HdTimes)[i+3] = INT_TO_HD(time);
PTR(HdTimes)[i+4] = INT_TO_HD(SyTime()-sime);
}
while ( 0 < i
&& (long)PTR(HdTimes)[i-2] < (long)PTR(HdTimes)[i+3] ) {
hd = PTR(HdTimes)[i-5];
PTR(HdTimes)[i-5] = PTR(HdTimes)[i];
PTR(HdTimes)[i] = hd;
hd = PTR(HdTimes)[i-4];
PTR(HdTimes)[i-4] = PTR(HdTimes)[i+1];
PTR(HdTimes)[i+1] = hd;
hd = PTR(HdTimes)[i-3];
PTR(HdTimes)[i-3] = PTR(HdTimes)[i+2];
PTR(HdTimes)[i+2] = hd;
hd = PTR(HdTimes)[i-2];
PTR(HdTimes)[i-2] = PTR(HdTimes)[i+3];
PTR(HdTimes)[i+3] = hd;
hd = PTR(HdTimes)[i-1];
PTR(HdTimes)[i-1] = PTR(HdTimes)[i+4];
PTR(HdTimes)[i+4] = hd;
i -= 5;
}
}
/* restore old environment */
ChangeEnv( hdOld );
/* If the function is traced, print the return value */
if ( trace & 1 ) {
Pr("\n%>",0L,0L); Print( PTR(hdCall)[0] ); Pr("%< returns",0L,0L);
if ( hdRes != HdVoid ) Print( hdRes );
Pr("%<",0L,0L);
}
/* recover the value of HdStat to enable debugging */
HdStat = hdStat;
/* recover the value of '~' */
PTR(HdTilde)[0] = hdTilde;
/* tell Gasman that we exit the kernel again */
ExitKernel(hdRes);
return hdRes;
}
/****************************************************************************
**
*F EvFunction( <hdFun> ) . . . . . . . . . . . . . . . . evaluate a function
**
** 'EvFunction' returns the value of the function <hdFun>. Since functions
** are constants and thus selfevaluating it just returns <hdFun>.
*/
TypHandle EvFunction ( hdDef )
TypHandle hdDef;
{
return hdDef;
}
/****************************************************************************
**
*F EvMakefunc( <hdFun> ) . . . . . . . . . . . . . . . . . . make a function
**
** 'EvMakefunc' makes a function, i.e., turns a variable function into a
** constant one. GAP has lexical binding. This means that the binding from
** identifiers to variables is determined by the environment that was active
** when a function was created and not by the one active when the function
** is executed. 'ChangeEnv' performs the task of switching from the
** active execution environment to the definition environment of a function.
** But in order to do this it needs to know the definition environment of
** a function. 'EvMakefunc' copies the function definition bag and adds
** the handle of the current environment to that bag. This process is
** usually called closing the function and the result is called a closure.
**
** To be precise, the make-function bag created by the parser has the form:
**
** handle 0: handle of the statement sequence.
** handle 1..n: handles of the arguments.
** handle n+1..n+m: handles of the local variables.
** handle n+m+1: 0.
** data 1: (short) number of arguments (n).
** data 2: (short) number of local variables (m).
**
** And 'EvMakefunc' makes a copy of the form:
**
** handle 0: handle of the statement sequence.
** handle 1..n: handles of the arguments.
** handle n+1..n+m: handles of the local variables.
** handle n+m+1: handle of the definition environment.
** data 1: (short) number of arguments (n).
** data 2: (short) number of local variables (m).
*/
TypHandle EvMakefunc ( hdFun )
TypHandle hdFun;
{
TypHandle Result;
short nrArg, nrLoc, i;
Result = NewBag( T_FUNCTION, SIZE(hdFun) );
/* copy the info about the number of arguments and locals */
nrArg = ((short*)((char*)PTR(hdFun) + SIZE(hdFun)))[ -2 ];
nrLoc = ((short*)((char*)PTR(hdFun) + SIZE(hdFun)))[ -1 ];
((short*)((char*)PTR(Result) + SIZE(Result)))[ -2 ] = nrArg;
((short*)((char*)PTR(Result) + SIZE(Result)))[ -1 ] = nrLoc;
/* now copy the formal arguments and locals */
if ( nrArg == -1 ) nrArg = 1;
for ( i = 0; i <= nrArg+nrLoc; ++i )
PTR(Result)[i] = PTR(hdFun)[i];
/* add the environment, i.e., close the function */
PTR(Result)[nrArg+nrLoc+1] = HdExec;
/* return the new function */
return Result;
}
/****************************************************************************
**
*F EvReturn( <hdRet> ) . . . . . . . . . . . . . evaluate a return-statement
**
** 'EvReturn' executes the return-statement with the handle <hdRet>.
**
** 'EvReturn' evaluates the expression in the return bag and puts the value
** in the 'HdReturn' bag. This bag is then passed back through all the
** statement execution functions, until it finally reaches 'EvFunccall'.
** 'EvFunccall' then returns the value in the 'HdResult' bag.
**
** Note that a quit statement is implemented as a return bag with the value
** 'HdReturn' in it. When 'EvReturn' sees this it does not try to evaluate
** it but just puts it into the 'HdReturn' bag. The rules for 'EvFunccall'
** now say that the function call will return 'HdReturn', thus it will make
** its way back to the mail loop.
*/
TypHandle EvReturn ( hdRet )
TypHandle hdRet;
{
TypHandle hd;
if ( PTR(hdRet)[0] == HdReturn )
hd = HdReturn;
else if ( PTR(hdRet)[0] == HdVoid )
hd = HdVoid;
else
hd = EVAL( PTR(hdRet)[0] );
PTR(HdReturn)[0] = hd;
return HdReturn;
}
/****************************************************************************
**
*F FunIsFunc( <hdCall> ) . . . . . . . . . . . . internal function 'IsFunc'
**
** 'IsFunc' returns 'true' if the object <obj> is a function and 'false'
** otherwise. May cause an error if <obj> is an unbound variable.
*/
TypHandle FunIsFunc ( hdCall )
TypHandle hdCall;
{
TypHandle hdObj;
/* evaluate and check the argument */
if ( SIZE(hdCall) != 2 * SIZE_HD )
return Error("usage: IsFunc( <obj> )",0L,0L);
hdObj = EVAL( PTR(hdCall)[1] );
if ( hdObj == HdVoid )
return Error("IsFunc: function must return a value",0L,0L);
/* return 'true' if <obj> is a rational and 'false' otherwise */
if ( TYPE(hdObj) == T_FUNCTION || TYPE(hdObj) == T_FUNCINT )
return HdTrue;
else
return HdFalse;
}
/****************************************************************************
**
*F FunTrace( <hdCall> ) . . . . . . . . . . . . . internal function 'Trace'
**
** 'FunTrace' implements the internal function 'Trace'.
**
** 'Trace( <function>... )'
**
** 'Trace' switches on tracing for the functions passed as arguments.
** Whenever such a function is called GAP prints a message of the form:
**
** <function1>( <arg1>, <arg2>, ... )
** <function2>()
** ...
** <function2> returns
** <function1> returns <value>
**
** Where <function1>, <function2>, <arg1>, <arg2> and <value> are replaced
** by the respective values.
**
** 'Untrace' switches this off again.
*/
TypHandle FunTrace ( hdCall )
TypHandle hdCall;
{
TypHandle hdDef;
short nrLoc, i;
for ( i = 1; i < SIZE(hdCall)/SIZE_HD; ++i ) {
hdDef = EVAL( PTR(hdCall)[i] );
if ( TYPE(hdDef) == T_FUNCINT )
return Error("sorry I can not trace internal function",0L,0L);
if ( TYPE(hdDef) != T_FUNCTION )
return Error("usage: Trace( <function>... )",0L,0L);
nrLoc = ((short*)((char*)PTR(hdDef)+SIZE(hdDef)))[-1];
if ( 0 <= nrLoc ) nrLoc = -nrLoc-1;
((short*)((char*)PTR(hdDef)+SIZE(hdDef)))[-1] = nrLoc;
}
return HdVoid;
}
/****************************************************************************
**
*F FunUntrace( <hdCall> ) . . . . . . . . . . . internal function 'Untrace'
**
** 'FunUntrace' implements the internal function 'Untrace'.
**
** 'Untrace( <function>... )'
**
** 'Untrace' switches of the tracing for the functions passed as arguments.
*/
TypHandle FunUntrace ( hdCall )
TypHandle hdCall;
{
TypHandle hdDef;
short nrLoc, i;
for ( i = 1; i < SIZE(hdCall)/SIZE_HD; ++i ) {
hdDef = EVAL( PTR(hdCall)[i] );
if ( TYPE(hdDef) != T_FUNCTION )
return Error("usage: Untrace( <function>... )",0L,0L);
nrLoc = ((short*)((char*)PTR(hdDef)+SIZE(hdDef)))[-1];
if ( nrLoc < 0 ) nrLoc = -nrLoc-1;
((short*)((char*)PTR(hdDef)+SIZE(hdDef)))[-1] = nrLoc;
}
return HdVoid;
}
/****************************************************************************
**
*F FunProfile( <hdCall> ) . . . . . . . . . . . internal function 'Profile'
**
** 'FunProfile' implements the internal function 'Profile'.
**
** 'Profile( true )'
** 'Profile( false )'
** 'Profile()'
**
** 'Profile' controls the function profiling.
**
** In the first form, with the argument 'true', 'Profile' switches the
** profiling on. From that moment on for every function GAP remembers the
** number of times this function was called, the time spent in this
** function without its children, i.e., the functions it called and their
** children, and the time spent in this function together with them. If the
** profiling was already on, 'Profile' clears the profiling information.
**
** In the second form, with the argument 'false', 'Profile' switches the
** profiling off again. Note that programs run faster without profiling.
**
** In the third form, without arguments, 'Profile' prints the profiling
** information.
*/
TypHandle FunProfile ( hdCall )
TypHandle hdCall;
{
TypHandle hdArg;
short i;
long total;
/* check argument count */
if ( 2 * SIZE_HD < SIZE(hdCall) ) {
return Error("usage: Profile( true|false ) or Profile()",0L,0L);
}
/* switch profiling on or off */
else if ( SIZE(hdCall) == 2 * SIZE_HD ) {
hdArg = EVAL( PTR(hdCall)[1] );
if ( hdArg == HdTrue ) {
IsProfiling = 2;
Resize( HdTimes, 0 * SIZE_HD );
}
else if ( hdArg == HdFalse ) {
IsProfiling = 0;
}
else {
return Error("usage: Profile( true|false ) or Profile()",0L,0L);
}
}
/* print profiling information, this should be formatted much nicer */
else {
total = 0;
for ( i = 0; i < SIZE(HdTimes)/SIZE_HD; i += 5 )
total = total + HD_TO_INT( PTR(HdTimes)[i+3] );
if ( total == 0 ) total = 1;
Pr(" count time percent time/call child function\n",0L,0L);
for ( i = 0; i < SIZE(HdTimes)/SIZE_HD; i += 5 ) {
Pr("%6d ", HD_TO_INT( PTR(HdTimes)[i+2] ), 0L );
Pr("%6d ", HD_TO_INT( PTR(HdTimes)[i+3] ), 0L );
Pr("%6d ", 100 * HD_TO_INT(PTR(HdTimes)[i+3]) / total, 0L );
Pr("%6d ", HD_TO_INT( PTR(HdTimes)[i+3] ) /
HD_TO_INT( PTR(HdTimes)[i+2] ), 0L );
Pr("%6d ", HD_TO_INT( PTR(HdTimes)[i+4] ), 0L );
Print( PTR(HdTimes)[i+1] );
Pr("\n",0L,0L);
}
Pr(" %6d 100 TOTAL\n",total-1,0L);
}
return HdVoid;
}
/****************************************************************************
**
*F FunApplyFunc( <hdCall> ) . . . . . . . . . . . . . internal 'ApplyFunc'
*/
TypHandle FunApplyFunc ( hdCall )
TypHandle hdCall;
{
TypHandle hdNew; /* the new function call bag */
TypHandle hdFunc; /* the function */
TypHandle hdList; /* and the list */
long i; /* loop */
/* check arguments */
if ( SIZE(hdCall) != 3*SIZE_HD )
return Error( "usage: ApplFunc( <func>, <list> )", 0L, 0L );
hdFunc = EVAL(PTR(hdCall)[1]);
hdList = EVAL(PTR(hdCall)[2]);
if ( ! IS_DENSE_LIST(hdList) )
return Error( "<list> must be a dense list", 0L, 0L );
/* create a new function call bag */
hdNew = NewBag( T_FUNCCALL, SIZE_HD*(1+LEN_LIST(hdList)) );
PTR(hdNew)[0] = hdFunc;
/* copy arguments into it */
for ( i = LEN_LIST(hdList); 0 < i; i-- )
PTR(hdNew)[i] = ELMF_LIST( hdList, i );
/* evaluate this call */
return EVAL(hdNew);
}
/****************************************************************************
**
*F PrFuncint( <hdFun> ) . . . . . . . . . . . . print an internal function
**
** 'PrFuncint' prints the internal function with the handle <hdFun> in the
** short form: 'function (...) internal; end'.
*/
/*ARGSUSED*/
void PrFuncint ( hdFun )
TypHandle hdFun;
{
Pr("%2>function%< %>(...)%< %>internal;%< %>end%2<",0L,0L);
}
/****************************************************************************
**
*F PrFunction( <hdFun> ) . . . . . . . . . . . . . . . . . print a function
**
** 'PrFunction' prints the function with the handle <hdFun> either in the
** short format:
**
** function ( <args> ) ... end
**
** if 'prFull' is 0, or in the long format:
**
** function ( <args> )
** local <locals>;
** <statements>
** end
**
** otherwise.
*/
long prFull;
void PrFunction ( hdFun )
TypHandle hdFun;
{
short nrArg, nrLoc, i;
Pr("%5>function%< ( %>",0L,0L);
nrArg = ((short*)((char*)PTR(hdFun) + SIZE(hdFun)))[-2];
if ( nrArg == -1 ) nrArg = 1;
for ( i = 1; i <= nrArg; ++i ) {
Print( PTR(hdFun)[i] );
if ( i != nrArg ) Pr("%<, %>",0L,0L);
}
Pr(" %<)",0L,0L);
if ( prFull == 0 ) {
Pr(" ...%4< ",0L,0L);
}
else {
Pr("\n",0L,0L);
nrLoc = ((short*)((char*)PTR(hdFun) + SIZE(hdFun)))[-1];
if ( nrLoc < 0 ) nrLoc = -nrLoc-1;
if ( nrLoc >= 1 ) {
Pr("%>local ",0L,0L);
for ( i = 1; i <= nrLoc; ++i ) {
Print( PTR(hdFun)[i+nrArg] );
if ( i != nrLoc ) Pr("%<, %>",0L,0L);
}
Pr("%<;\n",0L,0L);
}
Print( PTR(hdFun)[0] );
Pr(";%4<\n",0L,0L);
}
Pr("end",0L,0L);
}
/****************************************************************************
**
*F PrintFunction( <hdFun> ) . . . . . . . print a function in the full form
**
** 'PrintFunction' prints the function with the handle <hdFun> in the full
** form, i.e., with the statement sequence. It is called from 'Print'.
*/
void PrintFunction ( hdFun )
TypHandle hdFun;
{
prFull = 1L;
PrFunction( hdFun );
prFull = 0L;
}
/****************************************************************************
**
*F PrFunccall( <hdCall> ) . . . . . . . . . . . . . . print a function call
**
** 'PrFunccall' prints the function call with the handle <hdCall> in the
** usual form: '<function>( <args> )'.
**
** Linebreaks are preffered after the opening parenthesis and the commas
** between the arguments.
*/
void PrFunccall ( hdCall )
TypHandle hdCall;
{
long i;
Pr("%2>",0L,0L); Print( PTR(hdCall)[0] ); Pr("%<( %>",0L,0L);
for ( i = 1; i < SIZE(hdCall)/SIZE_HD; ++i ) {
Print( PTR(hdCall)[i] );
if ( i != SIZE(hdCall)/SIZE_HD-1 )
Pr("%<, %>",0L,0L);
}
Pr(" %2<)",0L,0L);
}
/****************************************************************************
**
** PrReturn( <hdRet> ) . . . . . . . . . . . . . . print a return statement
**
** 'PrReturn' prints the return statement with the handle <hdRet> in the
** usual form 'return;' or 'return <expr>;'.
*/
void PrReturn ( hdRet )
TypHandle hdRet;
{
if ( PTR(hdRet)[0] == HdReturn ) {
Pr("quit",0L,0L);
}
else if ( PTR(hdRet)[0] == HdVoid ) {
Pr("return",0L,0L);
}
else {
Pr("%2>return%< %>",0L,0L);
Print( PTR(hdRet)[0] );
Pr("%2<",0L,0L);
}
}
/****************************************************************************
**
*F InitFunc() . . . . . . . . . . . initialize function evaluation package
**
** 'InitFunc' initializes the function evaluation package.
*/
void InitFunc ()
{
InstEvFunc( T_FUNCCALL, EvFunccall );
InstEvFunc( T_FUNCTION, EvFunction );
InstEvFunc( T_FUNCINT, EvFunction );
InstEvFunc( T_MAKEFUNC, EvMakefunc );
InstEvFunc( T_RETURN, EvReturn );
InstPrFunc( T_FUNCCALL, PrFunccall );
InstPrFunc( T_FUNCTION, PrFunction );
InstPrFunc( T_FUNCINT, PrFuncint );
InstPrFunc( T_MAKEFUNC, PrFunction );
InstPrFunc( T_RETURN, PrReturn );
InstIntFunc( "IsFunc", FunIsFunc );
InstIntFunc( "TraceFunc", FunTrace );
InstIntFunc( "UntraceFunc", FunUntrace );
InstIntFunc( "ApplyFunc", FunApplyFunc );
HdTimes = NewBag( T_LIST, 0 );
InstIntFunc( "Profile", FunProfile );
HdReturn = NewBag( T_RETURN, SIZE_HD );
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.