This is gap.c in view mode; [Download] [Up]
/****************************************************************************
**
*A gap.c GAP source Martin Schoenert
**
*H @(#)$Id: gap.c,v 3.28 1994/06/10 16:22:28 mschoene Rel $
**
*Y Copyright 1990-1992, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany
**
** This file contains the various read-eval-print loops and related stuff.
**
*H $Log: gap.c,v $
*H Revision 3.28 1994/06/10 16:22:28 mschoene
*H changed 'VERSRC' for 3.4
*H
*H Revision 3.27 1993/11/08 23:12:40 martin
*H corrected the date in 'VERSRC'
*H
*H Revision 3.26 1993/10/15 09:21:46 martin
*H changed 'SyLinelength' to 'SyNrRows', added 'VERSRC' and 'VERSYS'
*H
*H Revision 3.25 1993/05/25 08:20:40 fceller
*H added 'IsIdentical'
*H
*H Revision 3.24 1993/05/05 11:10:12 fceller
*H added 'LogInputTo'
*H
*H Revision 3.23 1993/03/11 13:00:03 fceller
*H added package mode
*H
*H Revision 3.22 1993/02/15 14:39:42 fceller
*H fixed a typo in 'AppendTo'
*H
*H Revision 3.21 1993/02/12 11:20:18 martin
*H strings should print as strings in the main loop
*H
*H Revision 3.20 1993/02/09 10:22:29 martin
*H changed 'Print' to print empty string literals empty
*H
*H Revision 3.19 1993/02/04 14:07:46 martin
*H changed 'Print' to stop printing the empty list as a string
*H
*H Revision 3.18 1993/02/04 13:06:02 martin
*H fixed wrong test in 'CoefficientsInt'
*H
*H Revision 3.17 1993/02/04 10:51:10 martin
*H changed to use new list interface
*H
*H Revision 3.16 1992/11/06 08:52:19 fceller
*H Added 'FunTmpName' and 'SyTmpname'
*H
*H Revision 3.15 1992/04/02 17:26:05 martin
*H added the banner
*H
*H Revision 3.14 1992/04/02 15:21:08 martin
*H replaced 'Linelength' with 'SizeScreen'
*H
*H Revision 3.13 1992/03/04 18:26:23 goetz
*H restricted 'Linelength' to 256.
*H
*H Revision 3.12 1992/03/01 20:48:33 jmnich
*H added statistic functions
*H
*H Revision 3.11 1992/01/02 13:12:28 martin
*H changed 'Backtrace' to handle binary operators
*H
*H Revision 3.10 1991/09/24 14:42:55 fceller
*H 'Coefficients' is now 'CoefficientsInt'.
*H
*H Revision 3.9 1991/08/19 12:49:34 fceller
*H Added Prototype for 'FunIgnore'.
*H
*H Revision 3.8 1991/07/29 13:00:45 fceller
*H 'FunIgnore' added.
*H
*H Revision 3.7 1991/04/30 16:12:20 martin
*H initial revision under RCS
*H
*H Revision 3.6 1991/01/23 12:00:00 martin
*H improved 'Pr' to accept field width for strings
*H
*H Revision 3.5 1991/01/15 12:00:00 martin
*H added statistics to Gasman
*H
*H Revision 3.4 1991/01/15 12:00:00 martin
*H added 'Coefficients' temporary
*H
*H Revision 3.3 1991/01/14 12:00:00 martin
*H added expert functions 'TYPE' and 'SIZE'
*H
*H Revision 3.2 1990/12/07 12:00:00 goetz
*H added 'FunLinelength'
*H
*H Revision 3.1 1990/10/02 12:00:00 martin
*H added 'quit'
*H
*H Revision 3.0 1990/09/30 12:00:00 martin
*H changed '-2^2' to '-4'
*H
*/
#include <setjmp.h> /* definition of setjmp buffer */
#include "system.h" /* system dependent functions */
#include "gasman.h" /* dynamic storage manager */
#include "scanner.h" /* reading of single tokens */
#include "eval.h" /* evaluator main dispatcher */
#include "integer.h" /* arbitrary size integers */
#include "idents.h" /* 'InitIdents', 'FindIdent' */
#include "read.h" /* 'ReadIt' */
#include "list.h" /* generic list package */
#include "plist.h" /* 'LEN_PLIST', 'SET_LEN_PLIST',.. */
#include "string.h" /* 'IsString', 'PrintString' */
#include "statemen.h" /* 'HdStat', 'StrStat' */
#include "function.h" /* 'HdExec', 'ChangeEnv', 'PrintF' */
#include "record.h" /* 'HdCall*' */
/****************************************************************************
**
*V ErrRet . . . . . . . . . . . . . . . environment for error return, local
**
** 'ErrRet' is the saved environment from the beginning of the main
** read-eval-print loop. If you 'quit;' a break loop control returns to
** that place.
*/
jmp_buf ErrRet;
/****************************************************************************
**
*V HdLast . . . . . . . . . . . . . . handle of the variable 'last', local
*V HdLast2 . . . . . . . . . . . . . . handle of the variable 'last2', local
*V HdLast3 . . . . . . . . . . . . . . handle of the variable 'last3', local
**
** 'HdLast' is the handle of the variable 'last'. This global variable
** holds the result of the last evaluation in the main read-eval-print loop.
** 'HdLast2' likewise holds the next to last result, and 'HdLast3' holds the
** result before that.
*/
TypHandle HdLast, HdLast2, HdLast3;
/****************************************************************************
**
*V HdTime . . . . . . . . . . . . . . handle of the variable 'time', local
**
** 'HdTime' is the handle of the variable 'time'.
**
** 'time' holds the time in milliseconds that the execution of the last
** statement took. This variable is set at the end of the read-eval-print
** cycle.
*/
TypHandle HdTime;
/****************************************************************************
**
*F main( <argc>, <argv> ) . . . . . . . main program, read-eval-print loop
**
** 'main' is the entry point of GAP. The operating sytem transfers control
** to this point when GAP is started. 'main' calls 'InitGap' to initialize
** everything. Then 'main' starts the read-eval-print loop, i.e., it reads
** expression, evaluates it and prints the value. This continues until the
** end of the input file.
*/
int main ( argc, argv )
int argc;
char * argv [];
{
TypHandle hd;
unsigned long start;
extern void InitGap ();
extern char * In;
/* initialize everything */
InitGap( argc, argv );
/* set the environment to return in case of an error */
setjmp( ErrRet );
/* repeat the read-eval-print cycle until end of input */
while ( Symbol != S_EOF ) {
/* read an expression */
Prompt = "gap> ";
EnterKernel();
NrError = 0;
hd = ReadIt();
/* if there we no syntax error evaluate the expression */
if ( hd != 0 ) {
SyIsIntr();
start = SyTime();
hd = EVAL( hd );
if ( hd == HdReturn && PTR(hd)[0] != HdReturn )
Error("'return' must not be used in main loop",0L,0L);
else if ( hd == HdReturn ) {
hd = HdVoid;
Symbol = S_EOF;
}
PTR(HdTime)[0] = INT_TO_HD( SyTime() - start );
/* assign the value to 'last' and then print it */
if ( TYPE(hd) != T_VOID ) {
PTR(HdLast3)[0] = PTR(HdLast2)[0];
PTR(HdLast2)[0] = PTR(HdLast)[0];
PTR(HdLast)[0] = hd;
if ( *In != ';' ) {
IsString( hd );
Print( hd );
Pr("\n",0L,0L);
}
}
}
ExitKernel( (TypHandle)0 );
}
/* exit to the operating system, the return is there to please lint */
SyExit( 0 );
return 0;
}
/****************************************************************************
**
*F FunBacktrace( <hdCall> ) . . . . . . . . . internal function 'Backtrace'
**
** 'FunBacktrace' implements the internal function 'Backtrace'.
**
** 'Backtrace()' \\
** 'Backtrace( <level> )'
**
** 'Backtrace' can be used inside a break loop to print a history of the
** computation. 'Backtrace' prints a list of all active functions, most
** recent first, up to maximal <level> nestings. If <level> is positive
** the names of the formal arguments of the functions calls are printed,
** otherwise the values of the actual arguments are printed instead.
** <level> default to 5, i.e., calling 'Backtrace' with no argument will
** print the 5 most recent functions with the names of the formal arguments.
**
** When a break loop (see "Break Loops") is entered 'Backtrace' is called
** automatically.
*/
TypHandle FunBacktrace ( hdCall )
TypHandle hdCall;
{
short level, nrArg, nrLoc, i;
TypHandle hdExec, hdDef;
/* get the value of <level> */
if ( hdCall == 0 || SIZE(hdCall) == SIZE_HD ) {
level = 5;
}
else if ( SIZE(hdCall) == 2 * SIZE_HD ) {
hdDef = EVAL( PTR(hdCall)[1] );
if ( TYPE(hdDef) != T_INT )
return Error("usage: Backtrace( <level> )",0L,0L);
else
level = HD_TO_INT( hdDef );
}
else {
return Error("usage: Backtrace( <level> )",0L,0L);
}
/* for <level> frames */
for ( hdExec=HdExec; hdExec!=0 && level!=0; hdExec=PTR(hdExec)[4] ) {
/* if <level> is positive print only the names of the formal args */
if ( 0 < level ) {
if ( PTR(hdExec)[3] == HdCallSum )
Pr("<rec1> + <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallDiff )
Pr("<rec1> - <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallProd )
Pr("<rec1> * <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallQuo )
Pr("<rec1> / <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallMod )
Pr("<rec1> mod <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallPow )
Pr("<rec1> ^ <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallComm )
Pr("Comm(<rec1>,<rec2>) called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallEq )
Pr("<rec1> = <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallLt )
Pr("<rec1> < <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallIn )
Pr("<elm> in <rec> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallPrint )
Pr("Print( <rec> ) called from\n",0L,0L);
else {
Print( PTR(hdExec)[3] );
Pr(" called from\n",0L,0L);
}
--level;
}
/* if <level> is negative print the values of the arguments */
else {
if ( PTR(hdExec)[3] == HdCallSum )
Pr("<rec1> + <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallDiff )
Pr("<rec1> - <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallProd )
Pr("<rec1> * <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallQuo )
Pr("<rec1> / <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallMod )
Pr("<rec1> mod <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallPow )
Pr("<rec1> ^ <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallComm )
Pr("Comm(<rec1>,<rec2>) called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallEq )
Pr("<rec1> = <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallLt )
Pr("<rec1> < <rec2> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallIn )
Pr("<elm> in <rec> called from\n",0L,0L);
else if ( PTR(hdExec)[3] == HdCallPrint )
Pr("Print( <rec> ) called from\n",0L,0L);
else {
Print( PTR( PTR(hdExec)[3] )[0] );
Pr("%>( %>",0L,0L);
hdDef = EVAL( PTR( PTR(hdExec)[3] )[0] );
nrArg = ((short*)((char*)PTR(hdDef)+SIZE(hdDef)))[-2];
if ( nrArg == -1 ) nrArg = 1;
nrLoc = ((short*)((char*)PTR(hdDef)+SIZE(hdDef)))[-1];
if ( nrLoc < 0 ) nrLoc = -nrLoc-1;
for ( i = 1; i <= nrArg; ++i ) {
Print( PTR(hdExec)[i+nrArg+nrLoc+4] );
if ( i < nrArg ) Pr("%<, %>",0L,0L);
}
Pr(" %2<) called from\n",0L,0L);
}
++level;
}
}
/* print the bottom of the function stack */
if ( hdExec == 0 ) {
Pr("main loop\n",0L,0L);
}
else {
Pr("...\n",0L,0L);
}
return HdVoid;
}
/****************************************************************************
**
*F Error( <msg>, <arg1>, <arg2> ) . . . . . . . . . . . . . . error handler
**
** 'Error' is the GAP kernel error handler.
*/
TypHandle Error ( msg, arg1, arg2 )
char msg [];
long arg1, arg2;
{
TypHandle hd;
long i;
long ignore;
extern TypHandle FunPrint();
extern char * In;
extern TypHandle HdStack;
extern unsigned long TopStack;
/* open the standard error output file */
ignore = OpenOutput( "*errout*" );
/* print the error message, special if called from 'FunError' */
if ( SyStrcmp( msg, "FunError" ) != 0 ) {
Pr("Error, ",0L,0L); Pr( msg, arg1, arg2 );
}
else {
Pr("Error, ",0L,0L); FunPrint( (TypHandle)arg1 );
}
/* print the stack traceback */
if ( HdExec != 0 ) {
if ( HdStat != 0 && SyStrcmp( msg, "FunError" ) != 0 ) {
Pr(" at\n%s", (long)StrStat, 0L );
Print( HdStat );
Pr(" ...",0L,0L);
}
Pr(" in\n",0L,0L);
FunBacktrace( (TypHandle)0 );
}
else {
Pr("\n",0L,0L);
}
/* if requested enter a break loop */
if ( HdExec != 0 && OpenInput( "*errin*" ) ) {
/* first enter all funcdef bags from the exec list onto the */
/* stack, so that we can access args and locals in the loop */
hd = HdExec; TopStack = 0;
while ( hd != 0 && TopStack+1 < SIZE(HdStack)/SIZE_HD ) {
++TopStack;
hd = PTR(hd)[4];
}
hd = HdExec; i = 0;
while ( hd != 0 && TopStack-i+1 > 0 ) {
++i;
PTR(HdStack)[TopStack-i+1] = PTR(hd)[2];
hd = PTR(hd)[4];
}
/* now enter a read-eval-print loop, just as in main */
while ( Symbol != S_EOF ) {
/* read an expression */
Prompt = "brk> ";
EnterKernel();
NrError = 0;
hd = ReadIt();
/* if there we no syntax error evaluate the expression */
if ( hd != 0 ) {
SyIsIntr();
hd = EVAL( hd );
if ( hd == HdReturn && PTR(hd)[0] != HdReturn ) {
while ( TopStack >= 1 )
PTR(HdStack)[TopStack--] = 0;
ExitKernel( hd );
ignore = CloseInput();
ignore = CloseOutput();
return PTR(hd)[0];
}
else if ( hd == HdReturn ) {
hd = HdVoid;
Symbol = S_EOF;
}
/* assign the value to 'last' and then print it */
if ( TYPE(hd) != T_VOID ) {
PTR(HdLast)[0] = hd;
if ( *In != ';' ) {
Print( hd );
Pr("\n",0L,0L);
}
}
}
ExitKernel( (TypHandle)0 );
}
/* remove function definitions from the stack and close "*errin*" */
while ( TopStack >= 1 )
PTR(HdStack)[TopStack--] = 0;
ignore = CloseInput();
}
/* call ExitKernel(2) to clear new handles bag */
ExitKernel( (TypHandle)2 );
while ( HdExec != 0 ) ChangeEnv( PTR(HdExec)[4] );
/* close "*errout*" and return to the main read-eval-print loop */
while ( CloseOutput() ) ;
while ( CloseInput() ) ;
longjmp( ErrRet, 1 );
return 0; /* just to please lint ... */
}
/****************************************************************************
**
*F FunIgnore( <hdCall> ) . . . . . . . . . . . . internal function 'Ignore'
**
** 'FunIgnore' implements the internal function 'Ignore'.
**
** 'Ignore( <arg1>, <arg2>, ... )'
**
** 'Ignore' ignores all its arguments, it does not even evaluate them. So
** for tracing a GAP function, use a function 'InfoSomething' which either
** has value 'Print' and prints its arguments or has value 'Ignore' and does
** nothing at all.
*/
TypHandle FunIgnore( hdCall )
TypHandle hdCall;
{
return HdVoid;
}
/****************************************************************************
**
*F FunError( <hdCall> ) . . . . . . . . . . . . . internal function 'Error'
**
** 'FunError' implements the internal function 'Error'.
**
** 'Error( <arg1>, <arg2>,... )'
**
** raises an error.
** ...A lot of bla about errors and break loops...
**
** 'FunError' simply calls the GAP kernel function 'Error', which knows
** that it has been called from 'FunError' because the format argument is
** 'FunError'. 'FunError' passes <hdCall> as the first extra argument.
*/
TypHandle FunError ( hdCall )
TypHandle hdCall;
{
return Error("FunError", (long)hdCall, 0L );
}
/****************************************************************************
**
*F FunWindowCmd( <hdCall> ) . . . . . . . . . . . execute a window command
*/
TypHandle FunWindowCmd ( hdCall )
TypHandle hdCall;
{
TypHandle hdStr;
TypHandle hdTmp;
TypHandle hdCmd;
TypHandle hdLst;
long len;
long n, m;
long i;
char * ptr;
char * qtr;
/* check arguments */
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error( "usage: WindowCmd( <cmds> )", 0L, 0L );
hdCmd = EVAL(PTR(hdCall)[1]);
if ( !IsList(hdCmd) )
return Error( "usage: WindowCmd( <cmds> )", 0L, 0L );
hdTmp = ELM_LIST(hdCmd,1);
if ( TYPE(hdTmp) != T_STRING )
return Error( "<cmd> must be a string", 0L, 0L );
if ( SIZE(hdTmp) != 4 )
return Error( "<cmd> is not a valid command", 0L, 0L );
/* compute size needed to store argument string */
len = 13;
hdLst = NewBag( T_LIST, (LEN_LIST(hdCmd)+1)*SIZE_HD );
for ( i = LEN_LIST(hdCmd); 1 < i; i-- )
{
hdTmp = ELM_LIST(hdCmd,i);
if ( TYPE(hdTmp) != T_INT && ! IsString(hdTmp) )
return Error("%d.th argument must be a string or integer",i,0L);
PTR(hdLst)[i] = hdTmp;
if ( TYPE(hdTmp) == T_INT )
len += 12;
else
len += 5 + 2*SIZE(hdTmp);
}
/* convert <hdCall> into an argument string */
hdStr = NewBag( T_STRING, len + 13 );
ptr = (char*) PTR(hdStr);
*ptr = '\0';
/* first the command name */
SyStrncat( ptr, (char*)PTR(ELM_LIST(hdCmd,1)), 3 );
ptr += 3;
/* and at last the arguments */
for ( i = 2; i < SIZE(hdLst)/SIZE_HD; i++ )
{
hdTmp = PTR(hdLst)[i];
if ( TYPE(hdTmp) == T_INT )
{
*ptr++ = 'I';
m = HD_TO_INT(hdTmp);
for ( m = (m<0)?-m:m; 0 < m; m /= 10 )
*ptr++ = (m%10) + '0';
if ( HD_TO_INT(hdTmp) < 0 )
*ptr++ = '-';
else
*ptr++ = '+';
}
else
{
*ptr++ = 'S';
m = SIZE(hdTmp)-1;
for ( n = 7; 0 <= n; n--, m /= 10 )
*ptr++ = (m%10) + '0';
qtr = (char*) PTR(hdTmp);
for ( m = SIZE(hdTmp)-1; 0 < m; m-- )
*ptr++ = *qtr++;
}
}
*ptr = 0;
/* compute correct length of argument string */
qtr = (char*) PTR(hdStr);
len = (long)(ptr - qtr);
/* now call the window front end with the argument string */
ptr = SyWinCmd( qtr, len );
len = SyStrlen(ptr);
/* now convert result back into a list */
hdLst = NewBag( T_LIST, SIZE_PLEN_PLIST(11) );
SET_LEN_PLIST( hdLst, 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( hdLst, i, INT_TO_HD(n) );
}
else if ( *ptr == 'S' )
{
ptr++;
for ( n = 0, m = 7; 0 <= m; m-- )
n = n*10 + (ptr[m]-'0');
hdTmp = NewBag( T_STRING, n+1 );
*(char*)PTR(hdTmp) = '\0';
ptr += 8;
SyStrncat( (char*)PTR(hdTmp), ptr, n );
ptr += n;
len -= n+9;
AssPlist( hdLst, i, hdTmp );
}
else
return Error( "unknown return value '%s'", (long)ptr, 0 );
i++;
}
/* if the first entry is one signal an error */
if ( ELM_LIST(hdLst,1) == INT_TO_HD(1) )
{
hdStr = NewBag( T_STRING, 30 );
SyStrncat( (char*) PTR(hdStr), "window system: ", 15 );
SET_ELM_PLIST( hdLst, 1, hdStr );
Resize( hdLst, i*SIZE_HD );
return Error( "FunError", (long)hdLst, 0L );
}
else
{
for ( m = 1; m <= i-2; m++ )
SET_ELM_PLIST( hdLst,m, ELM_LIST(hdLst,m+1) );
SET_LEN_PLIST( hdLst, i-2 );
return hdLst;
}
}
/****************************************************************************
**
*F FunREAD( <hdCall> ) . . . . . . . . . . . . . . internal function 'READ'
**
** 'FunREAD' implements the internal function 'READ'.
**
** 'READ( <filename> )'
**
** 'READ' instructs GAP to read from the file with the name <filename>. If
** it is not found or could not be opened for reading 'false' is returned.
** If the file is found GAP reads all expressions and statements from this
** file and evaluates respectively executes them and finally returns 'true'.
** Then GAP continues evaluation or execution of what it was doing before.
** 'READ' can be nested, i.e., it is legal to execute a 'READ' function call
** in a file that is read with 'READ'.
**
** If a syntax error is found 'READ' continues reading the next expression
** or statement, just as GAP would in the main read-eval-print loop.
** If an evaluation error occurs, 'READ' enters a break loop. If you 'quit'
** this break loop, control returns to the main read-eval-print loop and
** reading of <filename> terminates.
**
** Note that this function is a helper function for 'Read', which behaves
** similar, but causes an error if a file is not found. 'READ' could also
** be used for a 'ReadLib' which searches for a file in various directories.
*/
TypHandle FunREAD ( hdCall )
TypHandle hdCall;
{
TypHandle hd, hdName, hdOld;
/* check the number and type of arguments */
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: READ( <filename> )",0L,0L);
hdName = EVAL( PTR(hdCall)[1] );
if ( ! IsString(hdName) )
return Error("usage: READ( <filename> )",0L,0L);
/* try to open the given file, if the file is not found return 'false' */
if ( ! OpenInput( (char*)PTR(hdName) ) )
return HdFalse;
/* now comes a read-eval-noprint loop, similar to the one in 'main' */
hdOld = HdExec; HdExec = 0;
while ( Symbol != S_EOF ) {
EnterKernel();
hd = ReadIt();
if ( hd != 0 ) hd = EVAL( hd );
if ( hd == HdReturn && PTR(hd)[0] != HdReturn )
return Error("READ: 'return' must not be used here",0L,0L);
else if ( hd == HdReturn )
return Error("READ: 'quit' must not be used here",0L,0L);
ExitKernel( (TypHandle)0 );
}
HdExec = hdOld;
/* close the input file again, and return 'true' */
if ( ! CloseInput() )
Error("READ: can not close input, this should not happen",0L,0L);
return HdTrue;
}
/****************************************************************************
**
*F FunAUTO( <hdCall> ) . . . . . . . . . . . . . . internal function 'AUTO'
**
** 'FunAUTO' implements the internal function 'AUTO'.
**
** 'AUTO( <expression>, <var1>, <var2>,... )'
**
** 'AUTO' associates the expression <expression> with the variables <var1>,
** <var2> etc. Whenever one those variables is evaluated, i.e., when its
** value is required, <expression> is automatically evaluated. This must
** assign a new value to the variable, otherwise an error is raised. The
** new value is then returned.
**
** Here is an example of the most important special usage of 'AUTO':
**
** | AUTO( ReadLib("integer"), Int, Abs, Sign, Maximum, Minimum ); |
**
** When one of the variables, 'Int', 'Abs', etc., is evaluated the libary
** file 'integer.g' is automatically read. This then defines the functions.
** This makes it possible to load the library function only on demand.
**
** 'AUTO' is a procedure, i.e., does not return a value.
*/
TypHandle FunAUTO ( hdCall )
TypHandle hdCall;
{
TypHandle hdExpr, hdVar;
long i;
/* check the number of arguments */
if ( SIZE(hdCall) < 3 * SIZE_HD )
return Error("usage: AUTO( <expr>, <var>, <var>... )",0L,0L);
/* get the expression */
hdExpr = PTR(hdCall)[1];
/* for all remaining arguments */
for ( i = 2; i < SIZE(hdCall)/SIZE_HD; ++i ) {
hdVar = PTR(hdCall)[i];
/* check that they are variables */
if ( TYPE(hdVar) != T_VAR && TYPE(hdVar) != T_VARAUTO )
return Error("usage: AUTO( <expr>, <var>, <var>... )",0L,0L);
/* turn them into automatic variables and bind them to <expr> */
Retype( hdVar, T_VARAUTO );
PTR(hdVar)[0] = hdExpr;
}
return HdVoid;
}
/****************************************************************************
**
** FunPrint( <hdCall> ) . . . . . . . . . . . . . internal function 'Print'
**
** 'FunPrint' implements the internal function 'Print'.
**
** 'Print( <obj1>, <obj2>... )'
**
** 'Print' prints the objects <obj1>, <obj2>, etc. one after the other.
** Strings are printed without the double quotes and special characters are
** not escaped, e.g., '\n' is printed as <newline>. This makes a limited
** amount of formatting possible. Functions are printed in the full form,
** i.e., with the function body, not in the abbreviated form.
**
** 'Print' is a procedure, i.e., does not return a value.
**
** Note that an empty string literal '""' prints empty (remember strings are
** printed without the double quotes), while an empty list '[]' prints as
** '[ ]'.
**
** gap> s := "";; l := [];; s = l;
** gap> Print( s, "\n", l, "\n" );
**
** [ ]
**
** To achieve this 'Print' must be able to distinguish between empty string
** literals and other empty lists. For that it relies on 'IsString' *not*
** to convert empty lists to type 'T_STRING'. This is ugly.
*/
TypHandle FunPrint ( hdCall )
TypHandle hdCall;
{
TypHandle hd;
long i;
/* print all the arguments, take care of strings and functions */
for ( i = 1; i < SIZE(hdCall)/SIZE_HD; ++i ) {
hd = EVAL( PTR(hdCall)[i] );
if ( IsString( hd ) && TYPE(hd) == T_STRING ) PrintString( hd );
else if ( TYPE( hd ) == T_MAKEFUNC ) PrintFunction( hd );
else if ( TYPE( hd ) == T_FUNCTION ) PrintFunction( hd );
else if ( TYPE( hd ) != T_VOID ) Print( hd );
else hd = Error("function must return a value",0L,0L);
}
return HdVoid;
}
/****************************************************************************
**
*F FunPrntTo( <hdCall> ) . . . . . . . . . . . . internal function 'PrintTo'
**
** 'FunPrntTo' implements the internal function 'PrintTo'. The stupid name
** is neccessary to avoid a name conflict with 'FunPrint'.
**
** 'PrintTo( <filename>, <obj1>, <obj2>... )'
**
** 'PrintTo' prints the objects <obj1>, <obj2>, etc. to the file with the
** name <filename>.
**
** 'PrintTo' works as follows. It opens the file with the name <filename>.
** If the file does not exist it is created, otherwise it is truncated.
** If you do not want to truncate the file use 'AppendTo' (see "AppendTo").
** After opening the file 'PrintTo' evaluates its arguments in turn and
** prints the values to <filename>. Finally it closes the file again.
** During evaluation of the arguments <filename> is the current output file.
** This means that output printed with 'Print' during the evaluation, for
** example to inform the user about the progress, also goes to <filename>.
** To make this feature more useful 'PrintTo' will silently ignore if one of
** the arguments is a procedure call, i.e., does not return a value.
**
** 'PrintTo' is a procedure, i.e., does not return a value.
**
** See the note about empty string literals and empty lists in 'Print'.
*/
TypHandle FunPrntTo ( hdCall )
TypHandle hdCall;
{
TypHandle hd;
long i;
/* check the number and type of the arguments, nothing special */
if ( SIZE(hdCall) == SIZE_HD )
return Error("usage: PrintTo( <file>, <obj>, <obj>... )",0L,0L);
hd = EVAL( PTR(hdCall)[1] );
if ( ! IsString(hd) )
return Error("usage: PrintTo( <file>, <obj>, <obj>... )",0L,0L);
/* try to open the given output file, raise an error if you can not */
if ( OpenOutput( (char*)PTR(hd) ) == 0 )
return Error("PrintTo: can not open the file for writing",0L,0L);
/* print all the arguments, take care of strings and functions */
for ( i = 2; i < SIZE(hdCall)/SIZE_HD; ++i ) {
hd = EVAL( PTR(hdCall)[i] );
if ( IsString( hd ) && TYPE(hd) == T_STRING ) PrintString( hd );
else if ( TYPE( hd ) == T_MAKEFUNC ) PrintFunction( hd );
else if ( TYPE( hd ) == T_FUNCTION ) PrintFunction( hd );
else if ( TYPE( hd ) != T_VOID ) Print( hd );
else Pr("",0L,0L);
}
/* close the output file again, and return nothing */
if ( ! CloseOutput() )
Error("PrintTo: can not close output, this should not happen",0L,0L);
return HdVoid;
}
/****************************************************************************
**
*F FunAppendTo( <hdCall> ) . . . . . . . . . . internal function 'AppendTo'
**
** 'FunAppendTo' implements the internal function 'AppendTo'.
**
** 'AppendTo( <filename>, <obj1>, <obj2>... )'
**
** 'AppendTo' appends the obejcts <obj1>, <obj2>, etc. to the file with the
** name <filename>. 'AppendTo' works like 'PrintTo' (see "PrintTo") except
** that it does not truncate the file if it exists.
**
** 'AppendTo' is a procedure, i.e., does not return a value.
**
** See the note about empty string literals and empty lists in 'Print'.
*/
TypHandle FunAppendTo ( hdCall )
TypHandle hdCall;
{
TypHandle hd;
long i;
/* check the number and type of the arguments, nothing special */
if ( SIZE(hdCall) == SIZE_HD )
return Error("usage: AppendTo( <file>, <obj>, <obj>... )",0L,0L);
hd = EVAL( PTR(hdCall)[1] );
if ( ! IsString(hd) )
return Error("usage: AppendTo( <file>, <obj>, <obj>... )",0L,0L);
/* try to open the given output file, raise an error if you can not */
if ( OpenAppend( (char*)PTR(hd) ) == 0 )
return Error("AppendTo: can not open the file for appending",0L,0L);
/* print all the arguments, take care of strings and functions */
for ( i = 2; i < SIZE(hdCall)/SIZE_HD; ++i ) {
hd = EVAL( PTR(hdCall)[i] );
if ( IsString( hd ) && TYPE(hd) == T_STRING ) PrintString( hd );
else if ( TYPE( hd ) == T_MAKEFUNC ) PrintFunction( hd );
else if ( TYPE( hd ) == T_FUNCTION ) PrintFunction( hd );
else if ( TYPE( hd ) != T_VOID ) Print( hd );
else Pr("",0L,0L);
}
/* close the output file again, and return nothing */
if ( ! CloseOutput() )
Error("AppendTo: can not close output, this should not happen",0L,0L);
return HdVoid;
}
/****************************************************************************
**
*F FunLogTo( <hdCall> ) . . . . . . . . . . . . . internal function 'LogTo'
**
** 'FunLogTo' implements the internal function 'LogTo'.
**
** 'LogTo( <filename> )' \\
** 'LogTo()'
**
** 'LogTo' instructs GAP to echo all input from the standard input files,
** '*stdin*' and '*errin*' and all output to the standard output files,
** '*stdout*' and '*errout*', to the file with the name <filename>.
** The file is created if it does not exist, otherwise it is truncated.
**
** 'LogTo' called with no argument closes the current logfile again, so that
** input from '*stdin*' and '*errin*' and output to '*stdout*' and
** '*errout*' will no longer be echoed to a file.
*/
TypHandle FunLogTo ( hdCall )
TypHandle hdCall;
{
TypHandle hdName;
/* 'LogTo()' */
if ( SIZE(hdCall) == SIZE_HD ) {
if ( ! CloseLog() )
return Error("LogTo: can not close the logfile",0L,0L);
}
/* 'LogTo( <filename> )' */
else if ( SIZE(hdCall) == 2 * SIZE_HD ) {
hdName = EVAL( PTR(hdCall)[1] );
if ( ! IsString(hdName) )
return Error("usage: LogTo() or LogTo( <string> )",0L,0L);
if ( ! OpenLog( (char*)PTR(hdName) ) )
return Error("LogTo: can not log to %s",(long)PTR(hdName),0L);
}
return HdVoid;
}
/****************************************************************************
**
*F FunLogInputTo( <hdCall> ) . . . . . . . . internal function 'LogInputTo'
**
** 'FunLogInputTo' implements the internal function 'LogInputTo'.
**
** 'LogInputTo( <filename> )' \\
** 'LogInputTo()'
**
** LogInputTo' instructs GAP to echo all input from the standard input
** files, '*stdin*' and '*errin*', to the file with the name <filename>.
** The file is created if it does not exist, otherwise it is truncated.
**
** 'LogInputTo' called with no argument closes the current logfile again, so
** that input from '*stdin*' and '*errin*' will no longer be echoed to a
** file.
*/
TypHandle FunLogInputTo ( hdCall )
TypHandle hdCall;
{
TypHandle hdName;
/* 'LogInputTo()' */
if ( SIZE(hdCall) == SIZE_HD ) {
if ( ! CloseInputLog() )
return Error("LogInputTo: can not close the logfile",0L,0L);
}
/* 'LogInputTo( <filename> )' */
else if ( SIZE(hdCall) == 2 * SIZE_HD ) {
hdName = EVAL( PTR(hdCall)[1] );
if ( ! IsString(hdName) )
return Error("usage: LogInputTo() or LogTo( <string> )",0L,0L);
if ( ! OpenInputLog( (char*)PTR(hdName) ) )
return Error("LogInputTo: cannot log to %s",(long)PTR(hdName),0L);
}
return HdVoid;
}
/****************************************************************************
**
*F FunReadTest( <hdCall> ) . . . . . . . . . . internal function 'ReadTest'
**
** 'FunReadTest' implements the internal function 'ReadTest'.
**
** 'ReadTest( <filename> )'
**
** 'ReadTest' instructs GAP to read test input from the file with the name
** <filename>. If it is not found or could not be opened for reading an
** error is raised. If the file is found GAP reads all expressions and
** statements from this file and evaluates respectively executes them.
** After that GAP continues evaluation or execution of what it was doing
** before. 'ReadTest' can be not nested, i.e., it is not legal to execute a
** 'ReadTest' function call in a file that is read with 'ReadTest'.
**
** Test mode works as follows. If GAP is about to print a line to the
** current output file (or to be more precise to the output file that
** was current when 'ReadTest' was called) this line is compared with the
** next line from the test input file, i.e., the one opened by 'ReadTest'.
** If this line starts with '#>' and the rest of it matches the output line
** the output line is not printed and the input comment line is discarded.
** Otherwise GAP prints the output line and does not discard the input line.
**
** On the other hand if an input line is encountered on the test input that
** starts with '#>' the GAP assumes that this is an expected output line
** that did not appear and echoes this line to the current output file.
**
** The upshot is that you can write test files that consist of alternating
** input and, as '#>' test comment lines the expected output. If GAP
** behaves normal and produces the expected output then nothing is printed.
** But if something goes wrong you see what actually was printed and what
** was expected instead.
**
** As a convention GAP test files should end with a print statement like:
**
** Print("prime 3.002 06-Jul-90 ",Quo(417000000,time)," GAPstones\n");
**
** without a matching '#>' comment line. This tells the user that the test
** file completed and also how much time it took. The constant should be
** such that a VAX 11/780 gets roughly 1000 GAPstones.
**
** If a syntax error is found 'ReadTest' continues reading a next expression
** or statement, just as GAP would in the main read-eval-print loop.
** If an evaluation error occurs, 'ReadTest' enters a break loop, but the
** input for this break loop is taken from the test input file.
*/
TypHandle FunReadTest ( hdCall )
TypHandle hdCall;
{
TypHandle hd, hdName, hdOld;
unsigned long start;
extern char * In;
/* check the number and type of arguments */
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: ReadTest( <filename> )",0L,0L);
hdName = EVAL( PTR(hdCall)[1] );
if ( ! IsString(hdName) )
return Error("usage: ReadTest( <filename> )",0L,0L);
/* try to open the given file, if the file is not found return 'false' */
if ( ! OpenTest( (char*)PTR(hdName) ) )
return Error("ReadTest: file '%s' must exist and be readable\n",
(long)PTR(hdName), 0L );
start = SyTime();
/* now comes a read-eval-print loop, similar to the one in 'main' */
hdOld = HdExec; HdExec = 0;
while ( Symbol != S_EOF ) {
EnterKernel();
hd = ReadIt();
if ( hd != 0 ) {
hd = EVAL( hd );
if ( hd == HdReturn && PTR(hd)[0] != HdReturn )
return Error("ReadTest: 'return' must not be used",0L,0L);
else if ( hd == HdReturn )
return Error("ReadTest: 'quit' must not be used",0L,0L);
PTR(HdTime)[0] = INT_TO_HD( SyTime() - start );
if ( TYPE(hd) != T_VOID ) {
if ( *In != ';' ) {
IsString( hd );
Print( hd );
Pr("\n",0L,0L);
}
}
}
ExitKernel( (TypHandle)0 );
}
HdExec = hdOld;
/* close the input file again, and return 'true' */
if ( ! CloseTest() )
Error("ReadTest: can not close input, this should not happen",0L,0L);
return HdVoid;
}
/****************************************************************************
**
*F FunHelp( <hdCall> ) . . . . . . . . . . . . . . internal function 'Help'
**
** 'FunHelp' implements the internal function 'Help'.
**
** 'Help( <topic> )'
**
** 'Help' prints a section from the on-line documentation about <topic>.
*/
TypHandle FunHelp ( hdCall )
TypHandle hdCall;
{
return Error("Help: not yet implemented",0L,0L);
}
/****************************************************************************
**
*F FunExec( <hdCall> ) . . . . . . . . . . . . . . internal function 'Exec'
**
** 'FunExec' implements the internal function 'Exec'.
**
** 'Exec( <command> )'
**
** 'Exec' passes the string <command> to the command interpreter of the
** operating system. The precise mechanismen of this is system dependent.
** Also operating system dependent are the possible commands.
**
** 'Exec' is a procedure, i.e., does not return a value.
*/
TypHandle FunExec ( hdCall )
TypHandle hdCall;
{
TypHandle hdCmd;
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: Exec( <command> )",0L,0L);
hdCmd = EVAL( PTR(hdCall)[1] );
if ( ! IsString(hdCmd) )
return Error("usage: Exec( <command> )",0L,0L);
SyExec( (char*)PTR(hdCmd) );
return HdVoid;
}
/****************************************************************************
**
*F FunRuntime( <hdCall> ) . . . . . . . . . . . internal function 'Runtime'
**
** 'FunRuntime' 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.
*/
TypHandle FunRuntime ( hdCall )
TypHandle hdCall;
{
if ( SIZE(hdCall) != SIZE_HD )
return Error("usage: Runtime()",0L,0L);
return INT_TO_HD( SyTime() );
}
/****************************************************************************
**
*F FunSizeScreen( <hdCall> ) . . . . . . . . internal function 'SizeScreen'
**
** 'FunSizeScreen' implements the internal function 'SizeScreen' to get or
** set the actual screen size.
**
** 'SizeScreen()'
**
** In this form 'ScreeSize' 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( [ <x>, <y> ] )'
**
** In this form 'SizeScreen' sets the size of the screen. <x> is the length
** of each line, <y> 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 <x>' and '-y <y>'.
*/
TypHandle FunSizeScreen ( hdCall )
TypHandle hdCall;
{
TypHandle hdSize; /* argument and result list */
long len; /* length of lines on the screen */
long nr; /* number of lines on the screen */
/* check the arguments */
if ( SIZE(hdCall) != SIZE_HD && SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: SizeScreen() or SizeScreen([<x>,<y>])",0L,0L);
/* no argument is equivalent to the empty list */
if ( SIZE(hdCall) == SIZE_HD ) {
hdSize = NewBag( T_LIST, SIZE_PLEN_PLIST(0) );
SET_LEN_PLIST( hdSize, 0 );
}
/* otherwise check the argument */
else {
hdSize = EVAL( PTR(hdCall)[1] );
if ( ! IS_LIST(hdSize) || 2 < LEN_LIST(hdSize) )
return Error("usage: SizeScreen() or SizeScreen([<x>,<y>])",0L,0L);
}
/* extract the length */
if ( LEN_LIST(hdSize) < 1 || ELMF_LIST(hdSize,1) == 0 ) {
len = SyNrCols;
}
else {
if ( TYPE( ELMF_LIST(hdSize,1) ) != T_INT )
return Error("SizeScreen: <x> must be an integer",0L,0L);
len = HD_TO_INT( ELMF_LIST(hdSize,1) );
if ( len < 20 ) len = 20;
if ( 256 < len ) len = 256;
}
/* extract the number */
if ( LEN_LIST( hdSize ) < 2 || ELMF_LIST(hdSize,2) == 0 ) {
nr = SyNrRows;
}
else {
if ( TYPE( ELMF_LIST(hdSize,2) ) != T_INT )
return Error("SizeScreen: <y> must be an integer",0L,0L);
nr = HD_TO_INT( ELMF_LIST(hdSize,2) );
if ( nr < 10 ) nr = 10;
}
/* set length and number */
SyNrCols = len;
SyNrRows = nr;
/* make and return the size of the screen */
hdSize = NewBag( T_LIST, SIZE_PLEN_PLIST(2) );
SET_LEN_PLIST( hdSize, 2 );
SET_ELM_PLIST( hdSize, 1, INT_TO_HD(len) );
SET_ELM_PLIST( hdSize, 2, INT_TO_HD(nr) );
return hdSize;
}
/****************************************************************************
**
*F FunTmpName( <hdCall> ) . . . . . . . . . . . internal function 'TmpName'
**
** 'TmpName()' returns a file names that can safely be used for a temporary
** file. It returns 'false' in case of failure.
*/
TypHandle FunTmpName ( hdCall )
TypHandle hdCall;
{
TypHandle hdStr;
char * str;
if ( SIZE(hdCall) != SIZE_HD )
return Error( "usage: TmpName()", 0L, 0L );
str = SyTmpname();
if ( str == (char*)0 )
return HdFalse;
hdStr = NewBag( T_STRING, SyStrlen(str)+1 );
*((char*)PTR(hdStr)) = 0;
SyStrncat( (char*)PTR(hdStr), str, SyStrlen(str) );
return hdStr;
}
/****************************************************************************
**
*F FunIsIdentical( <hdCall> ) . . . . . . . internal function 'IsIdentical'
**
** 'FunIsIdentical' implements 'IsIdentical'
*/
TypHandle FunIsIdentical ( hdCall )
TypHandle hdCall;
{
TypHandle hdL;
TypHandle hdR;
if ( SIZE(hdCall) != 3*SIZE_HD )
return Error( "usage: IsIdentical( <l>, <r> )", 0L, 0L );
hdL = EVAL( PTR(hdCall)[1] );
hdR = EVAL( PTR(hdCall)[2] );
if ( TYPE(hdL) < T_LIST && TYPE(hdR) < T_LIST )
return EQ( hdL, hdR );
else if ( TYPE(hdL) < T_LIST || TYPE(hdR) < T_LIST )
return HdFalse;
else
return ( hdL == hdR ) ? HdTrue : HdFalse;
}
/****************************************************************************
**
*F FunHANDLE( <hdCall> ) . . . . . . . . . . . . . expert function 'HANDLE'
**
** 'FunHANDLE' implements the internal function 'HANDLE'.
**
** 'HANDLE( <obj> )'
**
** 'HANDLE' returns the handle of the object <obj> as an integer. It
** exists only for debugging purposes and should only be used by experts.
*/
TypHandle FunHANDLE ( hdCall )
TypHandle hdCall;
{
TypHandle hdHD;
TypHandle hdObj;
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: HANDLE( <obj> )",0L,0L);
hdObj = EVAL( PTR(hdCall)[1] );
hdHD = INT_TO_HD( (long)hdObj );
if ( HD_TO_INT(hdHD) != (long)hdObj )
return Error("HANDLE: %d does not fit into 28 bits",(long)hdObj,0L);
return hdHD;
}
/****************************************************************************
**
*F FunOBJ( <hdCall> ) . . . . . . . . . . . . . . . . expert function 'OBJ'
**
** 'FunOBJ' implements the internal function 'OBJ'.
**
** 'OBJ( <int> )'
**
** 'OBJ' returns the object with the handle given by the integer <int>. It
** is the inverse function to 'HD'. Note that passing an integer to 'OBJ'
** which is not a valid handle is likely to crash GAP. Thus this function
** is only there for debugging purposes and should only be used by experts.
*/
TypHandle FunOBJ ( hdCall )
TypHandle hdCall;
{
TypHandle hdObj;
TypHandle hdHD;
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: OBJ( <hd> )",0L,0L);
hdHD = EVAL( PTR(hdCall)[1] );
if ( TYPE( hdHD ) != T_INT )
return Error("OBJ: <hd> must be a small integer",0L,0L);
hdObj = (TypHandle)HD_TO_INT( hdHD );
return hdObj;
}
/****************************************************************************
**
*F FunTYPE( <hdCall> ) . . . . . . . . . . . . . . . expert function 'TYPE'
**
** 'FunTYPE' implements the internal function 'TYPE'.
**
** 'TYPE( <obj> )'
**
** 'TYPE' returns the type of the object <obj> as a string.
*/
TypHandle FunTYPE ( hdCall )
TypHandle hdCall;
{
TypHandle hdType;
TypHandle hdObj;
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: TYPE( <obj> )",0L,0L);
hdObj = EVAL( PTR(hdCall)[1] );
if ( hdObj == 0 ) {
hdType = NewBag( T_STRING, 5 );
SyStrncat( (char*)PTR(hdType), "null", 4 );
}
else {
hdType = NewBag( T_STRING, SyStrlen(NameType[TYPE(hdObj)])+1 );
SyStrncat( (char*)PTR(hdType), NameType[TYPE(hdObj)],
SyStrlen(NameType[TYPE(hdObj)])+1 );
}
return hdType;
}
/****************************************************************************
**
*F FunSIZE( <hdCall> ) . . . . . . . . . . . . . . . expert function 'SIZE'
**
** 'FunSIZE' implements the internal function 'SIZE'.
**
** 'SIZE( <obj> )'
**
** 'SIZE' returns the size of the object <obj> including all its subobjects.
**
** First the all bags of the object are marked by 'MarkObj' by adding
** 'T_ILLEGAL' to their type. Then 'SizeObj' only counts marked bags and
** unmarks them before recursing to subobjects. This way every bag is only
** counted once, even if it appear several times in the object. This also
** helps to avoid infinite recursion if an object contains itself as
** subobject.
*/
void MarkObj ( hdObj )
TypHandle hdObj;
{
unsigned long i;
/* void and small integers do not have a handle structure */
if ( hdObj == 0 || TYPE(hdObj) == T_INT )
return;
/* do not mark a bag twice */
if ( T_ILLEGAL <= TYPE(hdObj) )
return;
/* mark this bag */
hdObj->type += T_ILLEGAL;
/* mark the subobjects */
for ( i = NrHandles( (hdObj->type)-T_ILLEGAL, SIZE(hdObj) ); 0 < i; i-- )
MarkObj( PTR(hdObj)[i-1] );
}
unsigned long SizeObj ( hdObj )
TypHandle hdObj;
{
unsigned long size;
unsigned long i;
/* void and small integers do not use any memory at all */
if ( hdObj == 0 || TYPE(hdObj) == T_INT )
return 0L;
/* do not count unmarked bags */
if ( TYPE(hdObj) < T_ILLEGAL )
return 0L;
/* unmark this bag */
hdObj->type -= T_ILLEGAL;
/* start with the size of this bag */
size = SIZE( hdObj );
/* add the sizes of the subobjects */
for ( i = NrHandles( TYPE(hdObj), SIZE(hdObj) ); 0 < i; i-- )
size += SizeObj( PTR(hdObj)[i-1] );
/* return the size */
return size;
}
TypHandle FunSIZE ( hdCall )
TypHandle hdCall;
{
unsigned long size;
TypHandle hdObj;
if ( SIZE(hdCall) != 2*SIZE_HD )
return Error("usage: SIZE( <obj> )",0L,0L);
hdObj = EVAL( PTR(hdCall)[1] );
MarkObj( hdObj );
size = SizeObj( hdObj );
return INT_TO_HD( size );
}
/****************************************************************************
**
*F FunGASMAN( <hdCall> ) . . . . . . . . . . . . . expert function 'GASMAN'
**
** 'FunGASMAN' implements the internal function 'GASMAN'
**
** 'GASMAN( "display" | "clear" | "collect" | "message" )'
*/
TypHandle FunGASMAN ( hdCall )
TypHandle hdCall;
{
TypHandle hdCmd; /* handle of an argument */
unsigned long i, k; /* loop variables */
/* check the argument */
if ( SIZE(hdCall) == SIZE_HD )
return Error(
"usage: GASMAN( \"display\"|\"clear\"|\"collect\"|\"message\" )",
0L,0L);
/* loop over the arguments */
for ( i = 1; i < SIZE(hdCall)/SIZE_HD; i++ ) {
/* evaluate and check the command */
hdCmd = EVAL( PTR(hdCall)[i] );
if ( ! IsString(hdCmd) )
return Error(
"usage: GASMAN( \"display\"|\"clear\"|\"collect\"|\"message\" )",
0L,0L);
/* if request display the statistics */
if ( SyStrcmp( (char*)PTR(hdCmd), "display" ) == 0 ) {
Pr("\t\t type alive size total size\n",0L,0L);
for ( k = T_VOID; k < T_ILLEGAL-1; k++ ) {
Pr("%24s ", (long)NameType[k], 0L );
Pr("%8d %8d ",(long)GasmanStatAlive[k],
(long)GasmanStatASize[k]);
Pr("%8d %8d\n",(long)GasmanStatTotal[k],
(long)GasmanStatTSize[k]);
}
}
/* if request display the statistics */
else if ( SyStrcmp( (char*)PTR(hdCmd), "clear" ) == 0 ) {
for ( k = T_VOID; k < T_ILLEGAL; k++ ) {
GasmanStatTotal[k] = GasmanStatAlive[k];
GasmanStatTSize[k] = GasmanStatASize[k];
}
}
/* or collect the garbage */
else if ( SyStrcmp( (char*)PTR(hdCmd), "collect" ) == 0 ) {
CollectGarb();
}
/* or finally toggle Gasman messages */
else if ( SyStrcmp( (char*)PTR(hdCmd), "message" ) == 0 ) {
SyGasman = ! SyGasman;
}
/* otherwise complain */
else {
return Error(
"usage: GASMAN( \"display\"|\"clear\"|\"collect\"|\"message\" )",
0L,0L);
}
}
/* return nothing, this function is a procedure */
return HdVoid;
}
/****************************************************************************
**
*F FunCoefficients( <hdCall> ) . . . . . . internal function 'Coefficients'
**
** 'FunCoefficients' implements the internal function 'Coefficients'.
**
** 'Coefficients( <list>, <number> )'
**
*N 15-Jan-91 martin this function should not be here
*N 15-Jan-91 martin this function should not be called 'Coefficients'
*/
TypHandle FunCoefficients ( hdCall )
TypHandle hdCall;
{
long pos, num, val;
TypHandle hdRes, hdList, hdInt;
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error("usage: Coefficients( <list>, <int> )",0L,0L);
hdList = EVAL( PTR(hdCall)[1] );
hdInt = EVAL( PTR(hdCall)[2] );
if ( ! IS_LIST(hdList) || TYPE(hdInt) != T_INT)
return Error("usage: Coefficients( <list>, <int> )",0L,0L);
pos = LEN_LIST( hdList );
hdRes = NewBag( T_LIST, SIZE_PLEN_PLIST( pos ) );
SET_LEN_PLIST( hdRes, pos );
num = HD_TO_INT( hdInt );
if ( num < 0 )
return Error("Coefficients: <int> must be non negative",0L,0L);
while ( 0 < num && 0 < pos ) {
hdInt = ELMF_LIST( hdList, pos );
if ( hdInt == 0 || TYPE( hdInt ) != T_INT )
return Error("Coefficients: <list>[%d] must be a positive integer",
(long)pos,0L);
val = HD_TO_INT(hdInt);
if ( val <= 0 )
return Error("Coefficients: <list>[%d] must be a positive integer",
(long)pos,0L);
SET_ELM_PLIST( hdRes, pos, INT_TO_HD( num % val ) );
pos--;
num /= val;
}
while ( 0 < pos ) {
SET_ELM_PLIST( hdRes, pos, INT_TO_HD( 0 ) );
pos--;
}
return hdRes;
}
/****************************************************************************
**
*F FunNUMBERHANDLES( <hdCall> ) . . . . internal function 'NUMBER_HANDLES'
**
** 'FunNUMBERHANDLES' implements the internal function 'NUMBER_HANDLES'.
**
** 'NUMBER_HANDLES( <type> )'
*/
TypHandle FunNUMBERHANDLES ( hdCall )
TypHandle hdCall;
{
long typ;
TypHandle hdTyp;
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error("usage: NUMBER_HANDLES( <type> )",0L,0L);
hdTyp = EVAL( PTR(hdCall)[1] );
if (TYPE(hdTyp) != T_INT)
return Error("usage: NUMBER_HANDLES( <type> )",0L,0L);
typ = HD_TO_INT( hdTyp );
if (typ < 0 || typ >= T_ILLEGAL)
return Error("NUMBER_HANDLES: <type> must lie in [%d,%d]",
0L,(long)(T_ILLEGAL-1));
return INT_TO_HD( GasmanStatTotal[typ] );
}
/****************************************************************************
**
*F FunSIZEHANDLES( <hdCall> ) . . . . . . internal function 'SIZE_HANDLES'
**
** 'FunSIZEHANDLES' implements the internal function 'SIZE_HANDLES'.
**
** 'SIZE_HANDLES( <type> )'
*/
TypHandle FunSIZEHANDLES ( hdCall )
TypHandle hdCall;
{
long typ;
TypHandle hdTyp;
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error("usage: SIZE_HANDLES( <type> )",0L,0L);
hdTyp = EVAL( PTR(hdCall)[1] );
if (TYPE(hdTyp) != T_INT)
return Error("usage: SIZE_HANDLES( <type> )",0L,0L);
typ = HD_TO_INT( hdTyp );
if (typ < 0 || typ >= T_ILLEGAL)
return Error("SIZE_HANDLES: <type> must lie in [%d,%d]",
0L,(long)(T_ILLEGAL-1));
return INT_TO_HD( GasmanStatTSize[typ] );
}
/****************************************************************************
**
*F InitGap( <argc>, <argv> ) . . . . . . . . . . . . . . . . initializes GAP
**
** 'InitGap' initializes GAP.
*/
void InitGap ( argc, argv )
int argc;
char * argv [];
{
TypHandle hd;
long i;
long ignore;
char * version;
/* initialize all subpackages of GAP */
InitSystem( argc, argv );
InitScanner();
InitGasman();
InitIdents();
InitEval();
/* create the variables last, last2, last3 */
HdLast = FindIdent( "last" );
HdLast2 = FindIdent( "last2" );
HdLast3 = FindIdent( "last3" );
HdTime = FindIdent( "time" );
hd = FindIdent( "VERSRC" );
version = "v3r4p0 1994/07/10";
PTR(hd)[0] = NewBag( T_STRING, SyStrlen(version)+1 );
SyStrncat( (char*)PTR(PTR(hd)[0]), version, SyStrlen(version)+1 );
hd = FindIdent( "VERSYS" );
version = SyFlags;
PTR(hd)[0] = NewBag( T_STRING, SyStrlen(version)+1 );
SyStrncat( (char*)PTR(PTR(hd)[0]), version, SyStrlen(version)+1 );
hd = FindIdent( "LIBNAME" );
PTR(hd)[0] = NewBag( T_STRING, (unsigned long)(SyStrlen(SyLibname)+1) );
SyStrncat( (char*)PTR(PTR(hd)[0]), SyLibname, SyStrlen(SyLibname) );
hd = FindIdent( "QUIET" );
if ( SyQuiet ) PTR(hd)[0] = HdTrue;
else PTR(hd)[0] = HdFalse;
hd = FindIdent( "BANNER" );
if ( SyBanner ) PTR(hd)[0] = HdTrue;
else PTR(hd)[0] = HdFalse;
/* install all internal function from this package */
InstIntFunc( "Ignore", FunIgnore );
InstIntFunc( "Error", FunError );
InstIntFunc( "Backtrace", FunBacktrace );
InstIntFunc( "WindowCmd", FunWindowCmd );
InstIntFunc( "READ", FunREAD );
InstIntFunc( "AUTO", FunAUTO );
InstIntFunc( "Print", FunPrint );
InstIntFunc( "PrintTo", FunPrntTo );
InstIntFunc( "AppendTo", FunAppendTo );
InstIntFunc( "LogTo", FunLogTo );
InstIntFunc( "LogInputTo", FunLogInputTo );
InstIntFunc( "ReadTest", FunReadTest );
InstIntFunc( "Help", FunHelp );
InstIntFunc( "Exec", FunExec );
InstIntFunc( "Runtime", FunRuntime );
InstIntFunc( "SizeScreen", FunSizeScreen );
InstIntFunc( "TmpName", FunTmpName );
InstIntFunc( "IsIdentical", FunIsIdentical );
InstIntFunc( "HANDLE", FunHANDLE );
InstIntFunc( "OBJ", FunOBJ );
InstIntFunc( "TYPE", FunTYPE );
InstIntFunc( "SIZE", FunSIZE );
InstIntFunc( "GASMAN", FunGASMAN );
InstIntFunc( "NUMBER_HANDLES", FunNUMBERHANDLES );
InstIntFunc( "SIZE_HANDLES", FunSIZEHANDLES );
/*N 15-Jan-91 martin this function should not be here */
InstIntFunc( "CoefficientsInt", FunCoefficients );
/* read all init files, stop doing so after quiting from Error */
if ( ! setjmp( ErrRet ) ) {
for ( i=0; i<sizeof(SyInitfiles)/sizeof(SyInitfiles[0]); ++i ) {
if ( SyInitfiles[i][0] != '\0' ) {
if ( OpenInput( SyInitfiles[i] ) ) {
while ( Symbol != S_EOF ) {
EnterKernel();
hd = ReadIt();
if ( hd != 0 ) hd = EVAL( hd );
if ( hd == HdReturn && PTR(hd)[0] != HdReturn )
Error("Read: 'return' must not be used",0L,0L);
else if ( hd == HdReturn )
Error("Read: 'quit' must not be used",0L,0L);
ExitKernel( (TypHandle)0 );
}
ignore = CloseInput();
}
else {
Error("can't read from \"%s\"",(long)SyInitfiles[i],0L);
}
}
}
}
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.