rs_bool BSOP_write( obj port, const char *src, UINT_32 len )
{
obj buf, fxpos;
char *ptr;
UINT_32 n, max, pos;
buf = gvec_read( port, BSOP_BUFFER );
fxpos = gvec_read( port, BSOP_INDEX );
max = string_length(buf);
assert( STRING_P(buf) );
assert( OBJ_ISA_FIXNUM(fxpos) );
pos = fx2int(fxpos);
ptr = (char *)string_text(buf);
if (pos + len > max)
{
n = max - pos;
memcpy( ptr + pos, src, n );
gvec_write_non_ptr( port, BSOP_INDEX, int2fx(max) );
return NO;
}
memcpy( ptr + pos, src, len );
pos += len;
gvec_write_non_ptr( port, BSOP_INDEX, int2fx(pos) );
return YES;
}
static obj mpz_to_bignum( mpz_t n )
{
return make3( bignum_class,
int2fx( n[0]._mp_alloc ),
int2fx( n[0]._mp_size ),
DATAPTR_TO_PTR( n[0]._mp_d ) );
}
static obj bc_bvec_ci_hash( obj bvec, INT_32 offset, INT_32 len,
int fpc )
{
if ((len < 0) || (offset < 0) || ((offset + len) > SIZEOF_PTR(bvec)))
scheme_error( "bvec_ci_hash: range error: (bvec-ci-hash ~s ~d ~d)",
3, bvec, int2fx(offset), int2fx(len) );
return bvec_ci_hash( bvec, offset, len );
}
_rs_volatile void too_few_args( const char *fn, unsigned min_required )
{
scheme_error( "Function ~a called with ~d args, required at least ~d",
3,
make_string( fn ),
int2fx(arg_count_reg),
int2fx(min_required) );
}
_rs_volatile void wrong_num_args( const char *fn, unsigned num_required )
{
scheme_error( "Function ~a called with ~d args, required exactly ~d",
3,
make_string( fn ),
int2fx(arg_count_reg),
int2fx(num_required) );
}
obj translate_LR( RStore *in_store, struct LocationRef lr )
{
struct PageRef ref;
if (lr.indirect)
{
if (lr.first)
{
struct VMPageRecord *vmpr;
ref.base_page_num = lr.base_page_num;
ref.first = 1;
ref.indirect = 1;
ref.dirty = 0;
ref.loaded = 0;
ref.nth_page = lr.nth_page;
vmpr = get_vmpr( in_store, &ref );
if (!vmpr || lr.offset > 63 || lr.nth_page != 1)
{
scheme_error( "translate_ptr(~d[~d]): illegal",
2,
int2fx( lr.base_page_num ),
int2fx( lr.offset ) );
}
return ((obj *)vmpr->mem_address)[ lr.offset ];
}
else
{
/* special hack for immobs */
return OBJ(lr.base_page_num);
}
}
else
{
struct VMPageRecord *vmpr;
ref.base_page_num = lr.base_page_num;
ref.first = lr.first;
ref.indirect = 0;
ref.dirty = 0;
ref.loaded = 0;
ref.nth_page = lr.nth_page;
vmpr = get_vmpr( in_store, &ref );
if (!vmpr)
{
scheme_error( "translate_ptr(~x.~04x+~x): illegal",
3,
int2fx( lr.base_page_num >> 16 ),
int2fx( lr.base_page_num & 0xFFFF ),
int2fx( lr.offset ) );
}
return OBJ( (UINT_32)vmpr->mem_address + lr.offset );
}
_rs_volatile void wrong_num_args_range( const char *fn,
unsigned mn, unsigned mx )
{
scheme_error( "Function ~a called with ~d args, expected ~d to ~d",
4,
make_string( fn ),
int2fx(arg_count_reg),
int2fx(mn),
int2fx(mx) );
}
static obj int_lshl(INT_32 a, INT_32 b)
{
int am;
if(!a)
return int2fx(0);
if(b > 63 || (am = (b + search_one32(a))) > 63)
return bignum_shl(int_32_to_bignum_u(a), b);
if(am > 30)
return int_64_compact(int_64_shl(int_32_to_int_64(a), b));
return int2fx(a<<b);
}
static void requeue( obj thr, obj blocked_on )
{
if (instance_p( blocked_on, mailbox_class ))
{
obj mbox = blocked_on;
/* two cases to consider
* 1. mailbox has data now
* 2. mailbox has no data
*/
if (truish(gvec_ref(mbox,MAILBOX_HAS_DATA_Q)) && !dequeue_empty(mbox))
{
/* mark_thread_ready() will set the state to WAITING */
send_item_to_thread( mbox, thr, dequeue_pop_front( mbox ) );
}
else
{
/* put it back in the wait queue */
gvec_write_non_ptr( mbox, MAILBOX_HAS_DATA_Q, FALSE_OBJ );
dequeue_push_back( mbox, thr );
/* now, we're blocked again */
gvec_set( thr, THREAD_STATE, int2fx( TSTATE_BLOCKED ) );
}
}
else
{
/* it can't be a <queued-output-port>, because we are only
* called when the thread has been ejected from the queue,
* and that never happens for qout's (they work like timers)
* -- see comments in output.c and class.scm
*/
assert( !instance_p( blocked_on, qout_class ) );
assert(0); /* not implemented yet... */
}
}
void *tcl_gateway( void )
{
char **argp, *(args[102]);
Tcl_CmdInfo *info;
Tcl_Interp *interp;
char temp[1000], *d;
int i, rc;
assert( arg_count_reg <= 100 );
info = (Tcl_CmdInfo *)PTR_TO_DATAPTR(LEXREF0(0));
interp = (Tcl_Interp *)OBJ_TO_RAW_PTR(LEXREF0(1));
d = temp;
argp = args;
*argp++ = (char *)string_text( LEXREF0(2) );
for (i=0; i<arg_count_reg; i++)
{
obj arg;
arg = reg_ref(i);
if (STRING_P(arg))
{
*argp++ = (char *)string_text(arg);
}
else if (OBJ_ISA_FIXNUM(arg))
{
*argp++ = d;
sprintf( d, "%d", fx2int(arg) );
d += strlen(d) + 1;
}
else if (SYMBOL_P(arg))
{
*argp++ = (char *)symbol_text(arg);
}
else
{
scheme_error( "tcl_gateway: ~s invalid", 1, arg );
}
}
*argp++ = NULL;
Tcl_ResetResult( interp );
rc = info->proc( info->clientData,
interp,
arg_count_reg + 1,
args );
if (rc)
{
REG0 = make_string( interp->result );
REG1 = int2fx( rc );
RETURN(2);
}
else
{
if (interp->result[0])
REG0 = make_string( interp->result );
else
REG0 = TRUE_OBJ;
RETURN1();
}
}
int rscheme_file_mode_to_os( int mode )
{
int i_mode;
i_mode = 0;
if ((mode & 3) == 0)
{
i_mode = O_RDONLY;
}
else if ((mode & 3) == 1)
{
i_mode = O_WRONLY;
}
else if ((mode & 3) == 2)
{
i_mode = O_RDWR;
}
else
{
scheme_error( "file-mode->os: mode ~d is invalid", 1, int2fx(mode) );
}
if (mode & 4) i_mode |= O_APPEND;
if (mode & 8) i_mode |= O_CREAT;
if (mode & (1<<4)) i_mode |= O_EXCL;
if (mode & (1<<5)) i_mode |= O_TRUNC;
return i_mode;
}
void mark_thread_suspended( obj th )
{
obj susp_count = gvec_ref( th, THREAD_SUSPEND_COUNT );
int still_in_q = 1;
if (FX_LT( susp_count, ZERO ))
{
still_in_q = 0;
susp_count = FX_SUB( ZERO, susp_count );
}
else if (EQ( susp_count, ZERO ))
{
/* newly suspended */
gvec_write_non_ptr( th, THREAD_STATE, int2fx( TSTATE_SUSPEND ) );
}
susp_count = ADD1( susp_count );
if (still_in_q)
gvec_write_non_ptr( th,
THREAD_SUSPEND_COUNT,
susp_count );
else
gvec_write_non_ptr( th,
THREAD_SUSPEND_COUNT,
FX_SUB(ZERO,susp_count) );
}
static void bc_bvec_copy(obj dst, INT_32 dst_offset,
obj src, INT_32 src_offset, INT_32 len,
int fpc )
{
char *dst_p;
const char *src_p;
if ((dst_offset < 0)
|| ((dst_offset + len) > SIZEOF_PTR(dst))
|| (src_offset < 0)
|| ((src_offset + len) > SIZEOF_PTR(src))
|| (len < 0))
scheme_error( "bvec_copy: range error: (bvec-copy ~s ~d ~s ~d ~d)",
5, dst, int2fx(dst_offset), src, int2fx(src_offset),
int2fx(len) );
bvec_copy( dst, dst_offset, src, src_offset, len );
}
obj make_bucket( obj bucket_class, int bucket_bits )
{
obj x;
assert( CLASS_P(bucket_class) );
x = gvec_alloc( (3 * BUCKET_CAPACITY) + 2, bucket_class );
gvec_write_fresh_non_ptr( x, SLOT(0), int2fx( bucket_bits ) );
return x;
}
void SOP_write( obj port, const char *src, UINT_32 len )
{
obj buf, fxpos;
char *ptr;
UINT_32 n, max, pos;
buf = gvec_read( port, SOP_BUFFER );
fxpos = gvec_read( port, SOP_INDEX );
assert( BYTE_VECTOR_P( buf ) );
assert( OBJ_ISA_FIXNUM( fxpos ) );
max = SIZEOF_PTR( buf );
pos = fx2int( fxpos );
ptr = (char *)PTR_TO_DATAPTR( buf );
if (pos + len >= max)
{
UINT_32 newbuflen;
/* if this write does not fit entirely within the current
* buffer, then we need to fill out this buffer and
* push it on the overflow list.
*/
n = max - pos;
memcpy( ptr + pos, src, n );
src += n;
len -= n;
gvec_write( port,
SOP_OVERFLOW,
cons( buf, gvec_read( port, SOP_OVERFLOW ) ) );
/* Now we need to allocate another buffer, do the
* rest of the write in there, and leave it current.
*
* We allocate the new buffer at least big enough to hold
* what's needed.
*/
if (len > SOP_BLOCK_SIZE)
newbuflen = len + SOP_BLOCK_SIZE;
else
newbuflen = SOP_BLOCK_SIZE;
buf = alloc( newbuflen, byte_vector_class );
gvec_write( port, SOP_BUFFER, buf );
pos = 0;
ptr = (char *)PTR_TO_DATAPTR( buf );
}
memcpy( ptr + pos, src, len );
pos += len;
gvec_write_non_ptr( port, SOP_INDEX, int2fx( pos ) );
}
static int chkest( int is, RS_bc_datum *v, int need, UINT_8 *pc )
{
static char *(est_t[]) = { "<none>", "<obj>", "<raw-float>", "<raw-str>", "<raw-bool>", "<raw-int>", "-unknown-" };
if (is != need && is != est_unknown)
{
UINT_8 *base = ((UINT_8 *)PTR_TO_DATAPTR(LITERAL(0)));
fprintf( stderr, "bcieval stack error: PC=%d\n", pc - base );
fprintf( stderr, "\ttype is %s (%x.%x), expected %s\n",
est_t[is], (v->raw_int_val) >> 2, v->raw_int_val & 3,
est_t[need] );
scheme_error(
"bcieval stack error: type = ~d, expected ~d (~x ~x) pc=~d",
5, int2fx(is), int2fx(need),
(v->raw_int_val) & ~3,
int2fx((v->raw_int_val) & 3),
int2fx(pc - base) );
}
static _rs_inline obj int_minus( INT_32 a, INT_32 b )
{
INT_32 c = a - b;
if ((~(a ^ b) & (c ^ a)) & HIGHBIT)
{
INT_64 a2 = int_32_to_int_64(a);
INT_64 b2 = int_32_to_int_64(b);
return int_64_compact( int_64_sub( a2, b2 ) );
}
return int2fx( a-b );
}
static obj get_bytecode_correlation( void )
{
obj q = make_dequeue();
int prev, op;
for (prev=0; prev<512; prev++)
for (op=0; op<512; op++)
{
int n = bci_corr[prev][op];
if (n != 0)
{
obj entry = make3( vector_class,
int2fx(n),
int2fx(prev),
int2fx(op) );
dequeue_push_back( q, entry );
}
}
return dequeue_state(q);
}
static _rs_inline obj int_plus( INT_32 a, INT_32 b )
{
INT_32 c = a + b;
if ((~(a ^ b) & (c ^ a)) & HIGHBIT)
{
INT_64 a2 = int_32_to_int_64(a);
INT_64 b2 = int_32_to_int_64(b);
INT_64 c2 = int_64_add( a2, b2 );
return int_64_compact( c2 );
}
return int2fx( c );
}
static _rs_inline obj int_mul( INT_32 a, INT_32 b )
{
INT_32 p_hi, p_lo;
INT_64 a2, b2;
#ifdef smul_ppmm
smul_ppmm( p_hi, p_lo, a, b );
#else
union
{
int i32[2];
long long int i64;
} u;
u.i64 = (long long int) a * (long long int) b;
# if __BYTE_ORDER == __LITTLE_ENDIAN
p_hi = u.i32[0];
p_lo = u.i32[1];
# else
p_hi = u.i32[1];
p_lo = u.i32[0];
# endif
#endif
if (p_hi == 0)
{
if (p_lo < HIGHBIT)
{
return int2fx( p_lo );
}
}
else if (p_hi == -1)
{
if (p_lo >= -HIGHBIT)
{
return int2fx( p_lo );
}
}
a2 = int_32_to_int_64(a);
b2 = int_32_to_int_64(b);
return int_64_compact( int_64_mul( a2, b2 ) );
}
obj string_to_fixnum( char *str_in, UINT_32 len, unsigned radix )
{
int i;
rs_bool neg = NO;
UINT_32 v, preq, prem;
UINT_8 *lim = ((UINT_8*)str_in) + len;
UINT_8 *str = (UINT_8*)str_in;
if (*str == '-')
{
str++;
neg = YES;
}
else if (*str == '+')
{
str++;
}
/* compute the maximum value & digit that is
allowed BEFORE a new digit is added.
For example, if the limit is 1024 (max 1023)
and we're in base 10, the preq is 102 and prem is 4
is if the value so far is 102 and we see a 4, we know
that's too much, but if we see a 3, that's OK */
preq = (1UL<<(WORD_SIZE_BITS-PRIMARY_TAG_SIZE-1)) / radix;
prem = (1UL<<(WORD_SIZE_BITS-PRIMARY_TAG_SIZE-1)) % radix;
/* printf( "preq = %d, prem = %d\n", preq, prem ); */
if (str >= lim)
return FALSE_OBJ; /* no digits! */
v = 0;
while (str < lim)
{
i = digit_value( *str++ );
if (i >= radix)
{
return FALSE_OBJ;
}
if ((v > preq)
|| ((v == preq)
&& ((i > prem) || ((i == prem) && !neg))))
{
/* too big -- doesn't fit as a fixnum */
return FALSE_OBJ;
}
v = v * radix + i;
}
return int2fx( neg ? -v : v );
}
obj float_truncate( IEEE_64 longfloat )
{
if ((longfloat >= -536870912.0) && (longfloat <= 536870911.0)) {
int t = (int)longfloat;
return int2fx( t );
} else if ((longfloat >= -9.22337e+18) && (longfloat <= 9.22337e+18)) {
return int_64_compact( float_to_int_64( longfloat ) );
} else {
scheme_error( "float_truncate(~d): out of exact range",
1, make_float( longfloat ) );
return FALSE_OBJ;
}
}
void mm_set_prot( void *base, size_t bytes, enum mm_mode new_mode )
{
int rc;
rc = mprotect( (caddr_t)base, bytes, prot[new_mode] );
if (rc < 0)
{
scheme_error( "mm_set_prot: at #x~04x_~04x for ~d bytes, to ~a: ~a",
5,
int2fx( ((UINT_32)base)>>16 ),
int2fx( ((UINT_32)base)&0xFFFF ),
int2fx( bytes ),
make_string( protname[new_mode] ),
make_string( strerror(errno) ) );
}
static void fixup_fnd( struct FASL_UnswizzledFnDescr *xd )
{
struct FASL_PartHdr *xp = xd->container;
struct FASL_ModuleHdr *xm;
struct part_descr *p;
unsigned i;
if (xd->real_fn_d) {
return;
}
xm = xp->container;
if (!xm->module)
{
struct module_descr *m;
/* printf( "** mapping in %s module\n", xm->name );*/
m = find_module( xm->name );
if (!m) {
char *p = strchr( xm->name, '|' );
if (p) {
scheme_error( "dynamic module ~s not loaded: ~a", 2,
make_string( p+1 ),
make_string( dynamic_link_errors() ) );
} else {
scheme_error( "static module ~s not loaded", 1,
make_string( xm->name ) );
}
}
xm->module = m;
}
/* printf( "** mapping in %s[%d]\n", xm->name, xp->part_tag );*/
p = find_part( xm->module, xp->part_tag );
if (!p)
{
scheme_error( "module ~s is missing part ~d",
2,
make_string( xm->name ),
int2fx( xp->part_tag ) );
}
for (i=0; p->functions[i]; i++)
{
xp->fnds[i].real_fn_d = p->functions[i];
xp->fnds[i].real_code_ptr = p->functions[i]->monotones[0];
}
}
int the_callback( ClientData data, Tcl_Interp *interp,
int argc, const char **argv )
{
obj item, info = NIL_OBJ;
while (argc > 1)
{
const char *a = argv[--argc];
if (isdigit(a[0]) || a[0] == '-')
item = int2fx( atoi(a) );
else
item = make_string(a);
info = cons( item, info );
}
evts = cons( info, evts );
return TCL_OK;
}
void install_bc_extension( struct bcx_descr *extn )
{
UINT_8 i = extn->extn_code;
if (extension_fns[i] != NOFN)
{
scheme_error( "cannot load bytecode extension ~a.~a in ~d: "
"already loaded ~a.~a",
5,
make_string( extn->owner->name ),
make_string( extn->name ),
int2fx(i),
make_string( loaded_extensions[i]->owner->name ),
make_string( loaded_extensions[i]->name ) );
}
loaded_extensions[i] = extn;
extension_fns[i] = extn->handler;
}
static obj *setup_reference_objects( obj ref_vec )
{
UINT_32 i, n = SIZEOF_PTR(ref_vec) / SLOT(1);
obj *saved_class;
if (n == 0)
return NULL;
saved_class = (obj *)malloc( n * sizeof(obj) );
for (i=0; i<n; i++)
{
obj ref_item = gvec_ref( ref_vec, SLOT(i) );
/*printf( "REF item %08x\n", VAL(ref_item) ); */
saved_class[i] = PTR_TO_HDRPTR(ref_item)->pob_class;
PTR_TO_HDRPTR(ref_item)->pob_class = int2fx(1);
}
return saved_class;
}
obj float_truncate( IEEE_64 longfloat )
{
/** TODO:
** Refine these tests so that exactly the smallest type is used
**/
if ((longfloat >= -536870912.0) && (longfloat <= 536870911.0))
{
int t = (int)longfloat;
return int2fx( t );
}
else if ((longfloat >= -9.22337e+18) && (longfloat <= 9.22337e+18))
{
return int_64_compact( float_to_int_64( longfloat ) );
}
else
{
return raw_float_to_bignum( longfloat );
}
}
obj dequeue_memq( obj deq, obj item )
{
int j = 0;
UINT_32 i = FXWORDS_TO_RIBYTES( DEQ_FRONT( deq ) );
UINT_32 b = FXWORDS_TO_RIBYTES( DEQ_BACK( deq ) );
obj state = DEQ_STATE( deq );
UINT_32 lim = SIZEOF_PTR(state);
while (i != b) {
if (EQ(gvec_read( state, i ),item)) {
return int2fx( j );
}
i += SLOT(1);
if (i >= lim) {
i = 0;
}
j++;
}
return FALSE_OBJ;
}
obj vmake_os_error( const char *fn, int num_args, va_list va )
{
int i, e = errno;
obj argv, props;
argv = alloc( SLOT(num_args), vector_class );
for (i=0; i<num_args; i++)
gvec_write_init( argv, SLOT(i), va_arg(va,obj) );
props = cons( cons( lookup_symbol( "stack" ),
make_exception_stack() ),
NIL_OBJ );
return make4( os_error_class,
props,
int2fx(e),
make_string( fn ),
argv );
}