/**************************************************************************** ** *W gap.c GAP source Frank Celler *W & Martin Schoenert ** *H @(#)$Id: gap.c,v 4.116 1998/02/04 11:27:22 ahulpke Exp $ ** *Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany *Y (C) 1998 School Math and Comp. Sci., University of St. Andrews, Scotland ** ** This file contains the various read-eval-print loops and related stuff. */ #include #include /* jmp_buf, setjmp, longjmp */ #include /* memcpy */ #include "system.h" /* system dependent part */ const char * Revision_gap_c = "@(#)$Id: gap.c,v 4.116 1998/02/04 11:27:22 ahulpke Exp $"; extern char * In; #include "gasman.h" /* garbage collector */ #include "objects.h" /* objects */ #include "scanner.h" /* scanner */ #define INCLUDE_DECLARATION_PART #include "gap.h" /* error handling, initialisation */ #undef INCLUDE_DECLARATION_PART #include "read.h" /* reader */ #include "gvars.h" /* global variables */ #include "calls.h" /* generic call mechanism */ #include "opers.h" /* generic operations */ #include "ariths.h" /* basic arithmetic */ #include "integer.h" /* integers */ #include "rational.h" /* rationals */ #include "cyclotom.h" /* cyclotomics */ #include "finfield.h" /* finite fields and ff elements */ #include "bool.h" /* booleans */ #include "permutat.h" /* permutations */ #include "records.h" /* generic records */ #include "precord.h" /* plain records */ #include "lists.h" /* generic lists */ #include "listoper.h" /* operations for generic lists */ #include "listfunc.h" /* functions for generic lists */ #include "plist.h" /* plain lists */ #include "set.h" /* plain sets */ #include "vector.h" /* functions for plain vectors */ #include "blister.h" /* boolean lists */ #include "range.h" /* ranges */ #include "string.h" /* strings */ #include "vecgf2.h" /* functions for GF2 vectors */ #include "objfgelm.h" /* objects of free groups */ #include "objpcgel.h" /* objects of polycyclic groups */ #include "objscoll.h" /* single collector */ #include "objcftl.h" /* from the left collect */ #include "dt.h" /* deep thought */ #include "dteval.h" /* deep though evaluation */ #include "sctable.h" /* structure constant table */ #include "costab.h" /* coset table */ #include "tietze.h" /* tietze helper functions */ #include "code.h" /* coder */ #include "vars.h" /* variables */ #include "exprs.h" /* expressions */ #include "stats.h" /* statements */ #include "funcs.h" /* functions */ #include "intrprtr.h" /* interpreter */ #include "compiler.h" /* compiler */ #include "compstat.h" /* statically linked modules */ #include "saveload.h" /* saving and loading */ #include "streams.h" /* streams package */ #include "sysfiles.h" /* file input/output */ #include "weakptr.h" /* weak pointers */ #ifdef GAPMPI #include "gapmpi.h" /* GAPMPI */ #endif /**************************************************************************** ** *V Last . . . . . . . . . . . . . . . . . . . . . . global variable 'last' ** ** 'Last', 'Last2', and 'Last3' are the global variables 'last', 'last2', ** and 'last3', which are automatically assigned the result values in the ** main read-eval-print loop. */ UInt Last; /**************************************************************************** ** *V Last2 . . . . . . . . . . . . . . . . . . . . . . global variable 'last2' */ UInt Last2; /**************************************************************************** ** *V Last3 . . . . . . . . . . . . . . . . . . . . . . global variable 'last3' */ UInt Last3; /**************************************************************************** ** *V Time . . . . . . . . . . . . . . . . . . . . . . global variable 'time' ** ** 'Time' is the global variable 'time', which is automatically assigned the ** time the last command took. */ UInt Time; /**************************************************************************** ** *V BreakOnError . . . . . . . . . . . . . . . . . . . . . . enter breakloop */ UInt BreakOnError = 1; /**************************************************************************** ** *F ViewObjHandler . . . . . . . . . handler to view object and catch errors */ UInt ViewObjGVar; void ViewObjHandler ( Obj obj ) { volatile Obj func; jmp_buf readJmpError; /* get the function */ func = ValAutoGVar(ViewObjGVar); /* if non-zero use this function, otherwise use `PrintObj' */ memcpy( readJmpError, ReadJmpError, sizeof(jmp_buf) ); if ( ! READ_ERROR() ) { if ( func == 0 || TNUM_OBJ(func) != T_FUNCTION ) { PrintObj(obj); } else { CALL_1ARGS( func, obj ); } Pr( "\n", 0L, 0L ); memcpy( ReadJmpError, readJmpError, sizeof(jmp_buf) ); } else { memcpy( ReadJmpError, readJmpError, sizeof(jmp_buf) ); } } /**************************************************************************** ** *F main( , ) . . . . . . . main program, read-eval-print loop */ Obj AtExitFunctions; int main ( int argc, char * argv [] ) { ExecStatus status; /* result of ReadEvalCommand*/ UInt type; /* result of compile */ UInt time; /* start time */ Obj func; /* function (compiler) */ Int4 crc; /* crc of file to compile */ volatile UInt i; /* loop variable */ /* initialize everything */ InitializeGap( &argc, argv ); if (UserHasQUIT) /* maybe the user QUIT from the initial read of init.g */ goto finalize; /* maybe compile */ if ( SyCompilePlease ) { if ( ! OpenInput(SyCompileInput) ) { SyExit(1); } func = READ_AS_FUNC(); crc = SyGAPCRC(SyCompileInput); type = CompileFunc( SyCompileOutput, func, SyCompileName, crc, SyCompileMagic1 ); if ( type == 0 ) SyExit( 1 ); SyExit( 0 ); } /* read-eval-print loop */ while ( 1 ) { /* start the stopwatch */ time = SyTime(); /* read and evaluate one command */ Prompt = "gap> "; ClearError(); status = ReadEvalCommand(); if (UserHasQUIT) break; /* stop the stopwatch */ AssGVar( Time, INTOBJ_INT( SyTime() - time ) ); /* handle ordinary command */ if ( status == STATUS_END && ReadEvalResult != 0 ) { /* remember the value in 'last' and the time in 'time' */ AssGVar( Last3, VAL_GVAR( Last2 ) ); AssGVar( Last2, VAL_GVAR( Last ) ); AssGVar( Last, ReadEvalResult ); /* print the result */ if ( ! DualSemicolon ) { ViewObjHandler( ReadEvalResult ); } } /* handle return-value or return-void command */ else if ( status & (STATUS_RETURN_VAL | STATUS_RETURN_VOID) ) { Pr( "'return' must not be used in main read-eval-print loop", 0L, 0L ); } /* handle quit command or */ else if ( status & (STATUS_EOF | STATUS_QUIT | STATUS_QQUIT) ) { break; } UserHasQuit = 0; /* quit has done its job if we are here */ } finalize: /* call the exit functions */ BreakOnError = 0; for ( i = 1; i <= LEN_PLIST(AtExitFunctions); i++ ) { if ( setjmp(ReadJmpError) == 0 ) { func = ELM_PLIST( AtExitFunctions, i ); CALL_0ARGS(func); } } /* exit to the operating system, the return is there to please lint */ SyExit(0); return 0; } /**************************************************************************** ** *F FuncID_FUNC( , ) . . . . . . . . . . . . . . . return */ Obj FuncID_FUNC ( Obj self, Obj val1 ) { return val1; } /**************************************************************************** ** *F FuncRuntime( ) . . . . . . . . . . . . internal function 'Runtime' ** ** 'FuncRuntime' implements the internal function 'Runtime'. ** ** 'Runtime()' ** ** 'Runtime' returns the time spent since the start of GAP in milliseconds. ** How much time execution of statements take is of course system dependent. ** The accuracy of this number is also system dependent. */ Obj FuncRuntime ( Obj self ) { return INTOBJ_INT( SyTime() ); } /**************************************************************************** ** *F FuncSizeScreen( , ) . . . . internal function 'SizeScreen' ** ** 'FuncSizeScreen' implements the internal function 'SizeScreen' to get ** or set the actual screen size. ** ** 'SizeScreen()' ** ** In this form 'SizeScreen' returns the size of the screen as a list with ** two entries. The first is the length of each line, the second is the ** number of lines. ** ** 'SizeScreen( [ , ] )' ** ** In this form 'SizeScreen' sets the size of the screen. is the length ** of each line, is the number of lines. Either value may be missing, ** to leave this value unaffected. Note that those parameters can also be ** set with the command line options '-x ' and '-y '. */ Obj FuncSizeScreen ( Obj self, Obj args ) { Obj size; /* argument and result list */ Obj elm; /* one entry from size */ UInt len; /* length of lines on the screen */ UInt nr; /* number of lines on the screen */ /* check the arguments */ while ( ! IS_LIST(args) || 1 < LEN_LIST(args) ) { args = ErrorReturnObj( "Function: number of arguments must be 0 or 1 (not %d)", LEN_LIST(args), 0L, "you can return a list of arguments" ); } /* get the arguments */ if ( LEN_LIST(args) == 0 ) { size = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( size, 0 ); } /* otherwise check the argument */ else { size = ELM_LIST( args, 1 ); while ( ! IS_LIST(size) || 2 < LEN_LIST(size) ) { size = ErrorReturnObj( "SizeScreen: must be a list of length 2", 0L, 0L, "you can return a new list for " ); } } /* extract the length */ if ( LEN_LIST(size) < 1 || ELM0_LIST(size,1) == 0 ) { len = SyNrCols; } else { elm = ELMW_LIST(size,1); while ( TNUM_OBJ(elm) != T_INT ) { elm = ErrorReturnObj( "SizeScreen: must be an integer", 0L, 0L, "you can return a new integer for " ); } len = INT_INTOBJ( elm ); if ( len < 20 ) len = 20; if ( 256 < len ) len = 256; } /* extract the number */ if ( LEN_LIST(size) < 2 || ELM0_LIST(size,2) == 0 ) { nr = SyNrRows; } else { elm = ELMW_LIST(size,2); while ( TNUM_OBJ(elm) != T_INT ) { elm = ErrorReturnObj( "SizeScreen: must be an integer", 0L, 0L, "you can return a new integer for " ); } nr = INT_INTOBJ( elm ); if ( nr < 10 ) nr = 10; } /* set length and number */ SyNrCols = len; SyNrRows = nr; /* make and return the size of the screen */ size = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( size, 2 ); SET_ELM_PLIST( size, 1, INTOBJ_INT(len) ); SET_ELM_PLIST( size, 2, INTOBJ_INT(nr) ); return size; } /**************************************************************************** ** *F FuncWindowCmd( , ) . . . . . . . . execute a window command */ static Obj WindowCmdString; Obj FuncWindowCmd ( Obj self, Obj args ) { Obj tmp; Obj list; Int len; Int n, m; Int i; Char * ptr; Char * qtr; /* check arguments */ while ( ! IS_LIST(args) ) { args = ErrorReturnObj( "argument list must be a list (not a %s)", (Int)TNAM_OBJ(args), 0L, "you can return a list of arguments" ); } tmp = ELM_LIST(args,1); while ( ! IsStringConv(tmp) || 3 != LEN_LIST(tmp) ) { while ( ! IsStringConv(tmp) ) { tmp = ErrorReturnObj( " must be a string (not a %s)", (Int)TNAM_OBJ(tmp), 0L, "you can return a string as command" ); } if ( 3 != LEN_LIST(tmp) ) { tmp = ErrorReturnObj( " must be a string of length 3", 0L, 0L, "you can return a string as command" ); } } /* compute size needed to store argument string */ len = 13; for ( i = 2; i <= LEN_LIST(args); i++ ) { tmp = ELM_LIST( args, i ); while ( TNUM_OBJ(tmp) != T_INT && ! IsStringConv(tmp) ) { tmp = ErrorReturnObj( "%d. argument must be a string or integer (not a %s)", i, (Int)TNAM_OBJ(tmp), "yout can return a string or integer" ); SET_ELM_PLIST( args, i, tmp ); } if ( TNUM_OBJ(tmp) == T_INT ) len += 12; else len += 12 + LEN_LIST(tmp); } if ( SIZE_OBJ(WindowCmdString) <= len ) { ResizeBag( WindowCmdString, 2*len+1 ); } /* convert into an argument string */ ptr = (Char*) CSTR_STRING(WindowCmdString); *ptr = '\0'; /* first the command name */ SyStrncat( ptr, CSTR_STRING( ELM_LIST(args,1) ), 3 ); ptr += 3; /* and now the arguments */ for ( i = 2; i <= LEN_LIST(args); i++ ) { tmp = ELM_LIST(args,i); if ( TNUM_OBJ(tmp) == T_INT ) { *ptr++ = 'I'; m = INT_INTOBJ(tmp); for ( m = (m<0)?-m:m; 0 < m; m /= 10 ) *ptr++ = (m%10) + '0'; if ( INT_INTOBJ(tmp) < 0 ) *ptr++ = '-'; else *ptr++ = '+'; } else { *ptr++ = 'S'; m = LEN_LIST(tmp); for ( ; 0 < m; m/= 10 ) *ptr++ = (m%10) + '0'; *ptr++ = '+'; qtr = CSTR_STRING(tmp); for ( m = LEN_LIST(tmp); 0 < m; m-- ) *ptr++ = *qtr++; } } *ptr = 0; /* now call the window front end with the argument string */ qtr = CSTR_STRING(WindowCmdString); ptr = SyWinCmd( qtr, SyStrlen(qtr) ); len = SyStrlen(ptr); /* now convert result back into a list */ list = NEW_PLIST( T_PLIST, 11 ); SET_LEN_PLIST( list, 0 ); i = 1; while ( 0 < len ) { if ( *ptr == 'I' ) { ptr++; for ( n=0,m=1; '0' <= *ptr && *ptr <= '9'; ptr++,m *= 10,len-- ) n += (*ptr-'0') * m; if ( *ptr++ == '-' ) n *= -1; len -= 2; AssPlist( list, i, INTOBJ_INT(n) ); } else if ( *ptr == 'S' ) { ptr++; for ( n=0,m=1; '0' <= *ptr && *ptr <= '9'; ptr++,m *= 10,len-- ) n += (*ptr-'0') * m; ptr++; /* ignore the '+' */ tmp = NEW_STRING(n); *CSTR_STRING(tmp) = '\0'; SyStrncat( CSTR_STRING(tmp), ptr, n ); ptr += n; len -= n+2; AssPlist( list, i, tmp ); } else { ErrorQuit( "unknown return value '%s'", (Int)ptr, 0 ); return 0; } i++; } /* if the first entry is one signal an error */ if ( ELM_LIST(list,1) == INTOBJ_INT(1) ) { tmp = NEW_STRING(15); SyStrncat( CSTR_STRING(tmp), "window system: ", 15 ); SET_ELM_PLIST( list, 1, tmp ); SET_LEN_PLIST( list, i-1 ); return FuncError( 0, list ); } else { for ( m = 1; m <= i-2; m++ ) SET_ELM_PLIST( list, m, ELM_PLIST(list,m+1) ); SET_LEN_PLIST( list, i-2 ); return list; } } /**************************************************************************** ** *F * * * * * * * * * * * * * * error functions * * * * * * * * * * * * * * * */ /**************************************************************************** ** *F FuncDownEnv( , ) . . . . . . . . . change the environment */ UInt ErrorLevel; Obj ErrorLVars0; Obj ErrorLVars; Int ErrorLLevel; extern Obj BottomLVars; Obj FuncDownEnv ( Obj self, Obj args ) { Int depth; if ( LEN_LIST(args) == 0 ) { depth = 1; } else if ( LEN_LIST(args) == 1 && IS_INTOBJ( ELM_PLIST(args,1) ) ) { depth = INT_INTOBJ( ELM_PLIST( args, 1 ) ); } else { ErrorQuit( "usage: DownEnv( [ ] )", 0L, 0L ); return 0; } if ( ErrorLVars == 0 ) { Pr( "not in any function\n", 0L, 0L ); return 0; } /* if we really want to go up */ if ( depth < 0 && -ErrorLLevel <= -depth ) { depth = 0; ErrorLVars = ErrorLVars0; ErrorLLevel = 0; } else if ( depth < 0 ) { depth = -ErrorLLevel + depth; ErrorLVars = ErrorLVars0; ErrorLLevel = 0; } /* now go down */ while ( 0 < depth && ErrorLVars != BottomLVars && PTR_BAG(ErrorLVars)[2] != BottomLVars ) { ErrorLVars = PTR_BAG(ErrorLVars)[2]; ErrorLLevel--; depth--; } /* return nothing */ return 0; } /**************************************************************************** ** *F FuncWhere( , ) . . . . . . . . . . . . print stack frames */ Obj FuncWhere ( Obj self, Obj args ) { Obj currLVars; Int depth; Expr call; #ifndef NO_BRK_CALLS /* evaluate the argument */ if ( LEN_LIST(args) == 0 ) { depth = 10; } else if ( LEN_LIST(args) == 1 && IS_INTOBJ( ELM_PLIST(args,1) ) ) { depth = INT_INTOBJ( ELM_PLIST( args, 1 ) ); } else { ErrorQuit( "usage: Where( [ ] )", 0L, 0L ); return 0; } currLVars = CurrLVars; if ( ErrorLVars != 0 ) { SWITCH_TO_OLD_LVARS( ErrorLVars ); SWITCH_TO_OLD_LVARS( BRK_CALL_FROM() ); while ( CurrLVars != BottomLVars && 0 < depth ) { call = BRK_CALL_TO(); if ( call == 0 ) { Pr( " ", 0L, 0L ); } #if T_PROCCALL_0ARGS else if ( T_PROCCALL_0ARGS <= TNUM_STAT(call) && TNUM_STAT(call) <= T_PROCCALL_XARGS ) { #else else if ( TNUM_STAT(call) <= T_PROCCALL_XARGS ) { #endif PrintStat( call ); } else if ( T_FUNCCALL_0ARGS <= TNUM_EXPR(call) && TNUM_EXPR(call) <= T_FUNCCALL_XARGS ) { PrintExpr( call ); } Pr( " called from\n", 0L, 0L ); SWITCH_TO_OLD_LVARS( BRK_CALL_FROM() ); depth--; } if ( 0 < depth ) { Pr( "( ) called from read-eval-loop\n", 0L, 0L ); } else { Pr( "...\n", 0L, 0L ); } } else { Pr( "not in any function\n", 0L, 0L ); } SWITCH_TO_OLD_LVARS( currLVars ); #endif return 0; } /**************************************************************************** ** *F ErrorMode( , , , , , ) */ Obj OnBreak; /* a Fopy of the global OnBreak, which by default is set to Where. */ UInt UserHasQuit = 0; UInt UserHasQUIT = 0; Obj ErrorMode ( const Char * msg, Int arg1, Int arg2, Obj args, const Char * msg2, Char mode ) { Obj errorLVars0; Obj errorLVars; UInt errorLLevel; ExecStatus status; char prompt [16]; /* ignore all errors when testing or quitting */ if ( ( TestInput != 0 && TestOutput == Output ) || ! BreakOnError ) { if ( msg != (Char*)0 ) { Pr( msg, arg1, arg2 ); } else if ( args != (Obj)0 ) { Pr( "Error ", 0L, 0L ); FuncPrint( (Obj)0, args ); } Pr( "\n", 0L, 0L ); ReadEvalError(); } /* open the standard error output file */ OpenOutput( "*errout*" ); ErrorLevel += 1; errorLVars0 = ErrorLVars0; ErrorLVars0 = CurrLVars; errorLVars = ErrorLVars; ErrorLVars = CurrLVars; errorLLevel = ErrorLLevel; ErrorLLevel = 0; /* print the error message */ if ( msg != (Char*)0 ) { Pr( msg, arg1, arg2 ); } else if ( args != (Obj)0 ) { Pr( "Error ", 0L, 0L ); FuncPrint( (Obj)0, args ); } /* print the location */ if ( CurrStat != 0 ) { Pr( " at\n", 0L, 0L ); PrintStat( CurrStat ); Pr( "\n", 0L, 0L ); CALL_0ARGS(OnBreak); } else { Pr( "\n", 0L, 0L ); } /* try to open input for a break loop */ if ( mode == 'q' || ! OpenInput( "*errin*") ) { ErrorLevel -= 1; ErrorLVars0 = errorLVars0; ErrorLVars = errorLVars; ErrorLLevel = errorLLevel; CloseOutput(); ReadEvalError(); } ClearError(); /* print the sencond message */ Pr( "Entering break read-eval-print loop, ", 0L, 0L ); Pr( "you can 'quit;' to quit to outer loop,\n", 0L, 0L ); Pr( "or %s to continue\n", (Int)msg2, 0L ); /* read-eval-print loop */ while ( 1 ) { /* read and evaluate one command */ if ( ErrorLevel == 1 ) { Prompt = "brk> "; } else { prompt[0] = 'b'; prompt[1] = 'r'; prompt[2] = 'k'; prompt[3] = '_'; prompt[4] = ErrorLevel / 10 + '0'; prompt[5] = ErrorLevel % 10 + '0'; prompt[6] = '>'; prompt[7] = ' '; prompt[8] = '\0'; Prompt = prompt; } /* read and evaluate one command */ ClearError(); DualSemicolon = 0; status = ReadEvalCommand(); UserHasQuit = 0; /* it is enough for quit to have got us here */ /* handle ordinary command */ if ( status == STATUS_END && ReadEvalResult != 0 ) { /* remember the value in 'last' */ AssGVar( Last, ReadEvalResult ); /* print the result */ if ( ! DualSemicolon ) { ViewObjHandler( ReadEvalResult ); } } /* handle return-value */ else if ( status == STATUS_RETURN_VAL ) { if ( mode == 'v' ) { ErrorLevel -= 1; ErrorLVars0 = errorLVars0; ErrorLVars = errorLVars; ErrorLLevel = errorLLevel; CloseInput(); ClearError(); CloseOutput(); return ReadEvalResult; } else { Pr( "'return ;' cannot be used in this break-loop\n", 0L, 0L ); } } /* handle return-value */ else if ( status == STATUS_RETURN_VOID ) { if ( mode == 'x' ) { ErrorLevel -= 1; ErrorLVars0 = errorLVars0; ErrorLVars = errorLVars; ErrorLLevel = errorLLevel; CloseInput(); ClearError(); CloseOutput(); return (Obj)0; } else { Pr( "'return;' cannot be used in this break-loop\n", 0L, 0L ); } } /* handle quit command or */ else if ( status == STATUS_EOF || status == STATUS_QUIT ) { UserHasQuit = 1; break; } else if ( status == STATUS_QQUIT ) { UserHasQUIT = 1; break; } if (UserHasQUIT) break; } /* return to the outer read-eval-print loop */ ErrorLevel -= 1; ErrorLVars0 = errorLVars0; ErrorLVars = errorLVars; ErrorLLevel = errorLLevel; CloseInput(); ClearError(); CloseOutput(); ReadEvalError(); /* this is just to please GNU cc, 'ReadEvalError' never returns */ return 0; } /**************************************************************************** ** *F ErrorQuit( , , ) . . . . . . . . . . . print and quit */ void ErrorQuit ( const Char * msg, Int arg1, Int arg2 ) { ErrorMode( msg, arg1, arg2, (Obj)0, (Char*)0, 'q' ); } /**************************************************************************** ** *F ErrorQuitBound( ) . . . . . . . . . . . . . . . unbound variable */ void ErrorQuitBound ( Char * name ) { ErrorQuit( "variable '%s' must have an assigned value", (Int)name, 0L ); } /**************************************************************************** ** *F ErrorQuitFuncResult() . . . . . . . . . . . . . . . . must return a value */ void ErrorQuitFuncResult ( void ) { ErrorQuit( "function must return a value", 0L, 0L ); } /**************************************************************************** ** *F ErrorQuitIntSmall( ) . . . . . . . . . . . . . not a small integer */ void ErrorQuitIntSmall ( Obj obj ) { ErrorQuit( " must be a small integer (not a %s)", (Int)TNAM_OBJ(obj), 0L ); } /**************************************************************************** ** *F ErrorQuitIntSmallPos( ) . . . . . . . not a positive small integer */ void ErrorQuitIntSmallPos ( Obj obj ) { ErrorQuit( " must be a positive small integer (not a %s)", (Int)TNAM_OBJ(obj), 0L ); } /**************************************************************************** ** *F ErrorQuitBool( ) . . . . . . . . . . . . . . . . . . not a boolean */ void ErrorQuitBool ( Obj obj ) { ErrorQuit( " must be 'true' or 'false' (not a %s)", (Int)TNAM_OBJ(obj), 0L ); } /**************************************************************************** ** *F ErrorQuitFunc( ) . . . . . . . . . . . . . . . . . not a function */ void ErrorQuitFunc ( Obj obj ) { ErrorQuit( " must be a function (not a %s)", (Int)TNAM_OBJ(obj), 0L ); } /**************************************************************************** ** *F ErrorQuitNrArgs( , ) . . . . . . . wrong number of arguments */ void ErrorQuitNrArgs ( Int narg, Obj args ) { ErrorQuit( "Function Calls: number of arguments must be %d (not %d)", narg, LEN_PLIST( args ) ); } /**************************************************************************** ** *F ErrorReturnObj( , , , ) . . print and return obj */ Obj ErrorReturnObj ( const Char * msg, Int arg1, Int arg2, const Char * msg2 ) { return ErrorMode( msg, arg1, arg2, (Obj)0, msg2, 'v' ); } /**************************************************************************** ** *F ErrorReturnVoid( , , , ) . . . print and return */ void ErrorReturnVoid ( const Char * msg, Int arg1, Int arg2, const Char * msg2 ) { ErrorMode( msg, arg1, arg2, (Obj)0, msg2, 'x' ); } /**************************************************************************** ** *F FuncError( , ) . . . . . . . . . . . . . . . signal an error ** */ Obj FuncError ( Obj self, Obj args ) { return ErrorMode( (Char*)0, 0L, 0L, args, "you can return", 'x' ); } /**************************************************************************** ** *F * * * * * * * * * functions for creating the init file * * * * * * * * * * */ /**************************************************************************** ** *F Complete( ) . . . . . . . . . . . . . . . . . . . complete a file */ Obj CompNowFuncs; UInt CompNowCount; Obj CompLists; Obj CompThenFuncs; #define COMP_THEN_OFFSET 2 void Complete ( Obj list ) { Obj filename; UInt type; Int4 crc; Int4 crc1; /* get the filename */ filename = ELM_PLIST( list, 1 ); /* and the crc value */ crc = INT_INTOBJ( ELM_PLIST( list, 2 ) ); /* check the crc value */ if ( SyCheckCompletionCrcRead ) { crc1 = SyGAPCRC( CSTR_STRING(filename) ); if ( crc != crc1 ) { ErrorQuit( "Error, crc value of \"%s\" does not match completion file", (Int)CSTR_STRING(filename), 0L ); return; } } /* try to open the file */ if ( ! OpenInput( CSTR_STRING(filename) ) ) { return; } ClearError(); /* we are now completing */ if ( SyDebugLoading ) { Pr( "#I completing '%s'\n", (Int)CSTR_STRING(filename), 0L ); } CompNowFuncs = list; CompNowCount = COMP_THEN_OFFSET; /* now do the reading */ while ( 1 ) { type = ReadEvalCommand(); if ( type == 1 || type == 2 ) { Pr( "'return' must not be used in file read-eval loop", 0L, 0L ); } else if ( type == 8 || type == 16 ) { break; } } /* thats it for completing */ CompNowFuncs = 0; CompNowCount = 0; /* close the input file again, and return 'true' */ if ( ! CloseInput() ) { ErrorQuit( "Panic: COMPLETE cannot close input, this should not happen", 0L, 0L ); } ClearError(); } /**************************************************************************** ** *F DoCompleteargs( ... ) . . . . . . . . . . handler to complete a file */ Obj DoComplete0args ( Obj self ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_0ARGS( self ); } Obj DoComplete1args ( Obj self, Obj arg1 ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_1ARGS( self, arg1 ); } Obj DoComplete2args ( Obj self, Obj arg1, Obj arg2 ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_2ARGS( self, arg1, arg2 ); } Obj DoComplete3args ( Obj self, Obj arg1, Obj arg2, Obj arg3 ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_3ARGS( self, arg1, arg2, arg3 ); } Obj DoComplete4args ( Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4 ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_4ARGS( self, arg1, arg2, arg3, arg4 ); } Obj DoComplete5args ( Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5 ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_5ARGS( self, arg1, arg2, arg3, arg4, arg5 ); } Obj DoComplete6args ( Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6 ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_6ARGS( self, arg1, arg2, arg3, arg4, arg5, arg6 ); } Obj DoCompleteXargs ( Obj self, Obj args ) { COMPLETE_FUNC( self ); if ( IS_UNCOMPLETED_FUNC(self) ) { ErrorQuit( "panic: completion did not define function", 0, 0 ); return 0; } return CALL_XARGS( self, args ); } /**************************************************************************** ** *F FuncCOM_FILE( , , ) . . . . . . . . . set filename */ Obj FuncCOM_FILE ( Obj self, Obj filename, Obj crc ) { Int len; StructInitInfo * info; Int4 crc1; Int4 crc2; Char result[256]; Int res; /* check the argument */ while ( ! IsStringConv(filename) ) { filename = ErrorReturnObj( " must be a string (not a %s)", (Int)TNAM_OBJ(filename), 0L, "you can return a string for " ); } while ( ! IS_INTOBJ(crc) ) { crc = ErrorReturnObj( " must be a small integer (not a %s)", (Int)TNAM_OBJ(crc), 0L, "you can return an integer for " ); } /* check if have a statically or dynamically loadable module */ crc1 = INT_INTOBJ(crc); res = SyFindOrLinkGapRootFile(CSTR_STRING(filename), crc1, result, 256); /* not found */ if ( res == 0 ) { ErrorQuit( "cannot find module or file '%s'", (Int)CSTR_STRING(filename), 0L ); return Fail; } /* dynamically linked */ else if ( res == 1 ) { if ( SyDebugLoading ) { Pr( "#I READ_GAP_ROOT: loading '%s' dynamically\n", (Int)CSTR_STRING(filename), 0L ); } info = *(StructInitInfo**)result; res = info->initKernel(info); UpdateCopyFopyInfo(); res = res || info->initLibrary(info); if ( res ) { Pr( "#W init functions returned non-zero exit code\n", 0L, 0L ); } return INTOBJ_INT(1); } /* statically linked */ else if ( res == 2 ) { if ( SyDebugLoading ) { Pr( "#I READ_GAP_ROOT: loading '%s' statically\n", (Int)CSTR_STRING(filename), 0L ); } info = *(StructInitInfo**)result; res = info->initKernel(info); UpdateCopyFopyInfo(); res = res || info->initLibrary(info); if ( res ) { Pr( "#W init functions returned non-zero exit code\n", 0L, 0L ); } return INTOBJ_INT(2); } /* we have to read the GAP file */ else if ( res == 3 ) { /* compute the crc value of the original and compare */ if ( SyCheckCompletionCrcComp ) { crc2 = SyGAPCRC(result); if ( crc1 != crc2 ) { return INTOBJ_INT(4); } } filename = NEW_STRING( SyStrlen(result) ); SyStrncat( CSTR_STRING(filename), result, SyStrlen(result) ); CompThenFuncs = NEW_PLIST( T_PLIST, COMP_THEN_OFFSET ); SET_LEN_PLIST( CompThenFuncs, COMP_THEN_OFFSET ); SET_ELM_PLIST( CompThenFuncs, 1, filename ); SET_ELM_PLIST( CompThenFuncs, 2, INTOBJ_INT(crc1) ); len = LEN_PLIST( CompLists ); GROW_PLIST( CompLists, len+1 ); SET_LEN_PLIST( CompLists, len+1 ); SET_ELM_PLIST( CompLists, len+1, CompThenFuncs ); CHANGED_BAG( CompLists ); return INTOBJ_INT(3); } /* we have to read the GAP file, crc mismatch */ else if ( res == 4 ) { return INTOBJ_INT(4); } /* don't know */ else { ErrorQuit( "unknown result code %d from 'SyFindGapRoot'", res, 0L ); return Fail; } } /**************************************************************************** ** *F FuncCOM_FUN( , ) . . . . . . . . make a completable function */ static Obj StringUncompleted; static Obj EmptyList; Obj FuncCOM_FUN ( Obj self, Obj num ) { Obj func; Int n; /* if the file is not yet completed then make a new function */ n = INT_INTOBJ(num) + COMP_THEN_OFFSET; if ( LEN_PLIST( CompThenFuncs ) < n ) { /* make the function */ func = NewFunctionT( T_FUNCTION, SIZE_FUNC, EmptyList, -1, StringUncompleted, 0 ); HDLR_FUNC( func, 0 ) = DoComplete0args; HDLR_FUNC( func, 1 ) = DoComplete1args; HDLR_FUNC( func, 2 ) = DoComplete2args; HDLR_FUNC( func, 3 ) = DoComplete3args; HDLR_FUNC( func, 4 ) = DoComplete4args; HDLR_FUNC( func, 5 ) = DoComplete5args; HDLR_FUNC( func, 6 ) = DoComplete6args; HDLR_FUNC( func, 7 ) = DoCompleteXargs; BODY_FUNC( func ) = CompThenFuncs; /* add the function to the list of functions to complete */ GROW_PLIST( CompThenFuncs, n ); SET_LEN_PLIST( CompThenFuncs, n ); SET_ELM_PLIST( CompThenFuncs, n, func ); CHANGED_BAG( CompThenFuncs ); } /* return the function */ return ELM_PLIST( CompThenFuncs, n ); } /**************************************************************************** ** *F FuncMAKE_INIT( , , ... ) . . . . . . . . . . generate init file */ #define MAKE_INIT_GET_SYMBOL \ do { \ symbol = Symbol; \ value[0] = '\0'; \ SyStrncat( value, Value, 1023 ); \ if ( Symbol != S_EOF ) GetSymbol(); \ } while (0) Obj FuncMAKE_INIT ( Obj self, Obj output, Obj filename ) { volatile UInt level; volatile UInt symbol; Char value [1024]; volatile UInt funcNum; jmp_buf readJmpError; /* check the argument */ if ( ! IsStringConv( filename ) ) { ErrorQuit( "%d.th argument must be a string (not a %s)", (Int)TNAM_OBJ(filename), 0L ); } /* try to open the output */ if ( ! OpenAppend(CSTR_STRING(output)) ) { ErrorQuit( "cannot open '%s' for output", (Int)CSTR_STRING(output), 0L ); } /* try to open the file */ if ( ! OpenInput( CSTR_STRING(filename) ) ) { CloseOutput(); ErrorQuit( "'%s' must exist and be readable", (Int)CSTR_STRING(filename), 0L ); } ClearError(); /* where is this stuff */ funcNum = 1; /* read the file */ GetSymbol(); MAKE_INIT_GET_SYMBOL; while ( symbol != S_EOF ) { memcpy( readJmpError, ReadJmpError, sizeof(jmp_buf) ); if ( READ_ERROR() ) { memcpy( ReadJmpError, readJmpError, sizeof(jmp_buf) ); CloseInput(); CloseOutput(); ReadEvalError(); } memcpy( ReadJmpError, readJmpError, sizeof(jmp_buf) ); /* handle function beginning and ending */ if ( symbol == S_FUNCTION ) { Pr( "COM_FUN(%d)", funcNum++, 0L ); MAKE_INIT_GET_SYMBOL; level = 0; while ( level != 0 || symbol != S_END ) { if ( symbol == S_FUNCTION ) level++; if ( symbol == S_END ) level--; MAKE_INIT_GET_SYMBOL; } MAKE_INIT_GET_SYMBOL; } /* handle -> expressions */ else if ( symbol == S_IDENT && Symbol == S_MAPTO ) { Pr( "COM_FUN(%d)", funcNum++, 0L ); symbol = Symbol; if ( Symbol != S_EOF ) GetSymbol(); MAKE_INIT_GET_SYMBOL; level = 0; while ( level != 0 || (symbol != S_RBRACK && symbol != S_RBRACE && symbol != S_RPAREN && symbol != S_COMMA && symbol != S_DOTDOT && symbol != S_SEMICOLON) ) { if ( symbol == S_LBRACK || symbol == S_LBRACE || symbol == S_LPAREN || symbol == S_FUNCTION || symbol == S_BLBRACK || symbol == S_BLBRACE ) level++; if ( symbol == S_RBRACK || symbol == S_RBRACE || symbol == S_RPAREN || symbol == S_END ) level--; MAKE_INIT_GET_SYMBOL; } } /* handle the other symbols */ else { switch ( symbol ) { case S_IDENT: Pr( "%I", (Int)value, 0L ); break; case S_UNBIND: Pr( "Unbind", 0L, 0L ); break; case S_ISBOUND: Pr( "IsBound", 0L, 0L ); break; case S_LBRACK: Pr( "[", 0L, 0L ); break; case S_RBRACK: Pr( "]", 0L, 0L ); break; case S_LBRACE: Pr( "{", 0L, 0L ); break; case S_RBRACE: Pr( "}", 0L, 0L ); break; case S_DOT: Pr( ".", 0L, 0L ); break; case S_LPAREN: Pr( "(", 0L, 0L ); break; case S_RPAREN: Pr( ")", 0L, 0L ); break; case S_COMMA: Pr( ",", 0L, 0L ); break; case S_DOTDOT: Pr( "..", 0L, 0L ); break; case S_BDOT: Pr( "!.", 0L, 0L ); break; case S_BLBRACK: Pr( "![", 0L, 0L ); break; case S_BLBRACE: Pr( "!{", 0L, 0L ); break; case S_INT: Pr( "%s", (Int)value, 0L ); break; case S_TRUE: Pr( "true", 0L, 0L ); break; case S_FALSE: Pr( "false", 0L, 0L ); break; case S_CHAR: Pr( "'%c'", (Int)value[0], 0L ); break; case S_STRING: Pr( "\"%S\"", (Int)value, 0L ); break; case S_REC: Pr( "rec", 0L, 0L ); break; case S_FUNCTION: /* handled above */ break; case S_LOCAL: /* shouldn't happen */ break; case S_END: /* handled above */ break; case S_MAPTO: /* handled above */ break; case S_MULT: Pr( "*", 0L, 0L ); break; case S_DIV: Pr( "/", 0L, 0L ); break; case S_MOD: Pr( " mod ", 0L, 0L ); break; case S_POW: Pr( "^", 0L, 0L ); break; case S_PLUS: Pr( "+", 0L, 0L ); break; case S_MINUS: Pr( "-", 0L, 0L ); break; case S_EQ: Pr( "=", 0L, 0L ); break; case S_LT: Pr( "<", 0L, 0L ); break; case S_GT: Pr( ">", 0L, 0L ); break; case S_NE: Pr( "<>", 0L, 0L ); break; case S_LE: Pr( "<=", 0L, 0L ); break; case S_GE: Pr( ">=", 0L, 0L ); break; case S_IN: Pr( " in ", 0L, 0L ); break; case S_NOT: Pr( "not ", 0L, 0L ); break; case S_AND: Pr( " and ", 0L, 0L ); break; case S_OR: Pr( " or ", 0L, 0L ); break; case S_ASSIGN: Pr( ":=", 0L, 0L ); break; case S_IF: Pr( "if ", 0L, 0L ); break; case S_FOR: Pr( "for ", 0L, 0L ); break; case S_WHILE: Pr( "while ", 0L, 0L ); break; case S_REPEAT: Pr( "repeat ", 0L, 0L ); break; case S_THEN: Pr( " then\n", 0L, 0L ); break; case S_ELIF: Pr( "elif ", 0L, 0L ); break; case S_ELSE: Pr( "else\n", 0L, 0L ); break; case S_FI: Pr( "fi", 0L, 0L ); break; case S_DO: Pr( " do\n", 0L, 0L ); break; case S_OD: Pr( "od", 0L, 0L ); break; case S_UNTIL: Pr( "until ", 0L, 0L ); break; case S_BREAK: Pr( "break", 0L, 0L ); break; case S_RETURN: Pr( "return ", 0L, 0L ); break; case S_QUIT: Pr( "quit", 0L, 0L ); break; case S_SEMICOLON: Pr( ";\n", 0L, 0L ); break; default: CloseInput(); CloseOutput(); ClearError(); ErrorQuit( "unknown symbol %d", (Int)symbol, 0L ); } /* get the next symbol */ MAKE_INIT_GET_SYMBOL; } } /* close the input file again */ if ( ! CloseInput() ) { ErrorQuit( "Panic: MAKE_INIT cannot close input, this should not happen", 0L, 0L ); } ClearError(); /* close the output file */ CloseOutput(); return 0; } /**************************************************************************** ** *F * * * * * * * * * functions for dynamical/static modules * * * * * * * * * */ /**************************************************************************** ** *F FuncGAP_CRC( , ) . . . . . . . create a crc value for a file */ Obj FuncGAP_CRC ( Obj self, Obj filename ) { /* check the argument */ while ( ! IsStringConv( filename ) ) { filename = ErrorReturnObj( " must be a string (not a %s)", (Int)TNAM_OBJ(filename), 0L, "you can return a string for " ); } /* compute the crc value */ return INTOBJ_INT( SyGAPCRC( CSTR_STRING(filename) ) ); } /**************************************************************************** ** *F FuncLOAD_DYN( , , ) . . . try to load a dynamic module */ Obj FuncLOAD_DYN ( Obj self, Obj filename, Obj crc ) { InitInfoFunc init; StructInitInfo * info; Obj crc1; Int res; /* check the argument */ while ( ! IsStringConv( filename ) ) { filename = ErrorReturnObj( " must be a string (not a %s)", (Int)TNAM_OBJ(filename), 0L, "you can return a string for " ); } while ( ! IS_INTOBJ(crc) && crc!=False ) { crc = ErrorReturnObj( " must be a small integer or 'false' (not a %s)", (Int)TNAM_OBJ(crc), 0L, "you can return a small integer or 'false' for " ); } /* try to read the module */ init = SyLoadModule( CSTR_STRING(filename) ); if ( (Int)init == 1 ) ErrorQuit( "module '%s' not found", (Int)CSTR_STRING(filename), 0L ); else if ( (Int) init == 3 ) ErrorQuit( "symbol 'Init_Dynamic' not found", 0L, 0L ); else if ( (Int) init == 5 ) ErrorQuit( "forget symbol failed", 0L, 0L ); /* no dynamic library support */ else if ( (Int) init == 7 ) { if ( SyDebugLoading ) { Pr( "#I LOAD_DYN: no support for dynamical loading\n", 0L, 0L ); } return False; } /* get the description structure */ info = (*init)(); if ( info == 0 ) ErrorQuit( "call to init function failed", 0L, 0L ); /* check the crc value */ if ( crc != False ) { crc1 = INTOBJ_INT( info->crc ); if ( ! EQ( crc, crc1 ) ) { if ( SyDebugLoading ) { Pr( "#I LOAD_DYN: crc values do not match, gap ", 0L, 0L ); PrintInt( crc ); Pr( ", dyn ", 0L, 0L ); PrintInt( crc1 ); Pr( "\n", 0L, 0L ); } return False; } } /* link and init me */ info->isGapRootRelative = 0; res = (info->initKernel)(info); UpdateCopyFopyInfo(); res = res || (info->initLibrary)(info); if ( res ) { Pr( "#W init functions returned non-zero exit code\n", 0L, 0L ); } RecordLoadedModule(info, CSTR_STRING(filename)); return True; } /**************************************************************************** ** *F FuncLOAD_STAT( , , ) . . . . try to load static module */ Obj FuncLOAD_STAT ( Obj self, Obj filename, Obj crc ) { StructInitInfo * info; Obj crc1; Int k; Int res; /* check the argument */ while ( ! IsStringConv( filename ) ) { filename = ErrorReturnObj( " must be a string (not a %s)", (Int)TNAM_OBJ(filename), 0L, "you can return a string for " ); } while ( !IS_INTOBJ(crc) && crc!=False ) { crc = ErrorReturnObj( " must be a small integer or 'false' (not a %s)", (Int)TNAM_OBJ(crc), 0L, "you can return a small integer or 'false' for " ); } /* try to find the module */ for ( k = 0; CompInitFuncs[k]; k++ ) { info = (*(CompInitFuncs[k]))(); if ( info == 0 ) { continue; } if ( ! SyStrcmp( CSTR_STRING(filename), info->name ) ) { break; } } if ( CompInitFuncs[k] == 0 ) { if ( SyDebugLoading ) { Pr( "#I LOAD_STAT: no module named '%s' found\n", (Int)CSTR_STRING(filename), 0L ); } return False; } /* check the crc value */ if ( crc != False ) { crc1 = INTOBJ_INT( info->crc ); if ( ! EQ( crc, crc1 ) ) { if ( SyDebugLoading ) { Pr( "#I LOAD_STAT: crc values do not match, gap ", 0L, 0L ); PrintInt( crc ); Pr( ", stat ", 0L, 0L ); PrintInt( crc1 ); Pr( "\n", 0L, 0L ); } return False; } } /* link and init me */ info->isGapRootRelative = 0; res = (info->initKernel)(info); UpdateCopyFopyInfo(); res = res || (info->initLibrary)(info); if ( res ) { Pr( "#W init functions returned non-zero exit code\n", 0L, 0L ); } RecordLoadedModule(info, CSTR_STRING(filename)); return True; } /**************************************************************************** ** *F FuncSHOW_STAT() . . . . . . . . . . . . . . . . . . . show static modules */ Obj FuncSHOW_STAT ( Obj self ) { Obj modules; Obj name; StructInitInfo * info; Int k; Int im; /* count the number of install modules */ for ( k = 0, im = 0; CompInitFuncs[k]; k++ ) { info = (*(CompInitFuncs[k]))(); if ( info == 0 ) { continue; } im++; } /* make a list of modules with crc values */ modules = NEW_PLIST( T_PLIST, 2*im ); SET_LEN_PLIST( modules, 2*im ); for ( k = 0, im = 1; CompInitFuncs[k]; k++ ) { info = (*(CompInitFuncs[k]))(); if ( info == 0 ) { continue; } name = NEW_STRING( SyStrlen(info->name) ); SyStrncat( CSTR_STRING(name), info->name, SyStrlen(info->name) ); SET_ELM_PLIST( modules, im, name ); /* compute the crc value */ SET_ELM_PLIST( modules, im+1, INTOBJ_INT( info->crc ) ); im += 2; } return modules; } /**************************************************************************** ** *F FuncLoadedModules( ) . . . . . . . . . . . list all loaded modules */ Obj FuncLoadedModules ( Obj self ) { Int i; StructInitInfo * m; Obj str; Obj list; /* create a list */ list = NEW_PLIST( T_PLIST, NrModules * 3 ); SET_LEN_PLIST( list, NrModules * 3 ); for ( i = 0; i < NrModules; i++ ) { m = Modules[i]; if ( m->type == MODULE_BUILTIN ) { SET_ELM_PLIST( list, 3*i+1, ObjsChar[(Int)'b'] ); CHANGED_BAG(list); C_NEW_STRING( str, SyStrlen(m->name), m->name ); SET_ELM_PLIST( list, 3*i+2, str ); SET_ELM_PLIST( list, 3*i+3, INTOBJ_INT(m->version) ); } else if ( m->type == MODULE_DYNAMIC ) { SET_ELM_PLIST( list, 3*i+1, ObjsChar[(Int)'d'] ); CHANGED_BAG(list); C_NEW_STRING( str, SyStrlen(m->name), m->name ); SET_ELM_PLIST( list, 3*i+2, str ); CHANGED_BAG(list); C_NEW_STRING( str, SyStrlen(m->filename), m->filename ); SET_ELM_PLIST( list, 3*i+3, str ); } else if ( m->type == MODULE_STATIC ) { SET_ELM_PLIST( list, 3*i+1, ObjsChar[(Int)'s'] ); SET_ELM_PLIST( list, 3*i+1, ObjsChar[(Int)'d'] ); CHANGED_BAG(list); C_NEW_STRING( str, SyStrlen(m->name), m->name ); SET_ELM_PLIST( list, 3*i+2, str ); CHANGED_BAG(list); C_NEW_STRING( str, SyStrlen(m->filename), m->filename ); SET_ELM_PLIST( list, 3*i+3, str ); } } return CopyObj( list, 0 ); } /**************************************************************************** ** *F * * * * * * * * * * * * * * debug functions * * * * * * * * * * * * * * * */ /**************************************************************************** ** *F FuncGASMAN( , ) . . . . . . . . . expert function 'GASMAN' ** ** 'FuncGASMAN' implements the internal function 'GASMAN' ** ** 'GASMAN( "display" | "clear" | "collect" | "message" | "partial" )' */ Obj FuncGASMAN ( Obj self, Obj args ) { Obj cmd; /* argument */ UInt i, k; /* loop variables */ Char buf[100]; /* check the argument */ while ( ! IS_LIST(args) || LEN_LIST(args) == 0 ) { args = ErrorReturnObj( "usage: GASMAN( \"display\"|\"clear\"|\"collect\"|\"message\" )", 0L, 0L, "you can return a list of arguments" ); } /* loop over the arguments */ for ( i = 1; i <= LEN_LIST(args); i++ ) { /* evaluate and check the command */ cmd = ELM_PLIST( args, i ); again: while ( ! IsStringConv(cmd) ) { cmd = ErrorReturnObj( "GASMAN: must be a string (not a %s)", (Int)TNAM_OBJ(cmd), 0L, "you can return a string for " ); } /* if request display the statistics */ if ( SyStrcmp( CSTR_STRING(cmd), "display" ) == 0 ) { Pr( "%40s ", (Int)"type", 0L ); Pr( "%8s %8s ", (Int)"alive", (Int)"kbyte" ); Pr( "%8s %8s\n", (Int)"total", (Int)"kbyte" ); for ( k = 0; k < 256; k++ ) { if ( InfoBags[k].name != 0 ) { buf[0] = '\0'; SyStrncat( buf, InfoBags[k].name, 40 ); Pr("%40s ", (Int)buf, 0L ); Pr("%8d %8d ", (Int)InfoBags[k].nrLive, (Int)(InfoBags[k].sizeLive/1024)); Pr("%8d %8d\n",(Int)InfoBags[k].nrAll, (Int)(InfoBags[k].sizeAll/1024)); } } } /* if request display the statistics */ else if ( SyStrcmp( CSTR_STRING(cmd), "clear" ) == 0 ) { for ( k = 0; k < 256; k++ ) { #ifdef GASMAN_CLEAR_TO_LIVE InfoBags[k].nrAll = InfoBags[k].nrLive; InfoBags[k].sizeAll = InfoBags[k].sizeLive; #else InfoBags[k].nrAll = 0; InfoBags[k].sizeAll = 0; #endif } } /* or collect the garbage */ else if ( SyStrcmp( CSTR_STRING(cmd), "collect" ) == 0 ) { CollectBags(0,1); } /* or collect the garbage */ else if ( SyStrcmp( CSTR_STRING(cmd), "partial" ) == 0 ) { CollectBags(0,0); } /* or display information about global bags */ else if ( SyStrcmp( CSTR_STRING(cmd), "global" ) == 0 ) { for ( i = 0; i < GlobalBags.nr; i++ ) { if ( *(GlobalBags.addr[i]) != 0 ) { Pr( "%50s: %12d bytes\n", (Int)GlobalBags.cookie[i], (Int)SIZE_BAG(*(GlobalBags.addr[i])) ); } } } /* or finally toggle Gasman messages */ else if ( SyStrcmp( CSTR_STRING(cmd), "message" ) == 0 ) { SyMsgsFlagBags = (SyMsgsFlagBags + 1) % 3; } /* otherwise complain */ else { cmd = ErrorReturnObj( "GASMAN: must be %s or %s", (Int)"\"display\" or \"clear\" or \"global\" or ", (Int)"\"collect\" or \"partial\" or \"message\"", "you can return a new string for " ); goto again; } } /* return nothing, this function is a procedure */ return 0; } /**************************************************************************** ** *F FuncSHALLOW_SIZE( , ) . . . . expert function 'SHALLOW_SIZE' */ Obj FuncSHALLOW_SIZE ( Obj self, Obj obj ) { return INTOBJ_INT( SIZE_BAG( obj ) ); } /**************************************************************************** ** *F FuncTNUM_OBJ( , ) . . . . . . . . expert function 'TNUM_OBJ' */ Obj FuncTNUM_OBJ ( Obj self, Obj obj ) { Obj res; Obj str; const Char * cst; res = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( res, 2 ); /* set the type */ SET_ELM_PLIST( res, 1, INTOBJ_INT( TNUM_OBJ(obj) ) ); cst = TNAM_OBJ(obj); str = NEW_STRING( SyStrlen(cst) ); SyStrncat( CSTR_STRING(str), cst, SyStrlen(cst) ); SET_ELM_PLIST( res, 2, str ); /* and return */ return res; } /**************************************************************************** ** *F FuncXTNUM_OBJ( , ) . . . . . . . expert function 'XTNUM_OBJ' */ Obj FuncXTNUM_OBJ ( Obj self, Obj obj ) { Obj res; Obj str; UInt xtype; const Char * cst; res = NEW_PLIST( T_PLIST, 2 ); SET_LEN_PLIST( res, 2 ); /* set the type */ xtype = XTNum(obj); SET_ELM_PLIST( res, 1, INTOBJ_INT(xtype) ); if ( xtype == T_OBJECT ) { cst = "virtual object"; } else if ( xtype == T_MAT_CYC ) { cst = "virtual mat cyc"; } else if ( xtype == T_MAT_FFE ) { cst = "virtual mat ffe"; } else { cst = InfoBags[xtype].name; } str = NEW_STRING( SyStrlen(cst) ); SyStrncat( CSTR_STRING(str), cst, SyStrlen(cst) ); SET_ELM_PLIST( res, 2, str ); /* and return */ return res; } /**************************************************************************** ** *F FuncOBJ_HANDLE( , ) . . . . . . expert function 'OBJ_HANDLE' */ Obj FuncOBJ_HANDLE ( Obj self, Obj obj ) { UInt hand; UInt prod; Obj rem; if ( IS_INTOBJ(obj) ) { return (Obj)INT_INTOBJ(obj); } else if ( TNUM_OBJ(obj) == T_INTPOS ) { hand = 0; prod = 1; while ( EQ( obj, INTOBJ_INT(0) ) == 0 ) { rem = RemInt( obj, INTOBJ_INT( 1 << 16 ) ); obj = QuoInt( obj, INTOBJ_INT( 1 << 16 ) ); hand = hand + prod * INT_INTOBJ(rem); prod = prod * ( 1 << 16 ); } return (Obj) hand; } else { ErrorQuit( " must be a positive integer", 0L, 0L ); return 0; } } /**************************************************************************** ** *F FuncHANDLE_OBJ( , ) . . . . . . expert function 'HANDLE_OBJ' */ Obj FuncHANDLE_OBJ ( Obj self, Obj obj ) { Obj hnum; Obj prod; Obj tmp; UInt hand; hand = (UInt) obj; hnum = INTOBJ_INT(0); prod = INTOBJ_INT(1); while ( 0 < hand ) { tmp = PROD( prod, INTOBJ_INT( hand & 0xffff ) ); prod = PROD( prod, INTOBJ_INT( 1 << 16 ) ); hnum = SUM( hnum, tmp ); hand = hand >> 16; } return hnum; } /**************************************************************************** ** *F FuncSWAP_MPTR( , , ) . . . . . . . swap master pointer ** ** Never use this function unless you are debugging. */ Obj FuncSWAP_MPTR ( Obj self, Obj obj1, Obj obj2 ) { if ( TNUM_OBJ(obj1) == T_INT || TNUM_OBJ(obj1) == T_FFE ) { ErrorQuit("SWAP_MPTR: must not be an integer or ffe", 0L, 0L); return 0; } if ( TNUM_OBJ(obj2) == T_INT || TNUM_OBJ(obj2) == T_FFE ) { ErrorQuit("SWAP_MPTR: must not be an integer or ffe", 0L, 0L); return 0; } SwapMasterPoint( obj1, obj2 ); return 0; } /**************************************************************************** ** *F * * * * * * * * * * * * * initialize package * * * * * * * * * * * * * * * */ /**************************************************************************** ** *F FillInVersion( , , ) . . . fill in version number */ static UInt ExtractRevision ( const Char * rev, const Char * * name ) { const Char * p; const Char * major; const Char * minor; UInt ver1; UInt ver2; /* store the revision strings */ /* the revision string is "@(#)Id: filename.x,v major.minor ..." */ p = rev; while ( *p && *p != ':' ) p++; if ( *p ) p++; while ( *p && *p == ' ' ) p++; *name = p; while ( *p && *p != ' ' ) p++; while ( *p && *p == ' ' ) p++; major = p; while ( *p && *p != '.' ) p++; if ( *p ) p++; while ( *p && *p == '.' ) p++; minor = p; /* the version is MMmmm, that is 2 digits major, 3 digits minor */ ver1 = 0; while ( '0' <= *major && *major <= '9' ) { ver1 = ver1 * 10 + (UInt)( *major - '0' ); major++; } ver2 = 0; while ( '0' <= *minor && *minor <= '9' ) { ver2 = ver2 * 10 + (UInt)( *minor - '0' ); minor++; } return ver1 * 1000 + ver2; } void FillInVersion ( StructInitInfo * module ) { const Char * p; const Char * q; const Char * name; const Char * rev_c; const Char * rev_h; UInt c_ver; UInt h_ver; /* store revision entries */ rev_c = module->revision_c; rev_h = module->revision_h; /* extract the filename and version entry from */ c_ver = ExtractRevision( rev_c, &name ); if ( module->name ) { p = name; q = module->name; while ( *p && *q && *p == *q ) { p++; q++; } if ( *q || *p != '.' ) { fputs( "#W corrupt version info '", stderr ); fputs( rev_c, stderr ); fputs( "'\n", stderr ); } } h_ver = ExtractRevision( rev_h, &name ); if ( module->name ) { p = name; q = module->name; while ( *p && *q && *p == *q ) { p++; q++; } if ( *q || *p != '.' ) { fputs( "#W corrupt version info '", stderr ); fputs( rev_h, stderr ); fputs( "'\n", stderr ); } } module->version = c_ver*100000+h_ver; } /**************************************************************************** ** *F RequireModule( , , ) . . . . require module */ void RequireModule ( StructInitInfo * module, const Char * required, UInt version ) { } /**************************************************************************** ** *F InitBagNamesFromTable( ) . . . . . . . . . initialise bag names */ void InitBagNamesFromTable ( StructBagNames * tab ) { Int i; for ( i = 0; tab[i].tnum != -1; i++ ) { InfoBags[tab[i].tnum].name = tab[i].name; } } /**************************************************************************** ** *F InitClearFiltsTNumsFromTable( ) . . . initialise clear filts tnums */ void InitClearFiltsTNumsFromTable ( Int * tab ) { Int i; for ( i = 0; tab[i] != -1; i += 2 ) { ClearFiltsTNums[tab[i]] = tab[i+1]; } } /**************************************************************************** ** *F InitHasFiltListTNumsFromTable( ) . . initialise tester filts tnums */ void InitHasFiltListTNumsFromTable ( Int * tab ) { Int i; for ( i = 0; tab[i] != -1; i += 3 ) { HasFiltListTNums[tab[i]][tab[i+1]] = tab[i+2]; } } /**************************************************************************** ** *F InitSetFiltListTNumsFromTable( ) . . initialise setter filts tnums */ void InitSetFiltListTNumsFromTable ( Int * tab ) { Int i; for ( i = 0; tab[i] != -1; i += 3 ) { SetFiltListTNums[tab[i]][tab[i+1]] = tab[i+2]; } } /**************************************************************************** ** *F InitResetFiltListTNumsFromTable( ) initialise unsetter filts tnums */ void InitResetFiltListTNumsFromTable ( Int * tab ) { Int i; for ( i = 0; tab[i] != -1; i += 3 ) { ResetFiltListTNums[tab[i]][tab[i+1]] = tab[i+2]; } } /**************************************************************************** ** *F InitGVarFiltsFromTable( ) . . . . . . . . . . . . . . . new filters */ void InitGVarFiltsFromTable ( StructGVarFilt * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { AssGVar( GVarName( tab[i].name ), NewFilterC( tab[i].name, 1, tab[i].argument, tab[i].handler ) ); MakeReadOnlyGVar( GVarName( tab[i].name ) ); } } /**************************************************************************** ** *F InitGVarAttrsFromTable( ) . . . . . . . . . . . . . new attributes */ void InitGVarAttrsFromTable ( StructGVarAttr * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { AssGVar( GVarName( tab[i].name ), NewAttributeC( tab[i].name, 1, tab[i].argument, tab[i].handler ) ); MakeReadOnlyGVar( GVarName( tab[i].name ) ); } } /**************************************************************************** ** *F InitGVarPropsFromTable( ) . . . . . . . . . . . . . new properties */ void InitGVarPropsFromTable ( StructGVarProp * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { AssGVar( GVarName( tab[i].name ), NewPropertyC( tab[i].name, 1, tab[i].argument, tab[i].handler ) ); MakeReadOnlyGVar( GVarName( tab[i].name ) ); } } /**************************************************************************** ** *F InitGVarOpersFromTable( ) . . . . . . . . . . . . . new operations */ void InitGVarOpersFromTable ( StructGVarOper * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { AssGVar( GVarName( tab[i].name ), NewOperationC( tab[i].name, tab[i].nargs, tab[i].args, tab[i].handler ) ); MakeReadOnlyGVar( GVarName( tab[i].name ) ); } } /**************************************************************************** ** *F InitGVarFuncsFromTable( ) . . . . . . . . . . . . . . new functions */ void InitGVarFuncsFromTable ( StructGVarFunc * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { AssGVar( GVarName( tab[i].name ), NewFunctionC( tab[i].name, tab[i].nargs, tab[i].args, tab[i].handler ) ); MakeReadOnlyGVar( GVarName( tab[i].name ) ); } } /**************************************************************************** ** *F InitHdlrFiltsFromTable( ) . . . . . . . . . . . . . . . new filters */ void InitHdlrFiltsFromTable ( StructGVarFilt * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { InitHandlerFunc( tab[i].handler, tab[i].cookie ); InitFopyGVar( tab[i].name, tab[i].filter ); } } /**************************************************************************** ** *F InitHdlrAttrsFromTable( ) . . . . . . . . . . . . . new attributes */ void InitHdlrAttrsFromTable ( StructGVarAttr * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { InitHandlerFunc( tab[i].handler, tab[i].cookie ); InitFopyGVar( tab[i].name, tab[i].attribute ); } } /**************************************************************************** ** *F InitHdlrPropsFromTable( ) . . . . . . . . . . . . . new properties */ void InitHdlrPropsFromTable ( StructGVarProp * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { InitHandlerFunc( tab[i].handler, tab[i].cookie ); InitFopyGVar( tab[i].name, tab[i].property ); } } /**************************************************************************** ** *F InitHdlrOpersFromTable( ) . . . . . . . . . . . . . new operations */ void InitHdlrOpersFromTable ( StructGVarOper * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { InitHandlerFunc( tab[i].handler, tab[i].cookie ); InitFopyGVar( tab[i].name, tab[i].operation ); } } /**************************************************************************** ** *F InitHdlrFuncsFromTable( ) . . . . . . . . . . . . . . new functions */ void InitHdlrFuncsFromTable ( StructGVarFunc * tab ) { Int i; for ( i = 0; tab[i].name != 0; i++ ) { InitHandlerFunc( tab[i].handler, tab[i].cookie ); } } /**************************************************************************** ** *F ImportGVarFromLibrary( ,
) . . . import global variable */ typedef struct { const Char * name; Obj * address; } StructImportedGVars; #ifndef MAX_IMPORTED_GVARS #define MAX_IMPORTED_GVARS 1024 #endif static StructImportedGVars ImportedGVars[MAX_IMPORTED_GVARS]; static Int NrImportedGVars = 0; void ImportGVarFromLibrary( const Char * name, Obj * address ) { if ( NrImportedGVars == 1024 ) { Pr( "#W warning: too many imported GVars\n", 0L, 0L ); } else { ImportedGVars[NrImportedGVars].name = name; ImportedGVars[NrImportedGVars].address = address; NrImportedGVars++; } if ( address != 0 ) { InitCopyGVar( name, address ); } } /**************************************************************************** ** *F ImportFuncFromLibrary( ,
) . . . import global function */ static StructImportedGVars ImportedFuncs[MAX_IMPORTED_GVARS]; static Int NrImportedFuncs = 0; void ImportFuncFromLibrary( const Char * name, Obj * address ) { if ( NrImportedFuncs == 1024 ) { Pr( "#W warning: too many imported Funcs\n", 0L, 0L ); } else { ImportedFuncs[NrImportedFuncs].name = name; ImportedFuncs[NrImportedFuncs].address = address; NrImportedFuncs++; } if ( address != 0 ) { InitFopyGVar( (Char *)name, address ); } } /**************************************************************************** ** *F FuncExportToKernelFinished( ) . . . . . . . . . . check functions */ Obj FuncExportToKernelFinished ( Obj self ) { UInt i; Int errs = 0; Obj val; for ( i = 0; i < NrImportedGVars; i++ ) { if ( ImportedGVars[i].address == 0 ) { val = ValAutoGVar(GVarName(ImportedGVars[i].name)); if ( val == 0 ) { errs++; if ( ! SyQuiet ) { Pr( "#W global variable '%s' has not been defined\n", (Int)ImportedFuncs[i].name, 0L ); } } } else if ( *ImportedGVars[i].address == 0 ) { errs++; if ( ! SyQuiet ) { Pr( "#W global variable '%s' has not been defined\n", (Int)ImportedGVars[i].name, 0L ); } } else { MakeReadOnlyGVar(GVarName(ImportedGVars[i].name)); } } for ( i = 0; i < NrImportedFuncs; i++ ) { if ( ImportedFuncs[i].address == 0 ) { val = ValAutoGVar(GVarName(ImportedFuncs[i].name)); if ( val == 0 || ! IS_FUNC(val) ) { errs++; if ( ! SyQuiet ) { Pr( "#W global function '%s' has not been defined\n", (Int)ImportedFuncs[i].name, 0L ); } } } else if ( *ImportedFuncs[i].address == ErrorMustEvalToFuncFunc || *ImportedFuncs[i].address == ErrorMustHaveAssObjFunc ) { errs++; if ( ! SyQuiet ) { Pr( "#W global function '%s' has not been defined\n", (Int)ImportedFuncs[i].name, 0L ); } } else { MakeReadOnlyGVar(GVarName(ImportedFuncs[i].name)); } } return errs == 0 ? True : False; } /**************************************************************************** ** *V Revisions . . . . . . . . . . . . . . . . . . record of revision numbers */ Obj Revisions; /**************************************************************************** ** *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export */ static StructGVarFunc GVarFuncs [] = { { "Runtime", 0, "", FuncRuntime, "src/gap.c:Runtime" }, { "SizeScreen", -1, "args", FuncSizeScreen, "src/gap.c:SizeScreen" }, { "ID_FUNC", 1, "object", FuncID_FUNC, "src/gap.c:ID_FUNC" }, { "ExportToKernelFinished", 0, "", FuncExportToKernelFinished, "src/gap.c:ExportToKernelFinished" }, { "DownEnv", -1, "args", FuncDownEnv, "src/gap.c:DownEnv" }, { "Where", -1, "args", FuncWhere, "src/gap.c:Where" }, { "Error", -1, "args", FuncError, "src/gap.c:Error" }, { "COM_FILE", 2, "filename, crc", FuncCOM_FILE, "src/gap.c:COM_FILE" }, { "COM_FUN", 1, "number", FuncCOM_FUN, "src/gap.c:COM_FUN" }, { "MAKE_INIT", 2, "output, input", FuncMAKE_INIT, "src/gap.c:MAKE_INIT" }, { "GAP_CRC", 1, "filename", FuncGAP_CRC, "src/gap.c:GAP_CRC" }, { "LOAD_DYN", 2, "filename, crc", FuncLOAD_DYN, "src/gap.c:LOAD_DYN" }, { "LOAD_STAT", 2, "filename, crc", FuncLOAD_STAT, "src/gap.c:LOAD_STAT" }, { "SHOW_STAT", 0, "", FuncSHOW_STAT, "src/gap.c:SHOW_STAT" }, { "GASMAN", -1, "args", FuncGASMAN, "src/gap.c:GASMAN" }, { "SHALLOW_SIZE", 1, "object", FuncSHALLOW_SIZE, "src/gap.c:SHALLOW_SIZE" }, { "TNUM_OBJ", 1, "object", FuncTNUM_OBJ, "src/gap.c:TNUM_OBJ" }, { "XTNUM_OBJ", 1, "object", FuncXTNUM_OBJ, "src/gap.c:XTNUM_OBJ" }, { "OBJ_HANDLE", 1, "object", FuncOBJ_HANDLE, "src/gap.c:OBJ_HANDLE" }, { "HANDLE_OBJ", 1, "object", FuncHANDLE_OBJ, "src/gap.c:HANDLE_OBJ" }, { "SWAP_MPTR", 2, "obj1, obj2", FuncSWAP_MPTR, "src/gap.c:SWAP_MPTR" }, { "LoadedModules", 0, "", FuncLoadedModules, "src/gap.c:LoadedModules" }, { "WindowCmd", 1, "arg-list", FuncWindowCmd, "src/gap.c:WindowCmd" }, { 0 } }; /**************************************************************************** ** *F InitKernel( ) . . . . . . . . initialise kernel data structures */ static Int InitKernel ( StructInitInfo * module ) { /* init the completion function */ InitGlobalBag( &CompNowFuncs, "src/gap.c:CompNowFuncs" ); InitGlobalBag( &CompThenFuncs, "src/gap.c:CompThenFuncs" ); InitGlobalBag( &CompLists, "src/gap.c:CompLists" ); InitGlobalBag( &StringUncompleted, "src/gap.c:StringUncompleted" ); InitGlobalBag( &EmptyList, "src/gap.c:EmptyList" ); InitGlobalBag( &Revisions, "src/gap.c:Revisions" ); /* list of exit functions */ InitGlobalBag( &AtExitFunctions, "src/gap.c:AtExitFunctions" ); /* init filters and functions */ InitHdlrFuncsFromTable( GVarFuncs ); /* use short cookies to save space in saved workspace */ InitHandlerFunc( DoComplete0args, "c0" ); InitHandlerFunc( DoComplete1args, "c1" ); InitHandlerFunc( DoComplete2args, "c2" ); InitHandlerFunc( DoComplete3args, "c3" ); InitHandlerFunc( DoComplete4args, "c4" ); InitHandlerFunc( DoComplete5args, "c5" ); InitHandlerFunc( DoComplete6args, "c6" ); InitHandlerFunc( DoCompleteXargs, "cX" ); /* establish Fopy of ViewObj */ ImportFuncFromLibrary( "ViewObj", 0L ); ImportFuncFromLibrary( "OnBreak", &OnBreak ); /* return success */ return 0; } /**************************************************************************** ** *F PostRestore( ) . . . . . . . . . . . . . after restore workspace */ static Int PostRestore ( StructInitInfo * module ) { /* construct the `ViewObj' variable */ ViewObjGVar = GVarName( "ViewObj" ); /* construct the last and time variables */ Last = GVarName( "last" ); Last2 = GVarName( "last2" ); Last3 = GVarName( "last3" ); Time = GVarName( "time" ); /* return success */ return 0; } /**************************************************************************** ** *F InitLibrary( ) . . . . . . . initialise library data structures */ static Int InitLibrary ( StructInitInfo * module ) { Char * version = "v4r0p0 1996/06/06"; Obj string; UInt var; /* init the completion function */ CompLists = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( CompLists, 0 ); /* create a revision record */ Revisions = NEW_PREC(0); var = GVarName( "Revision" ); AssGVar( var, Revisions ); MakeReadOnlyGVar(var); /* version info */ string = NEW_STRING( SyStrlen(version) ); SyStrncat( CSTR_STRING(string), version, SyStrlen(version) ); var = GVarName( "VERSRC" ); AssGVar( var, string ); MakeReadOnlyGVar(var); /* library name and other stuff */ var = GVarName( "QUIET" ); AssGVar( var, (SyQuiet ? True : False) ); MakeReadOnlyGVar(var); var = GVarName( "BANNER" ); AssGVar( var, (SyBanner ? True : False) ); MakeReadOnlyGVar(var); var = GVarName( "DEBUG_LOADING" ); AssGVar( var, (SyDebugLoading ? True : False) ); MakeReadOnlyGVar(var); var = GVarName( "CHECK_FOR_COMP_FILES" ); AssGVar( var, (SyCheckForCompletion ? True : False) ); MakeReadOnlyGVar(var); /* list of exit functions */ AtExitFunctions = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( AtExitFunctions, 0 ); var = GVarName( "AT_EXIT_FUNCS" ); AssGVar( var, AtExitFunctions ); MakeReadOnlyGVar(var); /* share between uncompleted functions */ C_NEW_STRING( StringUncompleted, 11, "uncompleted" ); RESET_FILT_LIST( StringUncompleted, FN_IS_MUTABLE ); EmptyList = NEW_PLIST( T_PLIST+IMMUTABLE, 0 ); SET_LEN_PLIST( EmptyList, 0 ); /* init filters and functions */ InitGVarFuncsFromTable( GVarFuncs ); /* create windows command buffer */ WindowCmdString = NEW_STRING( 1000 ); /* return success */ return PostRestore( module ); } /**************************************************************************** ** *F InitInfoGap() . . . . . . . . . . . . . . . . . . table of init functions */ static StructInitInfo module = { MODULE_BUILTIN, /* type */ "gap", /* name */ 0, /* revision entry of c file */ 0, /* revision entry of h file */ 0, /* version */ 0, /* crc */ InitKernel, /* initKernel */ InitLibrary, /* initLibrary */ 0, /* checkInit */ 0, /* preSave */ 0, /* postSave */ PostRestore /* postRestore */ }; StructInitInfo * InitInfoGap ( void ) { module.revision_c = Revision_gap_c; module.revision_h = Revision_gap_h; FillInVersion( &module ); return &module; } /**************************************************************************** ** *V InitFuncsBuiltinModules . . . . . list of builtin modules init functions */ static InitInfoFunc InitFuncsBuiltinModules[] = { /* global variables */ InitInfoGVars, /* objects */ InitInfoObjects, /* scanner, reader, interpreter, coder, caller, compiler */ InitInfoScanner, InitInfoRead, InitInfoCalls, InitInfoExprs, InitInfoStats, InitInfoCode, InitInfoVars, /* must come after InitExpr and InitStats */ InitInfoFuncs, InitInfoOpers, InitInfoIntrprtr, InitInfoCompiler, /* arithmetic operations */ InitInfoAriths, InitInfoInt, InitInfoRat, InitInfoCyc, InitInfoFinfield, InitInfoPermutat, InitInfoBool, /* record packages */ InitInfoRecords, InitInfoPRecord, /* list packages */ InitInfoLists, InitInfoListOper, InitInfoListFunc, InitInfoPlist, InitInfoSet, InitInfoVector, InitInfoBlist, InitInfoRange, InitInfoString, InitInfoGF2Vec, /* free and presented groups */ InitInfoFreeGroupElements, InitInfoCosetTable, InitInfoTietze, InitInfoPcElements, InitInfoSingleCollector, InitInfoPcc, InitInfoDeepThought, InitInfoDTEvaluation, /* algebras */ InitInfoSCTable, /* save and load workspace, weak pointers */ InitInfoWeakPtr, InitInfoSaveLoad, /* input and output */ InitInfoStreams, InitInfoSysFiles, /* main module */ InitInfoGap, #ifdef GAPMPI /* GAPMPI module */ InitInfoGapmpi, #endif 0 }; /**************************************************************************** ** *F Modules . . . . . . . . . . . . . . . . . . . . . . . . . list of modules */ #ifndef MAX_MODULES #define MAX_MODULES 1000 #endif #ifndef MAX_MODULE_FILENAMES #define MAX_MODULE_FILENAMES (MAX_MODULES*50) #endif Char LoadedModuleFilenames[MAX_MODULE_FILENAMES]; Char *NextLoadedModuleFilename = LoadedModuleFilenames; StructInitInfo * Modules [ MAX_MODULES ]; UInt NrModules = 0; UInt NrBuiltinModules = 0; /**************************************************************************** ** *F RecordLoadedModule( ) . . . . . . . . store module in */ void RecordLoadedModule ( StructInitInfo * module, Char *filename ) { UInt len; if ( NrModules == MAX_MODULES ) { Pr( "panic: no room to record module\n", 0L, 0L ); } len = SyStrlen(filename); if (NextLoadedModuleFilename + len + 1 > LoadedModuleFilenames+MAX_MODULE_FILENAMES) { Pr( "panic: no room for module filename\n", 0L, 0L ); } *NextLoadedModuleFilename = '\0'; SyStrncat(NextLoadedModuleFilename,filename, len); module->filename = NextLoadedModuleFilename; NextLoadedModuleFilename += len +1; Modules[NrModules++] = module; } /**************************************************************************** ** *F SET_REVISION( , ) . . . . . . . . . enter revision info */ #define SET_REVISION( file, revision ) \ do { \ UInt rev_rnam; \ Obj rev_str; \ rev_rnam = RNamName(file); \ C_NEW_STRING( rev_str, SyStrlen(revision), (revision) ); \ RESET_FILT_LIST( rev_str, FN_IS_MUTABLE ); \ AssPRec( Revisions, rev_rnam, rev_str ); \ } while (0) /**************************************************************************** ** *F InitializeGap() . . . . . . . . . . . . . . . . . . . . . . intialize GAP ** ** Each module (builtin or compiled) exports a sturctures which contains ** information about the name, version, crc, init function, save and restore ** functions. ** ** The init process is split into three different functions: ** ** `InitKernel': This function setups the internal data structures and ** tables, registers the global bags and functions handlers, copies and ** fopies. It is not allowed to create objects, gvar or rnam numbers. This ** function is used for both starting and restoring. ** ** `InitLibrary': This function creates objects, gvar and rnam number, and ** does assignments of auxillary C variables (for example, pointers from ** objects, length of hash lists). This function is only used for starting. ** ** `PostRestore': Everything in `InitLibrary' execpt creating objects. In ** general `InitLibrary' will create all objects and then calls ** `PostRestore'. This function is only used when restoring. */ extern TNumMarkFuncBags TabMarkFuncBags [ 256 ]; void InitializeGap ( int * pargc, char * argv [] ) { UInt type; UInt i; Int ret; /* initialize the basic system and gasman */ #ifdef GAPMPI /* GAPMPI needs to call MPI_Init() first to remove command line args */ InitGapmpi( pargc, &argv, &BreakOnError ); #endif InitSystem( *pargc, argv ); InitBags( SyAllocBags, SyStorMin, 0, (Bag*)pargc, SyStackAlign, SyCacheSize, 0, SyAbortBags ); InitMsgsFuncBags( SyMsgsBags ); /* get info structures for the build in modules */ for ( i = 0; InitFuncsBuiltinModules[i]; i++ ) { if ( NrModules == MAX_MODULES ) { fputs( "panic: too many builtin modules\n", stderr ); SyExit(1); } Modules[NrModules++] = InitFuncsBuiltinModules[i](); # ifdef DEBUG_LOADING fputs( "#I InitInfo(builtin ", stderr ); fputs( Modules[NrModules-1]->name, stderr ); fputs( ")\n", stderr ); # endif } NrBuiltinModules = NrModules; /* call kernel initialisation */ for ( i = 0; i < NrBuiltinModules; i++ ) { if ( Modules[i]->initKernel ) { # ifdef DEBUG_LOADING fputs( "#I InitKernel(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ")\n", stderr ); # endif ret =Modules[i]->initKernel( Modules[i] ); if ( ret ) { fputs( "#I InitKernel(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ") returned non-zero value\n", stderr ); } } } /* you should set 'COUNT_BAGS' as well */ # ifdef DEBUG_LOADING if ( SyRestoring ) { Pr( "#W after setup\n", 0L, 0L ); Pr( "#W %36s ", (Int)"type", 0L ); Pr( "%8s %8s ", (Int)"alive", (Int)"kbyte" ); Pr( "%8s %8s\n", (Int)"total", (Int)"kbyte" ); for ( i = 0; i < 256; i++ ) { if ( InfoBags[i].name != 0 && InfoBags[i].nrAll != 0 ) { char buf[41]; buf[0] = '\0'; SyStrncat( buf, InfoBags[i].name, 40 ); Pr("#W %36s ", (Int)buf, 0L ); Pr("%8d %8d ", (Int)InfoBags[i].nrLive, (Int)(InfoBags[i].sizeLive/1024)); Pr("%8d %8d\n",(Int)InfoBags[i].nrAll, (Int)(InfoBags[i].sizeAll/1024)); } } } # endif /* and now for a special hack */ for ( i = LAST_CONSTANT_TNUM+1; i <= LAST_REAL_TNUM; i++ ) { TabMarkFuncBags[ i+COPYING ] = TabMarkFuncBags[ i ]; } /* if we are restoring, load the workspace and call the post restore */ if ( SyRestoring ) { LoadWorkspace(SyRestoring); for ( i = 0; i < NrModules; i++ ) { if ( Modules[i]->postRestore ) { # ifdef DEBUG_LOADING fputs( "#I PostRestore(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ")\n", stderr ); # endif ret = Modules[i]->postRestore( Modules[i] ); if ( ret ) { fputs( "#I PostRestore(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ") returned non-zero value\n", stderr ); } } } SyRestoring = NULL; } /* otherwise call library initialisation */ else { extern Int WarnInitGlobalBag; WarnInitGlobalBag = 1; # ifdef DEBUG_HANDLER_REGISTRATION CheckAllHandlers(); # endif for ( i = 0; i < NrBuiltinModules; i++ ) { if ( Modules[i]->initLibrary ) { # ifdef DEBUG_LOADING fputs( "#I InitLibrary(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ")\n", stderr ); # endif ret = Modules[i]->initLibrary( Modules[i] ); if ( ret ) { fputs( "#I InitLibrary(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ") returned non-zero value\n", stderr ); } } } WarnInitGlobalBag = 0; } /* check initialisation */ for ( i = 0; i < NrModules; i++ ) { if ( Modules[i]->checkInit ) { # ifdef DEBUG_LOADING fputs( "#I CheckInit(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ")\n", stderr ); # endif ret = Modules[i]->checkInit( Modules[i] ); if ( ret ) { fputs( "#I CheckInit(builtin ", stderr ); fputs( Modules[i]->name, stderr ); fputs( ") returned non-zero value\n", stderr ); } } } /* create a revision record (overwrite a restored one) */ for ( i = 0; i < NrBuiltinModules; i++ ) { Char buf[30]; buf[0] = 0; SyStrncat( buf, Modules[i]->name, 27 ); SyStrncat( buf, "_c", 2 ); SET_REVISION( buf, Modules[i]->revision_c ); buf[0] = 0; SyStrncat( buf, Modules[i]->name, 27 ); SyStrncat( buf, "_h", 2 ); SET_REVISION( buf, Modules[i]->revision_h ); } /* add revisions for files which are not modules */ { extern const char * Revision_system_c; extern const char * Revision_system_h; extern const char * Revision_gasman_c; extern const char * Revision_gasman_h; SET_REVISION( "system_c", Revision_system_c ); SET_REVISION( "system_h", Revision_system_h ); SET_REVISION( "gasman_c", Revision_gasman_c ); SET_REVISION( "gasman_h", Revision_gasman_h ); } /* read the init files */ if ( SySystemInitFile[0] ) { if ( READ_GAP_ROOT(SySystemInitFile) == 0 ) { if ( ! SyQuiet ) { Pr( "gap: hmm, I cannot find '%s' maybe", (Int)SySystemInitFile, 0L ); Pr( " use option '-l '?\n", 0L, 0L ); } } } for ( i = 0; i < sizeof(SyInitfiles)/sizeof(SyInitfiles[0]); i++ ) { if ( SyInitfiles[i][0] != '\0' ) { if ( OpenInput( SyInitfiles[i] ) ) { ClearError(); while ( 1 ) { type = ReadEvalCommand(); if ( type == 1 || type == 2 ) { Pr("'return' must not be used in file",0L,0L); } else if ( type == 8 || type == 16 ) { break; } } CloseInput(); ClearError(); } else { Pr( "Error, file \"%s\" must exist and be readable\n", (Int)SyInitfiles[i], 0L ); } } } } /**************************************************************************** ** *E gap.c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here */