int equal_p(object o1, object o2) {
if (eqv_p(o1,o2)) return 1;
if (PAIR_P(o1)) {
return PAIR_P(o2)&&equal_p(CAR(o1),CAR(o2))&&equal_p(CDR(o1),CDR(o2));
} else if (VECTOR_P(o1)) {
if (VECTOR_P(o2)) {
long max = VECTOR_LENGTH(o1);
if (max == VECTOR_LENGTH(o2)) {
object *e1 = VECTOR_ELEMENTS(o1), *e2 = VECTOR_ELEMENTS(o2);
long i;
for (i=0; i<max; i++)
if (!equal_p(e1[i],e2[i]))
return 0;
return 1;
}
}
} else if (STRING_P(o1)) {
if (STRING_P(o2)) {
long max = STRING_LENGTH(o1);
if (max == STRING_LENGTH(o2)) {
char *p1 = STRING_VALUE(o1);
char *p2 = STRING_VALUE(o2);
while (*p1 && *p2) {
if (*p1++ != *p2++) return 0;
}
return (*p1 == *p2);
}
}
}
return 0;
}
static void primop_substring_ix(long argc) {
object s1 = *sp++;
object s2 = *sp;
char *s;
TYPE_CHECK(STRING_P(s1),1,"string",s1);
TYPE_CHECK(STRING_P(s2),1,"string",s2);
s = strstr(STRING_VALUE(s1), STRING_VALUE(s2));
if (s)
*sp = MAKE_FIXNUM(s - STRING_VALUE(s1));
else
*sp = false_object;
}
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;
}
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();
}
}
/* Given the ASCII representation of an alist in INFO->data,
store that data in the indicated package. */
void
sd_info_to_package (SESSION_INFO *info, Package *package)
{
WispObject *list;
/* The data is stored as the ASCII representation of an alist. */
list = wisp_from_string ((char *)info->data);
if (list != (WispObject *)NULL)
{
while (list != NIL)
{
WispObject *pair;
pair = CAR (list);
list = CDR (list);
if (CONS_P (pair) && STRING_P (CAR (pair)))
{
char *tag;
tag = strdup (STRING_VALUE (CAR (pair)));
if (STRING_P (CDR (pair)))
{
Symbol *sym;
sym = symbol_intern_in_package (package, tag);
symbol_add_value (sym, STRING_VALUE (CDR (pair)));
}
else
{
WispObject *values = CDR (pair);
Symbol *sym = symbol_intern_in_package (package, tag);
while (CONS_P (values) && STRING_P (CAR (values)))
{
symbol_add_value (sym, STRING_VALUE (CAR (values)));
values = CDR (values);
}
}
free (tag);
}
}
}
gc_wisp_objects ();
}
static void primop_string_ref(long argc) {
object s = *sp++;
long i = the_long(2,*sp);
TYPE_CHECK(STRING_P(s),1,"string",s);
if (i >= STRING_LENGTH(s))
error(*sp,"index out of range");
*sp = make_character(STRING_VALUE(s)[i]);
}
static void primop_string_set(long argc) {
object s = *sp;
long i = the_long(2,sp[1]);
char c = the_char(3,sp[2]);
TYPE_CHECK(STRING_P(s),1,"string",s);
if (i >= STRING_LENGTH(s))
error(sp[1],"index out of range");
STRING_VALUE(s)[i] = c;
sp += 2;
}
static void primop_string_to_list(long argc) {
long i;
object result = null_object;
PUSH_GC_PROTECT(result);
TYPE_CHECK(STRING_P(sp[0]),1,"string", sp[0]);
i = STRING_LENGTH(sp[0]);
while (i--) {
char c = STRING_VALUE(sp[0])[i];
result = cons(make_character(c),result);
}
POP_GC_PROTECT(1);
*sp = result;
}
static void
edwin_auto_save (void)
{
static SCHEME_OBJECT position;
static struct interpreter_state_s new_state;
position =
((VECTOR_P (fixed_objects))
? (VECTOR_REF (fixed_objects, FIXOBJ_EDWIN_AUTO_SAVE))
: EMPTY_LIST);
while (PAIR_P (position))
{
SCHEME_OBJECT entry = (PAIR_CAR (position));
position = (PAIR_CDR (position));
if ((PAIR_P (entry))
&& (GROUP_P (PAIR_CAR (entry)))
&& (STRING_P (PAIR_CDR (entry)))
&& ((GROUP_MODIFIED_P (PAIR_CAR (entry))) == SHARP_T))
{
SCHEME_OBJECT group = (PAIR_CAR (entry));
char * namestring = (STRING_POINTER (PAIR_CDR (entry)));
unsigned long length;
unsigned char * start = (GROUP_TEXT (group, (&length)));
unsigned char * end = (start + length);
unsigned char * gap_start = (start + (GROUP_GAP_START (group)));
unsigned char * gap_end = (start + (GROUP_GAP_END (group)));
if ((start < gap_start) || (gap_end < end))
{
bind_interpreter_state (&new_state);
if ((setjmp (interpreter_catch_env)) == 0)
{
Tchannel channel;
outf_error ("Auto-saving file \"%s\"\n", namestring);
outf_flush_error ();
channel = (OS_open_output_file (namestring));
if (start < gap_start)
OS_channel_write (channel, start, (gap_start - start));
if (gap_end < end)
OS_channel_write (channel, gap_end, (end - gap_end));
OS_channel_close (channel);
}
unbind_interpreter_state (&new_state);
}
}
}
}
static void primop_string_append(long argc) {
long i, len = 0;
object s, result;
char *rp;
for (i=0; i<argc; i++) {
s = sp[i];
TYPE_CHECK(STRING_P(s),i+1,"string",s);
len += STRING_LENGTH(s);
}
result = make_string_of_size(len,0);
rp = STRING_VALUE(result);
for (i=0; i<argc; i++) {
char *p = STRING_VALUE(sp[i]);
while (*p) *rp++ = *p++;
}
*rp = '\0';
sp += argc;
*--sp = result;
}
static VALUE erlix_list_init2(int argc, VALUE* argv,VALUE self){
ErlixTerm *list;
ETERM **les;
VALUE e;
ErlixTerm *ep;
int i;
Data_Get_Struct(self,ErlixTerm,list);
if(argc==0){
//empty list
list->term=erl_mk_empty_list();
return self;
}
if(argc==1 && (ARRAY_P(*argv)||STRING_P(*argv))){
return erlix_list_init(self, *argv);
}
//check: all elements' must be ErlixTerm or auto-convertable Type
for(i=0;i<argc;i++){
e=*(argv+i);
if(!IS_ETERM(e) && !CAN_AUTO_CONV(e)){
rb_raise(rb_eTypeError,"all list's elements must be ErlixTerm or Auto-Convertable-Type!");
}
}
les=(ETERM**)malloc(sizeof(ETERM*)*argc);
for(i=0;i<argc;i++){
e=*(argv+i);
if(IS_ETERM(e)){
Data_Get_Struct(e,ErlixTerm,ep);
*(les+i)=erl_copy_term(ep->term);
}else{
*(les+i)=erlix_auto_conv(e);
}
}
list->term=erl_mk_list(les,argc);
//for(i=0;i<RARRAY(ary)->len;i++){
// erl_free_term(*(les+i));
//}
free(les);
return self;
}
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;
}
static void primop_substring(long argc) {
object s = sp[0], result;
long start = the_long(2,sp[1]), end = the_long(3,sp[2]);
long i, len;
char *rp, *p;
TYPE_CHECK(STRING_P(s),1,"string",s);
len = STRING_LENGTH(s);
if (start < 0 || start > len)
error(sp[1],"starting index of range");
if (end < start || end > len)
error(sp[1],"ending index of range");
result = make_string_of_size(end-start,0);
p = STRING_VALUE(sp[0]);
rp = STRING_VALUE(result);
p += start;
for (i=start; i < end; i++) {
*rp++ = *p++;
}
*rp = '\0';
sp += 2;
*sp = result;
}
static void
delete_temp_files (void)
{
static SCHEME_OBJECT position;
static struct interpreter_state_s new_state;
position =
((VECTOR_P (fixed_objects))
? (VECTOR_REF (fixed_objects, FIXOBJ_FILES_TO_DELETE))
: EMPTY_LIST);
while (PAIR_P (position))
{
SCHEME_OBJECT entry = (PAIR_CAR (position));
position = (PAIR_CDR (position));
if (STRING_P (entry))
{
bind_interpreter_state (&new_state);
if ((setjmp (interpreter_catch_env)) == 0)
OS_file_remove (STRING_POINTER (entry));
unbind_interpreter_state (&new_state);
}
}
}
static void primop_string_p(long argc) {
if (!STRING_P(*sp)) *sp = false_object;
}
static long string_ci_compare(object s1, object s2) {
TYPE_CHECK(STRING_P(s1),1,"string",s1);
TYPE_CHECK(STRING_P(s2),2,"string",s2);
return strcmpci(STRING_VALUE(s1), STRING_VALUE(s2));
}
static void primop_string_length(long argc) {
object o = *sp;
TYPE_CHECK(STRING_P(o),1,"string",o);
*sp = MAKE_FIXNUM(STRING_LENGTH(o));
}
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;
}
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);
}