/src/opers.c

Large files files are truncated, but you can click here to view the full file

/****************************************************************************
**
*W  opers.c                     GAP source                       Frank Celler
*W                                                         & Martin Schönert
**
**
*Y  Copyright (C)  1996,  Lehrstuhl D für Mathematik,  RWTH Aachen,  Germany
*Y  (C) 1998 School Math and Comp. Sci., University of St Andrews, Scotland
*Y  Copyright (C) 2002 The GAP Group
**
**  This file contains the functions of the  filters, operations, attributes,
**  and properties package.
*/
#include        <assert.h>
#include        "system.h"              /* Ints, UInts                     */




#include        "gasman.h"              /* garbage collector               */
#include        "objects.h"             /* objects                         */
#include        "scanner.h"             /* scanner                         */

#include        "gvars.h"               /* global variables                */

#include        "gap.h"                 /* error handling, initialisation  */

#include        "calls.h"               /* generic call mechanism          */

#include        "opers.h"               /* generic operations              */

#include        "ariths.h"              /* basic arithmetic                */
#include        "lists.h"               /* generic lists                   */

#include        "bool.h"                /* booleans                        */

#include        "plist.h"               /* plain lists                     */
#include        "blister.h"             /* boolean lists                   */
#include        "string.h"              /* strings                         */
#include        "range.h"               /* ranges                          */

#include        "records.h"             /* generic records                 */
#include        "precord.h"             /* plain records                   */

#include        "saveload.h"            /* saving and loading              */

#include        "listfunc.h"   
#include        "integer.h"   

/****************************************************************************
**
*V  TRY_NEXT_METHOD . . . . . . . . . . . . . . . . . `TRY_NEXT_MESSAGE' flag
*/
Obj TRY_NEXT_METHOD;


#define CACHE_SIZE 5


/****************************************************************************
**

*F * * * * * * * * * * * * internal flags functions * * * * * * * * * * * * *
*/


/****************************************************************************
**

*F  PrintFlags( <flags> ) . . . . . . . . . . . . . . . .  print a flags list
*/
void PrintFlags (
    Obj                 flags )
{
    Pr( "<flag list>", 0L, 0L );
}


/****************************************************************************
**
*F  TypeFlags( <flags> )  . . . . . . . . . . . . . . .  type of a flags list
*/
Obj TYPE_FLAGS;

Obj TypeFlags (
    Obj                 flags )
{
    return TYPE_FLAGS;
}


/****************************************************************************
**
*F  SaveFlags( <flags> )  . . . . . . . . . . . . . . . . . save a flags list
**
*/
void SaveFlags (
    Obj         flags )
{
    UInt        i, len, *ptr;

    SaveSubObj(TRUES_FLAGS(flags));
    SaveSubObj(HASH_FLAGS(flags));
    SaveSubObj(ADDR_OBJ(flags)[2]); /* length, as an object */
    SaveSubObj(AND_CACHE_FLAGS(flags));

    len = NRB_FLAGS(flags);
    ptr = BLOCKS_FLAGS(flags);
    for ( i = 1;  i <= len;  i++ )
        SaveUInt(*ptr++);
    return;
}


/****************************************************************************
**
*F  LoadFlags( <flags> )  . . . . . . . . . . . . . . . . . load a flags list
**
*/
void LoadFlags(
    Obj         flags )
{
    Obj         sub;
    UInt        i, len, *ptr;

    sub = LoadSubObj();  SET_TRUES_FLAGS( flags, sub );
    sub = LoadSubObj();  SET_HASH_FLAGS( flags, sub );
    ADDR_OBJ(flags)[2] = LoadSubObj(); /* length, as an object */
    sub = LoadSubObj();  SET_AND_CACHE_FLAGS( flags, sub );
    
    len = NRB_FLAGS(flags);
    ptr = BLOCKS_FLAGS(flags);
    for ( i = 1;  i <= len;  i++ )
        *ptr++ = LoadUInt();
    return;
}


/****************************************************************************
**

*F * * * * * * * * * * * * *  GAP flags functions * * * * * * * * * * * * * *
*/


/****************************************************************************
**

*F  FuncLEN_FLAGS( <self>, <flags> )  . . . . . . . .  length of a flags list
**
*/
Obj FuncLEN_FLAGS (
    Obj                 self,
    Obj                 flags )
{
    /* do some trivial checks                                              */
    while ( TNUM_OBJ(flags) != T_FLAGS ) {
        flags = ErrorReturnObj( "<flags> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags), 0L,
            "you can replace <flags> via 'return <flags>;'" );
    }

    return INTOBJ_INT( LEN_FLAGS(flags) );
}


/****************************************************************************
**
*F  FuncELM_FLAGS( <self>, <flags>, <pos> ) . . . . . element of a flags list
*/
Obj FuncELM_FLAGS (
    Obj                 self,
    Obj                 flags,
    Obj                 pos )
{
    /* do some trivial checks                                              */
    while ( TNUM_OBJ(flags) != T_FLAGS ) {
        flags = ErrorReturnObj( "<flags> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags), 0L,
            "you can replace <flags> via 'return <flags>;'" );
    }

    /* select and return the element                                       */
    return ELM_FLAGS( flags, INT_INTOBJ(pos) );
}


/****************************************************************************
**
*F  FuncHASH_FLAGS( <self>, <flags> ) . . . . . .  hash value of a flags list
**
**  The hash value is independent of the size of a machine word (32 or 64).
**
**  The rather peculiar cast in the definition of HASH_FLAGS_SIZE is needed
**  to get the calculation to work right on the alpha.
**
*T  The 64 bit version depends on the byte order -- it assumes that
**  the lower addressed half-word is the less significant
**
*/
#define HASH_FLAGS_SIZE (Int4)67108879L

Obj FuncHASH_FLAGS (
    Obj                 self,
    Obj                 flags )
{
    Int4                 hash;
    Int4                 x;
    Int                  len;
    UInt4 *              ptr;
    Int                  i;

    /* do some trivial checks                                              */
    while ( TNUM_OBJ(flags) != T_FLAGS ) {
            flags = ErrorReturnObj( "<flags> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags), 0L,
            "you can replace <flags> via 'return <flags>;'" );
    }
    if ( HASH_FLAGS(flags) != 0 ) {
        return HASH_FLAGS(flags);
    }

    /* do the real work*/
#ifndef SYS_IS_64_BIT

    /* 32 bit case  -- this is the "defining" case, others are
     adjusted to comply with this */
    len = NRB_FLAGS(flags);
    ptr = (UInt4 *)BLOCKS_FLAGS(flags);
    hash = 0;
    x    = 1;
    for ( i = len; i >= 1; i-- ) {
        hash = (hash + (*ptr % HASH_FLAGS_SIZE) * x) % HASH_FLAGS_SIZE;
        x    = ((8*sizeof(UInt4)-1) * x) % HASH_FLAGS_SIZE;
        ptr++;
    }
#else
#ifdef WORDS_BIGENDIAN

    /* This is the hardest case */
    len = NRB_FLAGS(flags);
    ptr = (UInt4 *)BLOCKS_FLAGS(flags);
    hash = 0;
    x    = 1;
    for ( i = len; i >= 1; i-- ) {

        /* least significant 32 bits first */
        hash = (hash + (ptr[1] % HASH_FLAGS_SIZE) * x) % HASH_FLAGS_SIZE;
        x    = ((8*sizeof(UInt4)-1) * x) % HASH_FLAGS_SIZE;
        /* now the more significant */
        hash = (hash + (*ptr % HASH_FLAGS_SIZE) * x) % HASH_FLAGS_SIZE;
        x    = ((8*sizeof(UInt4)-1) * x) % HASH_FLAGS_SIZE;
        
        ptr+= 2;
    }
#else

    /* and the middle case -- for DEC alpha, the 32 bit chunks are
       in the right order, and we merely have to be sure to process them as
       32 bit chunks */
    len = NRB_FLAGS(flags)*(sizeof(UInt)/sizeof(UInt4));
    ptr = (UInt4 *)BLOCKS_FLAGS(flags);
    hash = 0;
    x    = 1;
    for ( i = len; i >= 1; i-- ) {
        hash = (hash + (*ptr % HASH_FLAGS_SIZE) * x) % HASH_FLAGS_SIZE;
        x    = ((8*sizeof(UInt4)-1) * x) % HASH_FLAGS_SIZE;
        ptr++;
    }
#endif
#endif
    SET_HASH_FLAGS( flags, INTOBJ_INT((UInt)hash+1) );
    CHANGED_BAG(flags);
    return HASH_FLAGS(flags);
}


/****************************************************************************
**
*F  FuncTRUES_FLAGS( <self>, <flags> )  . . .  true positions of a flags list
**
**  see 'FuncPositionsTruesBlist' in "blister.c" for information.
*/
Obj FuncTRUES_FLAGS (
    Obj                 self,
    Obj                 flags )
{
    Obj                 sub;            /* handle of the result            */
    Int                 len;            /* logical length of the list      */
    UInt *              ptr;            /* pointer to flags                */
    UInt                nrb;            /* number of blocks in flags       */
    UInt                m;              /* number of bits in a block       */
    UInt                n;              /* number of bits in flags         */
    UInt                nn;
    UInt                i;              /* loop variable                   */

    /* get and check the first argument                                    */
    while ( TNUM_OBJ(flags) != T_FLAGS ) {
        flags = ErrorReturnObj( "<flags> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags), 0L,
            "you can replace <flags> via 'return <flags>;'" );
    }
    if ( TRUES_FLAGS(flags) != 0 ) {
        return TRUES_FLAGS(flags);
    }

    /* compute the number of 'true'-s just as in 'FuncSizeBlist'            */
    nrb = NRB_FLAGS(flags);
    ptr = (UInt*)BLOCKS_FLAGS(flags);
    n = 0;
    for ( i = 1; i <= nrb; i++ ) {
        m = *ptr++;
        COUNT_TRUES_BLOCK(m); 
        n += m;
    }

    /* make the sublist (we now know its size exactely)                    */
    sub = NEW_PLIST( T_PLIST+IMMUTABLE, n );
    SET_LEN_PLIST( sub, n );

    /* loop over the boolean list and stuff elements into <sub>            */
    len = LEN_FLAGS( flags );
    nn  = 1;
    for ( i = 1; nn <= n && i <= len;  i++ ) {
        if ( ELM_FLAGS( flags, i ) == True ) {
            SET_ELM_PLIST( sub, nn, INTOBJ_INT(i) );
            nn++;
        }
    }
    CHANGED_BAG(sub);

    /* return the sublist                                                  */
    SET_TRUES_FLAGS( flags, sub );
    CHANGED_BAG(flags);
    return sub;
}


/****************************************************************************
**
*F  FuncSIZE_FLAGS( <self>, <flags> ) . . . . number of trues of a flags list
**
**  see 'FuncSIZE_FLAGS'
*/
Obj FuncSIZE_FLAGS (
    Obj                 self,
    Obj                 flags )
{
    UInt *              ptr;            /* pointer to flags                */
    UInt                nrb;            /* number of blocks in flags       */
    UInt                m;              /* number of bits in a block       */
    UInt                n;              /* number of bits in flags         */
    UInt                i;              /* loop variable                   */

    /* get and check the first argument                                    */
    while ( TNUM_OBJ(flags) != T_FLAGS ) {
        flags = ErrorReturnObj( "<flags> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags), 0L,
            "you can replace <flags> via 'return <flags>;'" );
    }
    if ( TRUES_FLAGS(flags) != 0 ) {
        return INTOBJ_INT( LEN_PLIST( TRUES_FLAGS(flags) ) );
    }

    /* get the number of blocks and a pointer                              */
    nrb = NRB_FLAGS(flags);
    ptr = BLOCKS_FLAGS(flags);

    /* loop over the blocks, adding the number of bits of each one         */
    n = 0;
    for ( i = 1; i <= nrb; i++ ) {
        m = *ptr++;
        COUNT_TRUES_BLOCK(m);
        n += m;
    }

    /* return the number of bits                                           */
    return INTOBJ_INT( n );
}


/****************************************************************************
**

*F  FuncIS_EQUAL_FLAGS( <self>, <flags1>, <flags2> )  equality of flags lists
*/
Obj FuncIS_EQUAL_FLAGS (
    Obj                 self,
    Obj                 flags1,
    Obj                 flags2 )
{
    Int                 len1;
    Int                 len2;
    UInt  *             ptr1;
    UInt  *             ptr2;
    Int                 i;

    /* do some trivial checks                                              */
    while ( TNUM_OBJ(flags1) != T_FLAGS ) {
        flags1 = ErrorReturnObj( "<flags1> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags1), 0L,
            "you can replace <flags1> via 'return <flags1>;'" );
    }
    while ( TNUM_OBJ(flags2) != T_FLAGS ) {
        flags2 = ErrorReturnObj( "<flags2> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags2), 0L,
            "you can replace <flags2> via 'return <flags2>;'" );
    }
    if ( flags1 == flags2 ) {
        return True;
    }

    /* do the real work                                                    */
    len1 = NRB_FLAGS(flags1);
    len2 = NRB_FLAGS(flags2);
    ptr1 = BLOCKS_FLAGS(flags1);
    ptr2 = BLOCKS_FLAGS(flags2);
    if ( len1 <= len2 ) {
        for ( i = 1; i <= len1; i++ ) {
            if ( *ptr1 != *ptr2 )
                return False;
            ptr1++;  ptr2++;
        }
        for ( ; i <= len2; i++ ) {
            if ( 0 != *ptr2 )
                return False;
            ptr2++;
        }
    }
    else {
        for ( i = 1; i <= len2; i++ ) {
            if ( *ptr1 != *ptr2 )
                return False;
            ptr1++;  ptr2++;
        }
        for ( ; i <= len1; i++ ) {
            if ( *ptr1 != 0 )
                return False;
            ptr1++;
        }
    }
    return True;
}


/****************************************************************************
**
*F  FuncIS_SUBSET_FLAGS( <self>, <flags1>, <flags2> ) . . . . . . subset test
*/
Int IsSubsetFlagsCalls;
Int IsSubsetFlagsCalls1;
Int IsSubsetFlagsCalls2;

Obj FuncIS_SUBSET_FLAGS (
    Obj                 self,
    Obj                 flags1,
    Obj                 flags2 )
{
    Int                 len1;
    Int                 len2;
    UInt *              ptr1;
    UInt *              ptr2;
    Int                 i;
    Obj                 trues;

    /* do some trivial checks                                              */
    while ( TNUM_OBJ(flags1) != T_FLAGS ) {
        flags1 = ErrorReturnObj( "<flags1> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags1), 0L,
            "you can replace <flags1> via 'return <flags1>;'" );
    }
    while ( TNUM_OBJ(flags2) != T_FLAGS ) {
        flags2 = ErrorReturnObj( "<flags2> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags2), 0L,
            "you can replace <flags2> via 'return <flags2>;'" );
    }
    if ( flags1 == flags2 ) {
        return True;
    }

    /* do the real work                                                    */
#ifdef COUNT_OPERS
    IsSubsetFlagsCalls++;
#endif

    /* first check the trues                                               */
    trues = TRUES_FLAGS(flags2);
    if ( trues != 0 ) {
        len2 = LEN_PLIST(trues);
        if ( TRUES_FLAGS(flags1) != 0 ) {
            if ( LEN_PLIST(TRUES_FLAGS(flags1)) < len2 ) {
#ifdef COUNT_OPERS
                IsSubsetFlagsCalls1++;
#endif
                return False;
            }
        }
        if ( len2 < 3 ) {
#ifdef COUNT_OPERS
            IsSubsetFlagsCalls2++;
#endif
            if ( LEN_FLAGS(flags1) < INT_INTOBJ(ELM_PLIST(trues,len2)) ) {
                return False;
            }
            for ( i = len2;  0 < i;  i-- ) {
               if (ELM_FLAGS(flags1,INT_INTOBJ(ELM_PLIST(trues,i)))==False) {
                   return False;
               }
            }
            return True;
        }
    }

    /* compare the bit lists                                               */
    len1 = NRB_FLAGS(flags1);
    len2 = NRB_FLAGS(flags2);
    ptr1 = BLOCKS_FLAGS(flags1);
    ptr2 = BLOCKS_FLAGS(flags2);
    if ( len1 <= len2 ) {
        for ( i = 1; i <= len1; i++ ) {
            if ( (*ptr1 & *ptr2) != *ptr2 ) {
                return False;
            }
            ptr1++;  ptr2++;
        }
        for ( ; i <= len2; i++ ) {
            if ( 0 != *ptr2 ) {
                return False;
            }
            ptr2++;
        }
    }
    else {
        for ( i = 1; i <= len2; i++ ) {
            if ( (*ptr1 & *ptr2) != *ptr2 ) {
                return False;
            }
            ptr1++;  ptr2++;
        }
    }
    return True;
}


/****************************************************************************
**

*F  FuncSUB_FLAGS( <self>, <flags1>, <flags2> ) . . .  substract a flags list
*/
Obj FuncSUB_FLAGS (
    Obj                 self,
    Obj                 flags1,
    Obj                 flags2 )
{
    Obj                 flags;
    Int                 len1;
    Int                 len2;
    Int                 size1;
    Int                 size2;
    UInt *              ptr;
    UInt *              ptr1;
    UInt *              ptr2;
    Int                 i;

    /* do some trivial checks                                              */
    while ( TNUM_OBJ(flags1) != T_FLAGS ) {
        flags1 = ErrorReturnObj( "<flags1> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags1), 0L,
            "you can replace <flags1> via 'return <flags1>;'" );
    }
    while ( TNUM_OBJ(flags2) != T_FLAGS ) {
        flags2 = ErrorReturnObj( "<flags2> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags2), 0L,
            "you can replace <flags2> via 'return <flags2>;'" );
    }

    /* do the real work                                                    */
    len1   = LEN_FLAGS(flags1);
    size1  = NRB_FLAGS(flags1);
    len2   = LEN_FLAGS(flags2);
    size2  = NRB_FLAGS(flags2);
    if ( len1 < len2 ) {
        NEW_FLAGS( flags, len1 );
        SET_LEN_FLAGS( flags, len1 );
        ptr1 = BLOCKS_FLAGS(flags1);
        ptr2 = BLOCKS_FLAGS(flags2);
        ptr  = BLOCKS_FLAGS(flags);
        for ( i = 1; i <= size1; i++ )
            *ptr++ = *ptr1++ & ~ *ptr2++;
    }
    else {
        NEW_FLAGS( flags, len1 );
        SET_LEN_FLAGS( flags, len1 );
        ptr1 = BLOCKS_FLAGS(flags1);
        ptr2 = BLOCKS_FLAGS(flags2);
        ptr  = BLOCKS_FLAGS(flags);
        for ( i = 1; i <= size2; i++ )
            *ptr++ = *ptr1++ & ~ *ptr2++;
        for (      ; i <= size1; i++ )
            *ptr++ = *ptr1++;
    }        

    return flags;
}


/****************************************************************************
**
*F  FuncAND_FLAGS( <self>, <flags1>, <flags2> ) . . . .  `and' of flags lists
*/
#define AND_FLAGS_HASH_SIZE             50

Int AndFlagsCacheHit;
Int AndFlagsCacheMiss;
Int AndFlagsCacheLost;

Obj FuncAND_FLAGS (
    Obj                 self,
    Obj                 flags1,
    Obj                 flags2 )
{
    Obj                 flags;
    Int                 len1;
    Int                 len2;
    Int                 size1;
    Int                 size2;
    UInt *              ptr;
    UInt *              ptr1;
    UInt *              ptr2;
    Int                 i;

#ifdef AND_FLAGS_HASH_SIZE
    Obj                 flagsX;
    Obj                 cache;
    Obj                 entry;
    UInt                hash;
    UInt                hash2;
    static UInt         next = 0;
#endif

    /* do some trivial checks                                              */
    while ( TNUM_OBJ(flags1) != T_FLAGS ) {
        flags1 = ErrorReturnObj( "<flags1> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags1), 0L,
            "you can replace <flags1> via 'return <flags1>;'" );
    }
    while ( TNUM_OBJ(flags2) != T_FLAGS ) {
        flags2 = ErrorReturnObj( "<flags2> must be a flags list (not a %s)",
            (Int)TNAM_OBJ(flags2), 0L,
            "you can replace <flags2> via 'return <flags2>;'" );
    }

    /* check the cache                                                     */
#   ifdef AND_FLAGS_HASH_SIZE
        if ( INT_INTOBJ(flags1) < INT_INTOBJ(flags2) ) {
            flagsX = flags2;
            cache  = AND_CACHE_FLAGS(flags1);
            if ( cache == 0 ) {
                cache = NEW_PLIST( T_PLIST, 2*AND_FLAGS_HASH_SIZE );
                SET_AND_CACHE_FLAGS( flags1, cache );
                CHANGED_BAG(flags1);
            }
        }
        else {
            flagsX = flags1;
            cache  = AND_CACHE_FLAGS(flags2);
            if ( cache == 0 ) {
                cache = NEW_PLIST( T_PLIST, 2*AND_FLAGS_HASH_SIZE );
                SET_AND_CACHE_FLAGS( flags2, cache );
                CHANGED_BAG(flags2);
            }
        }
        hash = (UInt)INT_INTOBJ(flagsX);
        for ( i = 0;  i < 24;  i++ ) {
            hash2 = (hash + 97*i) % AND_FLAGS_HASH_SIZE;
            entry = ELM_PLIST( cache, 2*hash2+1 );
            if ( entry == 0 ) {
                break;
            }
            if ( entry == flagsX ) {
#               ifdef COUNT_OPERS
                    AndFlagsCacheHit++;
#               endif
                return ELM_PLIST( cache, 2*hash2+2 );
            }
        }
        if ( entry == 0 ) {
            hash = hash2;
        }
        else {
            next = (next+1) % 24;
            hash = (hash + 97*next) % AND_FLAGS_HASH_SIZE;
        }
#       ifdef COUNT_OPERS
            AndFlagsCacheMiss++;
#       endif
#   endif


    /* do the real work                                                    */
    len1   = LEN_FLAGS(flags1);
    size1  = NRB_FLAGS(flags1);
    len2   = LEN_FLAGS(flags2);
    size2  = NRB_FLAGS(flags2);
    if ( len1 == 0 ) {
        return flags2;
    }
    if ( len2 == 0 ) {
        return flags1;
    }
    if ( len1 < len2 ) {
        NEW_FLAGS( flags, len2 );
        SET_LEN_FLAGS( flags, len2 );
        ptr1 = BLOCKS_FLAGS(flags1);
        ptr2 = BLOCKS_FLAGS(flags2);
        ptr  = BLOCKS_FLAGS(flags);
        for ( i = 1; i <= size1; i++ )
            *ptr++ = *ptr1++ | *ptr2++;
        for (      ; i <= size2; i++ )
            *ptr++ =           *ptr2++;
    }
    else {
        NEW_FLAGS( flags, len1 );
        SET_LEN_FLAGS( flags, len1 );
        ptr1 = BLOCKS_FLAGS(flags1);
        ptr2 = BLOCKS_FLAGS(flags2);
        ptr  = BLOCKS_FLAGS(flags);
        for ( i = 1; i <= size2; i++ )
            *ptr++ = *ptr1++ | *ptr2++;
        for (      ; i <= size1; i++ )
            *ptr++ = *ptr1++;
    }        

    /* store result in the cache                                           */
#   ifdef AND_FLAGS_HASH_SIZE
#       ifdef COUNT_OPERS
            if ( ELM_PLIST(cache,2*hash+1) != 0 ) {
                    AndFlagsCacheLost++;
            }
#       endif
        SET_ELM_PLIST( cache, 2*hash+1, flagsX );
        SET_ELM_PLIST( cache, 2*hash+2, flags  );
        CHANGED_BAG(cache);
#   endif

    /* and return the result                                               */
    return flags;
}


/****************************************************************************
**

*F * * * * * * * * * * *  internal filter functions * * * * * * * * * * * * *
*/


/****************************************************************************
**

*V  Countlags  . . . . . . . . . . . . . . . . . . . . next free flag number
*/
Int CountFlags;


/****************************************************************************
**

*F  SetterFilter( <oper> )  . . . . . . . . . . . . . . .  setter of a filter
*/
Obj SetterFilter (
    Obj                 oper )
{
    Obj                 setter;

    setter = SETTR_FILT( oper );
    if ( setter == INTOBJ_INT(0xBADBABE) )
        setter = SetterAndFilter( oper );
    return setter;
}


/****************************************************************************
**
*F  SetterAndFilter( <getter> )  . . . . . .  setter of a concatenated filter
*/
Obj DoSetAndFilter (
    Obj                 self,
    Obj                 obj,
    Obj                 val )
{
    Obj                 op;

    while (val != True)
      val = ErrorReturnObj(
             "You cannot set an \"and-filter\" except to true", 0L, 0L,
             "you can type 'return true;' to set all components true\n"
             "(but you might really want to reset just one component)");
    
    /* call the first 'and'-ed function                                    */
    op = FLAG1_FILT( self );
    CALL_2ARGS( op, obj, val );
    
    /* call the second 'and'-ed function                                   */
    op = FLAG2_FILT( self );
    CALL_2ARGS( op, obj, val );
    
    /* return 'void'                                                       */
    return 0;
}


Obj SetterAndFilter (
    Obj                 getter )
{
    Obj                 setter;

    if ( SETTR_FILT( getter ) == INTOBJ_INT(0xBADBABE) ) {
        setter = NewFunctionCT( T_FUNCTION, SIZE_OPER,
                                "<<setter-and-filter>>", 2L, "obj, val",
                                DoSetAndFilter );
        FLAG1_FILT(setter)  = SetterFilter( FLAG1_FILT(getter) );
        FLAG2_FILT(setter)  = SetterFilter( FLAG2_FILT(getter) );
        SETTR_FILT(getter)  = setter;
        CHANGED_BAG(getter);
    }

    return SETTR_FILT(getter);
}
        

/****************************************************************************
**
*F  TesterFilter( <oper> )  . . . . . . . . . . . . . . .  tester of a filter
*/
Obj TesterFilter (
    Obj                 oper )
{
    Obj                 tester;

    tester = TESTR_FILT( oper );
    if ( tester == INTOBJ_INT(0xBADBABE) )
        tester = TesterAndFilter( oper );
    return tester;
}


/****************************************************************************
**
*F  TestAndFilter( <getter> )  . . . . . . . .tester of a concatenated filter
*/
Obj DoTestAndFilter (
    Obj                 self,
    Obj                 obj )
{
    Obj                 val;
    Obj                 op;
    
    /* call the first 'and'-ed function                                    */
    op = FLAG1_FILT( self );
    val = CALL_1ARGS( op, obj );
    if ( val != True )  return False;
    
    /* call the second 'and'-ed function                                   */
    op = FLAG2_FILT( self );
    val = CALL_1ARGS( op, obj );
    if ( val != True )  return False;
    
    /* return 'true'                                                       */
    return True;
}


Obj TesterAndFilter (
    Obj                 getter )
{
    Obj                 tester;

    if ( TESTR_FILT( getter ) == INTOBJ_INT(0xBADBABE) ) {
        tester = NewAndFilter( TesterFilter( FLAG1_FILT(getter) ),
                               TesterFilter( FLAG2_FILT(getter) ) );
        TESTR_FILT(getter) = tester;
        CHANGED_BAG(getter);

    }
    return TESTR_FILT(getter);
}


/****************************************************************************
**
*F  NewFilter( <name>, <narg>, <nams>, <hdlr> )  . . . . .  make a new filter
*/
Obj DoTestFilter (
    Obj                 self,
    Obj                 obj )
{
    return True;
}

Obj NewTesterFilter (
    Obj                 getter )
{
    Obj                 tester;
    tester = ReturnTrueFilter;
    return tester;
}


Obj DoSetFilter (
    Obj                 self,
    Obj                 obj,
    Obj                 val )
{
    Int                 flag1;
    Obj                 kind;
    Obj                 flags;
    
    /* get the flag for the getter                                         */
    flag1 = INT_INTOBJ( FLAG1_FILT( self ) );
    
    /* get the kind of the object and its flags                            */
    kind  = TYPE_OBJ( obj );
    flags = FLAGS_TYPE( kind );
    
    /* return the value of the feature                                     */
    if ( flag1 <= LEN_FLAGS( flags ) ) {
        if ( val != ELM_FLAGS( flags, flag1 ) ) {
            ErrorReturnVoid(
                "value feature is already set the other way",
                0L, 0L,
                "you can 'return;' and ignore it" );
        }
    }
    else {
        if ( val != False ) {
            ErrorReturnVoid(
                "value feature is already set the other way",
                0L, 0L,
                "you can 'return;' and ignore it" );
        }
    }

    /* return 'void'                                                       */
    return 0;
}

static Obj StringFilterSetter;
static Obj ArglistObjVal;

Obj NewSetterFilter (
    Obj                 getter )
{
    Obj                 setter;

    setter = NewOperation( StringFilterSetter, 2, ArglistObjVal,
                           DoSetFilter );
    FLAG1_FILT(setter)  = FLAG1_FILT(getter);
    FLAG2_FILT(setter)  = INTOBJ_INT( 0 );
    CHANGED_BAG(setter);

    return setter;
}


Obj DoFilter (
    Obj                 self,
    Obj                 obj )
{
    Obj                 val;
    Int                 flag1;
    Obj                 kind;
    Obj                 flags;
    
    /* get the flag for the getter                                         */
    flag1 = INT_INTOBJ( FLAG1_FILT( self ) );
    
    /* get the kind of the object and its flags                            */
    kind  = TYPE_OBJ( obj );
    flags = FLAGS_TYPE( kind );
    
    /* return the value of the feature                                     */
    if ( flag1 <= LEN_FLAGS( flags ) ) {
        val = ELM_FLAGS( flags, flag1 );
    }
    else {
        val = False;
    }
    
    /* return the value                                                    */
    return val;
}


Obj NewFilter (
    Obj                 name,
    Int                 narg,
    Obj                 nams,
    ObjFunc             hdlr )
{
    Obj                 getter;
    Obj                 setter;
    Obj                 tester;
    Int                 flag1;
    Obj                 flags;
    
    flag1 = ++CountFlags;

    getter = NewOperation( name, 1L, nams, (hdlr ? hdlr : DoFilter) );
    FLAG1_FILT(getter)  = INTOBJ_INT( flag1 );
    FLAG2_FILT(getter)  = INTOBJ_INT( 0 );
    NEW_FLAGS( flags, flag1 );
    SET_LEN_FLAGS( flags, flag1 );
    SET_ELM_FLAGS( flags, flag1, True );
    FLAGS_FILT(getter)  = flags;
    CHANGED_BAG(getter);

    setter = NewSetterFilter( getter );
    SETTR_FILT(getter)  = setter;
    CHANGED_BAG(getter);
    
    tester = NewTesterFilter( getter );
    TESTR_FILT(getter)  = tester;
    CHANGED_BAG(getter);

    return getter;    
}


/****************************************************************************
**
*F  NewFilterC( <name>, <narg>, <nams>, <hdlr> )  . . . . . make a new filter 
*/
Obj NewFilterC (
    const Char *        name,
    Int                 narg,
    const Char *        nams,
    ObjFunc             hdlr )
{
    Obj                 getter;
    Obj                 setter;
    Obj                 tester;
    Int                 flag1;
    Obj                 flags;
    
    flag1 = ++CountFlags;

    getter = NewOperationC( name, 1L, nams, (hdlr ? hdlr : DoFilter) );
    FLAG1_FILT(getter)  = INTOBJ_INT( flag1 );
    FLAG2_FILT(getter)  = INTOBJ_INT( 0 );
    NEW_FLAGS( flags, flag1 );
    SET_LEN_FLAGS( flags, flag1 );
    SET_ELM_FLAGS( flags, flag1, True );
    FLAGS_FILT(getter)  = flags;
    CHANGED_BAG(getter);

    setter = NewSetterFilter( getter );
    SETTR_FILT(getter)  = setter;
    CHANGED_BAG(getter);
    
    tester = NewTesterFilter( getter );
    TESTR_FILT(getter)  = tester;
    CHANGED_BAG(getter);

    return getter;    
}


/****************************************************************************
**
*F  NewAndFilter( <filt1>, <filt2> ) . . . . . make a new concatenated filter
*/
Obj DoAndFilter (
    Obj                 self,
    Obj                 obj )
{
    Obj                 val;
    Obj                 op;
    
    /* call the first 'and'-ed function                                    */
    op = FLAG1_FILT( self );
    val = CALL_1ARGS( op, obj );
    if ( val != True )  return False;
    
    /* call the second 'and'-ed function                                   */
    op = FLAG2_FILT( self );
    val = CALL_1ARGS( op, obj );
    if ( val != True )  return False;
    
    /* return 'true'                                                       */
    return True;
}

static Obj StringAndFilter;
static Obj ArglistObj;

Obj NewAndFilter (
    Obj                 oper1,
    Obj                 oper2 )
{
    Obj                 getter;
    Obj                 flags;

    if ( oper1 == ReturnTrueFilter && oper2 == ReturnTrueFilter )
        return ReturnTrueFilter;

    getter = NewFunctionT( T_FUNCTION, SIZE_OPER, StringAndFilter, 1,
                           ArglistObj, DoAndFilter );
    FLAG1_FILT(getter)  = oper1;
    FLAG2_FILT(getter)  = oper2;
    flags = FuncAND_FLAGS( 0, FLAGS_FILT(oper1), FLAGS_FILT(oper2) );
    FLAGS_FILT(getter)  = flags;
    SETTR_FILT(getter)  = INTOBJ_INT(0xBADBABE);
    TESTR_FILT(getter)  = INTOBJ_INT(0xBADBABE);
    CHANGED_BAG(getter);

    return getter;
}

Obj FuncIS_AND_FILTER( Obj self, Obj filt )
{
  return (IS_FUNC(filt) && HDLR_FUNC(filt, 1) == DoAndFilter) ? True : False;
}


/****************************************************************************
**

*V  ReturnTrueFilter . . . . . . . . . . . . . . . . the return 'true' filter
*/
Obj ReturnTrueFilter;


/****************************************************************************
**
*F  NewReturnTrueFilter() . . . . . . . . . . create a new return true filter
*/
Obj DoTestReturnTrueFilter (
    Obj                 self,
    Obj                 obj )
{
    return True;
}

Obj TesterReturnTrueFilter (
    Obj                 getter )
{
    return getter;
}

Obj DoSetReturnTrueFilter (
    Obj                 self,
    Obj                 obj,
    Obj                 val )
{
    if ( val != True ) {
         ErrorReturnVoid( "you cannot set this flag to 'false'",
             0L, 0L,
             "you can 'return;' and ignore it" );
    }
    return 0;
}

Obj SetterReturnTrueFilter (
    Obj                 getter )
{
    Obj                 setter;

    setter = NewFunctionCT( T_FUNCTION, SIZE_OPER,
        "<<setter-true-filter>>", 2L, "obj, val",
        DoSetReturnTrueFilter );
    FLAG1_FILT(setter)  = INTOBJ_INT( 0 );
    FLAG2_FILT(setter)  = INTOBJ_INT( 0 );
    CHANGED_BAG(setter);

    return setter;    
}

Obj DoReturnTrueFilter (
    Obj                 self,
    Obj                 obj )
{
    return True;
}

Obj NewReturnTrueFilter ( void )
{
    Obj                 getter;
    Obj                 setter;
    Obj                 tester;
    Obj                 flags;

    getter = NewFunctionCT( T_FUNCTION, SIZE_OPER,
        "ReturnTrueFilter", 1L, "obj",
        DoReturnTrueFilter );
    FLAG1_FILT(getter)  = INTOBJ_INT( 0 );
    FLAG2_FILT(getter)  = INTOBJ_INT( 0 );
    NEW_FLAGS( flags, 0 );
    SET_LEN_FLAGS( flags, 0 );
    FLAGS_FILT(getter)  = flags;
    CHANGED_BAG(getter);

    setter = SetterReturnTrueFilter( getter );
    SETTR_FILT(getter)  = setter;
    CHANGED_BAG(getter);

    tester = TesterReturnTrueFilter( getter );
    TESTR_FILT(getter)  = tester;
    CHANGED_BAG(getter);
        
    return getter;
}


/****************************************************************************
**

*F * * * * * * * * * * * * * GAP filter functions * * * * * * * * * * * * * *
*/


/****************************************************************************
**

*F  FuncNEW_FILTER( <self>, <name> )  . . . . . . . . . . . . .  new filter
*/
Obj FuncNEW_FILTER (
    Obj                 self,
    Obj                 name )
{
    /* check the argument                                                  */
    if ( ! IsStringConv(name) ) {
        ErrorQuit("usage: NewFilter( <name> )",0L,0L);
        return 0;
    }

    /* make the new operation                                              */
    return NewFilter( name, 1L, (Obj)0, (ObjFunc)0 );
}


/****************************************************************************
**

*F  FuncFLAG1_FILTER( <self>, <oper> )  . . . . . . . . . . . .  `FLAG1_FILT'
*/
Obj FuncFLAG1_FILTER (
    Obj                 self,
    Obj                 oper )
{
    Obj                 flag1;

    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    flag1 = FLAG1_FILT( oper );
    if ( flag1 == 0 )
        flag1 = INTOBJ_INT(0);
    return flag1;
}


/****************************************************************************
**
*F  FuncSET_FLAG1_FILTER( <self>, <oper>, <flag1> ) . . . .  set `FLAG1_FILT'
*/
Obj FuncSET_FLAG1_FILTER (
    Obj                 self,
    Obj                 oper,
    Obj                 flag1 )
{
    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    FLAG1_FILT( oper ) = flag1;
    return 0;
}


/****************************************************************************
**
*F  FuncFLAG2_FILTER( <self>, <oper> )  . . . . . . . . . . . .  `FLAG2_FILT'
*/
Obj FuncFLAG2_FILTER (
    Obj                 self,
    Obj                 oper )
{
    Obj                 flag2;

    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    flag2 = FLAG2_FILT( oper );
    if ( flag2 == 0 )
        flag2 = INTOBJ_INT(0);
    return flag2;
}


/****************************************************************************
**
*F  FuncSET_FLAG2_FILTER( <self>, <oper>, <flag2> ) . . . .  set `FLAG2_FILT'
*/
Obj FuncSET_FLAG2_FILTER (
    Obj                 self,
    Obj                 oper,
    Obj                 flag2 )
{
    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    FLAG2_FILT( oper ) = flag2;
    return 0;
}


/****************************************************************************
**
*F  FuncFLAGS_FILTER( <self>, <oper> )  . . . . . . . . . . . .  `FLAGS_FILT'
*/
Obj FuncFLAGS_FILTER (
    Obj                 self,
    Obj                 oper )
{
    Obj                 flags;

    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    flags = FLAGS_FILT( oper );
    if ( flags == 0 )
        flags = False;
    return flags;
}


/****************************************************************************
**
*F  FuncSET_FLAGS_FILTER( <self>, <oper>, <flags> ) . . . .  set `FLAGS_FILT'
*/
Obj FuncSET_FLAGS_FILTER (
    Obj                 self,
    Obj                 oper,
    Obj                 flags )
{
    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    FLAGS_FILT( oper ) = flags;
    return 0;
}


/****************************************************************************
**

*F  FuncSETTER_FILTER( <self>, <oper> ) . . . . . . . . .  setter of a filter
*/
Obj FuncSETTER_FILTER (
    Obj                 self,
    Obj                 oper )
{
    Obj                 setter;

    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    setter = SetterFilter( oper );
    if ( setter == 0 )  setter = False;
    return setter;
}


/****************************************************************************
**
*F  FuncSET_SETTER_FILTER( <self>, <oper>, <setter> )  set setter of a filter
*/
Obj FuncSET_SETTER_FILTER (
    Obj                 self,
    Obj                 oper,
    Obj                 setter )
{
    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    SETTR_FILT( oper ) = setter;
    return 0;
}


/****************************************************************************
**
*F  FuncTESTER_FILTER( <self>, <oper> ) . . . . . . . . .  tester of a filter
*/
Obj FuncTESTER_FILTER (
    Obj                 self,
    Obj                 oper )
{
    Obj                 tester;

    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    tester = TesterFilter( oper );
    if ( tester == 0 )  tester = False;
    return tester;
}


/****************************************************************************
**
*F  FuncSET_TESTER_FILTER( <self>, <oper>, <tester> )  set tester of a filter
*/
Obj FuncSET_TESTER_FILTER (
    Obj                 self,
    Obj                 oper,
    Obj                 tester )
{
    if ( ! IS_OPERATION(oper) ) {
        ErrorQuit("<oper> must be an operation",0L,0L);
        return 0;
    }
    if ( SIZE_OBJ(oper) != SIZE_OPER ) {
        ResizeBag( oper, SIZE_OPER );
    }
    TESTR_FILT( oper ) = tester;
    return 0;
}


/****************************************************************************
**

*F * * * * * * * * * *  internal operation functions  * * * * * * * * * * * *
*/


/****************************************************************************
**
*F  CallHandleMethodNotFound( <oper>, <nargs>, <args>, <verbose>, <constructor>)
**
*/

static UInt RNamOperation;
static UInt RNamArguments;
static UInt RNamIsVerbose;
static UInt RNamIsConstructor;
static UInt RNamPrecedence;
static Obj HandleMethodNotFound;

Obj CallHandleMethodNotFound( Obj oper,
                              Int nargs,
                              Obj *args,
                              UInt verbose,
                              UInt constructor,
                              Obj precedence)
{
  Obj r;
  Obj arglist;
  UInt i;
  r = NEW_PREC(5);
  if (RNamOperation == 0)
    {
      /* we can't do this in initialization because opers
         is initialized BEFORE records */
      RNamIsConstructor = RNamName("isConstructor");
      RNamIsVerbose = RNamName("isVerbose");
      RNamOperation = RNamName("Operation");
      RNamArguments = RNamName("Arguments");
      RNamPrecedence = RNamName("Precedence");
    }
  AssPRec(r,RNamOperation,oper);
  arglist = NEW_PLIST(nargs ? T_PLIST_DENSE+IMMUTABLE:
                      T_PLIST_EMPTY+IMMUTABLE, nargs);
  SET_LEN_PLIST(arglist,nargs);
  for (i = 0; i < nargs; i++)
    SET_ELM_PLIST( arglist, i+1, args[i]);
  AssPRec(r,RNamArguments,arglist);
  AssPRec(r,RNamIsVerbose,verbose ? True : False);
  AssPRec(r,RNamIsConstructor,constructor ? True : False);
  AssPRec(r,RNamPrecedence,precedence);
  SortPRecRNam(r,0);
  return CALL_1ARGS(HandleMethodNotFound, r);
}

/****************************************************************************
**
*F  FuncCompactTypeIDs( <self> ) . . . garbage collect the type IDs
**
*/

static Int NextTypeID;
Obj IsType;

static void FixTypeIDs( Bag b ) {
  if ( (TNUM_OBJ( b )  == T_POSOBJ) &&
       (DoFilter(IsType, b ) == True ))
    {
      ID_TYPE(b) = INTOBJ_INT(NextTypeID);
      NextTypeID++;
    } 
}


Obj FuncCompactTypeIDs( Obj self )
{
  NextTypeID = -(1L << NR_SMALL_INT_BITS);
  CallbackForAllBags( FixTypeIDs );
  return INTOBJ_INT(NextTypeID);
}

/****************************************************************************
**
*F  DoOperation( <name> ) . . . . . . . . . . . . . . .  make a new operation
*/
UInt CacheIndex;

Obj Method0Args;
Obj NextMethod0Args;
Obj Method1Args;
Obj NextMethod1Args;
Obj Method2Args;
Obj NextMethod2Args;
Obj Method3Args;
Obj NextMethod3Args;
Obj Method4Args;
Obj NextMethod4Args;
Obj Method5Args;
Obj NextMethod5Args;
Obj Method6Args;
Obj NextMethod6Args;
Obj MethodXArgs;
Obj NextMethodXArgs;

Obj VMethod0Args;
Obj NextVMethod0Args;
Obj VMethod1Args;
Obj NextVMethod1Args;
Obj VMethod2Args;
Obj NextVMethod2Args;
Obj VMethod3Args;
Obj NextVMethod3Args;
Obj VMethod4Args;
Obj NextVMethod4Args;
Obj VMethod5Args;
Obj NextVMethod5Args;
Obj VMethod6Args;
Obj NextVMethod6Args;
Obj VMethodXArgs;
Obj NextVMethodXArgs;




/****************************************************************************
**
**  DoOperation0Args( <oper> )
*/
Int OperationHit;
Int OperationMiss;
Int OperationNext;


/* This avoids a function call in the case of external objects with a
   stored type */

static inline Obj TYPE_OBJ_FEO (
                Obj obj
        )
{
  if ( TNUM_OBJ(obj) >= FIRST_EXTERNAL_TNUM &&
       TNUM_OBJ(obj) <= T_DATOBJ) /* avoid T_WPOBJ */
    return TYPE_ANYOBJ(obj);
  else
    return TYPE_OBJ(obj);
}

static inline Obj CacheOper (
    Obj                 oper,
    UInt                i )
{
    Obj                 cache;
    UInt len;
    cache = CACHE_OPER( oper, i );
    if ( cache == 0 ) {
      len = (i < 7 ? CACHE_SIZE * (i+2) : CACHE_SIZE * (1+2)) ;
        cache = NEW_PLIST( T_PLIST, len);
        SET_LEN_PLIST(cache, len ); 
        CACHE_OPER( oper, i ) = cache;
        CHANGED_BAG( oper );
    }
    return cache;
}

Obj DoOperation0Args (
    Obj                 oper )
{
    Obj                 res;
    Obj *               cache;
    Obj                 method;
    Int                 i;
    Obj                prec;

    /* try to find an applicable method in the cache                       */
    cache = 1+ADDR_OBJ( CacheOper( oper, 0 ) );
    prec = INTOBJ_INT(-1);

    do {
      /* The next line depends on the implementation of INTOBJS */
      prec = (Obj)(((Int)prec) +4);
      method = 0;

      /* Up to CACHE_SIZE methods might be in the cache */
      if (prec < INTOBJ_INT(CACHE_SIZE))
        {
          for (i = 0;  i < 2*CACHE_SIZE; i+= 2) {
            if (  cache[i] != 0  && cache[i+1] == prec) {
              method = cache[i];
#ifdef COUNT_OPERS
              OperationHit++;
#endif
              break;
            }
          }
        }
      
      /* otherwise try to find one in the list of methods                    */
      if (!method)
        {
          if (prec == INTOBJ_INT(0))
            method = CALL_1ARGS( Method0Args, oper );
          else
            method = CALL_2ARGS( NextMethod0Args, oper, prec );

          /* If there was no method found, then pass the information needed for
             the error reporting. This function rarely returns */
          
          while (method == Fail)
            method = CallHandleMethodNotFound( oper, 0, (Obj *) 0, 0, 0, prec);
          
          /* update the cache */
          if (method && prec < INTOBJ_INT(CACHE_SIZE))
            {
              cache = 1+ADDR_OBJ( CACHE_OPER( oper, 0 ) );
              cache[2*CacheIndex] = method;
              cache[2*CacheIndex+1] = prec;
              CacheIndex = (CacheIndex + 1) % CACHE_SIZE;
              CHANGED_BAG(CACHE_OPER(oper,0));
            }
#ifdef COUNT_OPERS
          OperationMiss++;
#endif
        }
      if ( !method )  {
        ErrorQuit( "no method returned", 0L, 0L );
      }
      
      /* call this method                                                    */
      res = CALL_0ARGS( method );
    }
    while (res == TRY_NEXT_METHOD );

    /* return the result                                                   */
    return res;
}


/****************************************************************************
**
**  DoOperation1Args( <oper>, <a1> )
*/
Obj DoOperation1Args (
    Obj                 oper,
    Obj                 arg1 )
{
    Obj                 res;
    Obj                 kind1;
    Obj                 id1;
    Obj *               cache;
    Obj                 method;
    Int                 i;
    Obj                 prec;

    /* get the kinds of the arguments                                      */
    kind1 = TYPE_OBJ_FEO( arg1 );  id1 = ID_TYPE( kind1 );

    /* try to find an applicable method in the cache                       */
    cache = 1+ADDR_OBJ( CacheOper( oper, 1 ) );
    prec = INTOBJ_INT(-1);

    do {
      /* The next line depends on the implementation of INTOBJS */
      prec = (Obj)(((Int)prec) +4);
      method = 0;

      /* Up to CACHE_SIZE methods might be in the cache */
      if (prec < INTOBJ_INT(CACHE_SIZE))
        {
          for (i = 0;  i < 3*CACHE_SIZE; i+= 3) {
            if (  cache[i+1] == prec && cache[i+2] == id1 ) {
              method = cache[i];
#ifdef COUNT_OPERS
              OperationHit++;
#endif
              break;
            }
          }
        }
      
      /* otherwise try to find one in the list of methods                    */
      if (!method)
        {
          if (prec == INTOBJ_INT(0))
            method = CALL_2ARGS( Method1Args, oper, kind1 );
          else
            method = CALL_3ARGS( NextMethod1Args, oper, prec, kind1 );
          
          /* If there was no method found, then pass the information needed for
             the error reporting. This function rarely returns */
          if (method == Fail)
          {
            Obj args[1];
            args[0] = arg1;
            while (method == Fail)
              method = CallHandleMethodNotFound( oper, 1, (Obj *) args, 0, 0, prec);
          }
          /* update the cache */
          if (method && prec < INTOBJ_INT(CACHE_SIZE))
            {
              cache = 1+ADDR_OBJ( CACHE_OPER( oper, 1 ) );
              cache[3*CacheIndex] = method;
              cache[3*CacheIndex+1] = prec;
              cache[3*CacheIndex+2] = id1;
              CacheIndex = (CacheIndex + 1) % CACHE_SIZE;
              CHANGED_BAG(CACHE_OPER(oper,1));
            }
#ifdef COUNT_OPERS
          OperationMiss++;
#endif
        }
      if ( !method )  {
        ErrorQuit( "no method returned", 0L, 0L );
      }
      
      /* call this method                                                    */
      res = CALL_1ARGS( method, arg1 );
    }
    while (res == TRY_NEXT_METHOD );

    /* return the result                                                   */
    return res;
}


/****************************************************************************
**
**  DoOperation2Args( <oper>, <a1>, <a2> )
*/
Obj DoOperation2Args (
    Obj              …