Quelle calls.c Sprache: C

/****************************************************************************
**
** This file is part of GAP, a system for computational discrete algebra.
**
** Copyright of GAP belongs to its developers, whose names are too numerous
** to list here. Please refer to the COPYRIGHT file for details.
**
** SPDX-License-Identifier: GPL-2.0-or-later
**
** This file contains the functions for the function call mechanism package.
**
** For a description of what the function call mechanism is about see the
** declaration part of this package.
**
** Each function is represented by a function bag (of type 'T_FUNCTION'),
** which has the following format.
**
** +-------+-------+- - - -+-------+
** |handler|handler| |handler| (for all functions)
** | 0 | 1 | | 7 |
** +-------+-------+- - - -+-------+
**
** +-------+-------+-------+-------+
** | name | number| args &| prof- | (for all functions)
** | func. | args | locals| iling |
** +-------+-------+-------+-------+
**
** +-------+-------+-------+-------+
** | number| body | envir-| funcs.| (only for interpreted functions)
** | locals| func. | onment| exprs.|
** +-------+-------+-------+-------+
**
** ...what the handlers are..
** ...what the other components are...
*/

#include "calls.h"

#include "bool.h"
#include "code.h"
#include "error.h"
#ifdef USE_GASMAN
#include "gasman_intern.h"
#endif
#include "gaptime.h"
#include "gvars.h"
#include "integer.h"
#include "io.h"
#include "lists.h"
#include "modules.h"
#include "opers.h"
#include "plist.h"
#include "saveload.h"
#include "stats.h"
#include "stringobj.h"
#include "sysstr.h"
#include "vars.h"

#ifdef HPCGAP
#include "hpc/thread.h"
#endif

void SET_NAME_FUNC(Obj func, Obj name)
{
 GAP_ASSERT(name == 0 || IS_STRING_REP(name));
 FUNC(func)->name = name;
}

Obj NAMI_FUNC(Obj func, Int i)
{
 return ELM_LIST(NAMS_FUNC(func),i);
}

/****************************************************************************
**
*F COUNT_PROF( <prof> ) . . . . . . . . number of invocations of a function
*F TIME_WITH_PROF( <prof> ) . . . . . . time with children in a function
*F TIME_WOUT_PROF( <prof> ) . . . . . . time without children in a function
*F STOR_WITH_PROF( <prof> ) . . . . storage with children in a function
*F STOR_WOUT_PROF( <prof> ) . . . . storage without children in a function
*V LEN_PROF . . . . . . . . . . . length of a profiling bag for a function
**
** With each function we associate two time measurements. First the *time
** spent by this function without its children*, i.e., the amount of time
** during which this function was active. Second the *time spent by this
** function with its children*, i.e., the amount of time during which this
** function was either active or suspended.
**
** Likewise with each function we associate the two storage measurements,
** the storage spent by this function without its children and the storage
** spent by this function with its children.
**
** These macros make it possible to access the various components of a
** profiling information bag <prof> for a function <func>.
**
** 'COUNT_PROF(<prof>)' is the number of calls to the function <func>.
** 'TIME_WITH_PROF(<prof>) is the time spent while the function <func> was
** either active or suspended. 'TIME_WOUT_PROF(<prof>)' is the time spent
** while the function <func> was active. 'STOR_WITH_PROF(<prof>)' is the
** amount of storage allocated while the function <func> was active or
** suspended. 'STOR_WOUT_PROF(<prof>)' is the amount of storage allocated
** while the function <func> was active. 'LEN_PROF' is the length of a
** profiling information bag.
*/
#define COUNT_PROF(prof) (INT_INTOBJ(ELM_PLIST(prof,1)))
#define TIME_WITH_PROF(prof) (INT_INTOBJ(ELM_PLIST(prof,2)))
#define TIME_WOUT_PROF(prof) (INT_INTOBJ(ELM_PLIST(prof,3)))
#define STOR_WITH_PROF(prof) (UInt8_ObjInt(ELM_PLIST(prof,4)))
#define STOR_WOUT_PROF(prof) (UInt8_ObjInt(ELM_PLIST(prof,5)))

#define SET_COUNT_PROF(prof,n) SET_ELM_PLIST(prof,1,INTOBJ_INT(n))
#define SET_TIME_WITH_PROF(prof,n) SET_ELM_PLIST(prof,2,INTOBJ_INT(n))
#define SET_TIME_WOUT_PROF(prof,n) SET_ELM_PLIST(prof,3,INTOBJ_INT(n))

static inline void SET_STOR_WITH_PROF(Obj prof, UInt8 n)
{
 SET_ELM_PLIST(prof,4,ObjInt_Int8(n));
 CHANGED_BAG(prof);
}

static inline void SET_STOR_WOUT_PROF(Obj prof, UInt8 n)
{
 SET_ELM_PLIST(prof,5,ObjInt_Int8(n));
 CHANGED_BAG(prof);
}

#define LEN_PROF 5

/****************************************************************************
**
*F * * * * wrapper for functions with variable number of arguments * * * * *
*/

/****************************************************************************
**
*F DoWrap0args( <self> ) . . . . . . . . . . . wrap up 0 arguments in a list
**
** 'DoWrapargs' accepts the arguments <arg1>, <arg2>, and so on,
** wraps them up in a list, and then calls <self> again via 'CALL_XARGS',
** passing this list. 'DoWrapargs' are the handlers for callees that
** accept a variable number of arguments. Note that there is no
** 'DoWrapXargs' handler, since in this case the function call mechanism
** already requires that the passed arguments are collected in a list.
*/
static Obj DoWrap0args(Obj self)
{
 Obj result; // value of function call, result
 Obj args; // arguments list

 // make the arguments list
 args = NEW_PLIST( T_PLIST, 0 );

 // call the variable number of arguments function
 result = CALL_XARGS( self, args );
 return result;
}

/****************************************************************************
**
*F DoWrap1args( <self>, <arg1> ) . . . . . . . wrap up 1 argument in a list
*/
static Obj DoWrap1args(Obj self, Obj arg1)
{
 Obj result; // value of function call, result
 Obj args; // arguments list

 // make the arguments list
 args = NEW_PLIST( T_PLIST, 1 );
 SET_LEN_PLIST( args, 1 );
 SET_ELM_PLIST( args, 1, arg1 );

 // call the variable number of arguments function
 result = CALL_XARGS( self, args );
 return result;
}

/****************************************************************************
**
*F DoWrap2args( <self>, <arg1>, ... ) . . . . wrap up 2 arguments in a list
*/
static Obj DoWrap2args(Obj self, Obj arg1, Obj arg2)
{
 Obj result; // value of function call, result
 Obj args; // arguments list

 // make the arguments list
 args = NEW_PLIST( T_PLIST, 2 );
 SET_LEN_PLIST( args, 2 );
 SET_ELM_PLIST( args, 1, arg1 );
 SET_ELM_PLIST( args, 2, arg2 );

 // call the variable number of arguments function
 result = CALL_XARGS( self, args );
 return result;
}

/****************************************************************************
**
*F DoWrap3args( <self>, <arg1>, ... ) . . . . wrap up 3 arguments in a list
*/
static Obj DoWrap3args(Obj self, Obj arg1, Obj arg2, Obj arg3)
{
 Obj result; // value of function call, result
 Obj args; // arguments list

 // make the arguments list
 args = NEW_PLIST( T_PLIST, 3 );
 SET_LEN_PLIST( args, 3 );
 SET_ELM_PLIST( args, 1, arg1 );
 SET_ELM_PLIST( args, 2, arg2 );
 SET_ELM_PLIST( args, 3, arg3 );

 // call the variable number of arguments function
 result = CALL_XARGS( self, args );
 return result;
}

/****************************************************************************
**
*F DoWrap4args( <self>, <arg1>, ... ) . . . . wrap up 4 arguments in a list
*/
static Obj DoWrap4args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
{
 Obj result; // value of function call, result
 Obj args; // arguments list

 // make the arguments list
 args = NEW_PLIST( T_PLIST, 4 );
 SET_LEN_PLIST( args, 4 );
 SET_ELM_PLIST( args, 1, arg1 );
 SET_ELM_PLIST( args, 2, arg2 );
 SET_ELM_PLIST( args, 3, arg3 );
 SET_ELM_PLIST( args, 4, arg4 );

 // call the variable number of arguments function
 result = CALL_XARGS( self, args );
 return result;
}

/****************************************************************************
**
*F DoWrap5args( <self>, <arg1>, ... ) . . . . wrap up 5 arguments in a list
*/
static Obj
DoWrap5args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
{
 Obj result; // value of function call, result
 Obj args; // arguments list

 // make the arguments list
 args = NEW_PLIST( T_PLIST, 5 );
 SET_LEN_PLIST( args, 5 );
 SET_ELM_PLIST( args, 1, arg1 );
 SET_ELM_PLIST( args, 2, arg2 );
 SET_ELM_PLIST( args, 3, arg3 );
 SET_ELM_PLIST( args, 4, arg4 );
 SET_ELM_PLIST( args, 5, arg5 );

 // call the variable number of arguments function
 result = CALL_XARGS( self, args );
 return result;
}

/****************************************************************************
**
*F DoWrap6args( <self>, <arg1>, ... ) . . . . wrap up 6 arguments in a list
*/
static Obj DoWrap6args(
 Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
{
 Obj result; // value of function call, result
 Obj args; // arguments list

 // make the arguments list
 args = NEW_PLIST( T_PLIST, 6 );
 SET_LEN_PLIST( args, 6 );
 SET_ELM_PLIST( args, 1, arg1 );
 SET_ELM_PLIST( args, 2, arg2 );
 SET_ELM_PLIST( args, 3, arg3 );
 SET_ELM_PLIST( args, 4, arg4 );
 SET_ELM_PLIST( args, 5, arg5 );
 SET_ELM_PLIST( args, 6, arg6 );

 // call the variable number of arguments function
 result = CALL_XARGS( self, args );
 return result;
}

/****************************************************************************
**
*F * * wrapper for functions with do not support the number of arguments * *
*/

/****************************************************************************
**
*F DoFail0args( <self> ) . . . . . . fail a function call with 0 arguments
**
** 'DoFailargs' accepts the arguments <arg1>, <arg2>, and so on, and
** signals an error, because the function for which they are installed
** expects another number of arguments. 'DoFailargs' are the handlers in
** the other slots of a function.
*/

// Pull this out to avoid repetition, since it gets a little more complex in
// the presence of partially variadic functions
NORETURN static void NargError(Obj func, Int actual)
{
 Int narg = NARG_FUNC(func);

 if (narg >= 0) {
 assert(narg != actual);
 ErrorMayQuitNrArgs(narg, actual);
 } else {
 assert(-narg-1 > actual);
 ErrorMayQuitNrAtLeastArgs(-narg - 1, actual);
 }
}

static Obj DoFail0args(Obj self)
{
 NargError(self, 0);
}

/****************************************************************************
**
*F DoFail1args( <self>,<arg1> ) . . . fail a function call with 1 argument
*/
static Obj DoFail1args(Obj self, Obj arg1)
{
 NargError(self, 1);
}

/****************************************************************************
**
*F DoFail2args( <self>, <arg1>, ... ) fail a function call with 2 arguments
*/
static Obj DoFail2args(Obj self, Obj arg1, Obj arg2)
{
 NargError(self, 2);
}

/****************************************************************************
**
*F DoFail3args( <self>, <arg1>, ... ) fail a function call with 3 arguments
*/
static Obj DoFail3args(Obj self, Obj arg1, Obj arg2, Obj arg3)
{
 NargError(self, 3);
}

/****************************************************************************
**
*F DoFail4args( <self>, <arg1>, ... ) fail a function call with 4 arguments
*/
static Obj DoFail4args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
{
 NargError(self, 4);
}

/****************************************************************************
**
*F DoFail5args( <self>, <arg1>, ... ) fail a function call with 5 arguments
*/
static Obj
DoFail5args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
{
 NargError(self, 5);
}

/****************************************************************************
**
*F DoFail6args( <self>, <arg1>, ... ) fail a function call with 6 arguments
*/
static Obj DoFail6args(
 Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
{
 NargError(self, 6);
}

/****************************************************************************
**
*F DoFailXargs( <self>, <args> ) . . fail a function call with X arguments
*/
static Obj DoFailXargs(Obj self, Obj args)
{
 NargError(self, LEN_LIST(args));
}

/****************************************************************************
**
*F * * * * * * * * * * * * * wrapper for profiling * * * * * * * * * * * * *
*/

/****************************************************************************
**
*V TimeDone . . . . . . amount of time spent for completed function calls
**
** 'TimeDone' is the amount of time spent for all function calls that have
** already been completed.
*/
static UInt TimeDone;

/****************************************************************************
**
*V StorDone . . . . . amount of storage spent for completed function calls
**
** 'StorDone' is the amount of storage spent for all function call that have
** already been completed.
*/
static UInt8 StorDone;

/****************************************************************************
**
*F DoProf0args( <self> ) . . . . . . . . profile a function with 0 arguments
**
** 'DoProfargs' accepts the arguments <arg1>, <arg2>, and so on, and
** calls the function through the secondary handler. It also updates the
** profiling information in the profiling information bag of the called
** function. 'DoProfargs' are the primary handlers for all functions
** when profiling is requested.
*/
static ALWAYS_INLINE Obj DoProfNNNargs (
 Obj self,
 Int n,
 Obj arg1,
 Obj arg2,
 Obj arg3,
 Obj arg4,
 Obj arg5,
 Obj arg6 )

{
 Obj result; // value of function call, result
 Obj prof; // profiling bag
 UInt timeElse; // time spent elsewhere
 UInt timeCurr; // time spent in current funcs.
 UInt8 storElse; // storage spent elsewhere
 UInt8 storCurr; // storage spent in current funcs.

 // get the profiling bag
 prof = PROF_FUNC( PROF_FUNC( self ) );

 // time and storage spent so far while this function what not active
 timeElse = SyTime() - TIME_WITH_PROF(prof);
 storElse = SizeAllBags - STOR_WITH_PROF(prof);

 // time and storage spent so far by all currently suspended functions
 timeCurr = SyTime() - TimeDone;
 storCurr = SizeAllBags - StorDone;

 // call the real function
 switch (n) {
 case 0: result = CALL_0ARGS_PROF( self ); break;
 case 1: result = CALL_1ARGS_PROF( self, arg1 ); break;
 case 2: result = CALL_2ARGS_PROF( self, arg1, arg2 ); break;
 case 3: result = CALL_3ARGS_PROF( self, arg1, arg2, arg3 ); break;
 case 4: result = CALL_4ARGS_PROF( self, arg1, arg2, arg3, arg4 ); break;
 case 5: result = CALL_5ARGS_PROF( self, arg1, arg2, arg3, arg4, arg5 ); break;
 case 6: result = CALL_6ARGS_PROF( self, arg1, arg2, arg3, arg4, arg5, arg6 ); break;
 case -1: result = CALL_XARGS_PROF( self, arg1 ); break;
 default: result = 0; GAP_ASSERT(0);
 }

 // number of invocation of this function
 SET_COUNT_PROF( prof, COUNT_PROF(prof) + 1 );

 // time and storage spent in this function and its children
 SET_TIME_WITH_PROF( prof, SyTime() - timeElse );
 SET_STOR_WITH_PROF( prof, SizeAllBags - storElse );

 // time and storage spent by this invocation of this function
 timeCurr = SyTime() - TimeDone - timeCurr;
 SET_TIME_WOUT_PROF( prof, TIME_WOUT_PROF(prof) + timeCurr );
 TimeDone += timeCurr;
 storCurr = SizeAllBags - StorDone - storCurr;
 SET_STOR_WOUT_PROF( prof, STOR_WOUT_PROF(prof) + storCurr );
 StorDone += storCurr;

 return result;
}

static Obj DoProf0args (
 Obj self )
{
 return DoProfNNNargs(self, 0, 0, 0, 0, 0, 0, 0);
}

/****************************************************************************
**
*F DoProf1args( <self>, <arg1>) . . . . profile a function with 1 argument
*/
static Obj DoProf1args (
 Obj self,
 Obj arg1 )
{
 return DoProfNNNargs(self, 1, arg1, 0, 0, 0, 0, 0);
}

/****************************************************************************
**
*F DoProf2args( <self>, <arg1>, ... ) . profile a function with 2 arguments
*/
static Obj DoProf2args (
 Obj self,
 Obj arg1,
 Obj arg2 )
{
 return DoProfNNNargs(self, 2, arg1, arg2, 0, 0, 0, 0);
}

/****************************************************************************
**
*F DoProf3args( <self>, <arg1>, ... ) . profile a function with 3 arguments
*/
static Obj DoProf3args (
 Obj self,
 Obj arg1,
 Obj arg2,
 Obj arg3 )
{
 return DoProfNNNargs(self, 3, arg1, arg2, arg3, 0, 0, 0);
}

/****************************************************************************
**
*F DoProf4args( <self>, <arg1>, ... ) . profile a function with 4 arguments
*/
static Obj DoProf4args (
 Obj self,
 Obj arg1,
 Obj arg2,
 Obj arg3,
 Obj arg4 )
{
 return DoProfNNNargs(self, 4, arg1, arg2, arg3, arg4, 0, 0);
}

/****************************************************************************
**
*F DoProf5args( <self>, <arg1>, ... ) . profile a function with 5 arguments
*/
static Obj DoProf5args (
 Obj self,
 Obj arg1,
 Obj arg2,
 Obj arg3,
 Obj arg4,
 Obj arg5 )
{
 return DoProfNNNargs(self, 5, arg1, arg2, arg3, arg4, arg5, 0);
}

/****************************************************************************
**
*F DoProf6args( <self>, <arg1>, ... ) . profile a function with 6 arguments
*/
static Obj DoProf6args (
 Obj self,
 Obj arg1,
 Obj arg2,
 Obj arg3,
 Obj arg4,
 Obj arg5,
 Obj arg6 )
{
 return DoProfNNNargs(self, 6, arg1, arg2, arg3, arg4, arg5, arg6);
}

/****************************************************************************
**
*F DoProfXargs( <self>, <args> ) . . . . profile a function with X arguments
*/
static Obj DoProfXargs (
 Obj self,
 Obj args )
{
 return DoProfNNNargs(self, -1, args, 0, 0, 0, 0, 0);
}

/****************************************************************************
**
*F * * * * * * * * * * * * * create a new function * * * * * * * * * * * * *
*/

/****************************************************************************
**
*F InitHandlerFunc( <handler>, <cookie> ) . . . . . . . . register a handler
**
** Every handler should be registered (once) before it is installed in any
** function bag. This is needed so that it can be identified when loading a
** saved workspace. <cookie> should be a unique C string, identifying the
** handler
*/
#ifndef MAX_HANDLERS
#define MAX_HANDLERS 20000
#endif

typedef struct {
 ObjFunc hdlr;
 const Char * cookie;
}
TypeHandlerInfo;

static UInt HandlerSortingStatus = 0;

static TypeHandlerInfo HandlerFuncs[MAX_HANDLERS];
static UInt NHandlerFuncs = 0;

void InitHandlerFunc (
 ObjFunc hdlr,
 const Char * cookie )
{
 if ( NHandlerFuncs >= MAX_HANDLERS ) {
 Panic("No room left for function handler");
 }

 for (UInt i = 0; i < NHandlerFuncs; i++)
 if (streq(HandlerFuncs[i].cookie, cookie))
 Pr("Duplicate cookie %s\n", (Int)cookie, 0);

 HandlerFuncs[NHandlerFuncs].hdlr = hdlr;
 HandlerFuncs[NHandlerFuncs].cookie = cookie;
 HandlerSortingStatus = 0; // no longer sorted by handler or cookie
 NHandlerFuncs++;
}

/****************************************************************************
**
*f CheckHandlersBag( <bag> ) . . . . . . check that handlers are initialised
*/
#ifdef USE_GASMAN

static void CheckHandlersBag(
 Bag bag )
{
 UInt i;
 UInt j;
 ObjFunc hdlr;

 if ( TNUM_BAG(bag) == T_FUNCTION ) {
 for ( j = 0; j < 8; j++ ) {
 hdlr = HDLR_FUNC(bag,j);

 // zero handlers are used in a few odd places
 if ( hdlr != 0 ) {
 for ( i = 0; i < NHandlerFuncs; i++ ) {
 if ( hdlr == HandlerFuncs[i].hdlr )
 break;
 }
 if ( i == NHandlerFuncs ) {
 Pr("Unregistered Handler %d args ", j, 0);
 PrintObj(NAME_FUNC(bag));
 Pr("\n", 0, 0);
 }
 }
 }
 }
}

void CheckAllHandlers(void)
{
 CallbackForAllBags(CheckHandlersBag);
}

static int IsLessHandlerInfo (
 TypeHandlerInfo * h1,
 TypeHandlerInfo * h2,
 UInt byWhat )
{
 switch (byWhat) {
 case 1:
 // cast to please Irix CC and HPUX CC
 return (UInt)(h1->hdlr) < (UInt)(h2->hdlr);
 case 2:
 return strcmp(h1->cookie, h2->cookie) < 0;
 default:
 ErrorQuit("Invalid sort mode %u", (Int)byWhat, 0);
 }
}

void SortHandlers( UInt byWhat )
{
 TypeHandlerInfo tmp;
 UInt len, h, i, k;
 if (HandlerSortingStatus == byWhat)
 return;
 len = NHandlerFuncs;
 h = 1;
 while ( 9*h + 4 < len )
 { h = 3*h + 1; }
 while ( 0 < h ) {
 for ( i = h; i < len; i++ ) {
 tmp = HandlerFuncs[i];
 k = i;
 while ( h <= k && IsLessHandlerInfo(&tmp, HandlerFuncs+(k-h), byWhat))
 {
 HandlerFuncs[k] = HandlerFuncs[k-h];
 k -= h;
 }
 HandlerFuncs[k] = tmp;
 }
 h = h / 3;
 }
 HandlerSortingStatus = byWhat;
}

const Char * CookieOfHandler (
 ObjFunc hdlr )
{
 UInt i, top, bottom, middle;

 if ( HandlerSortingStatus != 1 ) {
 for ( i = 0; i < NHandlerFuncs; i++ ) {
 if ( hdlr == HandlerFuncs[i].hdlr )
 return HandlerFuncs[i].cookie;
 }
 return (Char *)0;
 }
 else {
 top = NHandlerFuncs;
 bottom = 0;
 while ( top >= bottom ) {
 middle = (top + bottom)/2;
 if ( (UInt)(hdlr) < (UInt)(HandlerFuncs[middle].hdlr) )
 top = middle-1;
 else if ( (UInt)(hdlr) > (UInt)(HandlerFuncs[middle].hdlr) )
 bottom = middle+1;
 else
 return HandlerFuncs[middle].cookie;
 }
 return (Char *)0;
 }
}

ObjFunc HandlerOfCookie(
 const Char * cookie )
{
 Int i,top,bottom,middle;
 Int res;
 if (HandlerSortingStatus != 2)
 {
 for (i = 0; i < NHandlerFuncs; i++)
 {
 if (streq(cookie, HandlerFuncs[i].cookie))
 return HandlerFuncs[i].hdlr;
 }
 return (ObjFunc)0;
 }
 else
 {
 top = NHandlerFuncs;
 bottom = 0;
 while (top >= bottom) {
 middle = (top + bottom)/2;
 res = strcmp(cookie,HandlerFuncs[middle].cookie);
 if (res < 0)
 top = middle-1;
 else if (res > 0)
 bottom = middle+1;
 else
 return HandlerFuncs[middle].hdlr;
 }
 return (ObjFunc)0;
 }
}

#endif

/****************************************************************************
**
*F NewFunction( <name>, <narg>, <nams>, <hdlr> ) . . . . make a new function
**
** 'NewFunction' creates and returns a new function. <name> must be a GAP
** string containing the name of the function. <narg> must be the number of
** arguments, where -1 means a variable number of arguments. <nams> must be
** a GAP list containing the names of the arguments. <hdlr> must be the
** C function (accepting <self> and the <narg> arguments) that will be
** called to execute the function.
*/
Obj NewFunction (
 Obj name,
 Int narg,
 Obj nams,
 ObjFunc hdlr )
{
 return NewFunctionT( T_FUNCTION, sizeof(FuncBag), name, narg, nams, hdlr );
}

/****************************************************************************
**
*F NewFunctionC( <name>, <narg>, <nams>, <hdlr> ) . . . make a new function
**
** 'NewFunctionC' does the same as 'NewFunction', but expects <name> and
** <nams> as C strings.
*/
Obj NewFunctionC (
 const Char * name,
 Int narg,
 const Char * nams,
 ObjFunc hdlr )
{
 return NewFunction(MakeImmString(name), narg, ArgStringToList(nams), hdlr);
}

/****************************************************************************
**
*F NewFunctionT( <type>, <size>, <name>, <narg>, <nams>, <hdlr> )
**
** 'NewFunctionT' does the same as 'NewFunction', but allows to specify the
** <type> and <size> of the newly created bag.
*/
Obj NewFunctionT (
 UInt type,
 UInt size,
 Obj name,
 Int narg,
 Obj nams,
 ObjFunc hdlr )
{
 Obj func; // function, result
 Obj prof; // profiling bag

 // make the function object
 func = NewBag( type, size );

 // create a function with a fixed number of arguments
 if ( narg >= 0 ) {
 SET_HDLR_FUNC(func, 0, DoFail0args);
 SET_HDLR_FUNC(func, 1, DoFail1args);
 SET_HDLR_FUNC(func, 2, DoFail2args);
 SET_HDLR_FUNC(func, 3, DoFail3args);
 SET_HDLR_FUNC(func, 4, DoFail4args);
 SET_HDLR_FUNC(func, 5, DoFail5args);
 SET_HDLR_FUNC(func, 6, DoFail6args);
 SET_HDLR_FUNC(func, 7, DoFailXargs);
 SET_HDLR_FUNC(func, (narg <= 6 ? narg : 7), hdlr );
 }

 // create a function with a variable number of arguments
 else {
 SET_HDLR_FUNC(func, 0, (narg >= -1) ? DoWrap0args : DoFail0args);
 SET_HDLR_FUNC(func, 1, (narg >= -2) ? DoWrap1args : DoFail1args);
 SET_HDLR_FUNC(func, 2, (narg >= -3) ? DoWrap2args : DoFail2args);
 SET_HDLR_FUNC(func, 3, (narg >= -4) ? DoWrap3args : DoFail3args);
 SET_HDLR_FUNC(func, 4, (narg >= -5) ? DoWrap4args : DoFail4args);
 SET_HDLR_FUNC(func, 5, (narg >= -6) ? DoWrap5args : DoFail5args);
 SET_HDLR_FUNC(func, 6, (narg >= -7) ? DoWrap6args : DoFail6args);
 SET_HDLR_FUNC(func, 7, hdlr);
 }

 // enter the arguments and the names
 SET_NAME_FUNC(func, name ? ImmutableString(name) : 0);
 SET_NARG_FUNC(func, narg);
 SET_NAMS_FUNC(func, nams);
 SET_NLOC_FUNC(func, 0);
#ifdef HPCGAP
 if (nams) MakeBagPublic(nams);
#endif
 CHANGED_BAG(func);

 // enter the profiling bag
 prof = NEW_PLIST( T_PLIST, LEN_PROF );
 SET_LEN_PLIST( prof, LEN_PROF );
 SET_COUNT_PROF( prof, 0 );
 SET_TIME_WITH_PROF( prof, 0 );
 SET_TIME_WOUT_PROF( prof, 0 );
 SET_STOR_WITH_PROF( prof, 0 );
 SET_STOR_WOUT_PROF( prof, 0 );
 SET_PROF_FUNC(func, prof);
 CHANGED_BAG(func);

 // return the function bag
 return func;
}

/****************************************************************************
**
*F ArgStringToList( <nams_c> )
**
** 'ArgStringToList' takes a C string <nams_c> containing a list of comma
** separated argument names, and turns it into a plist of strings, ready
** to be passed to 'NewFunction' as <nams>.
*/
Obj ArgStringToList(const Char *nams_c) {
 Obj tmp; // argument name as an object
 Obj nams_o; // nams as an object
 UInt len; // length
 UInt i, k, l; // loop variables

 // convert the arguments list to an object
 len = 0;
 for ( k = 0; nams_c[k] != '\0'; k++ ) {
 if ( (0 == k || nams_c[k-1] == ' ' || nams_c[k-1] == ',')
 && ( nams_c[k ] != ' ' && nams_c[k ] != ',') ) {
 len++;
 }
 }
 nams_o = NEW_PLIST( T_PLIST, len );
 SET_LEN_PLIST( nams_o, len );
 k = 0;
 for ( i = 1; i <= len; i++ ) {
 while ( nams_c[k] == ' ' || nams_c[k] == ',' ) {
 k++;
 }
 l = k;
 while ( nams_c[l] != ' ' && nams_c[l] != ',' && nams_c[l] != '\0' ) {
 l++;
 }
 tmp = MakeImmStringWithLen(nams_c + k, l - k);
 SET_ELM_PLIST( nams_o, i, tmp );
 CHANGED_BAG( nams_o );
 k = l;
 }

 return nams_o;
}

/****************************************************************************
**
*F * * * * * * * * * * * * * type and print function * * * * * * * * * * * *
*/

/****************************************************************************
**
*F TypeFunction( <func> ) . . . . . . . . . . . . . . . type of a function
**
** 'TypeFunction' returns the type of the function <func>.
**
** 'TypeFunction' is the function in 'TypeObjFuncs' for functions.
*/
static Obj TYPE_FUNCTION;
static Obj TYPE_OPERATION;
static Obj TYPE_FUNCTION_WITH_NAME;
static Obj TYPE_OPERATION_WITH_NAME;

static Obj TypeFunction(Obj func)
{
 if (NAME_FUNC(func) == 0)
 return (IS_OPERATION(func) ? TYPE_OPERATION : TYPE_FUNCTION);
 else
 return (IS_OPERATION(func) ? TYPE_OPERATION_WITH_NAME : TYPE_FUNCTION_WITH_NAME);
}

/****************************************************************************
**
*F PrintFunction( <func> ) . . . . . . . . . . . . . . . print a function
**
*/

static Obj PrintOperation;

static void PrintFunction(Obj func)
{
 Int narg; // number of arguments
 Int nloc; // number of locals
 UInt i; // loop variable
 BOOL isvarg; // does function have varargs?

 isvarg = FALSE;

 if ( IS_OPERATION(func) ) {
 CALL_1ARGS( PrintOperation, func );
 return;
 }

#ifdef HPCGAP
 // print 'function (' or 'atomic function ('
 if (LCKS_FUNC(func)) {
 Pr("%5>atomic function%< ( %>", 0, 0);
 } else
 Pr("%5>function%< ( %>", 0, 0);
#else
 // print 'function ('
 Pr("%5>function%< ( %>", 0, 0);
#endif

 // print the arguments
 narg = NARG_FUNC(func);
 if (narg < 0) {
 isvarg = TRUE;
 narg = -narg;
 }

 for ( i = 1; i <= narg; i++ ) {
#ifdef HPCGAP
 if (LCKS_FUNC(func)) {
 const Char * locks = CONST_CSTR_STRING(LCKS_FUNC(func));
 switch(locks[i-1]) {
 case LOCK_QUAL_READONLY:
 Pr("%>readonly %<", 0, 0);
 break;
 case LOCK_QUAL_READWRITE:
 Pr("%>readwrite %<", 0, 0);
 break;
 }
 }
#endif
 if ( NAMS_FUNC(func) != 0 )
 Pr("%I", (Int)NAMI_FUNC(func, (Int)i), 0);
 else
 Pr("<>", (Int)i, 0);
 if(isvarg && i == narg) {
 Pr("...", 0, 0);
 }
 if (i != narg)
 Pr("%<, %>", 0, 0);
 }
 Pr(" %<)\n", 0, 0);

 // print the body
 if (IsKernelFunction(func)) {
 PrintKernelFunction(func);
 }
 else {
 // print the locals
 nloc = NLOC_FUNC(func);
 if ( nloc >= 1 ) {
 Pr("%>local ", 0, 0);
 for ( i = 1; i <= nloc; i++ ) {
 if ( NAMS_FUNC(func) != 0 )
 Pr("%I", (Int)NAMI_FUNC(func, (Int)(narg + i)), 0);
 else
 Pr("<>", (Int)i, 0);
 if (i != nloc)
 Pr("%<, %>", 0, 0);
 }
 Pr("%<;\n", 0, 0);
 }

 // print the code
 Obj oldLVars;
 oldLVars = SWITCH_TO_NEW_LVARS(func, narg, NLOC_FUNC(func));
 PrintStat( OFFSET_FIRST_STAT );
 SWITCH_TO_OLD_LVARS( oldLVars );
 }
 Pr("%4<\n", 0, 0);

 // print 'end'
 Pr("end", 0, 0);
}

void PrintKernelFunction(Obj func)
{
 GAP_ASSERT(IsKernelFunction(func));
 Obj body = BODY_FUNC(func);
 Obj filename = body ? GET_FILENAME_BODY(body) : 0;
 if (filename) {
 if ( GET_LOCATION_BODY(body) ) {
 Pr("<> from %g:%g",
 (Int)filename,
 (Int)GET_LOCATION_BODY(body));
 }
 else if ( GET_STARTLINE_BODY(body) ) {
 Pr("<> from %g:%d",
 (Int)filename,
 GET_STARTLINE_BODY(body));
 }
 }
 else {
 Pr("<>", 0, 0);
 }
}

/****************************************************************************
**
*F FiltIS_FUNCTION( <self>, <func> ) . . . . . . . . . . . test for function
**
** 'FiltIS_FUNCTION' implements the internal function 'IsFunction'.
**
** 'IsFunction( <func> )'
**
** 'IsFunction' returns 'true' if <func> is a function and 'false'
** otherwise.
*/
static Obj IsFunctionFilt;

static Obj FiltIS_FUNCTION(Obj self, Obj obj)
{
 if ( TNUM_OBJ(obj) == T_FUNCTION ) {
 return True;
 }
 else if ( TNUM_OBJ(obj) < FIRST_EXTERNAL_TNUM ) {
 return False;
 }
 else {
 return DoFilter( self, obj );
 }
}

/****************************************************************************
**
*F FuncCALL_FUNC_LIST( <self>, <func>, <list> ) . . . . . . call a function
**
** 'FuncCALL_FUNC_LIST' implements the internal function 'CallFuncList'.
**
** 'CallFuncList( <func>, <list> )'
**
** 'CallFuncList' calls the function <func> with the arguments list <list>,
** i.e., it is equivalent to '<func>( <list>[1], <list>[2]... )'.
*/
Obj CallFuncListOper;
static Obj CallFuncListWrapOper;

Obj CallFuncList ( Obj func, Obj list )
{
 Obj result; // result
 Obj list2; // list of arguments
 Obj arg; // one argument
 UInt i; // loop variable

 if (TNUM_OBJ(func) == T_FUNCTION) {

 // call the function
 if ( LEN_LIST(list) == 0 ) {
 result = CALL_0ARGS( func );
 }
 else if ( LEN_LIST(list) == 1 ) {
 result = CALL_1ARGS( func, ELMV_LIST(list,1) );
 }
 else if ( LEN_LIST(list) == 2 ) {
 result = CALL_2ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2) );
 }
 else if ( LEN_LIST(list) == 3 ) {
 result = CALL_3ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
 ELMV_LIST(list,3) );
 }
 else if ( LEN_LIST(list) == 4 ) {
 result = CALL_4ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
 ELMV_LIST(list,3), ELMV_LIST(list,4) );
 }
 else if ( LEN_LIST(list) == 5 ) {
 result = CALL_5ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
 ELMV_LIST(list,3), ELMV_LIST(list,4),
 ELMV_LIST(list,5) );
 }
 else if ( LEN_LIST(list) == 6 ) {
 result = CALL_6ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
 ELMV_LIST(list,3), ELMV_LIST(list,4),
 ELMV_LIST(list,5), ELMV_LIST(list,6) );
 }
 else {
 list2 = NEW_PLIST( T_PLIST, LEN_LIST(list) );
 SET_LEN_PLIST( list2, LEN_LIST(list) );
 for ( i = 1; i <= LEN_LIST(list); i++ ) {
 arg = ELMV_LIST( list, (Int)i );
 SET_ELM_PLIST( list2, i, arg );
 }
 result = CALL_XARGS( func, list2 );
 }
 } else {
 result = DoOperation2Args(CallFuncListOper, func, list);
 }
 return result;

}

static Obj FuncCALL_FUNC_LIST(Obj self, Obj func, Obj list)
{
 RequireSmallList(SELF_NAME, list);
 return CallFuncList(func, list);
}

static Obj FuncCALL_FUNC_LIST_WRAP(Obj self, Obj func, Obj list)
{
 RequireSmallList(SELF_NAME, list);
 Obj retval = CallFuncList(func, list);
 return (retval == 0) ? NewImmutableEmptyPlist()
 : NewPlistFromArgs(retval);
}

/****************************************************************************
**
*F * * * * * * * * * * * * * * * utility functions * * * * * * * * * * * * *
*/

/****************************************************************************
**
*F AttrNAME_FUNC( <self>, <func> ) . . . . . . . . . . . name of a function
*/
static Obj NameFuncAttr;
static Obj SET_NAME_FUNC_Oper;

static Obj AttrNAME_FUNC(Obj self, Obj func)
{
 Obj name;

 if ( TNUM_OBJ(func) == T_FUNCTION ) {
 name = NAME_FUNC(func);
 if ( name == 0 ) {
 name = MakeImmString("unknown");
 SET_NAME_FUNC(func, name);
 CHANGED_BAG(func);
 }
 return name;
 }
 else {
 return DoAttribute( self, func );
 }
}

static Obj FuncSET_NAME_FUNC(Obj self, Obj func, Obj name)
{
 RequireStringRep(SELF_NAME, name);

 if (TNUM_OBJ(func) == T_FUNCTION ) {
 SET_NAME_FUNC(func, ImmutableString(name));
 CHANGED_BAG(func);
 } else
 DoOperation2Args(SET_NAME_FUNC_Oper, func, name);
 return (Obj) 0;
}

/****************************************************************************
**
*F FuncNARG_FUNC( <self>, <func> ) . . . . number of arguments of a function
*/
static Obj NARG_FUNC_Oper;

static Obj FuncNARG_FUNC(Obj self, Obj func)
{
 if ( TNUM_OBJ(func) == T_FUNCTION ) {
 return INTOBJ_INT( NARG_FUNC(func) );
 }
 else {
 return DoOperation1Args( self, func );
 }
}

/****************************************************************************
**
*F FuncNAMS_FUNC( <self>, <func> ) . . . . names of local vars of a function
*/
static Obj NAMS_FUNC_Oper;

static Obj FuncNAMS_FUNC(Obj self, Obj func)
{
 Obj nams;
 if ( TNUM_OBJ(func) == T_FUNCTION ) {
 nams = NAMS_FUNC(func);
 return (nams != (Obj)0) ? nams : Fail;
 }
 else {
 return DoOperation1Args( self, func );
 }
}

/****************************************************************************
**
*F FuncLOCKS_FUNC( <self>, <func> ) . . . . locking status of a possibly
** atomic function
*/
static Obj LOCKS_FUNC_Oper;

static Obj FuncLOCKS_FUNC(Obj self, Obj func)
{
#ifdef HPCGAP
 Obj locks;
 if (TNUM_OBJ(func) == T_FUNCTION) {
 locks = LCKS_FUNC(func);
 if (locks == (Obj)0)
 return Fail;
 else
 return locks;
 }
 else {
 return DoOperation1Args(self, func);
 }
#else
 return Fail;
#endif
}

/****************************************************************************
**
*F FuncPROF_FUNC( <self>, <func> ) . . . . . . profiling info of a function
*/
static Obj PROF_FUNC_Oper;

static Obj FuncPROF_FUNC(Obj self, Obj func)
{
 Obj prof;

 if ( TNUM_OBJ(func) == T_FUNCTION ) {
 prof = PROF_FUNC(func);
 if ( TNUM_OBJ(prof) == T_FUNCTION ) {
 return PROF_FUNC(prof);
 } else {
 return prof;
 }
 }
 else {
 return DoOperation1Args( self, func );
 }
}

/****************************************************************************
**
*F FuncCLEAR_PROFILE_FUNC( <self>, <func> ) . . . . . . . . . clear profile
*/
static Obj FuncCLEAR_PROFILE_FUNC(Obj self, Obj func)
{
 Obj prof;

 RequireFunction(SELF_NAME, func);

 // clear profile info
 prof = PROF_FUNC(func);
 if ( prof == 0 ) {
 ErrorQuit(" has corrupted profile info", 0, 0);
 }
 if ( TNUM_OBJ(prof) == T_FUNCTION ) {
 prof = PROF_FUNC(prof);
 }
 if ( prof == 0 ) {
 ErrorQuit(" has corrupted profile info", 0, 0);
 }
 SET_COUNT_PROF( prof, 0 );
 SET_TIME_WITH_PROF( prof, 0 );
 SET_TIME_WOUT_PROF( prof, 0 );
 SET_STOR_WITH_PROF( prof, 0 );
 SET_STOR_WOUT_PROF( prof, 0 );

 return (Obj)0;
}

/****************************************************************************
**
*F FuncPROFILE_FUNC( <self>, <func> ) . . . . . . . . . . . . start profile
*/
static Obj FuncPROFILE_FUNC(Obj self, Obj func)
{
 Obj prof;
 Obj copy;

 RequireFunction(SELF_NAME, func);

 // uninstall trace handler
 ChangeDoOperations( func, 0 );

 // install profiling
 prof = PROF_FUNC(func);

 // install new handlers
 if ( TNUM_OBJ(prof) != T_FUNCTION ) {
 copy = NewBag( TNUM_OBJ(func), SIZE_OBJ(func) );
 SET_HDLR_FUNC(copy,0, HDLR_FUNC(func,0));
 SET_HDLR_FUNC(copy,1, HDLR_FUNC(func,1));
 SET_HDLR_FUNC(copy,2, HDLR_FUNC(func,2));
 SET_HDLR_FUNC(copy,3, HDLR_FUNC(func,3));
 SET_HDLR_FUNC(copy,4, HDLR_FUNC(func,4));
 SET_HDLR_FUNC(copy,5, HDLR_FUNC(func,5));
 SET_HDLR_FUNC(copy,6, HDLR_FUNC(func,6));
 SET_HDLR_FUNC(copy,7, HDLR_FUNC(func,7));
 SET_NAME_FUNC(copy, NAME_FUNC(func));
 SET_NARG_FUNC(copy, NARG_FUNC(func));
 SET_NAMS_FUNC(copy, NAMS_FUNC(func));
 SET_PROF_FUNC(copy, PROF_FUNC(func));
 SET_NLOC_FUNC(copy, NLOC_FUNC(func));
 SET_HDLR_FUNC(func,0, DoProf0args);
 SET_HDLR_FUNC(func,1, DoProf1args);
 SET_HDLR_FUNC(func,2, DoProf2args);
 SET_HDLR_FUNC(func,3, DoProf3args);
 SET_HDLR_FUNC(func,4, DoProf4args);
 SET_HDLR_FUNC(func,5, DoProf5args);
 SET_HDLR_FUNC(func,6, DoProf6args);
 SET_HDLR_FUNC(func,7, DoProfXargs);
 SET_PROF_FUNC(func, copy);
 CHANGED_BAG(func);
 }

 return (Obj)0;
}

/****************************************************************************
**
*F FuncIS_PROFILED_FUNC( <self>, <func> ) . . check if function is profiled
*/
static Obj FuncIS_PROFILED_FUNC(Obj self, Obj func)
{
 RequireFunction(SELF_NAME, func);
 return ( TNUM_OBJ(PROF_FUNC(func)) != T_FUNCTION ) ? False : True;
}

static Obj FuncFILENAME_FUNC(Obj self, Obj func)
{
 RequireFunction(SELF_NAME, func);

 if (BODY_FUNC(func)) {
 Obj fn = GET_FILENAME_BODY(BODY_FUNC(func));
 if (fn)
 return fn;
 }
 return Fail;
}

static Obj FuncSTARTLINE_FUNC(Obj self, Obj func)
{
 RequireFunction(SELF_NAME, func);

 if (BODY_FUNC(func)) {
 UInt sl = GET_STARTLINE_BODY(BODY_FUNC(func));
 if (sl)
 return INTOBJ_INT(sl);
 }
 return Fail;
}

static Obj FuncENDLINE_FUNC(Obj self, Obj func)
{
 RequireFunction(SELF_NAME, func);

 if (BODY_FUNC(func)) {
 UInt el = GET_ENDLINE_BODY(BODY_FUNC(func));
 if (el)
 return INTOBJ_INT(el);
 }
 return Fail;
}

static Obj FuncLOCATION_FUNC(Obj self, Obj func)
{
 RequireFunction(SELF_NAME, func);

 if (BODY_FUNC(func)) {
 Obj sl = GET_LOCATION_BODY(BODY_FUNC(func));
 if (sl)
 return sl;
 }
 return Fail;
}

/****************************************************************************
**
*F FuncUNPROFILE_FUNC( <self>, <func> ) . . . . . . . . . . . stop profile
*/
static Obj FuncUNPROFILE_FUNC(Obj self, Obj func)
{
 Obj prof;

 RequireFunction(SELF_NAME, func);

 // uninstall trace handler
 ChangeDoOperations( func, 0 );

 // profiling is active, restore handlers
 prof = PROF_FUNC(func);
 if ( TNUM_OBJ(prof) == T_FUNCTION ) {
 for (Int i = 0; i <= 7; i++)
 SET_HDLR_FUNC(func, i, HDLR_FUNC(prof, i));
 SET_PROF_FUNC(func, PROF_FUNC(prof));
 CHANGED_BAG(func);
 }

 return (Obj)0;
}

/****************************************************************************
*
*F FuncIsKernelFunction( <self>, <func> )
**
** 'FuncIsKernelFunction' returns Fail if <func> is not a function, True if
** <func> is a kernel function, and False otherwise.
*/
static Obj FuncIsKernelFunction(Obj self, Obj func)
{
 if (!IS_FUNC(func))
 return Fail;
 return IsKernelFunction(func) ? True : False;
}

BOOL IsKernelFunction(Obj func)
{
 GAP_ASSERT(IS_FUNC(func));
 return (BODY_FUNC(func) == 0) ||
 (SIZE_OBJ(BODY_FUNC(func)) == sizeof(BodyHeader));
}

// Returns a measure of the size of a GAP function
static Obj FuncFUNC_BODY_SIZE(Obj self, Obj func)
{
 RequireFunction(SELF_NAME, func);
 Obj body = BODY_FUNC(func);
 if (body == 0)
 return INTOBJ_INT(0);
 return ObjInt_UInt(SIZE_BAG(body));
}

#ifdef GAP_ENABLE_SAVELOAD

static void SaveHandler(ObjFunc hdlr)
{
 const Char * cookie;
 if (hdlr == (ObjFunc)0)
 SaveCStr("");
 else {
 cookie = CookieOfHandler(hdlr);
 if (!cookie) {
 Pr("No cookie for Handler -- workspace will be corrupt\n", 0, 0);
 SaveCStr("");
 }
 else
 SaveCStr(cookie);
 }
}

static ObjFunc LoadHandler( void )
{
 Char buf[256];
 LoadCStr(buf, 256);
 if (buf[0] == '\0')
 return (ObjFunc) 0;
 else
 return HandlerOfCookie(buf);
}

/****************************************************************************
**
*F SaveFunction( <func> ) . . . . . . . . . . . . . . . . . save a function
**
*/
static void SaveFunction(Obj func)
{
 const FuncBag * header = CONST_FUNC(func);
 for (UInt i = 0; i < ARRAY_SIZE(header->handlers); i++)
 SaveHandler(header->handlers[i]);
 SaveSubObj(header->name);
 SaveSubObj(header->nargs);
 SaveSubObj(header->namesOfArgsAndLocals);
 SaveSubObj(header->prof);
 SaveSubObj(header->nloc);
 SaveSubObj(header->body);
 SaveSubObj(header->envi);
 if (IS_OPERATION(func))
 SaveOperationExtras( func );
}

/****************************************************************************
**
*F LoadFunction( <func> ) . . . . . . . . . . . . . . . . . load a function
**
*/
static void LoadFunction(Obj func)
{
 FuncBag * header = FUNC(func);
 for (UInt i = 0; i < ARRAY_SIZE(header->handlers); i++)
 header->handlers[i] = LoadHandler();
 header->name = LoadSubObj();
 header->nargs = LoadSubObj();
 header->namesOfArgsAndLocals = LoadSubObj();
 header->prof = LoadSubObj();
 header->nloc = LoadSubObj();
 header->body = LoadSubObj();
 header->envi = LoadSubObj();
 if (IS_OPERATION(func))
 LoadOperationExtras( func );
}

#endif

/****************************************************************************
**
*F MarkFunctionSubBags( <bag> ) . . . . . . . marking function for functions
**
** 'MarkFunctionSubBags' is the marking function for bags of type 'T_FUNCTION'.
*/
static void MarkFunctionSubBags(Obj func, void * ref)
{
 // the first eight slots are pointers to C functions, so we need
 // to skip those for marking
 UInt size = SIZE_BAG(func) / sizeof(Obj) - 8;
 const Bag * data = CONST_PTR_BAG(func) + 8;
 MarkArrayOfBags(data, size, ref);
}

/****************************************************************************
**
*F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
*/

/****************************************************************************
**
*V BagNames . . . . . . . . . . . . . . . . . . . . . . . list of bag names
*/
static StructBagNames BagNames[] = {
 { T_FUNCTION, "function" },
 { -1, "" }
};

/****************************************************************************
**
*V GVarFilts . . . . . . . . . . . . . . . . . . . list of filters to export
*/
static StructGVarFilt GVarFilts [] = {

 GVAR_FILT(IS_FUNCTION, "obj", &IsFunctionFilt),
 { 0, 0, 0, 0, 0 }

};

/****************************************************************************
**
*V GVarAttrs . . . . . . . . . . . . . . . . . list of attributes to export
*/
static StructGVarAttr GVarAttrs [] = {

 GVAR_ATTR(NAME_FUNC, "func", &NameFuncAttr),
 { 0, 0, 0, 0, 0 }

};

/****************************************************************************
**
*V GVarOpers . . . . . . . . . . . . . . . . . list of operations to export
*/
static StructGVarOper GVarOpers [] = {

 GVAR_OPER_2ARGS(CALL_FUNC_LIST, func, list, &CallFuncListOper),
 GVAR_OPER_2ARGS(CALL_FUNC_LIST_WRAP, func, list, &CallFuncListWrapOper),
 GVAR_OPER_2ARGS(SET_NAME_FUNC, func, name, &SET_NAME_FUNC_Oper),
 GVAR_OPER_1ARGS(NARG_FUNC, func, &NARG_FUNC_Oper),
 GVAR_OPER_1ARGS(NAMS_FUNC, func, &NAMS_FUNC_Oper),
 GVAR_OPER_1ARGS(LOCKS_FUNC, func, &LOCKS_FUNC_Oper),
 GVAR_OPER_1ARGS(PROF_FUNC, func, &PROF_FUNC_Oper),
 { 0, 0, 0, 0, 0, 0 }

};

/****************************************************************************
**
*V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
*/
static StructGVarFunc GVarFuncs[] = {

 GVAR_FUNC_1ARGS(CLEAR_PROFILE_FUNC, func),
 GVAR_FUNC_1ARGS(IS_PROFILED_FUNC, func),
 GVAR_FUNC_1ARGS(PROFILE_FUNC, func),
 GVAR_FUNC_1ARGS(UNPROFILE_FUNC, func),
 GVAR_FUNC_1ARGS(IsKernelFunction, func),
 GVAR_FUNC_1ARGS(FILENAME_FUNC, func),
 GVAR_FUNC_1ARGS(LOCATION_FUNC, func),
 GVAR_FUNC_1ARGS(STARTLINE_FUNC, func),
 GVAR_FUNC_1ARGS(ENDLINE_FUNC, func),

 GVAR_FUNC_1ARGS(FUNC_BODY_SIZE, func),

 { 0, 0, 0, 0, 0 }

};

/****************************************************************************
**
*F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
*/
static Int InitKernel (
 StructInitInfo * module )
{
 // set the bag type names (for error messages and debugging)
 InitBagNamesFromTable( BagNames );

 // install the marking functions
 InitMarkFuncBags(T_FUNCTION, MarkFunctionSubBags);

#ifdef HPCGAP
 // Allocate functions in the public region
 MakeBagTypePublic(T_FUNCTION);
#endif

 // install the type functions
 ImportGVarFromLibrary( "TYPE_FUNCTION", &TYPE_FUNCTION );
 ImportGVarFromLibrary( "TYPE_OPERATION", &TYPE_OPERATION );
 ImportGVarFromLibrary( "TYPE_FUNCTION_WITH_NAME", &TYPE_FUNCTION_WITH_NAME );
 ImportGVarFromLibrary( "TYPE_OPERATION_WITH_NAME", &TYPE_OPERATION_WITH_NAME );
 TypeObjFuncs[ T_FUNCTION ] = TypeFunction;

 // init filters and functions
 InitHdlrFiltsFromTable( GVarFilts );
 InitHdlrAttrsFromTable( GVarAttrs );
 InitHdlrOpersFromTable( GVarOpers );
 InitHdlrFuncsFromTable( GVarFuncs );

#ifdef USE_GASMAN
 // and the saving function
 SaveObjFuncs[ T_FUNCTION ] = SaveFunction;
 LoadObjFuncs[ T_FUNCTION ] = LoadFunction;
#endif

 // install the printer
 InitFopyGVar( "PRINT_OPERATION", &PrintOperation );
 PrintObjFuncs[ T_FUNCTION ] = PrintFunction;

 // initialise all 'Do<Something><N>args' handlers, give the most
 // common ones short cookies to save space in the saved workspace
 InitHandlerFunc( DoFail0args, "f0" );
 InitHandlerFunc( DoFail1args, "f1" );
 InitHandlerFunc( DoFail2args, "f2" );
 InitHandlerFunc( DoFail3args, "f3" );
 InitHandlerFunc( DoFail4args, "f4" );
 InitHandlerFunc( DoFail5args, "f5" );
 InitHandlerFunc( DoFail6args, "f6" );
 InitHandlerFunc( DoFailXargs, "f7" );

 InitHandlerFunc( DoWrap0args, "w0" );
 InitHandlerFunc( DoWrap1args, "w1" );
 InitHandlerFunc( DoWrap2args, "w2" );
 InitHandlerFunc( DoWrap3args, "w3" );
 InitHandlerFunc( DoWrap4args, "w4" );
 InitHandlerFunc( DoWrap5args, "w5" );
 InitHandlerFunc( DoWrap6args, "w6" );

 InitHandlerFunc( DoProf0args, "p0" );
 InitHandlerFunc( DoProf1args, "p1" );
 InitHandlerFunc( DoProf2args, "p2" );
 InitHandlerFunc( DoProf3args, "p3" );
 InitHandlerFunc( DoProf4args, "p4" );
 InitHandlerFunc( DoProf5args, "p5" );
 InitHandlerFunc( DoProf6args, "p6" );
 InitHandlerFunc( DoProfXargs, "pX" );

 return 0;
}

/****************************************************************************
**
*F InitLibrary( <module> ) . . . . . . . initialise library data structures
*/
static Int InitLibrary(StructInitInfo * module)
{
 // init filters and functions
 InitGVarFiltsFromTable( GVarFilts );
 InitGVarAttrsFromTable( GVarAttrs );
 InitGVarOpersFromTable( GVarOpers );
 InitGVarFuncsFromTable( GVarFuncs );

 return 0;
}

/****************************************************************************
**
*F InitInfoCalls() . . . . . . . . . . . . . . . . . table of init functions
*/
static StructInitInfo module = {
 // init struct using C99 designated initializers; for a full list of
 // fields, please refer to the definition of StructInitInfo
 .type = MODULE_BUILTIN,
 .name = "calls",
 .initKernel = InitKernel,
 .initLibrary = InitLibrary,
};

StructInitInfo * InitInfoCalls ( void )
{
 return &module;
}

quality84%

¤ Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.0.24Bemerkung: (vorverarbeitet) ¤

*Bot Zugriff

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.