LISPTR lisp_print(LISPTR x, FILE* out)
{
if (consp(x)) {
fputwc('(', out);
while (true) {
lisp_print(car(x), out);
x = cdr(x);
if (!consp(x)) {
if (x != NIL) {
fputws(L" . ", out);
lisp_print(x, out);
}
break;
}
fputwc(' ', out);
}
fputwc(')', out);
} else if (symbolp(x)) {
fputws(string_text(symbol_name(x)), out);
} else if (numberp(x)) {
fwprintf(out, L"%g", number_value(x));
} else if (stringp(x)) {
fputwc('"', out);
fputws(string_text(x), out);
fputwc('"', out);
} else {
fputws(L"*UNKOBJ*", out);
}
return x;
}
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();
}
}
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;
}
obj basic_num_to_string_obj( obj a, unsigned radix )
{
char buf[100];
if (FIXNUM_P(a)) {
return make_string( fixnum_to_string( &buf[100], a, radix ) );
} else if (LONGFLOAT_P(a)) {
snprintf( buf, 100, "%g", extract_float(a) );
if (!strchr( buf,'.') && !strchr(buf,'e')) {
strcat( buf, "." );
}
return make_string( buf );
} else if (OBJ_ISA_PTR_OF_CLASS(a,bignum_class)) {
return bignum_to_string_obj( a, radix );
} else if (OBJ_ISA_PTR_OF_CLASS(a,mp_rational_class)) {
return rational_to_string_obj( a, radix );
} else if (OBJ_ISA_PTR_OF_CLASS(a,rect_complex_class)) {
obj r;
char *str;
obj re = basic_num_to_string_obj( gvec_ref( a, SLOT(0) ), radix );
obj im = basic_num_to_string_obj( gvec_ref( a, SLOT(1) ), radix );
unsigned len = string_length(re) + string_length(im) + 1;
if (string_text(im)[0] != '-') {
len++;
}
r = bvec_alloc( len+1, string_class );
str = string_text( r );
memcpy( str, string_text( re ), string_length( re ) );
str += string_length( re );
if (string_text(im)[0] != '-') {
*str++ = '+';
}
memcpy( str, string_text( im ), string_length( im ) );
str += string_length( im );
*str++ = 'i';
*str = 0;
return r;
} else {
return FALSE_OBJ;
}
}
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;
}
static const char *scheme_generator( char *text, int state )
{
static obj current;
static int len;
obj item;
const char *name;
if (state == 0) /* restarting generation */
{
current = the_completions;
len = strlen( text );
}
while (!EQ( current, NIL_OBJ ))
{
assert( PAIR_P(current) );
item = pair_car( current );
current = pair_cdr( current );
if (STRING_P(item))
{
name = string_text(item);
}
else
{
assert( SYMBOL_P(item) );
name = symbol_text(item);
}
if (strncmp( name, text, len ) == 0)
{
char *name2;
name2 = (char *)malloc( strlen( name ) + 1 );
strcpy( name2, name );
return name2;
}
}
return NULL;
}
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;
}
void rdln_add_history( obj str )
{
add_history( string_text(str) );
}
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);
}
string MyLogStructure::wchar_t_pointerToString(const wchar_t*wchar_t_pointer_text)
{
wstring wstring_text(wchar_t_pointer_text);
string string_text(wstring_text.begin(), wstring_text.end());
return string_text;
}
obj rs_save_image_file( obj root, obj ref_vec, obj ref_names,
obj rplc, obj out_info )
{
int i;
obj *save, result, output_id;
char *outfile_name = NULL;
FILE *outfile_strm = NULL;
/* Phase 1 --- Setup */
if (STRING_P(out_info))
{
outfile_name = string_text(out_info);
outfile_strm = fopen( outfile_name, "wb" );
if (!outfile_strm)
{
scheme_error( "~a: error opening image output", 1, out_info );
}
}
for (i=0; i<NUM_CLASS_MODES; i++)
hi_init_queue( &image_modes[i].queue );
hi_init_queue( &used_refs );
if (OBJ_ISA_PTR(rplc))
setup_replacement_objects( rplc );
save = setup_reference_objects( ref_vec );
/* Phase 2 --- Traversal */
spot_object( root );
traverse_all();
/* Phase 3 --- Name Assignment */
output_id = OBJ(POINTER_TAG);
output_id = assign_ref_queue_names( &used_refs, output_id );
for (i=0; i<NUM_CLASS_MODES; i++)
output_id = assign_queue_names( &image_modes[i].queue, output_id );
#if DEBUG_SAVE
printf( "%u objects named in output\n", VAL(output_id)>>PRIMARY_TAG_SIZE );
#endif
/* Phase 4 --- Output */
if (outfile_strm)
{
#if DEBUG_SAVE
printf( "writing image to file: \"%s\"\n", outfile_name );
#endif
do_file_output( outfile_strm, ref_vec, ref_names, root );
}
/* Phase 5 --- Cleanup */
for (i=0; i<NUM_CLASS_MODES; i++)
cleanup_queued_objects( &image_modes[i].queue );
cleanup_reference_objects( ref_vec, save );
cleanup_queued_objects( &rplc_queue );
if (EQ(out_info,TRUE_OBJ))
result = do_vector_output();
else
result = TRUE_OBJ;
for (i=0; i<NUM_CLASS_MODES; i++)
hi_free_queue( &image_modes[i].queue );
clear_part_descr_labels( &used_refs );
hi_free_queue( &used_refs );
return result;
}
int layout_text( struct text_rendition *info )
{
UINT_32 i, n, cur_w, last_line_start, last_line_end;
int base_x, base_y, sel_start_x, sel_end_x;
unsigned char *text_str;
unsigned *widths, w_temp[300];
struct line_layout *lines, *cur_ll, *ll_limit, ll_temp[30];
int line_height = info->line_height;
int line_width = info->line_width;
UINT_32 sel_from = info->sel_from;
UINT_32 sel_to = info->sel_to;
n = string_length(info->text);
if (n < 300)
{
widths = w_temp;
}
else
{
widths = (unsigned *)malloc( sizeof(unsigned) * n );
}
cur_ll = lines = ll_temp;
ll_limit = lines + 30;
text_str = (unsigned char *)string_text(info->text);
PerCharWidths( info->font, text_str, widths, n );
base_x = info->origin_x;
base_y = info->origin_y;
i = 0;
cur_w = 0;
last_line_start = last_line_end = 0;
sel_start_x = sel_end_x = -1;
while (i < n)
{
unsigned char ch = text_str[i];
if (i == sel_from)
{
cur_ll->sel_start_x = cur_w;
}
if (i == sel_to)
{
cur_ll->sel_end_x = cur_w;
}
if (ch == '\n')
{
cur_ll->base_x = base_x;
cur_ll->base_y = base_y;
cur_ll->line_start = last_line_start;
cur_ll->line_end = i;
cur_ll++;
base_y += line_height;
i++;
last_line_start = i;
cur_w = 0;
}
else if (ch == '\t' || ch == ' ')
{
cur_w += widths[i];
i++;
last_line_end = i;
}
else
{
cur_w += widths[i];
if (cur_w <= line_width)
{
i++;
}
else if (last_line_start == last_line_end)
{
/* break on characters
-- there was no good place to break... */
cur_ll->base_x = base_x;
cur_ll->base_y = base_y;
cur_ll->line_start = last_line_start;
cur_ll->line_end = i;
cur_ll++;
base_y += line_height;
last_line_start = i;
cur_w = 0;
}
else
{
/* break on the last good place to break */
cur_ll->base_x = base_x;
cur_ll->base_y = base_y;
cur_ll->line_start = last_line_start;
cur_ll->line_end = last_line_end;
cur_ll++;
base_y += line_height;
last_line_start = last_line_end;
i = last_line_end;
cur_w = 0;
}
}
}
if (n != last_line_start)
{
/* flush the current line */
cur_ll->base_x = base_x;
cur_ll->base_y = base_y;
cur_ll->line_start = last_line_start;
cur_ll->line_end = n;
cur_ll++;
base_y += line_height;
}
/* render the lines */
ll_limit = cur_ll;
#if 0
for (n=0, cur_ll=lines; cur_ll<ll_limit; cur_ll++,n++)
{
printf( "line[%u]: base=(%d,%d) line=(%u,%u) sel=(%d,%d)\n",
n, cur_ll->base_x, cur_ll->base_y,
cur_ll->line_start, cur_ll->line_end,
cur_ll->sel_start_x, cur_ll->sel_end_x );
}
#endif
if (truish(info->sel_bleed))
{
XSetForeground( info->ctx_dsp, info->ctx_gc, info->selection_color );
for (cur_ll=lines; cur_ll<ll_limit; cur_ll++)
render_line_sel( info, cur_ll );
}
XSetForeground( info->ctx_dsp, info->ctx_gc, info->text_color );
for (cur_ll=lines; cur_ll<ll_limit; cur_ll++)
render_line( info, cur_ll );
if (widths != w_temp)
free(widths);
if (lines != ll_temp)
free(lines);
return base_y;
}
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);
}
