/**************************************************************************** ** *F SetList( <list> ) . . . . . . . . . . . . . . . . make a set from a list ** ** 'SetList' returns a new set that contains the elements of <list>. Note ** that 'SetList' returns a new plain list even if <list> was already a set. ** ** 'SetList' makes a copy of the list <list>, removes the holes, sorts the ** copy and finally removes duplicates, which must appear next to each other ** now that the copy is sorted. */ Obj SetList ( Obj list ) { Obj set; /* result set */ Int lenSet; /* length of <set> */ Int lenList; /* length of <list> */ Obj elm; /* one element of the list */ UInt status; /* the elements are mutable */ UInt i; /* loop variable */ /* make a dense copy */ lenList = LEN_LIST( list ); set = NEW_PLIST( T_PLIST, lenList ); lenSet = 0; for ( i = 1; i <= lenList; i++ ) { elm = ELMV0_LIST( list, i ); if ( elm != 0 ) { lenSet += 1; SET_ELM_PLIST( set, lenSet, elm ); CHANGED_BAG(set); /* in case elm had to be made, not just extracted */ } } SET_LEN_PLIST( set, lenSet ); SET_FILT_LIST( set, FN_IS_DENSE ); /* sort the set (which is a dense plain list) */ SortDensePlist( set ); /* remove duplicates */ status = RemoveDupsDensePlist( set ); /* adjust flags where possible */ switch(status) { case 0: break; case 1: SET_FILT_LIST(set, FN_IS_NHOMOG); SET_FILT_LIST(set, FN_IS_SSORT); break; case 2: SET_FILT_LIST( set, FN_IS_HOMOG ); SET_FILT_LIST( set, FN_IS_SSORT ); break; } /* return set */ return set; }
Obj CopyContainerToGap(const T& v) { size_t s = v.size(); if(s == 0) { Obj l = NEW_PLIST(T_PLIST_EMPTY, 0); SET_LEN_PLIST(l, 0); CHANGED_BAG(l); return l; } Obj list = NEW_PLIST(T_PLIST_DENSE, s); SET_LEN_PLIST(list, s); CHANGED_BAG(list); GAP_maker<typename T::value_type> m; int pos = 1; for(typename T::const_iterator it = v.begin(); it != v.end(); ++it, ++pos) { SET_ELM_PLIST(list, pos, m(*it)); CHANGED_BAG(list); } return list; }
/* 'InitLibrary' sets up gvars, rnams, functions */ static Int InitLibrary ( StructInitInfo * module ) { Obj func1; Obj body1; /* Complete Copy/Fopy registration */ UpdateCopyFopyInfo(); FileName = MakeImmString( "assert.g" ); PostRestore(module); /* create all the functions defined in this module */ func1 = NewFunction(NameFunc[1],0,0,HdlrFunc1); SET_ENVI_FUNC( func1, STATE(CurrLVars) ); CHANGED_BAG( STATE(CurrLVars) ); body1 = NewBag( T_BODY, sizeof(BodyHeader)); SET_BODY_FUNC( func1, body1 ); CHANGED_BAG( func1 ); CALL_0ARGS( func1 ); /* return success */ return 0; }
Obj FuncWeakPointerObj( Obj self, Obj list ) { Obj wp; Int i; Int len; len = LEN_LIST(list); wp = (Obj) NewBag(T_WPOBJ, (len+1)*sizeof(Obj)); STORE_LEN_WPOBJ(wp,len); for (i = 1; i <= len ; i++) { ELM_WPOBJ(wp,i) = ELM0_LIST(list,i); CHANGED_BAG(wp); /* this must be here in case list is in fact an object and causes a GC in the element access method */ } return wp; }
void AddIn( Obj list, Obj w, Obj e ) { Int g, i; Obj r, s, t; for( i = 1; i < LEN_PLIST(w); i += 2 ) { g = INT_INTOBJ( ELM_PLIST( w, i ) ); s = ELM_PLIST( w, i+1 ); C_PROD_FIA( t, s, e ); /* t = s * e */ r = ELM_PLIST( list, g ); C_SUM_FIA( s, t, r ); /* s = r + s * e */ SET_ELM_PLIST( list, g, s ); CHANGED_BAG( list ); } }
/* handler for function 1 */ static Obj HdlrFunc1 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Bag oldFrame; /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); /* runtest := function ( ) Print( AssertionLevel( ), "\n" ); Assert( 1, false, "fail-A" ); Assert( 1, false ); Assert( 0, true, "fail-B" ); Assert( 0, true ); SetAssertionLevel( 2 ); Print( AssertionLevel( ), "\n" ); Assert( 3, false, "fail-C" ); Assert( 3, false ); Assert( 2, true, "fail-D" ); Assert( 2, true ); Assert( 2, false, "pass!\n" ); Print( "end of function\n" ); return; end; */ t_1 = NewFunction( NameFunc[2], 0, 0, HdlrFunc2 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 1); SET_ENDLINE_BODY(t_2, 18); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_runtest, t_1 ); /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
/**************************************************************************** ** *F CleanObjWPObjCopy( <obj> ) . . . . . . . . . . . . . . clean WPobj copy */ void CleanObjWPObjCopy ( Obj obj ) { UInt i; /* loop variable */ Obj elm; /* subobject */ /* remove the forwarding pointer */ ADDR_OBJ(obj)[0] = ELM_PLIST( ADDR_OBJ(obj)[0], 1 ); CHANGED_BAG(obj); /* now it is cleaned */ RetypeBag( obj, TNUM_OBJ(obj) - COPYING ); /* clean the subvalues */ for ( i = 1; i < SIZE_OBJ(obj)/sizeof(Obj); i++ ) { elm = ADDR_OBJ(obj)[i]; if ( elm != 0 && !IS_WEAK_DEAD_BAG(elm)) CLEAN_OBJ( elm ); } }
/* handler for function 1 */ static Obj HdlrFunc1 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Bag oldFrame; /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); /* runtest := function ( ) Print( 1, "\n" ); Print( "abc", "\n" ); Print( (1,2)(5,6), "\n" ); Print( [ 1, "abc" ], "\n" ); Print( Group( (1,2,3) ), "\n" ); return; end; */ t_1 = NewFunction( NameFunc[2], 0, 0, HdlrFunc2 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 1); SET_ENDLINE_BODY(t_2, 7); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_runtest, t_1 ); /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
/* handler for function 1 */ static Obj HdlrFunc1 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Bag oldFrame; OLD_BRK_CURR_STAT /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); REM_BRK_CURR_STAT(); SET_BRK_CURR_STAT(0); /* runtest := function ( ) return 1 + 2; end; */ t_1 = NewFunction( NameFunc[2], 0, 0, HdlrFunc2 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 1); SET_ENDLINE_BODY(t_2, 3); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_runtest, t_1 ); /* return; */ RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
/**************************************************************************** ** *F FuncADD_SET( <self>, <set>, <obj> ) . . . . . . . add an element to a set ** ** 'FuncADD_SET' implements the internal function 'AddSet'. ** ** 'AddSet( <set>, <obj> )' ** ** 'AddSet' adds <obj>, which may be an object of an arbitrary type, to the ** set <set>, which must be a proper set. If <obj> is already an element of ** the set <set>, then <set> is not changed. Otherwise <obj> is inserted at ** the correct position such that <set> is again a set afterwards. ** ** 'AddSet' does not return anything, it is only called for the side effect ** of changing <set>. */ Obj FuncADD_SET ( Obj self, Obj set, Obj obj ) { UInt len; /* logical length of the list */ UInt pos; /* position */ UInt isCyc; /* True if the set being added to consists of kernel cyclotomics */ UInt notpos; /* position of an original element (not the new one) */ UInt wasHom; UInt wasNHom; UInt wasTab; /* check the arguments */ while ( ! IsSet(set) || ! IS_MUTABLE_OBJ(set) ) { set = ErrorReturnObj( "AddSet: <set> must be a mutable proper set (not a %s)", (Int)TNAM_OBJ(set), 0L, "you can replace <set> via 'return <set>;'" ); } len = LEN_LIST(set); /* perform the binary search to find the position */ pos = PositionSortedDensePlist( set, obj ); /* add the element to the set if it is not already there */ if ( len < pos || ! EQ( ELM_PLIST(set,pos), obj ) ) { GROW_PLIST( set, len+1 ); SET_LEN_PLIST( set, len+1 ); { Obj *ptr; ptr = PTR_BAG(set); memmove((void *)(ptr + pos+1),(void*)(ptr+pos),(size_t)(sizeof(Obj)*(len+1-pos))); #if 0 for ( i = len+1; pos < i; i-- ) { *ptr = *(ptr-1); ptr--; */ /* SET_ELM_PLIST( set, i, ELM_PLIST(set,i-1) ); */ } #endif } SET_ELM_PLIST( set, pos, obj ); CHANGED_BAG( set ); /* fix up the type of the result */ if ( HAS_FILT_LIST( set, FN_IS_SSORT ) ) { isCyc = (TNUM_OBJ(set) == T_PLIST_CYC_SSORT); wasHom = HAS_FILT_LIST(set, FN_IS_HOMOG); wasTab = HAS_FILT_LIST(set, FN_IS_TABLE); wasNHom = HAS_FILT_LIST(set, FN_IS_NHOMOG); CLEAR_FILTS_LIST(set); /* the result of addset is always dense */ SET_FILT_LIST( set, FN_IS_DENSE ); /* if the object we added was not mutable then we might be able to conclude more */ if ( ! IS_MUTABLE_OBJ(obj) ) { /* a one element list is automatically homogenous and ssorted */ if (len == 0 ) { if (TNUM_OBJ(obj) <= T_CYC) RetypeBag( set, T_PLIST_CYC_SSORT); else { SET_FILT_LIST( set, FN_IS_HOMOG ); SET_FILT_LIST( set, FN_IS_SSORT ); if (IS_HOMOG_LIST(obj)) /* it might be a table */ SET_FILT_LIST( set, FN_IS_TABLE ); } } else { /* Now determine homogeneity */ if (isCyc) if (TNUM_OBJ(obj) <= T_CYC) RetypeBag( set, T_PLIST_CYC_SSORT); else { RESET_FILT_LIST(set, FN_IS_HOMOG); SET_FILT_LIST(set, FN_IS_NHOMOG); } else if (wasHom) { if (!SyInitializing) { notpos = (pos == 1) ? 2 : 1; if (FAMILY_OBJ(ELM_PLIST(set,notpos)) == FAMILY_OBJ(obj)) { SET_FILT_LIST(set, FN_IS_HOMOG); if (wasTab) { if (IS_HOMOG_LIST( obj )) SET_FILT_LIST(set, FN_IS_TABLE); } } else SET_FILT_LIST(set, FN_IS_NHOMOG); } } else if (wasNHom) SET_FILT_LIST(set, FN_IS_NHOMOG); } } SET_FILT_LIST( set, FN_IS_SSORT ); } else { CLEAR_FILTS_LIST(set); SET_FILT_LIST( set, FN_IS_DENSE ); } }
Obj SCTableProductHandler ( Obj self, Obj table, Obj list1, Obj list2 ) { Obj res; /* result list */ Obj row; /* one row of sc table */ Obj zero; /* zero from sc table */ Obj ai, aj; /* elements from list1 */ Obj bi, bj; /* elements from list2 */ Obj c, c1, c2; /* products of above */ Int dim; /* dimension of vectorspace */ Int i, j; /* loop variables */ /* check the arguments a bit */ if ( ! IS_SMALL_LIST(table) ) { table = ErrorReturnObj( "SCTableProduct: <table> must be a list (not a %s)", (Int)TNAM_OBJ(table), 0L, "you can replace <table> via 'return <table>;'" ); return SCTableProductHandler( self, table, list1, list2 ); } dim = LEN_LIST(table) - 2; if ( dim <= 0 ) { table = ErrorReturnObj( "SCTableProduct: <table> must be a list with at least 3 elements", 0L, 0L, "you can replace <table> via 'return <table>;'" ); return SCTableProductHandler( self, table, list1, list2 ); } zero = ELM_LIST( table, dim+2 ); if ( ! IS_SMALL_LIST(list1) || LEN_LIST(list1) != dim ) { list1 = ErrorReturnObj( "SCTableProduct: <list1> must be a list with %d elements", dim, 0L, "you can replace <list1> via 'return <list1>;'" ); return SCTableProductHandler( self, table, list1, list2 ); } if ( ! IS_SMALL_LIST(list2) || LEN_LIST(list2) != dim ) { list2 = ErrorReturnObj( "SCTableProduct: <list2> must be a list with %d elements", dim, 0L, "you can replace <list2> via 'return <list2>;'" ); return SCTableProductHandler( self, table, list1, list2 ); } /* make the result list */ res = NEW_PLIST( T_PLIST, dim ); SET_LEN_PLIST( res, dim ); for ( i = 1; i <= dim; i++ ) { SET_ELM_PLIST( res, i, zero ); } CHANGED_BAG( res ); /* general case */ if ( EQ( ELM_LIST( table, dim+1 ), INTOBJ_INT(0) ) ) { for ( i = 1; i <= dim; i++ ) { ai = ELM_LIST( list1, i ); if ( EQ( ai, zero ) ) continue; row = ELM_LIST( table, i ); for ( j = 1; j <= dim; j++ ) { bj = ELM_LIST( list2, j ); if ( EQ( bj, zero ) ) continue; c = PROD( ai, bj ); if ( ! EQ( c, zero ) ) { SCTableProdAdd( res, c, ELM_LIST( row, j ), dim ); } } } } /* commutative case */ else if ( EQ( ELM_LIST( table, dim+1 ), INTOBJ_INT(1) ) ) { for ( i = 1; i <= dim; i++ ) { ai = ELM_LIST( list1, i ); bi = ELM_LIST( list2, i ); if ( EQ( ai, zero ) && EQ( bi, zero ) ) continue; row = ELM_LIST( table, i ); c = PROD( ai, bi ); if ( ! EQ( c, zero ) ) { SCTableProdAdd( res, c, ELM_LIST( row, i ), dim ); } for ( j = i+1; j <= dim; j++ ) { bj = ELM_LIST( list2, j ); aj = ELM_LIST( list1, j ); if ( EQ( aj, zero ) && EQ( bj, zero ) ) continue; c1 = PROD( ai, bj ); c2 = PROD( aj, bi ); c = SUM( c1, c2 ); if ( ! EQ( c, zero ) ) { SCTableProdAdd( res, c, ELM_LIST( row, j ), dim ); } } } } /* anticommutative case */ else if ( EQ( ELM_LIST( table, dim+1 ), INTOBJ_INT(-1) ) ) { for ( i = 1; i <= dim; i++ ) { ai = ELM_LIST( list1, i ); bi = ELM_LIST( list2, i ); if ( EQ( ai, zero ) && EQ( bi, zero ) ) continue; row = ELM_LIST( table, i ); for ( j = i+1; j <= dim; j++ ) { bj = ELM_LIST( list2, j ); aj = ELM_LIST( list1, j ); if ( EQ( aj, zero ) && EQ( bj, zero ) ) continue; c1 = PROD( ai, bj ); c2 = PROD( aj, bi ); c = DIFF( c1, c2 ); if ( ! EQ( c, zero ) ) { SCTableProdAdd( res, c, ELM_LIST( row, j ), dim ); } } } } /* return the result */ return res; }
/* handler for function 1 */ static Obj HdlrFunc1 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Bag oldFrame; /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); /* f1 := function ( a ) Print( "f1:", a, "\n" ); return; end; */ t_1 = NewFunction( NameFunc[2], 1, 0, HdlrFunc2 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 1); SET_ENDLINE_BODY(t_2, 3); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_f1, t_1 ); /* f2 := function ( a, b ) Print( "f2:", a, ":", b, "\n" ); return; end; */ t_1 = NewFunction( NameFunc[3], 2, 0, HdlrFunc3 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 5); SET_ENDLINE_BODY(t_2, 7); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_f2, t_1 ); /* f3 := function ( a... ) Print( "f3:", a, "\n" ); return; end; */ t_1 = NewFunction( NameFunc[4], -1, 0, HdlrFunc4 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 9); SET_ENDLINE_BODY(t_2, 11); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_f3, t_1 ); /* f4 := function ( a, b... ) Print( "f4:", a, ":", b, "\n" ); return; end; */ t_1 = NewFunction( NameFunc[5], -2, 0, HdlrFunc5 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 13); SET_ENDLINE_BODY(t_2, 15); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_f4, t_1 ); /* runtest := function ( ) f1( 2 ); f2( 2, 3 ); f3( ); f3( 2 ); f3( 2, 3, 4 ); f4( 1 ); f4( 1, 2 ); f4( 1, 2, 3 ); return; end; */ t_1 = NewFunction( NameFunc[6], 0, 0, HdlrFunc6 ); SET_ENVI_FUNC( t_1, STATE(CurrLVars) ); t_2 = NewBag( T_BODY, sizeof(BodyHeader) ); SET_STARTLINE_BODY(t_2, 17); SET_ENDLINE_BODY(t_2, 26); SET_FILENAME_BODY(t_2, FileName); SET_BODY_FUNC(t_1, t_2); CHANGED_BAG( STATE(CurrLVars) ); AssGVar( G_runtest, t_1 ); /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
UInt RNamName ( const Char * name ) { Obj rnam; /* record name (as imm intobj) */ UInt pos; /* hash position */ UInt len; /* length of name */ Char namx [1024]; /* temporary copy of <name> */ Obj string; /* temporary string object <name> */ Obj table; /* temporary copy of <HashRNam> */ Obj rnam2; /* one element of <table> */ const Char * p; /* loop variable */ UInt i; /* loop variable */ /* start looking in the table at the following hash position */ pos = 0; len = 0; for ( p = name; *p != '\0'; p++ ) { pos = 65599 * pos + *p; len++; } pos = (pos % SizeRNam) + 1; if(len >= 1023) { // Note: We can't pass 'name' here, as it might get moved by garbage collection ErrorQuit("Record names must consist of less than 1023 characters", 0, 0); } /* look through the table until we find a free slot or the global */ while ( (rnam = ELM_PLIST( HashRNam, pos )) != 0 && strncmp( NAME_RNAM( INT_INTOBJ(rnam) ), name, 1023 ) ) { pos = (pos % SizeRNam) + 1; } /* if we did not find the global variable, make a new one and enter it */ /* (copy the name first, to avoid a stale pointer in case of a GC) */ if ( rnam == 0 ) { CountRNam++; rnam = INTOBJ_INT(CountRNam); SET_ELM_PLIST( HashRNam, pos, rnam ); strlcpy( namx, name, sizeof(namx) ); C_NEW_STRING_DYN(string, namx); GROW_PLIST( NamesRNam, CountRNam ); SET_LEN_PLIST( NamesRNam, CountRNam ); SET_ELM_PLIST( NamesRNam, CountRNam, string ); CHANGED_BAG( NamesRNam ); } /* if the table is too crowed, make a larger one, rehash the names */ if ( SizeRNam < 3 * CountRNam / 2 ) { table = HashRNam; SizeRNam = 2 * SizeRNam + 1; HashRNam = NEW_PLIST( T_PLIST, SizeRNam ); SET_LEN_PLIST( HashRNam, SizeRNam ); for ( i = 1; i <= (SizeRNam-1)/2; i++ ) { rnam2 = ELM_PLIST( table, i ); if ( rnam2 == 0 ) continue; pos = 0; for ( p = NAME_RNAM( INT_INTOBJ(rnam2) ); *p != '\0'; p++ ) { pos = 65599 * pos + *p; } pos = (pos % SizeRNam) + 1; while ( ELM_PLIST( HashRNam, pos ) != 0 ) { pos = (pos % SizeRNam) + 1; } SET_ELM_PLIST( HashRNam, pos, rnam2 ); } } /* return the record name */ return INT_INTOBJ(rnam); }
Obj CollectPolycyc ( Obj pcp, Obj list, Obj word ) { Int ngens = INT_INTOBJ( CONST_ADDR_OBJ(pcp)[ PC_NUMBER_OF_GENERATORS ] ); Obj commute = CONST_ADDR_OBJ(pcp)[ PC_COMMUTE ]; Obj gens = CONST_ADDR_OBJ(pcp)[ PC_GENERATORS ]; Obj igens = CONST_ADDR_OBJ(pcp)[ PC_INVERSES ]; Obj pow = CONST_ADDR_OBJ(pcp)[ PC_POWERS ]; Obj ipow = CONST_ADDR_OBJ(pcp)[ PC_INVERSEPOWERS ]; Obj exp = CONST_ADDR_OBJ(pcp)[ PC_EXPONENTS ]; Obj wst = CFTLState()->WORD_STACK; Obj west = CFTLState()->WORD_EXPONENT_STACK; Obj sst = CFTLState()->SYLLABLE_STACK; Obj est = CFTLState()->EXPONENT_STACK; Obj conj=0, iconj=0; /*QQ initialize to please compiler */ Int st; Int g, syl, h, hh; Obj e, ee, ge, mge, we, s, t; Obj w, x = (Obj)0, y = (Obj)0; if( LEN_PLIST(word) == 0 ) return (Obj)0; if( LEN_PLIST(list) < ngens ) { ErrorQuit( "vector too short", 0L, 0L ); return (Obj)0; } if( LEN_PLIST(word) % 2 != 0 ) { ErrorQuit( "Length of word odd", 0L, 0L ); return (Obj)0; } st = 0; PUSH_STACK( word, INTOBJ_INT(1) ); while( st > 0 ) { w = ELM_PLIST( wst, st ); syl = INT_INTOBJ( ELM_PLIST( sst, st ) ); g = INT_INTOBJ( ELM_PLIST( w, syl ) ); if( st > 1 && syl==1 && g == GET_COMMUTE(g) ) { /* Collect word^exponent in one go. */ e = ELM_PLIST( west, st ); /* Add in. */ AddIn( list, w, e ); /* Reduce. */ for( h = g; h <= ngens; h++ ) { s = ELM_PLIST( list, h ); if( IS_INT_ZERO( s ) ) continue; y = (Obj)0; if( (e = GET_EXPONENT( h )) != (Obj)0 ) { if( !LtInt( s, e ) ) { t = ModInt( s, e ); SET_ELM_PLIST( list, h, t ); CHANGED_BAG( list ); if( (y = GET_POWER( h )) ) e = QuoInt( s, e ); } else if( LtInt( s, INTOBJ_INT(0) ) ) { t = ModInt( s, e ); SET_ELM_PLIST( list, h, t ); CHANGED_BAG( list ); if( (y = GET_IPOWER( h )) ) { e = QuoInt( s, e ); if( !IS_INT_ZERO( t ) ) e = DiffInt( e, INTOBJ_INT(1) ); e = AInvInt(e); } } } if( y != (Obj)0 ) AddIn( list, y, e ); } st--; } else { if( g == GET_COMMUTE( g ) ) { s = ELM_PLIST( list, g ); t = ELM_PLIST( est, st ); C_SUM_FIA( ge, s, t ); SET_ELM_PLIST( est, st, INTOBJ_INT(0) ); } else { /* Assume that the top of the exponent stack is non-zero. */ e = ELM_PLIST( est, st ); if( LtInt( INTOBJ_INT(0), e ) ) { C_DIFF_FIA( ee, e, INTOBJ_INT(1) ); e = ee; SET_ELM_PLIST( est, st, e ); CHANGED_BAG( est ); conj = CONST_ADDR_OBJ(pcp)[PC_CONJUGATES]; iconj = CONST_ADDR_OBJ(pcp)[PC_INVERSECONJUGATES]; C_SUM_FIA( ge, ELM_PLIST( list, g ), INTOBJ_INT(1) ); } else { C_SUM_FIA( ee, e, INTOBJ_INT(1) ); e = ee; SET_ELM_PLIST( est, st, e ); CHANGED_BAG( est ); conj = CONST_ADDR_OBJ(pcp)[PC_CONJUGATESINVERSE]; iconj = CONST_ADDR_OBJ(pcp)[PC_INVERSECONJUGATESINVERSE]; C_DIFF_FIA( ge, ELM_PLIST( list, g ), INTOBJ_INT(1) ); } } SET_ELM_PLIST( list, g, ge ); CHANGED_BAG( list ); /* Reduce the exponent. We delay putting the power onto the stack until all the conjugates are on the stack. The power is stored in y, its exponent in ge. */ y = (Obj)0; if( (e = GET_EXPONENT( g )) ) { if( !LtInt( ge, e ) ) { mge = ModInt( ge, e ); SET_ELM_PLIST( list, g, mge ); CHANGED_BAG( list ); if( (y = GET_POWER( g )) ) ge = QuoInt( ge, e ); } else if( LtInt( ge, INTOBJ_INT(0) ) ) { mge = ModInt( ge, e ); SET_ELM_PLIST( list, g, mge ); CHANGED_BAG( list ); if( (y = GET_IPOWER( g )) ) { ge = QuoInt( ge, e ); if( !IS_INT_ZERO( mge ) ) ge = DiffInt( ge, INTOBJ_INT(1) ); ge = AInvInt(ge); } } } hh = h = GET_COMMUTE( g ); /* Find the place where we start to collect. */ for( ; h > g; h-- ) { e = ELM_PLIST( list, h ); if( !IS_INT_ZERO(e) ) { if( LtInt( INTOBJ_INT(0), e ) ) { if( GET_CONJ( h, g ) ) break; } else { if( GET_ICONJ( h, g ) ) break; } } } /* Put those onto the stack, if necessary. */ if( h > g || y != (Obj)0 ) for( ; hh > h; hh-- ) { e = ELM_PLIST( list, hh ); if( !IS_INT_ZERO(e) ) { SET_ELM_PLIST( list, hh, INTOBJ_INT(0) ); if( LtInt( INTOBJ_INT(0), e ) ) { x = ELM_PLIST( gens, hh ); } else { x = ELM_PLIST( igens, hh ); C_PROD_FIA( ee, e, INTOBJ_INT(-1) ); e = ee; } PUSH_STACK( x, e ); } } for( ; h > g; h-- ) { e = ELM_PLIST( list, h ); if( !IS_INT_ZERO(e) ) { SET_ELM_PLIST( list, h, INTOBJ_INT(0) ); x = (Obj)0; if( LtInt( INTOBJ_INT(0), e ) ) x = GET_CONJ( h, g ); else x = GET_ICONJ( h, g ); if( x == (Obj)0 ) { if( LtInt( INTOBJ_INT(0), e ) ) x = ELM_PLIST( gens, h ); else x = ELM_PLIST( igens, h ); } if( LtInt( e, INTOBJ_INT(0) ) ) { C_PROD_FIA( ee, e, INTOBJ_INT(-1) ); e = ee; } PUSH_STACK( x, e ); } } if( y != (Obj)0 ) PUSH_STACK( y, ge ); } while( st > 0 && IS_INT_ZERO( ELM_PLIST( est, st ) ) ) { w = ELM_PLIST( wst, st ); syl = INT_INTOBJ( ELM_PLIST( sst, st ) ) + 2; if( syl > LEN_PLIST( w ) ) { we = DiffInt( ELM_PLIST( west, st ), INTOBJ_INT(1) ); if( EqInt( we, INTOBJ_INT(0) ) ) { st--; } else { SET_ELM_PLIST( west, st, we ); SET_ELM_PLIST( sst, st, INTOBJ_INT(1) ); SET_ELM_PLIST( est, st, ELM_PLIST( w, 2 ) ); CHANGED_BAG( west ); CHANGED_BAG( est ); } } else { SET_ELM_PLIST( sst, st, INTOBJ_INT(syl) ); SET_ELM_PLIST( est, st, ELM_PLIST( w, syl+1 )); CHANGED_BAG( est ); } } } return (Obj)0; }
/* handler for function 2 */ static Obj HdlrFunc2 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Obj t_3 = 0; Obj t_4 = 0; Obj t_5 = 0; Obj t_6 = 0; Bag oldFrame; /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); /* Print( 1, "\n" ); */ t_1 = GF_Print; t_2 = MakeString( "\n" ); CALL_2ARGS( t_1, INTOBJ_INT(1), t_2 ); /* Print( "abc", "\n" ); */ t_1 = GF_Print; t_2 = MakeString( "abc" ); t_3 = MakeString( "\n" ); CALL_2ARGS( t_1, t_2, t_3 ); /* Print( (1,2)(5,6), "\n" ); */ t_1 = GF_Print; t_2 = IdentityPerm; t_4 = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( t_4, 2 ); t_3 = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( t_3, 2 ); SET_ELM_PLIST( t_4, 1, t_3 ); CHANGED_BAG( t_4 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(1) ); CHANGED_BAG( t_3 ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) ); CHANGED_BAG( t_3 ); t_3 = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( t_3, 2 ); SET_ELM_PLIST( t_4, 2, t_3 ); CHANGED_BAG( t_4 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(5) ); CHANGED_BAG( t_3 ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(6) ); CHANGED_BAG( t_3 ); t_2 = Array2Perm( t_4 ); t_3 = MakeString( "\n" ); CALL_2ARGS( t_1, t_2, t_3 ); /* Print( [ 1, "abc" ], "\n" ); */ t_1 = GF_Print; t_2 = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( t_2, 2 ); SET_ELM_PLIST( t_2, 1, INTOBJ_INT(1) ); t_3 = MakeString( "abc" ); SET_ELM_PLIST( t_2, 2, t_3 ); CHANGED_BAG( t_2 ); t_3 = MakeString( "\n" ); CALL_2ARGS( t_1, t_2, t_3 ); /* Print( Group( (1,2,3) ), "\n" ); */ t_1 = GF_Print; t_3 = GF_Group; t_4 = IdentityPerm; t_6 = NEW_PLIST( T_PLIST, 1 ); SET_LEN_PLIST( t_6, 1 ); t_5 = NEW_PLIST( T_PLIST, 3 ); SET_LEN_PLIST( t_5, 3 ); SET_ELM_PLIST( t_6, 1, t_5 ); CHANGED_BAG( t_6 ); SET_ELM_PLIST( t_5, 1, INTOBJ_INT(1) ); CHANGED_BAG( t_5 ); SET_ELM_PLIST( t_5, 2, INTOBJ_INT(2) ); CHANGED_BAG( t_5 ); SET_ELM_PLIST( t_5, 3, INTOBJ_INT(3) ); CHANGED_BAG( t_5 ); t_4 = Array2Perm( t_6 ); t_2 = CALL_1ARGS( t_3, t_4 ); CHECK_FUNC_RESULT( t_2 ) t_3 = MakeString( "\n" ); CALL_2ARGS( t_1, t_2, t_3 ); /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
Obj boyers_planarity_check(Obj digraph, int flags, bool krtwsk) { DIGRAPHS_ASSERT(flags == EMBEDFLAGS_PLANAR || flags == EMBEDFLAGS_OUTERPLANAR || flags == EMBEDFLAGS_SEARCHFORK23 || flags == EMBEDFLAGS_SEARCHFORK4 || flags == EMBEDFLAGS_SEARCHFORK33); if (CALL_1ARGS(IsDigraph, digraph) != True) { ErrorQuit("Digraphs: boyers_planarity_check (C): the 1st argument must be " "a digraph, not %s", (Int) TNAM_OBJ(digraph), 0L); } Obj const out = FuncOutNeighbours(0L, digraph); if (FuncIS_ANTISYMMETRIC_DIGRAPH(0L, out) != True) { ErrorQuit("Digraphs: boyers_planarity_check (C): the 1st argument must be " "an antisymmetric digraph", 0L, 0L); } Int V = DigraphNrVertices(digraph); Int E = DigraphNrEdges(digraph); if (V > INT_MAX) { // Cannot currently test this, it might always be true, depending on the // definition of Int. ErrorQuit("Digraphs: boyers_planarity_check (C): the maximum number of " "nodes is %d, found %d", INT_MAX, V); return 0L; } else if (2 * E > INT_MAX) { // Cannot currently test this ErrorQuit("Digraphs: boyers_planarity_check (C): the maximum number of " "edges is %d, found %d", INT_MAX / 2, E); return 0L; } graphP theGraph = gp_New(); switch (flags) { case EMBEDFLAGS_SEARCHFORK33: gp_AttachK33Search(theGraph); break; case EMBEDFLAGS_SEARCHFORK23: gp_AttachK23Search(theGraph); break; case EMBEDFLAGS_SEARCHFORK4: gp_AttachK4Search(theGraph); break; } if (gp_InitGraph(theGraph, V) != OK) { gp_Free(&theGraph); ErrorQuit("Digraphs: boyers_planarity_check (C): invalid number of nodes!", 0L, 0L); return 0L; } else if (gp_EnsureArcCapacity(theGraph, 2 * E) != OK) { gp_Free(&theGraph); ErrorQuit("Digraphs: boyers_planarity_check (C): invalid number of edges!", 0L, 0L); return 0L; } int status; for (Int v = 1; v <= LEN_LIST(out); ++v) { DIGRAPHS_ASSERT(gp_VertexInRange(theGraph, v)); gp_SetVertexIndex(theGraph, v, v); Obj const out_v = ELM_LIST(out, v); for (Int w = 1; w <= LEN_LIST(out_v); ++w) { DIGRAPHS_ASSERT(gp_VertexInRange(theGraph, w)); int u = INT_INTOBJ(ELM_LIST(out_v, w)); if (v != u) { status = gp_AddEdge(theGraph, v, 0, u, 0); if (status != OK) { // Cannot currently test this, i.e. it shouldn't happen (and // currently there is no example where it does happen) gp_Free(&theGraph); ErrorQuit("Digraphs: boyers_planarity_check (C): internal error, " "can't add edge from %d to %d", (Int) v, (Int) u); return 0L; } } } } status = gp_Embed(theGraph, flags); if (status == NOTOK) { // Cannot currently test this, i.e. it shouldn't happen (and // currently there is no example where it does happen) gp_Free(&theGraph); ErrorQuit("Digraphs: boyers_planarity_check (C): status is not ok", 0L, 0L); } Obj res; if (krtwsk) { // Kuratowski subgraph isolator gp_SortVertices(theGraph); Obj subgraph = NEW_PLIST_IMM(T_PLIST, theGraph->N); SET_LEN_PLIST(subgraph, theGraph->N); for (int i = 1; i <= theGraph->N; ++i) { int nr = 0; Obj list = NEW_PLIST_IMM(T_PLIST, 0); int j = theGraph->V[i].link[1]; while (j) { if (CALL_3ARGS(IsDigraphEdge, digraph, INTOBJ_INT((Int) i), INTOBJ_INT((Int) theGraph->E[j].neighbor)) == True) { AssPlist(list, ++nr, INTOBJ_INT(theGraph->E[j].neighbor)); } j = theGraph->E[j].link[1]; } if (nr == 0) { RetypeBag(list, T_PLIST_EMPTY); } SET_ELM_PLIST(subgraph, i, list); CHANGED_BAG(subgraph); } res = NEW_PLIST_IMM(T_PLIST, 2); SET_LEN_PLIST(res, 2); SET_ELM_PLIST(res, 1, (status == NONEMBEDDABLE ? False : True)); SET_ELM_PLIST(res, 2, subgraph); CHANGED_BAG(res); } else if (status == NONEMBEDDABLE) { res = False; } else { res = True; } gp_Free(&theGraph); return res; }
/* 'InitLibrary' sets up gvars, rnams, functions */ static Int InitLibrary ( StructInitInfo * module ) { Obj func1; Obj body1; /* Complete Copy/Fopy registration */ UpdateCopyFopyInfo(); /* global variables used in handlers */ G_IS__FUNCTION = GVarName( "IS_FUNCTION" ); G_ADD__LIST = GVarName( "ADD_LIST" ); G_Error = GVarName( "Error" ); G_IS__IDENTICAL__OBJ = GVarName( "IS_IDENTICAL_OBJ" ); G_AND__FLAGS = GVarName( "AND_FLAGS" ); G_HASH__FLAGS = GVarName( "HASH_FLAGS" ); G_WITH__HIDDEN__IMPS__FLAGS = GVarName( "WITH_HIDDEN_IMPS_FLAGS" ); G_IS__SUBSET__FLAGS = GVarName( "IS_SUBSET_FLAGS" ); G_TRUES__FLAGS = GVarName( "TRUES_FLAGS" ); G_FLAGS__FILTER = GVarName( "FLAGS_FILTER" ); G_WITH__HIDDEN__IMPS__FLAGS__COUNT = GVarName( "WITH_HIDDEN_IMPS_FLAGS_COUNT" ); G_WITH__HIDDEN__IMPS__FLAGS__CACHE__MISS = GVarName( "WITH_HIDDEN_IMPS_FLAGS_CACHE_MISS" ); G_WITH__HIDDEN__IMPS__FLAGS__CACHE__HIT = GVarName( "WITH_HIDDEN_IMPS_FLAGS_CACHE_HIT" ); G_IMPLICATIONS = GVarName( "IMPLICATIONS" ); G_WITH__IMPS__FLAGS__CACHE = GVarName( "WITH_IMPS_FLAGS_CACHE" ); G_WITH__IMPS__FLAGS__COUNT = GVarName( "WITH_IMPS_FLAGS_COUNT" ); G_WITH__IMPS__FLAGS__CACHE__HIT = GVarName( "WITH_IMPS_FLAGS_CACHE_HIT" ); G_WITH__IMPS__FLAGS__CACHE__MISS = GVarName( "WITH_IMPS_FLAGS_CACHE_MISS" ); G_CLEAR__IMP__CACHE = GVarName( "CLEAR_IMP_CACHE" ); G_BIND__GLOBAL = GVarName( "BIND_GLOBAL" ); G_UNBIND__GLOBAL = GVarName( "UNBIND_GLOBAL" ); G_RANK__FILTERS = GVarName( "RANK_FILTERS" ); G_RankFilter = GVarName( "RankFilter" ); G_RANK__FILTER = GVarName( "RANK_FILTER" ); G_RANK__FILTER__LIST__CURRENT = GVarName( "RANK_FILTER_LIST_CURRENT" ); G_RANK__FILTER__LIST = GVarName( "RANK_FILTER_LIST" ); G_RANK__FILTER__COUNT = GVarName( "RANK_FILTER_COUNT" ); /* record names used in handlers */ /* information for the functions */ C_NEW_STRING( DefaultName, 14, "local function" ); C_NEW_STRING( FileName, 21, "GAPROOT/lib/filter1.g" ); NameFunc[1] = DefaultName; NamsFunc[1] = 0; NargFunc[1] = 0; NameFunc[2] = DefaultName; NamsFunc[2] = 0; NargFunc[2] = 0; NameFunc[3] = DefaultName; NamsFunc[3] = 0; NargFunc[3] = 1; NameFunc[4] = DefaultName; NamsFunc[4] = 0; NargFunc[4] = 1; NameFunc[5] = DefaultName; NamsFunc[5] = 0; NargFunc[5] = 1; NameFunc[6] = DefaultName; NamsFunc[6] = 0; NargFunc[6] = 1; /* create all the functions defined in this module */ func1 = NewFunction(NameFunc[1],NargFunc[1],NamsFunc[1],HdlrFunc1); ENVI_FUNC( func1 ) = TLS(CurrLVars); CHANGED_BAG( TLS(CurrLVars) ); body1 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj)); BODY_FUNC( func1 ) = body1; CHANGED_BAG( func1 ); CALL_0ARGS( func1 ); /* return success */ return 0; }
/* handler for function 1 */ static Obj HdlrFunc1 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Obj t_3 = 0; Obj t_4 = 0; Bag oldFrame; OLD_BRK_CURR_STAT /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); REM_BRK_CURR_STAT(); SET_BRK_CURR_STAT(0); /* WITH_HIDDEN_IMPS_FLAGS_COUNT := 0; */ AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__COUNT, INTOBJ_INT(0) ); /* WITH_HIDDEN_IMPS_FLAGS_CACHE_MISS := 0; */ AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__CACHE__MISS, INTOBJ_INT(0) ); /* WITH_HIDDEN_IMPS_FLAGS_CACHE_HIT := 0; */ AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__CACHE__HIT, INTOBJ_INT(0) ); /* IMPLICATIONS := [ ]; */ t_1 = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( t_1, 0 ); AssGVar( G_IMPLICATIONS, t_1 ); /* WITH_IMPS_FLAGS_CACHE := [ ]; */ t_1 = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( t_1, 0 ); AssGVar( G_WITH__IMPS__FLAGS__CACHE, t_1 ); /* WITH_IMPS_FLAGS_COUNT := 0; */ AssGVar( G_WITH__IMPS__FLAGS__COUNT, INTOBJ_INT(0) ); /* WITH_IMPS_FLAGS_CACHE_HIT := 0; */ AssGVar( G_WITH__IMPS__FLAGS__CACHE__HIT, INTOBJ_INT(0) ); /* WITH_IMPS_FLAGS_CACHE_MISS := 0; */ AssGVar( G_WITH__IMPS__FLAGS__CACHE__MISS, INTOBJ_INT(0) ); /* Unbind( CLEAR_IMP_CACHE ); */ AssGVar( G_CLEAR__IMP__CACHE, 0 ); /* BIND_GLOBAL( "CLEAR_IMP_CACHE", function ( ) WITH_IMPS_FLAGS_CACHE := [ ]; return; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 15, "CLEAR_IMP_CACHE" ); t_3 = NewFunction( NameFunc[2], NargFunc[2], NamsFunc[2], HdlrFunc2 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(39); ENDLINE_BODY(t_4) = INTOBJ_INT(41); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* BIND_GLOBAL( "WITH_IMPS_FLAGS", function ( flags ) local with, changed, imp, hash, hash2, i; hash := HASH_FLAGS( flags ) mod 11001; for i in [ 0 .. 3 ] do hash2 := 2 * ((hash + 31 * i) mod 11001) + 1; if IsBound( WITH_IMPS_FLAGS_CACHE[hash2] ) then if IS_IDENTICAL_OBJ( WITH_IMPS_FLAGS_CACHE[hash2], flags ) then WITH_IMPS_FLAGS_CACHE_HIT := WITH_IMPS_FLAGS_CACHE_HIT + 1; return WITH_IMPS_FLAGS_CACHE[hash2 + 1]; fi; else break; fi; od; if i = 3 then WITH_IMPS_FLAGS_COUNT := (WITH_IMPS_FLAGS_COUNT + 1) mod 4; i := WITH_IMPS_FLAGS_COUNT; hash2 := 2 * ((hash + 31 * i) mod 11001) + 1; fi; WITH_IMPS_FLAGS_CACHE_MISS := WITH_IMPS_FLAGS_CACHE_MISS + 1; with := flags; changed := true; while changed do changed := false; for imp in IMPLICATIONS do if IS_SUBSET_FLAGS( with, imp[2] ) and not IS_SUBSET_FLAGS( with, imp[1] ) then with := AND_FLAGS( with, imp[1] ); changed := true; fi; od; od; WITH_IMPS_FLAGS_CACHE[hash2] := flags; WITH_IMPS_FLAGS_CACHE[hash2 + 1] := with; return with; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 15, "WITH_IMPS_FLAGS" ); t_3 = NewFunction( NameFunc[3], NargFunc[3], NamsFunc[3], HdlrFunc3 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(44); ENDLINE_BODY(t_4) = INTOBJ_INT(83); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* UNBIND_GLOBAL( "RANK_FILTER" ); */ t_1 = GF_UNBIND__GLOBAL; C_NEW_STRING( t_2, 11, "RANK_FILTER" ); CALL_1ARGS( t_1, t_2 ); /* BIND_GLOBAL( "RANK_FILTER", function ( filter ) local rank, flags, i; rank := 0; if IS_FUNCTION( filter ) then flags := FLAGS_FILTER( filter ); else flags := filter; fi; for i in TRUES_FLAGS( WITH_HIDDEN_IMPS_FLAGS( flags ) ) do if IsBound( RANK_FILTERS[i] ) then rank := rank + RANK_FILTERS[i]; else rank := rank + 1; fi; od; return rank; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 11, "RANK_FILTER" ); t_3 = NewFunction( NameFunc[4], NargFunc[4], NamsFunc[4], HdlrFunc4 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(97); ENDLINE_BODY(t_4) = INTOBJ_INT(114); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* RankFilter := RANK_FILTER; */ t_1 = GC_RANK__FILTER; CHECK_BOUND( t_1, "RANK_FILTER" ) AssGVar( G_RankFilter, t_1 ); /* UNBIND_GLOBAL( "RANK_FILTER_STORE" ); */ t_1 = GF_UNBIND__GLOBAL; C_NEW_STRING( t_2, 17, "RANK_FILTER_STORE" ); CALL_1ARGS( t_1, t_2 ); /* BIND_GLOBAL( "RANK_FILTER_STORE", function ( filter ) local hash, rank, flags; if IS_FUNCTION( filter ) then flags := FLAGS_FILTER( filter ); else flags := filter; fi; hash := HASH_FLAGS( flags ); rank := RANK_FILTER( flags ); ADD_LIST( RANK_FILTER_LIST_CURRENT, hash ); ADD_LIST( RANK_FILTER_LIST_CURRENT, rank ); return rank; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 17, "RANK_FILTER_STORE" ); t_3 = NewFunction( NameFunc[5], NargFunc[5], NamsFunc[5], HdlrFunc5 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(119); ENDLINE_BODY(t_4) = INTOBJ_INT(133); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* UNBIND_GLOBAL( "RANK_FILTER_COMPLETION" ); */ t_1 = GF_UNBIND__GLOBAL; C_NEW_STRING( t_2, 22, "RANK_FILTER_COMPLETION" ); CALL_1ARGS( t_1, t_2 ); /* BIND_GLOBAL( "RANK_FILTER_COMPLETION", function ( filter ) local hash, flags; if IS_FUNCTION( filter ) then flags := FLAGS_FILTER( filter ); else flags := filter; fi; hash := HASH_FLAGS( flags ); if hash <> RANK_FILTER_LIST[RANK_FILTER_COUNT] then Error( "corrupted completion file" ); fi; RANK_FILTER_COUNT := RANK_FILTER_COUNT + 2; return RANK_FILTER_LIST[RANK_FILTER_COUNT - 1]; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 22, "RANK_FILTER_COMPLETION" ); t_3 = NewFunction( NameFunc[6], NargFunc[6], NamsFunc[6], HdlrFunc6 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(136); ENDLINE_BODY(t_4) = INTOBJ_INT(151); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* return; */ RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
/* handler for function 4 */ static Obj HdlrFunc4 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Obj t_3 = 0; Obj t_4 = 0; Obj t_5 = 0; Bag oldFrame; /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); /* BreakOnError := false; */ t_1 = False; AssGVar( G_BreakOnError, t_1 ); /* CALL_WITH_CATCH( range2, [ 1, 2 ^ 80 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range2; CHECK_BOUND( t_2, "range2" ) t_3 = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( t_3, 2 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(1) ); t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(80) ); SET_ELM_PLIST( t_3, 2, t_4 ); CHANGED_BAG( t_3 ); CALL_2ARGS( t_1, t_2, t_3 ); /* CALL_WITH_CATCH( range2, [ - 2 ^ 80, 0 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range2; CHECK_BOUND( t_2, "range2" ) t_3 = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( t_3, 2 ); t_5 = POW( INTOBJ_INT(2), INTOBJ_INT(80) ); C_AINV_FIA( t_4, t_5 ) SET_ELM_PLIST( t_3, 1, t_4 ); CHANGED_BAG( t_3 ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(0) ); CALL_2ARGS( t_1, t_2, t_3 ); /* CALL_WITH_CATCH( range3, [ 1, 2, 2 ^ 80 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range3; CHECK_BOUND( t_2, "range3" ) t_3 = NEW_PLIST( T_PLIST, 3 ); SET_LEN_PLIST( t_3, 3 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(1) ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) ); t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(80) ); SET_ELM_PLIST( t_3, 3, t_4 ); CHANGED_BAG( t_3 ); CALL_2ARGS( t_1, t_2, t_3 ); /* CALL_WITH_CATCH( range3, [ - 2 ^ 80, 0, 1 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range3; CHECK_BOUND( t_2, "range3" ) t_3 = NEW_PLIST( T_PLIST, 3 ); SET_LEN_PLIST( t_3, 3 ); t_5 = POW( INTOBJ_INT(2), INTOBJ_INT(80) ); C_AINV_FIA( t_4, t_5 ) SET_ELM_PLIST( t_3, 1, t_4 ); CHANGED_BAG( t_3 ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(0) ); SET_ELM_PLIST( t_3, 3, INTOBJ_INT(1) ); CALL_2ARGS( t_1, t_2, t_3 ); /* CALL_WITH_CATCH( range3, [ 0, 2 ^ 80, 2 ^ 81 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range3; CHECK_BOUND( t_2, "range3" ) t_3 = NEW_PLIST( T_PLIST, 3 ); SET_LEN_PLIST( t_3, 3 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(0) ); t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(80) ); SET_ELM_PLIST( t_3, 2, t_4 ); CHANGED_BAG( t_3 ); t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(81) ); SET_ELM_PLIST( t_3, 3, t_4 ); CHANGED_BAG( t_3 ); CALL_2ARGS( t_1, t_2, t_3 ); /* Display( [ 1, 2 .. 2 ] ); */ t_1 = GF_Display; t_2 = Range3Check( INTOBJ_INT(1), INTOBJ_INT(2), INTOBJ_INT(2) ); CALL_1ARGS( t_1, t_2 ); /* CALL_WITH_CATCH( range3, [ 2, 2, 2 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range3; CHECK_BOUND( t_2, "range3" ) t_3 = NEW_PLIST( T_PLIST, 3 ); SET_LEN_PLIST( t_3, 3 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(2) ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) ); SET_ELM_PLIST( t_3, 3, INTOBJ_INT(2) ); CALL_2ARGS( t_1, t_2, t_3 ); /* Display( [ 2, 4 .. 6 ] ); */ t_1 = GF_Display; t_2 = Range3Check( INTOBJ_INT(2), INTOBJ_INT(4), INTOBJ_INT(6) ); CALL_1ARGS( t_1, t_2 ); /* CALL_WITH_CATCH( range3, [ 2, 4, 7 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range3; CHECK_BOUND( t_2, "range3" ) t_3 = NEW_PLIST( T_PLIST, 3 ); SET_LEN_PLIST( t_3, 3 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(2) ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(4) ); SET_ELM_PLIST( t_3, 3, INTOBJ_INT(7) ); CALL_2ARGS( t_1, t_2, t_3 ); /* Display( [ 2, 4 .. 2 ] ); */ t_1 = GF_Display; t_2 = Range3Check( INTOBJ_INT(2), INTOBJ_INT(4), INTOBJ_INT(2) ); CALL_1ARGS( t_1, t_2 ); /* Display( [ 2, 4 .. 0 ] ); */ t_1 = GF_Display; t_2 = Range3Check( INTOBJ_INT(2), INTOBJ_INT(4), INTOBJ_INT(0) ); CALL_1ARGS( t_1, t_2 ); /* CALL_WITH_CATCH( range3, [ 4, 2, 1 ] ); */ t_1 = GF_CALL__WITH__CATCH; t_2 = GC_range3; CHECK_BOUND( t_2, "range3" ) t_3 = NEW_PLIST( T_PLIST, 3 ); SET_LEN_PLIST( t_3, 3 ); SET_ELM_PLIST( t_3, 1, INTOBJ_INT(4) ); SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) ); SET_ELM_PLIST( t_3, 3, INTOBJ_INT(1) ); CALL_2ARGS( t_1, t_2, t_3 ); /* Display( [ 4, 2 .. 0 ] ); */ t_1 = GF_Display; t_2 = Range3Check( INTOBJ_INT(4), INTOBJ_INT(2), INTOBJ_INT(0) ); CALL_1ARGS( t_1, t_2 ); /* Display( [ 4, 2 .. 8 ] ); */ t_1 = GF_Display; t_2 = Range3Check( INTOBJ_INT(4), INTOBJ_INT(2), INTOBJ_INT(8) ); CALL_1ARGS( t_1, t_2 ); /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; }