obj rscheme_global_ref( UINT_32 offset )
{
if (offset >= SLOT(NUM_RSCHEME_GLOBALS))
scheme_error( "rscheme-global-ref: ~d out of range",
1, RIBYTES_TO_FXWORDS(offset) );
return *(obj *)(((char *)rscheme_global) + offset);
}
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 *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();
}
}
unsigned expand_last( void )
{
obj list = ZERO;
unsigned N = 0;
switch (arg_count_reg)
{
case 0:
scheme_error( "expand_list: no arguments", 0 );
break;
STAGE(0,1);
STAGE(1,2);
STAGE(2,3);
STAGE(3,4);
STAGE(4,5);
STAGE(5,6);
STAGE(6,7);
STAGE(7,8);
STAGE(8,9);
STAGE(9,10);
default:
/* this is for cases 11, 12, ..., since STAGE(9,10) is case 10
* hence, N = (arg_count_reg - 1) is at least 10
*/
N = arg_count_reg - 1;
list = REG(N);
filled_10:
while (PAIR_P(list))
{
REG(N) = pair_car( list );
list = pair_cdr( list );
N++;
if (N >= IMPL_ARG_LIMIT)
scheme_error( "expand_last: list of args too long at: ~#*@40s",
1, list );
}
break;
}
if (!NULL_P(list))
{
scheme_error( "expand_last: last arg not a proper list at ~a",
1,
list );
}
return N;
}
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];
}
}
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 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) );
}
_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) );
}
struct function_descr *resolve_function_descr( struct function_descr *f )
{
if (resolve_function_descr_fn) {
return resolve_function_descr_fn( f );
} else {
scheme_error( "no resolve_function_descr_fn", 0 );
return NULL;
}
}
int basic_raw_int_conv( obj a )
{
if (FIXNUM_P( a ))
{
return fx2int( a );
}
if (LONG_INT_P( a ))
{
INT_64 i = extract_int_64( a );
if (int_64_fit_in_32_q( i ))
{
return int_64_to_int_32( i );
}
else
{
scheme_error( "long int ~s is out of range for a raw int", 1, a );
return 0;
}
}
#if FULL_NUMERIC_TOWER
else if (BIGNUM_P( a ))
{
mpz_t z;
OBJ_TO_MPZ( z, a );
if (bignum_fit_in_32( z ))
{
return bignum_to_int( z );
}
else
{
scheme_error( "bignum ~s is out of range for a raw int", 1, a );
return 0;
}
}
#endif
else
{
scheme_error( "cannot convert ~s to an exact integer", 1, a );
return 0;
}
}
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) );
}
_rs_volatile void failed_type_check( obj place, obj var, obj val, obj expect )
{
if (!PAIR_P(expect))
expect = cons( expect, NIL_OBJ );
scheme_error( "failed type check: in ~a\n~a = ~s is not one of: ~a",
4,
place,
var,
val,
expect );
}
/* <simple datum> -> <boolean> | <number> | <character> | <string> | <symbol>
*/
static SCM read_simple_datum(FILE *file, int previous)
{
int c;
c = previous == 0 ? skip_comment_and_space(file) : previous;
if (SCM_INITIAL_CHARACTERS_P(c)) { /* <symbol> */
return read_symbol(file, c);
}
if (isdigit(c)) { /* <number> */
return read_number(file, c);
}
if (SCM_PECULIAR_IDENTIFIER_P(c)) { /* <number> or <symbol> */
return read_number_or_peculiar(file, c);
}
switch (c) {
case EOF:
return SCM_EOF;
case '#': /* <boolean> or <character> or <number prefix> */
c = fgetc(file);
switch (c) {
case EOF:
scheme_error("syntax error");
/* <boolean> */
case 't': return SCM_TRUE;
case 'f': return SCM_FALSE;
/* <character> */
case '\\':
return read_character(file);
/* <number prefix> */
default:
scheme_error("unsupport number prefix");
}
case '"': /* <string> */
return read_string(file);
default:
scheme_error("unsupport character");
}
}
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;
}
/* R5RS library procedure read
* (read)
* (read [port])
*/
SCM scm_proc_read(FILE *file)
{
int c = skip_comment_and_space(file);
switch (c) {
case '(':
return read_list(file);
case ')': /* List end */
scheme_error("symtax error");
case '[':
case ']':
scheme_error("unsupport bracket");
case '{':
case '}':
scheme_error("unsupport brace");
case '|':
scheme_error("unsupport bar");
case '#':
c = fgetc(file);
if ('(' == c) {
return read_vector(file);
} else {
ungetc(c, file);
return read_simple_datum(file, '#');
}
case '\'': /* Quotation */
return new_cons(SCM_SYMBOL_QUOTE, new_cons(scm_proc_read(file), SCM_NULL));
case '`': /* Quasiquotation */
scheme_error("unsupport quasiquotation");
case ',': /* (Splicing) Uuquotation */
scheme_error("unsupport (splicing) unquotation");
default:
return read_simple_datum(file, c);
}
}
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;
}
}
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;
}
}
obj bignum_div( obj a, obj b )
{
mpz_t r, a1, b1;
OBJ_TO_MPZ(a1, a);
OBJ_TO_MPZ(b1, b);
mpz_init(r);
if ( mpz_sgn(b1) == 0 ) {
scheme_error( "dividing ~s by zero", 1, a );
}
mpz_div(r, a1, b1);
return bignum_compact(r);
}
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 */
}
obj rational_div( obj a, obj b )
{
mpq_t r, a1, b1;
OBJ_TO_MPQ(a1, a);
OBJ_TO_MPQ(b1, b);
if (mpq_sgn( b1 ) == 0) {
scheme_error( "dividing ~s by zero", 1, a );
}
mpq_init(r);
mpq_div(r, a1, b1);
return rational_compact(r);
}
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 rscheme_global_set( UINT_32 offset, obj new_val )
{
obj old_val;
if (offset < SLOT(NUM_RSCHEME_GLOBALS))
{
old_val = *(obj *)(((char *)rscheme_global) + offset);
*(obj *)(((char *)rscheme_global) + offset) = new_val;
}
else
{
scheme_error( "rscheme-global-ref: ~d out of range",
1, RIBYTES_TO_FXWORDS(offset) );
old_val = FALSE_OBJ; /* quiet compiler */
}
return old_val;
}
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;
}
/* <list> -> (<datum>*) | (<datum>+ . <datum>) | <abbreviation>
*/
static SCM read_list(FILE *file)
{
int c;
SCM lst = SCM_NULL;
SCM last_pair = SCM_NULL;
SCM datum = SCM_NULL;
for (;;) {
c = skip_comment_and_space(file);
switch (c) {
case EOF:
goto syntax_error;
break;
case ')': /* end of list */
return lst;
case '.': /* dot pair */
if (NULL_P(last_pair)) /* ( . <datum>) is invalid */
goto syntax_error;
CDR(last_pair) = scm_proc_read(file);
c = skip_comment_and_space(file);
if (c != ')')
goto syntax_error;
return lst;
break;
default: /* read datum */
ungetc(c, file);
datum = scm_proc_read(file);
if (NULL_P(lst)) { /* initialize list */
lst = new_cons(datum, SCM_NULL);
last_pair= lst;
} else {
CDR(last_pair) = new_cons(datum, SCM_NULL);
last_pair = CDR(last_pair);
}
}
}
syntax_error:
scheme_error("syntax error");
return NULL;
}
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) );
}
double basic_raw_float_conv( obj a )
{
if (LONG_INT_P( a ))
{
return int_64_to_float( extract_int_64( a ) );
}
#if FULL_NUMERIC_TOWER
if (RATIONAL_P( a ))
{
return rational_to_raw_float( a );
}
#endif
if (LONGFLOAT_P( a ))
{
return extract_float( a );
}
scheme_error( "cannot convert ~s to an inexact real", 1, a );
return 0;
}
void *mm_alloc( size_t bytes, enum mm_mode mode )
{
void *pg;
if (bytes > num_bytes_in_buff)
{
if (bytes == MM_PAGE_SIZE)
{
num_bytes_in_buff = NUM_PAGES_TO_GRAB * MM_PAGE_SIZE;
page_buff = raw_mm_alloc( num_bytes_in_buff, MM_MODE_NO_ACCESS );
if (!page_buff)
goto failed;
}
else
{
pg = raw_mm_alloc( bytes, mode );
if (!pg)
goto failed;
return pg;
}
}
ok:
pg = page_buff;
page_buff = (void *)((char *)page_buff + bytes);
num_bytes_in_buff -= bytes;
if (mode != MM_MODE_NO_ACCESS)
mm_set_prot( pg, bytes, mode );
return pg;
failed:
scheme_error( "mm_alloc: couldn't alloc ~d pages (~a)",
2,
int2fx((bytes + MM_PAGE_MASK) / MM_PAGE_SIZE),
make_string( strerror(errno) ) );
return NULL;
}
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 );
}
jump_addr rs_gf_dispatch( obj gf )
{
obj m;
if (arg_count_reg < 1)
{
scheme_error( "GF ~s called with no arguments", 1, gf );
}
m = rs_gf_find_method( gf, REG0 );
if (EQ(m,FALSE_OBJ))
{
/* a miss -- call the fallback function */
COLLECT0();
REG1 = REG0;
REG0 = gf;
arg_count_reg = 2;
return apply( load_cache_and_call_proc );
}
else
{
return apply(m);
}
}
