The Fred Fish Collection 1.5

home *** CD-ROM | disk | FTP | other *** search

/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_c / schem2c1.lzh / Scheme2C / Scheme-src.lzh / scrt / objects.h < prev next >

Wrap

C/C++ Source or Header | 1991-10-11 | 35.8 KB | 1,170 lines

/* SCHEME->C */ /* Copyright 1989 Digital Equipment Corporation * All Rights Reserved * * Permission to use, copy, and modify this software and its documentation is * hereby granted only under the following terms and conditions. Both the * above copyright notice and this permission notice must appear in all copies * of the software, derivative works or modified versions, and any portions * thereof, and both notices must appear in supporting documentation. * * Users of this software agree to the terms and conditions set forth herein, * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free * right and license under any changes, enhancements or extensions made to the * core functions of the software, including but not limited to those affording * compatibility with other hardware or software environments, but excluding * applications which incorporate this software. Users further agree to use * their best efforts to return to Digital any such changes, enhancements or * extensions that they make and inform Digital of noteworthy uses of this * software. Correspondence should be provided to Digital at: * * Director of Licensing * Western Research Laboratory * Digital Equipment Corporation * 100 Hamilton Avenue * Palo Alto, California 94301 * * This software may be distributed (but not offered for sale or transferred * for compensation) to third parties, provided such third parties agree to * abide by the terms and conditions of this notice. * * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS * SOFTWARE. */ /* This module defines the basic data objects and their associated functions. */ /* Default the value of CPUTYPE if not currently defined. */ #ifndef MIPS #ifndef TITAN #ifndef VAX #ifndef SPARC #ifndef SUN3 #ifndef I386 #ifndef APOLLO #ifndef PRISM #ifdef mips #define MIPS 1 #endif #ifdef titan #define TITAN 1 #endif #ifdef vax #define VAX 1 #endif #ifdef sun # ifdef sparc # define SPARC 1 # else # ifdef mc68000 # define SUN3 1 # endif # endif #endif #ifdef i386 #define I386 1 #endif #ifdef apollo # ifdef _ISP_A88K # define PRISM 1 # else # define APOLLO 1 # endif #endif #endif /* PRISM */ #endif /* APOLLO */ #endif /* I386 */ #endif /* SUN3 */ #endif /* SPARC */ #endif /* VAX */ #endif /* TITAN */ #endif /* MIPS */ /* The Scheme->C installer may elect to have arithmetic overflow handled gracefully on either the MIPS or the VAX implementations. The default is to handle it. */ #ifndef MATHTRAPS #define MATHTRAPS 1 #endif /* A machine dependent definition: the setjmp/longjmp buffer. */ #ifdef MIPS #include <setjmp.h> #define CPUTYPE MIPS #define DOUBLE_ALIGN 1 #endif #ifdef TITAN #include <setjmp.h> #define CPUTYPE TITAN #undef MATHTRAPS #endif #ifdef VAX typedef int jmp_buf[ 16 ]; /* The buffer contains the following items: R2-R11 saved registers SIGM saved signal mask SP stack pointer on entry to setjmp PSW PSW word from stack frame AP saved argument ptr from frame FP saved frame ptr from frame PC saved program cntr from frame */ #define CPUTYPE VAX #endif #ifdef AMIGA #include <setjmp.h> #define NO_RUSAGE #define BIG_ENDIAN #undef DOUBLE_ALIGN #undef SHORTFLOAT #undef MATHTRAPS #define MATHTRAPS 0 #endif #ifdef APOLLO #include <setjmp.h> #define CPUTYPE APOLLO #define BIG_ENDIAN #endif #ifdef PRISM /* Use our own setjmp/longjmp so we can make sure all the registers are saved that need to be saved, namely, .10 through .23, plus the signal mask, return PC, and PSWs. The layout of these registers in the array is described in prism.asm. */ typedef int jmp_buf[18]; #define CPUTYPE PRISM #define BIG_ENDIAN #endif #ifdef SPARC typedef int jmp_buf[2+7+8+8+1]; #define DOUBLE_ALIGN 1 #define CPUTYPE SPARC #define BIG_ENDIAN #undef MATHTRAPS #define MATHTRAPS 0 #endif #ifdef SUN3 #include <setjmp.h> #define CPUTYPE SUN3 #define BIG_ENDIAN #undef MATHTRAPS #define MATHTRAPS 0 #endif #ifdef I386 #include <setjmp.h> #define CPUTYPE I386 #undef MATHTRAPS #define MATHTRAPS 0 #endif #ifdef SYSV #define NO_RUSAGE #endif /* The data encoding scheme is similar to that used by Vax NIL and T, where all objects are represented by 32-bit pointers, with a "low tag" encoded in the two least significant bits encoding the type. All objects are multiples of 32-bits and must be allocated on word boundaries. The basic data object is a "Scheme to C Object", or SCOBJ. It is defined by the following UNION type. In addition, the following types are also defined: SCP pointer to a SCOBJ. TSCP tagged pointer to a SCOBJ PATSCP pointer to an array of TSCP's. TSCPP function which returns a TSCP as its value. The most common type conversion is that which converts SCP's and TSCP's. It is done by the following: U_T( tsp, tag ) convert Untagged SCP to a Tagged TSCP. U_TX( tsp ) convert Untagged SCP to an Extended Tagged TSCP. U_TP( tsp ) convert Untagged SCP to an Pair Tagged TSCP. T_U( tscp ) convert Tagged TSCP to an Untagged SCP. TX_U( tscp ) convert Tagged eXtended pointer to an Untagged SCP. TP_U( tscp ) convert Tagged Pair pointer to an Untagged SCP. */ struct STACKTRACE; /* Ugly, but machine independent way to declare and use bit fields: Bit fields are declared using F?(...), where the least significant fields are listed first (in honor of the original implementations). Similarly, static objects are created with the U?(...) macros. */ #ifdef BIG_ENDIAN #define F2(a,b) b;a #define F3(a,b,c) c;b;a #define U2(a,b) (b),(a) #define U3(a,b,c) (c),(b),(a) #else #define F2(a,b) a;b #define F3(a,b,c) a;b;c #define U2(a,b) (a),(b) #define U3(a,b,c) (a),(b),(c) #endif typedef char *TSCP; typedef union SCOBJ { /* SCHEME to C OBJECT */ struct { /* as an unsigned value */ unsigned gned; } unsi; struct { /* EXTENDEDOBJ */ F2(unsigned tag:8, unsigned rest:24); } extendedobj; struct { /* SYMBOL */ F2(unsigned tag:8, unsigned rest:24); TSCP name; TSCP *ptrtovalue; TSCP value; TSCP propertylist; } symbol; struct { /* STRING */ F2(unsigned tag:8, unsigned length:24); char char0; } string; struct { /* VECTOR */ F2(unsigned tag:8, unsigned length:24); TSCP element0; } vector; struct { /* PROCEDURE */ F3(unsigned tag:8, unsigned required:8, unsigned optional:16); TSCP (*code)(); TSCP closure; } procedure; struct { /* CLOSURE */ F2(unsigned tag:8, unsigned length:24); TSCP closure; TSCP var0; } closure; struct { /* CONTINUATION */ F2(unsigned tag:8, unsigned length:24); TSCP continuation; jmp_buf savedstate; int *address; struct STACKTRACE* stacktrace; int word0; } continuation; struct { /* FLOAT32 */ F2(unsigned tag:8, unsigned rest:24); float value; } float32; struct { /* FLOAT64 */ F2(unsigned tag:8, unsigned rest:24); double value; } float64; struct { /* FORWARD */ F2(unsigned tag:8, unsigned length:24); TSCP forward; } forward; struct { /* WORDALIGN */ F2(unsigned tag:8, unsigned length:24); } wordalign; struct { /* PAIR */ TSCP car; TSCP cdr; } pair; } *SCP; typedef TSCP *PATSCP; /* POINTER to ARRAY of TAGGED SCHEME to C POINTERs */ typedef TSCP (*TSCPP)(); /* TAGGED SCHEME to C POINTER returning PROCEDURE */ #define TAGMASK 3 #define TSCPTAG( x ) ((int)x & TAGMASK) #define U_T( scp, tag ) ((TSCP)((char*)(scp)+tag)) #define U_TX( scp ) ((TSCP)((char*)(scp)+EXTENDEDTAG)) #define U_TP( scp ) ((TSCP)((char*)(scp)+PAIRTAG)) #define T_U( tscp ) ((SCP)((int)(tscp) & (~TAGMASK))) #ifdef MIPS #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif #ifdef TITAN #define TX_U( tscp ) ((SCP)tscp) #define TP_U( tscp ) ((SCP)tscp) #endif #ifdef VAX #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif #ifdef apollo #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif #ifdef SPARC #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif #ifdef SUN3 #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif #ifdef AMIGA #define TX_U( tscp ) ((SCP)((char*)(tscp)-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)(tscp)-PAIRTAG)) #endif #ifdef I386 #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif /* Fixed point numbers are encoded in the address portion of the pointer. The value is obtained by arithmetically shifting the pointer value two bits to the right. A tag value of 0 is used to allow fixed point numbers to be added and subtracted without any tag extraction and insertion. Note that the define FIXED_C assumes that >> provides an arithmetic right shift. +--------+--------+--------+--------+ |....signed fixed point value.....00| +--------+--------+--------+--------+ */ #define FIXNUMTAG 0 typedef int SCFIXED; /* Scheme to C fixed point number */ #define FIXED_C( x ) (((int)(x))>>2) #define C_FIXED( x ) ((TSCP)((x)<<2)) /* The second type of object is an "extended" object. This is where the pointer points to the header of a multi-word object. +--------+--------+--------+--------+ |........pointer to object........01| +--------+--------+--------+--------+ This header in turn has an immediate tag (tag = 2) and the remaining 6 bits of the first byte define the type of the object as follows. A SYMBOL is represented by: +--------+--------+--------+--------+ | 0 | 0 | 0 |10000010| symbol (tag = 130) +--------+--------+--------+--------+ | symbol name | +--------+--------+--------+--------+ | pointer to value | +--------+--------+--------+--------+ | value | +--------+--------+--------+--------+ | property list | +--------+--------+--------+--------+ where the first word contains the tag. Following the tag is the symbol name. It is a string and is of the form "symbol-name" for top-level symbols and "module-name_symbol-name" for other symbols. Next comes a pointer to the top-level value of the symbol. If the symbol is bound to a compiled global value, then the pointer will point to that value and the following field will not be used. On the other hand, if the symbol is not bound to a compiled global, then the pointer will point to the following word which will hold its value. The final field points to the property list for the symbol. All "interned" symbols are kept in a data structure called the OBARRAY. It is a Scheme array which maintains bucket-hash lists of all allocated symbols. Symbols are created and entered into the data structure by the function "sc_string_2d_3esymbol". A STRING is represented by: +--------+--------+--------+--------+ | length of string |10000110| string (tag = 134) +--------+--------+--------+--------+ | i | r | t | s | +--------+--------+--------+--------+ | - | 0 | g | n | +--------+--------+--------+--------+ where the first word contains the tag and the length (in bytes) of the string. The string storage starts in the next word. Following the last character of the string is a null byte. A VECTOR is represented by: +--------+--------+--------+--------+ | number of elements |10001010| vector (tag = 138) +--------+--------+--------+--------+ | element 0 | +--------+--------+--------+--------+ | element 1 | +--------+--------+--------+--------+ | ... | where the first word contains the tag and the length (in elements) of the vector. The vector storage starts in the next word, where each element is a scheme pointer. A PROCEDURE is represented by: +--------+--------+--------+--------+ | 0 |optional|required|10001110| procedure (tag = 142) +--------+--------+--------+--------+ | code address | +--------+--------+--------+--------+ | pointer to enclosing closure | +--------+--------+--------+--------+ where the first word contains the tag and the argument flags. The optional flag is 0 when the function takes a fixed number of arguments and 1 when it takes a list of optional arguments as its final argument. The required field is the number of required arguments that the function takes. This is followed by the code address and a pointer to the enclosing closure (which may be () or a continuation). A CLOSURE is represented by: +--------+--------+--------+--------+ | # closed values |10010010| closure (tag = 146) +--------+--------+--------+--------+ | pointer to enclosing closure | +--------+--------+--------+--------+ | 1st closed variable | +--------+--------+--------+--------+ | 2nd closed variable | +--------+--------+--------+--------+ | ... | where the first word contains the tag and the number of closed variables. The next word contains a pointer to the enclosing closure (which may be ()) and the closed variables then follow. A CONTINUATION is a formed by CALL-WITH-CURRENT-CONTINUATION. It is represented by: +--------+--------+--------+--------+ | # saved words |10010110| continuation (tag=150) +--------+--------+--------+--------+ | pointer to enclosing continuation | +--------+--------+--------+--------+ . . . state saved by setjmp . . . +--------+--------+--------+--------+ | address of word[0] of saved stack | +--------+--------+--------+--------+ | saved value of sc_stacktrace | +--------+--------+--------+--------+ . . . saved display . . . +--------+--------+--------+--------+ | 1st word of saved stack | +--------+--------+--------+--------+ | 2nd word of saved stack | +--------+--------+--------+--------+ | ... | where the first word contains the tag and the count of the number of words required to hold the continuation (does not include word for pointer to enclosing continuation). The next word contains a pointer to the enclosing continuation (or () if there isn't one). Following this is the state saved by setjmp. The continuation is terminated by the stack address, the value of sc_stacktrace, the saved display, and the saved stack block. Note the contents of any of these saved words may be pointers or derived from pointers. A 32-BIT FLOATING POINT number is represented by: +--------+--------+--------+--------+ | 0 | 0 | 0 |10011010| 32-bit fp (tag = 154) +--------+--------+--------+--------+ | 32-bit floating point value | +--------+--------+--------+--------+ A 64-BIT FLOATING POINT number is represented by: +--------+--------+--------+--------+ | 0 | 0 | 0 |10011110| 64-bit fp (tag = 158) +--------+--------+--------+--------+ | | +-- 64-bit floating point value --+ | | +--------+--------+--------+--------+ A forwarded object (which may be a pair or an extended object) is represented by: +--------+--------+--------+--------+ | word count |10100010| forward (tag = 162) +--------+--------+--------+--------+ | tagged pointer to new copy | +--------+--------+--------+--------+ where the first word contains the tag and the size of the object (in words). The next word contains a Scheme pointer to the new copy of the object. When storage must be allocated to correctly align objects, a wordalign object is allocated: +--------+--------+--------+--------+ | 0 | 0 | 0 |10100110| word align (tag = 166) +--------+--------+--------+--------+ */ #define EXTENDEDTAG 1 #define SYMBOLTAG 130 #define STRINGTAG 134 #define VECTORTAG 138 #define PROCEDURETAG 142 #define CLOSURETAG 146 #define CONTINUATIONTAG 150 #define FLOAT32TAG 154 #define FLOAT64TAG 158 #define FORWARDTAG 162 #define WORDALIGNTAG 166 /* The following definitions define the size in words of each extended object. */ #define SYMBOLSIZE 5 #define STRINGSIZE( x ) ((((x)+4)/4)+1) #define VECTORSIZE( x ) ((x)+1) #define PROCEDURESIZE 3 #define CLOSURESIZE( x ) ((x)+2) #define CONTINUATIONSIZE( x ) ((x)+2) #define FLOAT32SIZE 2 #ifdef DOUBLE_ALIGN #define FLOAT64SIZE 4 #endif #ifndef DOUBLE_ALIGN #define FLOAT64SIZE 3 #endif #define FORWARDSIZE( x ) (x) #define WORDALIGNSIZE 1 /* While the data representation allows for two types of floating point numbers, only one type is actually used. The default is 64-bits, but 32-bit numbers may be selected by defining the flag SHORTFLOAT. */ #ifdef SHORTFLOAT #define FLOATTAG FLOAT32TAG #define FLOATTYPE float #define FLOATUTYPE float32 #define MAKEFLOAT sc_makefloat32 #else #define FLOATTAG FLOAT64TAG #define FLOATTYPE double #define FLOATUTYPE float64 #define MAKEFLOAT sc_makefloat64 #endif /* A pointer that points to an extended object must pass the following test. Note that some things which aren't pointers can pass this test too. The pointer P must be untagged. */ #define EXTENDEDHEADER( p ) ((p->extendedobj.tag >= SYMBOLTAG) && \ (TSCPTAG( p->extendedobj.tag ) == IMMEDIATETAG)) /* The number of closed variables in a contination with 0 saved stack words is NULLCONTINUATIONSIZE. */ #define NULLCONTINUATIONSIZE (sizeof( jmp_buf )/4+2) /* There is one string which is the empty string and one vector which is the empty vector. */ #define EMPTYSTRING sc_emptystring #define EMPTYVECTOR sc_emptyvector extern TSCP sc_emptystring, sc_emptyvector; /* The third type of object is an "immediate" object where the actual object type is encoded in the rest of the pointer. The objects of this type are: +--------+--------+--------+--------+ | 0 | 0 | 0 |00000010| empty list +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00001010| #F +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00001110| #T +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | char |00010010| character +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00010110| eof object +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00011010| undefined +--------+--------+--------+--------+ Tags are allocated with an eye toward null testing. Note that the the boolean #F and the list () are separate objects, but both are treated as false to conform to the Scheme definition. () == 2 == emptylist #F == 10 == falsevalue #T == 14 == truevalue (NOT P) == $1 := P and 247; $1 := $1 =i 2; */ #define IMMEDIATETAG 2 #define IMMEDIATETAGMASK 255 #define EMPTYLIST ((TSCP)2) #define FALSEVALUE ((TSCP)10) #define TRUEVALUE ((TSCP)14) #define CHARACTERTAG 18 #define EOFOBJECT ((TSCP)22) #define UNDEFINED ((TSCP)26) #define C_CHAR( i ) ((TSCP)(((unsigned)( i )<< 8)+CHARACTERTAG)) #define CHAR_C( c ) ((char)(((unsigned)( c )) >> 8)) #define CHAR_FIX( c ) ((TSCP)(((unsigned)( c )) >> 6)) #define FIX_CHAR( fix ) ((TSCP)(((unsigned)( fix ) << 6)+CHARACTERTAG)) #define TSCPIMMEDIATETAG( p ) ((int)(p) & IMMEDIATETAGMASK) extern TSCP sc_emptylist, /* Immediate denoting empty list */ sc_falsevalue, /* Immediate denoting false */ sc_truevalue, /* Immediate denoting true */ sc_eofobject, /* Immediate denoting end-of-file */ sc_undefined; /* Immediate denoting the undefined value */ /* The final type of object is a list cell. The CAR of the cell is a word stored at (pointer), and the CDR of the cell is the next word. +--------+--------+--------+--------+ | CAR of the pair | pair +--------+--------+--------+--------+ | CDR of the pair | +--------+--------+--------+--------+ */ #define PAIRTAG 3 #define CONSSIZE 2 #define CONSBYTES 8 /* Symbols are kept in the "obarray" which is a data structure internal to this module. It is used by SYMBOL->STRING to make symbols unique. */ extern TSCP sc_obarray; /* In order for garbage collection to work correctly, the addresses of all globals containing constants and top level variables must be known. They are maintained in two extensible structures: sc_constants and sc_globals. Entries are added by addtoSCPTRS. */ struct SCPTRS { int count; /* # of pointers in the structure */ int limit; /* # of pointers it could hold */ TSCP *ptrs[ 1 ]; /* pointers */ }; #define sizeofSCPTRS( x ) (sizeof(struct SCPTRS)+sizeof(TSCP)*((x)-1)) extern struct SCPTRS *addtoSCPTRS(); extern struct SCPTRS *sc_constants; extern struct SCPTRS *sc_globals; /* Access to lexically nested variables is via a display maintained by the following data structure. SC_DISPLAY is an array which maintains the display, and SC_MAXDISPLAY is the maximum number of cells in the display that are ever used. */ extern TSCP sc_display[]; extern int sc_maxdisplay; /* Debugging information is kept on the stack in an implementation independent manner by using the following data structures and conventions. When a procedure is entered, it will allocate a STACKTRACE structure on the stack and set SC_STACKTRACE to point to it. The fields in the structure are set as follows: in sceval_exec: in any other procedure: prevstacktrace: previous value of previous value of sc_stacktrace sc_stacktrace procname: current environment string naming the procedure exp: expression being unused interpreted When the procedure is exited, sc_stacktrace is restored. In order to assure that sc_stacktrace always points to a valid entry, the list is maintained by subroutines (compilers want to optimize it out!). In dobacktrace(), the stack is traced by calling C-UNSIGNED-REF to get the prevstacktrace pointer. The problem with this is that C-UNSIGNED-REF (aka scrt4_c_2dunsigned_2dref) uses MUNSIGNED, which uses T_U, which masks out the least significant two bits of the pointer. The trick is to get an implementation independent method of aligning the stacktrace structure. Most compilers at least align the structure with an even address, but only some will align it on a four-byte boundary. The macro ALIGN4(t,x) declares "x" to be a pointer to "t", aligned on a 4-byte boundary. If nothing special needs to be done, then the default definition can be used. */ #ifdef APOLLO /* On an Apollo, things are usually aligned properly on the stack, but after an interrupt, things can get screwy, and even doubles can end up non-longword aligned. To be safe, we need to align everything on a longword boundary ourselves. */ #define IDENT(a) a #define CAT(a,b) IDENT(a)b #define ALIGN4(t,x) char CAT(x,buf)[sizeof(t) + sizeof(long)];\ t& x = * (t*) ((unsigned)CAT(x,buf) & ~(sizeof(long)-1)) #endif /* the rest of the world does not need to worry about such matters */ #ifndef ALIGN4 #define ALIGN4(t,x) t x #endif struct STACKTRACE { /* Stack trace back record */ struct STACKTRACE* prevstacktrace; TSCP procname; TSCP exp; }; extern struct STACKTRACE *sc_stacktrace; #define PUSHSTACKTRACE( procedure ) ALIGN4(struct STACKTRACE, st); \ sc_pushtrace( &st, (procedure) ) #define POPSTACKTRACE( exp ) return( sc_poptrace( &st, (exp) ) ) #define LOOPSTACKTRACE( exp, env ) sc_looptrace( &st, (exp), (env) ) /* The procedural interfaces to this module are: */ extern TSCP sc_make_2dstring_v; extern TSCP sc_make_2dstring(); extern TSCP sc_string_2dcopy_v; extern TSCP sc_string_2dcopy(); extern TSCP sc_cstringtostring(); extern TSCP sc_make_2dvector_v; extern TSCP sc_make_2dvector(); extern TSCP sc_makeclosure(); extern TSCP sc_makeprocedure(); extern void sc_initializevar(); extern void sc_global_TSCP(); extern void sc_constantexp(); extern TSCP sc_string_2d_3esymbol_v; extern TSCP sc_string_2d_3esymbol(); extern TSCP sc_d_2dsymbol_ab4b4447_v; extern TSCP sc_d_2dsymbol_ab4b4447(); extern TSCP sc_uninterned_2dsymbol_3f_v; extern TSCP sc_uninterned_2dsymbol_3f(); extern TSCP sc_clarguments(); extern char sc_tscp_char(); extern int sc_tscp_int(); extern unsigned sc_tscp_unsigned(); extern unsigned sc_tscp_pointer(); extern double sc_tscp_double(); extern TSCP sc_int_tscp(); extern TSCP sc_unsigned_tscp(); extern unsigned sc_procedureaddress(); extern void sc_pushtrace(); extern void sc_looptrace(); extern TSCP sc_poptrace(); /* The definitions which follow are used by the code generated by the Scheme->C compiler. They are included in this file so that only one #include file will be required. */ /* Alternative C access to SCOBJ's */ #define UNSI_GNED( tscp ) (TX_U( tscp )->unsi.gned) #define TSCP_EXTENDEDTAG( tscp ) (TX_U( tscp )->extendedobj.tag) #define SYMBOL_NAME( tscp ) (TX_U( tscp )->symbol.name) #define SYMBOL_VALUEADDR( tscp ) (TX_U( tscp )->symbol.ptrtovalue) #define SYMBOL_VALUE( tscp ) (*TX_U( tscp )->symbol.ptrtovalue) #define SYMBOL_PROPERTYLIST( tscp ) (TX_U( tscp )->symbol.propertylist) #define STRING_LENGTH( tscp ) (TX_U( tscp )->string.length) #define STRING_CHAR( tscp, n ) (*(((unsigned char*)tscp)+FIXED_C( n )+3)) #define VECTOR_LENGTH( tscp ) (TX_U( tscp )->vector.length) #ifdef MIPS #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif #ifdef TITAN #define VECTOR_ELEMENT( tscp, n ) (*(&TX_U( tscp )->vector.element0+ \ FIXED_C( n ))) #endif #ifdef VAX #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif #ifdef apollo #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif #ifdef SPARC #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif #ifdef I386 #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif #ifdef SUN3 #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif #ifdef AMIGA #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif #define PROCEDURE_REQUIRED( tscp ) (TX_U( tscp )->procedure.required) #define PROCEDURE_OPTIONAL( tscp ) (TX_U( tscp )->procedure.optional) #define PROCEDURE_CLOSURE( tscp ) (TX_U( tscp )->procedure.closure) #define PROCEDURE_CODE( tscp ) (TX_U( tscp )->procedure.code) #define CLOSURE_LENGTH( tscp ) (TX_U( tscp )->closure.length) #define CLOSURE_CLOSURE( tscp ) (TX_U( tscp )->closure.closure) #define CLOSURE_VAR( tscp, n ) (*(&TX_U( tscp )->closure.var0+(n))) #define FLOAT_VALUE( tscp ) (TX_U( tscp )->FLOATUTYPE.value) #define PAIR_CAR( tscp ) (TP_U( tscp )->pair.car) #define PAIR_CDR( tscp ) (TP_U( tscp )->pair.cdr) /* C declarations */ #define DEFSTRING( name, chars, len ) \ static struct { F2(unsigned tag:8, \ unsigned length:24); \ char char0[len+(4-(len % 4))]; } \ name = { U2(STRINGTAG, len), chars } #define DEFFLOAT( name, value ) \ static struct { F2(unsigned tag:8, \ unsigned length: 24); \ FLOATTYPE f; } \ name = { U2(FLOATTAG, 0), value } #define DEFTSCP( name ) TSCP name #define DEFSTATICTSCP( name ) static TSCP name #define DEFSTATICTSCP2( name, obj ) static TSCP name = U_TX( &obj ) #define EXTERNTSCP( a ) extern TSCP a #define EXTERNTSCPP( a ) extern TSCP (a)() #define EXTERNINT( a ) extern int a #define EXTERNINTP( a ) extern int (a)() #define EXTERNPOINTER( a ) extern void *a #define EXTERNPOINTERP( a ) extern void *(a)() #define EXTERNCHAR( a ) extern char a #define EXTERNCHARP( a ) extern char (a)() #define EXTERNSHORTINT( a ) extern short int a #define EXTERNSHORTINTP( a ) extern short int (a)() #define EXTERNLONGINT( a ) extern long int a #define EXTERNLONGINTP( a ) extern long int (a)() #define EXTERNUNSIGNED( a ) extern unsigned a #define EXTERNUNSIGNEDP( a ) extern unsigned (a)() #define EXTERNSHORTUNSIGNED( a ) extern unsigned short a #define EXTERNSHORTUNSIGNEDP( a ) extern unsigned short (a)() #define EXTERNLONGUNSIGNED( a ) extern unsigned long a #define EXTERNLONGUNSIGNEDP( a ) extern unsigned long (a)() #define EXTERNFLOAT( a ) extern float a #define EXTERNFLOATP( a ) extern float (a)() #define EXTERNDOUBLE( a ) extern double a #define EXTERNDOUBLEP( a ) extern double (a)() #define EXTERNVOIDP( a ) extern void (a)() #define MAXDISPLAY( a ) if (a > sc_maxdisplay) sc_maxdisplay = a /* C operators */ #define EQ( a, b ) (a == b) #define NEQ( a, b ) (a != b) #define NOT( a ) (a == 0) #define GT( a, b ) (a > b) #define LT( a, b ) (a < b) #define GTE( a, b ) (a >= b) #define LTE( a, b ) (a <= b) #define OR( a, b ) (a || b) #define AND( a, b ) (a && b) #define SET( a, b ) (a = b) #define BITAND( a, b ) (a & b) #define BITOR( a, b ) (a | b) #define BITXOR( a, b ) (a ^ b) #define BITLSH( a, b ) (a << b) #define BITRSH( a, b ) (a >> b) #define PLUS( a, b ) (a + b) #define DIFFERENCE( a, b ) (a - b) #define NEGATE( a ) (- a) #define TIMES( a, b ) (a * b) #define QUOTIENT( a, b ) (a / b) #define REMAINDER( a, b ) (a % b) #define SHORTINT( a ) ((short int) a) #define INT( a ) ((int) a) #define LONGINT( a ) ((long int) a) #define SHORTUNSIGNED( a ) ((unsigned short) a) #define UNSIGNED( a ) ((unsigned) a) #define LONGUNSIGNED( a ) ((unsigned long) a) #define FLOAT( a ) ((FLOATTYPE) a) #define CFLOAT( a ) ((float) a) #define CDOUBLE( a ) ((double) a) #define _TSCP( a ) ((TSCP) a) #define VIA( a ) (*a) #define ADR( a ) (&a) #define DISPLAY( a ) (sc_display[ a ]) /* AmigaOS doesn't do divide-by-zero trapping, so we add it here */ #ifdef AMIGA #undef QUOTIENT #define QUOTIENT(a, b) (b == 0 ? sc_error("?????", "Divide by zero", 0) : (a / b)) #undef REMAINDER #define REMAINDER(a, b) (b == 0 ? sc_error("?????", "Divide by zero", 0) : (a % b)) #endif /* C operators that detect integer overflow in some implementations */ #if (MATHTRAPS == 0 || CPUTYPE == TITAN) #define IPLUS( a, b ) (a + b) #define IDIFFERENCE( a, b ) (a - b) #define INEGATE( a ) (- a) #define ITIMES( a, b ) (a * b) #else #define IPLUS( a, b ) sc_iplus( a, b ) #define IDIFFERENCE( a, b ) sc_idifference( a, b ) #define ITIMES( a, b ) sc_itimes( a, b ) #define INEGATE( a ) sc_inegate( a ) #endif /* Generational garbage collection requires that stores of pointers to new objects in old objects be detected. This is done by requiring the use of the macro SETGEN to set cells in SET-CAR!, SET-CDR!, VECTOR-SET!, PUTPROP, SCHEME-TSCP-SET!, and SET! of lexically bound variables. The macro SETGENTL must be used to set the values of top level variables. N.B. These macros assume a page size of 512 bytes. */ #define SETGEN( a, b ) ((sc_pagelink[ (int)(((unsigned)(&a))>>9) ])?\ (a = b):sc_setgeneration( &a, b )) #define SETGENTL( a, b ) (sc_setgeneration( &a, b )) /* Scheme boolean tests */ #define TRUE( x ) ((((int)(x)) & 247) != 2) #define FALSE( x ) ((((int)(x)) & 247) == 2) /* Short circuiting for procedure application. In order for this code to work correctly, it requires that the tag field be in the least significant 8 bits of the extended object header. */ #define UNKNOWNCALL( proc, argc ) \ (sc_unknownargc = argc, sc_unknownproc[ 1 ] = proc, \ sc_unknownproc[(PROCEDURE_REQUIRED(sc_unknownproc[ TSCPTAG(proc) ]) == argc\ && ! PROCEDURE_OPTIONAL(sc_unknownproc[ TSCPTAG( proc )]))]) /* UNSI_GNED(sc_unknownproc[ TSCPTAG( proc ) ] ) \ == (argc*256+PROCEDURETAG)) ]) */ /* Inline type conversions */ /* round a floating point number to the nearest integer */ #ifdef apollo #include <math.h> /* Apollo SR10.2, with cc 6.7: rint() returns a bogus value (e.g., 0.9 is "rounded" to 0.899902). If Apollo does not fix rint() soon, then we should write our own. */ #define rint(x) floor((x) + 0.5) #define ROUND(x) ((int) rint(x)) #endif #ifndef ROUND #define ROUND(x) ((int) (x)) #endif #define FLT_FIX( flt ) C_FIXED( ROUND(FLOAT_VALUE( flt )) ) #define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) ) #define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix ))) #define FLTV_FLT( flt ) MAKEFLOAT( flt ) #define FLTP_FLT( fltp ) MAKEFLOAT( *((FLOATTYPE*)( fltp )) ) #define STRING_C( s ) (&T_U( s )->string.char0) #define BOOLEAN( c ) ((c) ? TRUEVALUE : FALSEVALUE) /* Memory Access */ #define MBYTE( base, bx ) (*( ((unsigned char*)T_U( base ))+bx )) #define MSINT( base, bx ) (*((short int*)( ((char*)T_U( base )) + bx ))) #define MINT( base, bx ) (*((int*)( ((char*)T_U( base )) + bx ))) #define MUNSIGNED(base, bx) (*((unsigned *)( ((char*)T_U( base )) + bx ))) #define MSUNSIGNED(base,bx) (*((unsigned short*)( ((char*)T_U( base )) + bx ))) #define MTSCP( base, bx ) (*((TSCP*)( ((char*)T_U( base )) + bx ))) #define MFLOAT( base, bx ) (*((float*)( ((char*)T_U( base )) + bx ))) #define MDOUBLE( base, bx ) (*((double*)( ((char*)T_U( base )) + bx ))) /* Low-level builtins */ #define CONS sc_cons #define STRINGTOSYMBOL sc_string_2d_3esymbol #define CONSTANTEXP sc_constantexp #define CLARGUMENTS sc_clarguments #define MAKEPROCEDURE sc_makeprocedure #define MAKECLOSURE sc_makeclosure #define INITIALIZEVAR sc_initializevar #define TSCP_CHAR sc_tscp_char #define TSCP_UNSIGNED sc_tscp_unsigned #define TSCP_INT sc_tscp_int #define TSCP_POINTER sc_tscp_pointer #define TSCP_DOUBLE sc_tscp_double #define CHAR_TSCP C_CHAR #define INT_TSCP sc_int_tscp #define UNSIGNED_TSCP sc_unsigned_tscp #define POINTER_TSCP sc_unsigned_tscp #define DOUBLE_TSCP FLTV_FLT #define INITHEAP sc_restoreheap #define SCHEMEEXIT() scrt6_default_2dexit() #define LISTTOVECTOR scrt4_list_2d_3evector /* External Functions and SCHEME->C globals which are defined in other modules. They are duplicated here so that this file contains all external definitions needed by a SCHEME->C program. */ #ifdef PRISM /* As explained in heap.c, it is important to declare the function prototype, so the compiler passes the floating point argument in a register, rather than on the stack. */ extern TSCP sc_makefloat32(float); extern TSCP sc_makefloat64(double); #else extern TSCP sc_makefloat32(); extern TSCP sc_makefloat64(); #endif extern TSCP sc_cons(); extern int sc_unknownargc; extern TSCP sc_unknownproc[ 4 ]; extern void sc_restoreheap(); extern TSCP scrt4_list_2d_3evector(); extern int sc_iplus(); extern int sc_idifference(); extern int sc_itimes(); extern int sc_inegate(); extern int* sc_pagelink; extern TSCP sc_setgeneration();