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 void scan_as_gvec( obj item, UINT_32 offset, UINT_32 lim )
{
obj *s, *limit;
s = (obj *)(offset + (char *)PTR_TO_DATAPTR( item ));
limit = (obj *)(lim + (char *)PTR_TO_DATAPTR( item ));
while (s < limit)
spot_object( *s++ );
}
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();
}
}
obj rational_to_string_obj( obj a, unsigned radix )
{
mpq_t v;
size_t sz;
obj str, str2;
int len;
OBJ_TO_MPQ(v, a);
sz = mpz_sizeinbase(mpq_numref(v), radix) + 2;
if(mpz_sgn(mpq_numref(v))<0)
sz++;
sz += mpz_sizeinbase(mpq_denref(v), radix);
str = bvec_alloc(sz, string_class);
if(!mpz_get_str(PTR_TO_DATAPTR(str), radix, mpq_numref(v)))
return FALSE_OBJ;
len = strlen(PTR_TO_DATAPTR(str));
((char *)PTR_TO_DATAPTR(str))[len++]='/';
if(!mpz_get_str(PTR_TO_DATAPTR(str) + len, radix, mpq_denref(v)))
return FALSE_OBJ;
if(strlen(PTR_TO_DATAPTR(str)) == sz - 1)
return str;
str2 = bvec_alloc(sz - 1, string_class);
strcpy(PTR_TO_DATAPTR(str2), PTR_TO_DATAPTR(str));
return str2;
}
obj bignum_to_string_obj(obj a, unsigned radix)
{
mpz_t v;
size_t sz;
obj str, str2;
OBJ_TO_MPZ(v, a);
sz = mpz_sizeinbase(v, radix) + 1;
if(mpz_sgn(v)<0)
sz++;
str = bvec_alloc(sz, string_class);
if(!mpz_get_str(PTR_TO_DATAPTR(str), radix, v))
return FALSE_OBJ;
if(strlen(PTR_TO_DATAPTR(str)) == sz - 1)
return str;
str2 = bvec_alloc(sz - 1, string_class);
strcpy(PTR_TO_DATAPTR(str2), PTR_TO_DATAPTR(str));
return str2;
}
obj SOP_flush( obj port, int closeq )
{
int len;
obj dst, overflow;
char *endptr;
const char *src;
len = fx2int( gvec_read( port, SOP_INDEX ) );
overflow = gvec_read( port, SOP_OVERFLOW );
while (!EQ( overflow, NIL_OBJ ))
{
len += SIZEOF_PTR( pair_car( overflow ) );
overflow = pair_cdr( overflow );
}
dst = bvec_alloc( len+1, string_class );
endptr = ((char *)string_text( dst )) + len;
*endptr = 0;
src = (const char *)PTR_TO_DATAPTR( gvec_read( port, SOP_BUFFER ) );
len = fx2int( gvec_read( port, SOP_INDEX ) );
overflow = gvec_read( port, SOP_OVERFLOW );
while (1)
{
endptr -= len;
memcpy( endptr, src, len );
if (EQ( overflow, NIL_OBJ ))
break;
src = (const char *)PTR_TO_DATAPTR( pair_car( overflow ) );
len = SIZEOF_PTR( pair_car( overflow ) );
overflow = pair_cdr( overflow );
}
if (closeq) {
gvec_write( port, SOP_BUFFER, FALSE_OBJ );
gvec_write( port, SOP_OVERFLOW, FALSE_OBJ );
}
return dst;
}
obj rs_des_make_key_schedule( obj key )
{
obj sched;
int rc;
sched = bvec_alloc( sizeof( DES_key_schedule ), byte_vector_class );
rc = DES_set_key_checked( (DES_cblock *)PTR_TO_DATAPTR( key ),
(DES_key_schedule *)PTR_TO_DATAPTR( sched ) );
if (rc < 0) {
if (rc == -2) {
scheme_error( "DES_set_key_checked: weak key: ~s", 1, key );
} else if (rc == -1) {
scheme_error( "DES_set_key_checked: parity error: ~s", 1, key );
} else {
scheme_error( "DES_set_key_checked: error ~d", 1, int2fx( rc ) );
}
return FALSE_OBJ;
} else {
return sched;
}
}
int init_paddr( struct PAddrVec *pv, obj item )
{
struct VMPageRecord *vmpr;
RStore *owner;
vmpr = find_owner_and_vmpr( PTR_TO_DATAPTR(item), &owner );
if (!vmpr) {
return -EINVAL;
}
pv->owner = owner;
pv->spare = 0;
pv->vec[0] = create_LR( owner, item );
return 0;
}
void render_line( struct text_rendition *info, struct line_layout *ll )
{
int base_x = ll->base_x;
int base_y = ll->base_y;
UINT_32 line_start = ll->line_start;
UINT_32 line_end = ll->line_end;
int sel_start_x = ll->sel_start_x;
int sel_end_x = ll->sel_end_x;
XDrawString( info->ctx_dsp, info->ctx_win, info->ctx_gc,
base_x, base_y,
((unsigned char *)PTR_TO_DATAPTR(info->text)) + line_start,
line_end - line_start );
}
static _rs_inline obj bignum_to_float(obj x)
{
mpz_t a;
if( FIXNUM_P(x) ) {
return make_float( (float) fx2int(x) );
} else if(BIGNUM_P(x)) {
OBJ_TO_MPZ(a, x);
return make_float(mpz_get_d(a));
} else if( LONG_INT_P(x) ) {
return make_float(int_64_to_float( *((INT_64 *)PTR_TO_DATAPTR(x)) ));
}
scheme_error("bignum_to_float type not found for ~a", 1, x);
return FALSE_OBJ; /* not reached */
}
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) );
}
UINT_32 basic_raw_uint_conv( obj a )
{
if (FIXNUM_P(a)) {
if (FX_LT( a, ZERO )) {
scheme_error( "fixnum value ~s is negative, not a valid UINT_32", 1, a );
}
return fx2int( a );
} else if (LONG_INT_P( a )) {
INT_64 *p = (INT_64 *)PTR_TO_DATAPTR( a );
if ((p->digits[0] == 0) && (p->digits[1] == 0)) {
return (p->digits[2] << 16) + p->digits[3];
} else {
scheme_error( "longint value ~s is not a valid UINT_32", 1, a );
}
#if FULL_NUMERIC_TOWER
} else if (BIGNUM_P( a )) {
mpz_t z;
int cmp;
OBJ_TO_MPZ( z, a );
cmp = mpz_sgn( z );
if (cmp < 0) {
scheme_error( "bignum value ~s is negative, not a valid UINT_32", 1, a );
}
if (cmp == 0) {
return 0;
}
cmp = mpz_cmp_ui( z, 0xFFFFFFFFUL );
if (cmp > 0) {
scheme_error( "bignum value ~s is too big for a UINT_32", 1, a );
}
return mpz_get_ui( z );
#endif
} else {
scheme_error( "non-basic-integer value ~s is not a valid UINT_32", 1, a );
}
return 0;
}
struct LocationRef create_LR( RStore *in_store, obj item )
{
if (OBJ_ISA_PTR(item))
{
struct VMPageRecord *vmpr;
vmpr = addr_to_vm_page_record( in_store, PTR_TO_DATAPTR(item) );
if (vmpr)
{
return create_LR_on_page( in_store, item, vmpr );
}
else
{
/* could check for an indirect object, but currently
indirect objects are often created on-demand, and
we're not really in a position to do that here just yet
*/
scheme_error( "create_LR(~s): not in pstore ~s",
2, item, in_store->owner );
}
}
return create_immob_LR( item );
}
obj BSOP_flush( obj port, int closeq )
{
const char *src;
int len;
obj result;
src = string_text( gvec_read( port, BSOP_BUFFER ) );
len = fx2int( gvec_read( port, BSOP_INDEX ) );
result = bvec_alloc( len+1, string_class );
memcpy( PTR_TO_DATAPTR(result), src, len );
/*
We don't need to set the last byte to NUL because
bvec_alloc sets the whole last UINT_32 to 0,
even if (len+1) is a multiple of 4 bytes.
PTR_TO_DATAPTR(result)[len] = NUL;
*/
if (closeq) {
gvec_write( port, BSOP_BUFFER, FALSE_OBJ );
}
return result;
}
jump_addr gui_call( void )
{
Tcl_Interp *interp;
int rc = 0;
COUNT_ARGS_AT_LEAST(1);
if (EQ(REG0,FALSE_OBJ))
{
COUNT_ARGS(1);
interp = Tcl_CreateInterp();
REG0 = RAW_PTR_TO_OBJ( interp );
}
else if (arg_count_reg > 2 && EQ(REG1,int2fx(4)))
{
obj info;
COUNT_ARGS(3);
interp = (Tcl_Interp *)OBJ_TO_RAW_PTR(REG0);
/* this hook creates a Scheme procedure
for calling the given Tcl command
The arguments to the scheme procedure had
better be strings, fixnums, or symbols.
*/
info = bvec_alloc( sizeof(Tcl_CmdInfo), byte_vector_class );
/*printf( "seeking info on `%s'\n", string_text(REG2) );*/
if (!Tcl_GetCommandInfo( interp,
(char *)string_text(REG2),
(Tcl_CmdInfo *)PTR_TO_DATAPTR(info) ))
{
REG0 = make_string( "command not found" );
REG1 = int2fx(1);
RETURN(1);
}
REG0 = make2(closure_class,
make4(bindingenvt_class,
NIL_OBJ,
info,
RAW_PTR_TO_OBJ(interp),
REG2 ),
make2(template_class,
JUMP_ADDR_TO_OBJ(tcl_gateway),
ZERO));
RETURN1();
}
else
{
COUNT_ARGS(2);
interp = (Tcl_Interp *)OBJ_TO_RAW_PTR(REG0);
if (EQ(REG1,int2fx(0)))
{
switch_hw_regs_back_to_os();
main_tk_win = Tk_CreateMainWindow( interp, NULL, "rs", "RScheme" );
if (!main_tk_win)
{
switch_hw_regs_into_scheme();
goto tcl_error;
}
printf( "main window = %#x\n", main_tk_win );
/*
Tk_GeometryRequest( main_tk_win, 200, 200 );
*/
Tcl_SetVar(interp, "tcl_interactive","0", TCL_GLOBAL_ONLY);
Tcl_CreateCommand(interp,
"scheme-callback",
the_callback,
(ClientData)0,
NULL);
switch_hw_regs_into_scheme();
if ((rc = Tcl_Init(interp)) == TCL_ERROR) {
goto tcl_error;
}
if ((rc = Tk_Init(interp)) == TCL_ERROR) {
goto tcl_error;
}
}
else if (EQ(REG1,int2fx(2)))
{
Tk_MakeWindowExist( main_tk_win );
RETURN0();
}
else if (EQ(REG1,int2fx(1)))
{
evts = NIL_OBJ;
switch_hw_regs_back_to_os();
Tk_DoOneEvent(TK_ALL_EVENTS|TK_DONT_WAIT);
switch_hw_regs_into_scheme();
REG0 = evts;
RETURN(1);
}
else if (EQ(REG1,int2fx(3)))
{
evts = NIL_OBJ;
/* flush events */
switch_hw_regs_back_to_os();
while (Tk_DoOneEvent(TK_ALL_EVENTS|TK_DONT_WAIT));
switch_hw_regs_into_scheme();
REG0 = evts;
RETURN(1);
}
else
{
assert( STRING_P(REG1) );
rc = Tcl_Eval( interp, (char *)string_text(REG1) );
}
REG0 = make_string( interp->result );
}
RETURN(1);
tcl_error:
REG0 = make_string( interp->result );
REG1 = int2fx(rc);
RETURN(2);
}
static void *mp_alloc( size_t n )
{
return PTR_TO_DATAPTR(alloc( n, mp_data_class ));
}
static void *mp_realloc( void *old_data, size_t old_size, size_t new_size )
{
void *new_data = PTR_TO_DATAPTR(alloc( new_size, mp_data_class ));
memcpy( new_data, old_data, old_size );
return new_data;
}
obj parse_format_string( obj str )
{
obj entry, substr, prev, first, next;
const char *begin, *s, *limit;
int sharp_flag, star_flag, negative_flag;
int pre_dot_lead_zero, pre_dot_num;
int post_dot_digits, post_dot_num;
obj at_flag, braced;
prev = first = cons( FALSE_OBJ, NIL_OBJ );
begin = s = string_text(str);
limit = begin + string_length(str);
while (s < limit)
{
if (s[0] == '~' && (s+1 < limit))
{
if (begin != s)
{
/* flush the chars we've seen so far... */
substr = bvec_alloc( s - begin + 1, string_class );
memcpy( PTR_TO_DATAPTR(substr), (void*)begin, s - begin );
next = cons( substr, NIL_OBJ );
gvec_write_fresh_ptr( prev, SLOT(1), next );
prev = next;
}
begin = ++s;
pre_dot_lead_zero = 0;
post_dot_digits = -1;
pre_dot_num = -1;
post_dot_num = -1;
sharp_flag = 0;
star_flag = 0;
at_flag = FALSE_OBJ;
braced = FALSE_OBJ;
another:
switch (*s)
{
case '#':
sharp_flag = 1;
s++;
goto another;
case '*':
star_flag = 1;
s++;
goto another;
case '@':
at_flag = TRUE_OBJ;
s++;
goto another;
case '{':
{
const char *sb = s;
unsigned n;
while ((s < limit) && (*s != '}'))
s++;
n = s - sb - 1;
braced = bvec_alloc( n+1, string_class );
memcpy( string_text( braced ), sb+1, n );
if (s < limit)
s++; /* skip the brace itself */
goto another;
}
}
if (*s == '-')
{
s++;
negative_flag = 1;
}
else
negative_flag = 0;
if (isdigit(*(unsigned char *)s))
{
pre_dot_num = 0;
if (*s == '0')
{
s++;
pre_dot_lead_zero = 1;
}
while (isdigit(*(unsigned char *)s))
{
pre_dot_num = (pre_dot_num * 10) + *s++ - '0';
}
}
if (*s == '.')
{
s++;
post_dot_num = 0;
post_dot_digits = 0;
while (isdigit(*(unsigned char *)s))
{
post_dot_digits++;
post_dot_num = (post_dot_num * 10) + *s++ - '0';
}
}
if (begin == s)
{
entry = MAKE_ASCII_CHAR( *s );
}
else
{
entry = maken( vector_class,
10,
MAKE_ASCII_CHAR( *s ),
sharp_flag ? TRUE_OBJ : FALSE_OBJ,
star_flag ? TRUE_OBJ : FALSE_OBJ,
at_flag,
negative_flag ? TRUE_OBJ : FALSE_OBJ,
pre_dot_lead_zero ? TRUE_OBJ : FALSE_OBJ,
(pre_dot_num < 0) ? FALSE_OBJ
: int2fx(pre_dot_num),
(post_dot_digits < 0) ? FALSE_OBJ
: int2fx(post_dot_digits),
(post_dot_num < 0) ? FALSE_OBJ
: int2fx(post_dot_num),
braced );
}
next = cons( entry, NIL_OBJ );
gvec_write_fresh_ptr( prev, SLOT(1), next );
prev = next;
begin = ++s;
}
else
s++;
}
if (begin != s)
{
substr = bvec_alloc( s - begin + 1, string_class );
memcpy( PTR_TO_DATAPTR(substr), (void*)begin, s - begin );
next = cons( substr, NIL_OBJ );
gvec_write_fresh_ptr( prev, SLOT(1), next );
}
return pair_cdr(first);
}
static obj _rs_inline longint_to_bignum(obj a)
{
return int64_to_bignum(*((INT_64 *)PTR_TO_DATAPTR(a)));
}
