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))); }