This is objects.c in view mode; [Download] [Up]
/* 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 implements the object storage allocation functions. */
/* Imported definitions */
#include "objects.h"
#include "scinit.h"
#include "heap.h"
#include "signal.h"
#include "apply.h"
#include "cio.h"
#include <varargs.h>
extern TSCP scrt1_reverse();
/* Allocate storage for objects defined in objects.h */
TSCP sc_obarray; /* OBARRAY for symbols */
struct SCPTRS *sc_constants; /* Table of compile time constant addresses */
struct SCPTRS *sc_globals; /* Table of top level variable addresses */
int sc_maxdisplay = 0; /* The DISPLAY */
TSCP sc_display[ 200 ];
TSCP sc_emptylist, /* Immediate denoting empty list */
sc_emptystring, /* Pointer to the empty string */
sc_emptyvector, /* Pointer to the empty vector */
sc_falsevalue, /* Immediate denoting false */
sc_truevalue, /* Immediate denoting true */
sc_eofobject, /* Immediate denoting end-of-file */
sc_undefined; /* Immediate denoting the undefined value */
struct STACKTRACE *sc_stacktrace; /* Pointer to debug stack trace records */
/* Entries are added to SCPTRS structures by the following procedure. It is
called with a pointer to the structure and a value to add. It returns the
pointer to the expanded structure.
*/
struct SCPTRS* addtoSCPTRS( s, p )
struct SCPTRS* s;
TSCP *p;
{
if (s == NULL) {
/* Initially allocate the table */
s = (struct SCPTRS*)malloc( sizeofSCPTRS( 500 ) );
s->count = 0;
s->limit = 500;
} else if (s->count == s->limit) {
s->limit = s->limit+100;
s = (struct SCPTRS*)realloc( s, sizeofSCPTRS( s->limit ) );
}
s->ptrs[ s->count++ ] = p;
return( s );
}
/* Strings are allocated by the following function which takes a length (as a
tsfixed value), and a char initialization value. It will return a Scheme
pointer to the new string. The strings will be null terminated in order to
be compatible with C strings. This function is visible as MAKE-STRING
inside Scheme.
*/
TSCP sc_make_2dstring_v;
TSCP sc_make_2dstring( length, initial )
TSCP length, initial;
{
int len, x;
char initchar, *cp;
SCP sp;
len = FIXED_C( length );
if ((TSCPTAG( length ) != FIXNUMTAG) || len < 0)
sc_error( "MAKE-STRING", "Argument is not a POSITIVE INTEGER", 0 );
if (len == 0) return( sc_emptystring );
if (initial != EMPTYLIST) {
initial = T_U( initial )->pair.car;
if (TSCPIMMEDIATETAG( initial ) != CHARACTERTAG)
sc_error( "MAKE-STRING", "Argument is not a CHARACTER", 0 );
initchar = CHAR_C( initial );
}
MUTEXON;
sp = sc_allocateheap( STRINGSIZE( len ), STRINGTAG, len );
cp = &sp->string.char0;
if (initial != EMPTYLIST) {
x = len;
while (x--) *cp++ = initchar;
}
else cp = cp+len;
x = 4-(len & 3); /* Null bytes in rest of last word */
while (x--) *cp++ = 0;
MUTEXOFF;
return( U_T( sp, EXTENDEDTAG ) );
}
/* A copy of a string is made by the following procedure. It is available
inside Scheme as STRING-COPY.
*/
TSCP sc_string_2dcopy_v;
TSCP sc_string_2dcopy( string )
TSCP string;
{
SCP ustring, newstring;
int words, *from, *to;
ustring = T_U( string );
if ((TSCPTAG( string ) != EXTENDEDTAG) ||
ustring->string.tag != STRINGTAG)
sc_error( "STRING-COPY", "Argument is not a STRING", 0 );
if (string == sc_emptystring) return( string );
words = STRINGSIZE( ustring->string.length );
MUTEXON;
newstring = sc_allocateheap( words, 0, 0 );
from = (int*)ustring;
to = (int*)newstring;
while (words--) *to++ = *from++;
MUTEXOFF;
return( U_T( newstring, EXTENDEDTAG ) );
}
/* C strings are converted to heap allocated Scheme strings by the following
function.
*/
TSCP sc_cstringtostring( cstring )
char *cstring;
{
int len, x;
char *cp;
SCP sp;
len = 0;
cp = cstring;
if (cp) while (*cp++) len++;
if (len == 0) return( sc_emptystring );
MUTEXON;
sp = sc_allocateheap( STRINGSIZE( len ), STRINGTAG, len );
cp = &sp->string.char0;
x = len;
while (x--) *cp++ = *cstring++;
x = 4-(len & 3); /* Null bytes in rest of last word */
while (x--) *cp++ = 0;
MUTEXOFF;
return( U_T( sp, EXTENDEDTAG ) );
}
/* Vectors are allocated by the following functions which takes a length (as a
tsfixed value), and an initialization value. It will return a Scheme
pointer to the new vector. It has the name MAKE-VECTOR in Scheme.
*/
TSCP sc_make_2dvector_v;
TSCP sc_make_2dvector( length, initial )
TSCP length, initial;
{
int len;
SCP vp;
PATSCP ve;
len = FIXED_C( length );
if ((TSCPTAG( length ) != FIXNUMTAG) || len < 0)
sc_error( "MAKE-VECTOR", "Argument is not a POSITIVE INTEGER", 0 );
if (len == 0) return( sc_emptyvector );
MUTEXON;
vp = sc_allocateheap( VECTORSIZE( len ), VECTORTAG, len );
ve = &vp->vector.element0;
if (initial != EMPTYLIST) initial = T_U( initial )->pair.car;
while (len--) *ve++ = initial;
MUTEXOFF;
return( U_T( vp, EXTENDEDTAG ) );
}
/* Closures are constructed by the following function. It takes a previous
closure pointer, a closure size, and the values to be closed. It returns
a Scheme pointer to the closure. It is used by compiled code to heap
allocate variables and is visible within the compiler as MAKECLOSURE.
*/
TSCP sc_makeclosure( va_alist )
va_dcl
{
va_list argl;
TSCP prevclosure;
int count;
SCP cp;
PATSCP vars;
MUTEXON;
va_start( argl );
prevclosure = va_arg( argl, TSCP );
count = va_arg( argl, int );
cp = sc_allocateheap( CLOSURESIZE( count ), CLOSURETAG, count );
cp->closure.closure = prevclosure;
vars = &cp->closure.var0;
while (count--) *vars++ = va_arg( argl, TSCP );
MUTEXOFF;
return( U_T( cp, EXTENDEDTAG ) );
}
/* Procedure objects are constructed by the following function. It takes the
required variable count, the optvars flag, the function, and the current
closure. It returns a Scheme pointer to the procedure. It is used by
compiled code to make the value of a (LAMBDA (...) ...) expression. It is
visible within the compiler as MAKEPROCEDURE.
*/
TSCP sc_makeprocedure( reqvars, optvars, function, closure )
int reqvars, optvars;
TSCP closure;
TSCPP function;
{
SCP pp;
if (reqvars > MAXARGS)
sc_error( "MAKEPROCEDURE",
"PROCEDURE requires too many arguments",
0 );
if (optvars) reqvars = reqvars+256;
MUTEXON;
pp = sc_allocateheap( PROCEDURESIZE, PROCEDURETAG, reqvars );
pp->procedure.code = function;
pp->procedure.closure = closure;
MUTEXOFF;
return( U_T( pp, EXTENDEDTAG ) );
}
/* Compiled global variables are "registered" by this function. It will add
them to the symbol table (sc_obarray) and set their initial values. The
function is visible within the compiler as INITIALIZEVAR.
*/
void sc_initializevar( symbolname, location, value )
TSCP symbolname, *location, value;
{
SCP sp;
sp = T_U( sc_string_2d_3esymbol( symbolname ) );
if (*sp->symbol.ptrtovalue != UNDEFINED)
fprintf( stderr,
"***** INITIALIZEVAR Duplicately defined symbol %s\n",
&(T_U(sp->symbol.name)->string.char0) );
sp->symbol.ptrtovalue = location;
*location = value;
sc_globals = addtoSCPTRS( sc_globals, location );
}
/* Global TSCP's declared in languages other than Scheme are registered with
the garbage collector by the following function. N.B. The garbage
collector may reloacte objects pointed to by these cells.
*/
void sc_global_TSCP( location )
TSCP *location;
{
sc_globals = addtoSCPTRS( sc_globals, location );
}
/* Compiled constants which are constructed from the heap during initialization
must be "registered" with the runtime system so that they will not be
treated as garbage. This function is visible as CONSTANTEXP within the
compiler.
*/
void sc_constantexp( constantaddress )
TSCP *constantaddress;
{
sc_constants = addtoSCPTRS( sc_constants, constantaddress );
}
/* Strings are converted to symbols by the following function. It will examine
the obarray to see if an identifier with the same name already exists. If
it does then it will return a pointer to that symbol. If not then it will
either add the symbol to the table or return #F as determined by the
value of add.
*/
static TSCP stringtosymbol( symbolstring, add )
TSCP symbolstring, add;
{
TSCP tp, cell;
SCP sp, utp;
int x, *oldp, *newp, *endnewp;
PATSCP buckets;
newp = (int*)T_U( symbolstring );
endnewp = newp+(T_U( symbolstring )->string.length+4)/4;
x = 0;
do x = x ^ *newp; while (newp++ != endnewp);
if (x < 0) x = -x;
x = x % T_U( sc_obarray )->vector.length;
buckets = &T_U( sc_obarray )->vector.element0;
tp = buckets[ x ];
while (tp != EMPTYLIST) {
utp = T_U( tp );
oldp = (int*)(T_U( T_U( utp->pair.car )->symbol.name ));
newp = (int*)(T_U( symbolstring ));
while (*oldp++ == *newp)
if (newp++ == endnewp) return( utp->pair.car );
tp = utp->pair.cdr;
}
if ((add == EMPTYLIST) || (add == FALSEVALUE))
return( FALSEVALUE );
cell = sc_cons( EMPTYLIST, EMPTYLIST );
MUTEXON;
sp = sc_allocateheap( SYMBOLSIZE, SYMBOLTAG, 0 );
sp->symbol.name = symbolstring;
sp->symbol.ptrtovalue = &sp->symbol.value;
sp->symbol.value = UNDEFINED;
sp->symbol.propertylist = EMPTYLIST;
PAIR_CAR( cell ) = U_T( sp, EXTENDEDTAG );
PAIR_CDR( cell ) = buckets[ x ];
sc_setgeneration( &buckets[ x ], cell );
MUTEXOFF;
return( U_T( sp, EXTENDEDTAG ) );
}
/* The following function implements STRING->SYMBOL. */
TSCP sc_string_2d_3esymbol_v;
TSCP sc_string_2d_3esymbol( symbolstring )
TSCP symbolstring;
{
if ((TSCPTAG( symbolstring ) != EXTENDEDTAG) ||
(T_U( symbolstring )->string.tag != STRINGTAG))
sc_error( "STRING->SYMBOL", "Argument is not a STRING", 0 );
return( stringtosymbol( symbolstring, TRUEVALUE ) );
}
/* The following function implements STRING->UNINTERNED-SYMBOL. */
TSCP sc_d_2dsymbol_ab4b4447_v;
TSCP sc_d_2dsymbol_ab4b4447( symbolstring )
TSCP symbolstring;
{
SCP sp;
if ((TSCPTAG( symbolstring ) != EXTENDEDTAG) ||
(T_U( symbolstring )->string.tag != STRINGTAG))
sc_error( "STRING->UNINTERNED-SYMBOL?",
"Argument is not a STRING", 0 );
MUTEXON;
sp = sc_allocateheap( SYMBOLSIZE, SYMBOLTAG, 0 );
sp->symbol.name = symbolstring;
sp->symbol.ptrtovalue = &sp->symbol.value;
sp->symbol.value = UNDEFINED;
sp->symbol.propertylist = EMPTYLIST;
MUTEXOFF;
return( U_T( sp, EXTENDEDTAG ) );
}
/* The following function implements UNINTERNED-SYMBOL?. */
TSCP sc_uninterned_2dsymbol_3f_v;
TSCP sc_uninterned_2dsymbol_3f( symbol )
TSCP symbol;
{
if ((TSCPTAG( symbol ) != EXTENDEDTAG) ||
(T_U( symbol )->symbol.tag != SYMBOLTAG))
sc_error( "UNINTERNED-SYMBOL?", "Argument is not a SYMBOL", 0 );
return ( (stringtosymbol( T_U( symbol )->symbol.name, FALSEVALUE )
== symbol) ? FALSEVALUE : TRUEVALUE );
}
/* The command line arguments passed to a program with a Scheme main are
formed into a list of strings by the following function. It is accessed
as CLARGUMENTS within the compiler. If an argument of the form: -scm <name>
is provided, then a list of command line arguments will not be
returned, and the function <name> will be invoked as the "main" program
with the command line arguments. All flags of the form: -sc... <value>
are reserved for use of the Scheme system and will be deleted from the
command line. If this function is called at initialization, then we
know that the stack will be above or equal to &argv and sc_stackbase will
be set accordingly.
*/
TSCP sc_clarguments( argc, argv )
int argc;
char *argv[];
{
int i;
TSCP argl, main;
argl = EMPTYLIST;
main = FALSEVALUE;
i = 0;
while (i < argc) {
if (strcmp( argv[ i ], "-scm" ) == 0) {
main = sc_string_2d_3esymbol(
sc_cstringtostring( argv[ ++i ] ) );
}
else if (strncmp( argv[ i ], "-sc", 3 ) == 0) {
i++;
}
else {
argl = sc_cons( sc_cstringtostring( argv[ i ] ), argl );
}
i++;
}
argl = scrt1_reverse( argl );
sc_stackbase = ((int*)&argc)+2;
if (main != FALSEVALUE) {
sc_apply_2dtwo( *T_U( main )->symbol.ptrtovalue,
sc_cons( argl, EMPTYLIST ) );
SCHEMEEXIT();
}
return( argl );
}
/* Argument conversion for calling C external procedures is provided by the
following functions. A character is converted to a C character by the
following function.
*/
char sc_tscp_char( p )
TSCP p;
{
if (TSCPIMMEDIATETAG( p ) != CHARACTERTAG)
sc_error( "TSCP_CHAR", "Argument is not a CHARACTER: ~s", 1, p );
return( CHAR_C( p ) );
}
/* The a fixed integer or a floating point number is converted to an integer.
by the following function.
*/
int sc_tscp_int( p )
TSCP p;
{
switch TSCPTAG( p ) {
case FIXNUMTAG:
return( FIXED_C( p ) );
break;
case EXTENDEDTAG:
if (TX_U( p )->extendedobj.tag == FLOATTAG)
return ROUND( FLOAT_VALUE( p ) );
break;
}
sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 );
}
/* The a fixed integer or a floating point number is converted to an integer.
by the following function. The special case testing is present as many C
compilers do not correctly cast double <-> unsigned.
*/
unsigned sc_tscp_unsigned( p )
TSCP p;
{
double v;
switch TSCPTAG( p ) {
case FIXNUMTAG:
return( (unsigned)FIXED_C( p ) );
break;
case EXTENDEDTAG:
if (TX_U( p )->extendedobj.tag == FLOATTAG) {
v = TX_U( p )->FLOATUTYPE.value;
if (v <= (double)(0x7fffffff))
return( (unsigned)ROUND( v ) );
else
return( (unsigned)ROUND( v-((double)(0x40000000))*2.0 ) |
0x80000000 );
}
break;
}
sc_error( "TSCP_UNSIGNED",
"Argument cannot be converted to C unsigned", 0 );
}
/* Numbers, strings, and procedures are converted to C pointers by the
following function.
*/
unsigned sc_tscp_pointer( p )
TSCP p;
{
SCP s;
double v;
switch TSCPTAG( p ) {
case FIXNUMTAG:
return( (unsigned)FIXED_C( p ) );
break;
case EXTENDEDTAG:
s = T_U( p );
switch (s->extendedobj.tag) {
case STRINGTAG:
return( (unsigned)&s->string.char0 );
break;
case PROCEDURETAG:
return( sc_procedureaddress( p ) );
break;
case FLOATTAG:
v = TX_U( p )->FLOATUTYPE.value;
if (v <= (double)(0x7fffffff))
return( (unsigned int)( v ) );
else
return( (unsigned int)( v-((double)(0x40000000))*2.0 ) |
0x80000000 );
break;
}
break;
}
sc_error( "TSCP_POINTER", "Argument cannot be converted to C pointer",
0 );
}
/* The following function produces a double value from a Scheme pointer. */
double sc_tscp_double( p )
TSCP p;
{
switch TSCPTAG( p ) {
case FIXNUMTAG:
return( (double)(FIXED_C( p )) );
break;
case EXTENDEDTAG:
if (TX_U( p )->extendedobj.tag == FLOATTAG)
return( TX_U( p )->FLOATUTYPE.value );
break;
}
sc_error( "TSCP_DOUBLE", "Argument cannot be converted to C double",
0 );
}
/* The following function converts an integer returned by C into either a
fixed or float value.
*/
TSCP sc_int_tscp( n )
int n;
{
if (n <= 0x1fffffff && n >= -0x1fffffff)
return( C_FIXED( n ) );
return( MAKEFLOAT( (double)n ) );
}
/* The following function converts an unsigned returned by C into either a
fixed or float value. The special case testing is present as many C
compilers do not correctly cast double <-> unsigned.
*/
TSCP sc_unsigned_tscp( n )
unsigned n;
{
if (n <= 0x1fffffff) return( C_FIXED( n ) );
if (n & 0x80000000)
return( MAKEFLOAT( (double)(n & 0x7fffffff)+
((double)( 0x40000000 ))*2.0 ) );
return( MAKEFLOAT( (double)n ) );
}
/* The address of a procedure is returned by the following function. */
unsigned sc_procedureaddress( pp )
TSCP pp;
{
return( (unsigned)(TX_U( pp )->procedure.code) );
}
/* The following routine is called to push an entry onto the debug stack. */
void sc_pushtrace( stp, procedure )
struct STACKTRACE *stp;
TSCP procedure;
{
stp->prevstacktrace = sc_stacktrace;
stp->procname = procedure;
sc_stacktrace = stp;
}
/* The following routine is called following a tail call within EXEC to
update the values saved in the trace record.
*/
void sc_looptrace( stp, exp, env )
struct STACKTRACE *stp;
TSCP exp, env;
{
stp->exp = exp;
stp->procname = env;
}
/* The following routine pops an entry off the debug stack. */
TSCP sc_poptrace( stp, exp )
struct STACKTRACE *stp;
TSCP exp;
{
sc_stacktrace = stp->prevstacktrace;
return( exp );
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.