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;
}
void print_tree(VALUE tree)
{
if(NIL_P(tree)) printf("()");
else if(FALSE_P(tree)) printf("#f");
else if(TRUE_P(tree)) printf("#t");
else if(FIXNUM_P(tree)) printf("%ld", FIX2INT(tree));
else if(SYMBOL_P(tree)) printf("%s", SYMBOL_NAME(tree));
else if(CLOSURE_P(tree)) printf("#<closure>");
else if(MACRO_P(tree)) printf("#<macro>");
else if(NATIVE_PROCEDURE_P(tree)) printf("#<subr>");
else if (PAIR_P(tree))
{
printf("(");
while(1)
{
print_tree(CAR(tree));
tree = CDR(tree);
if(NIL_P(tree)) break;
if(DIRECTVAL_P(tree) || SYMBOL_P(tree) || CLOSURE_P(tree) || MACRO_P(tree) || NATIVE_PROCEDURE_P(tree))
{
printf(" . ");
print_tree(tree);
break;
}
printf(" ");
}
printf(")");
}
else
{
fprintf(stderr, "print error");
exit(1);
}
}
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);
}
}
}
}
_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 );
}
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 int slot_list_delq( obj owner, UINT_32 slot, obj key )
{
obj p, prev = FALSE_OBJ;
p = gvec_ref( owner, slot );
while (PAIR_P( p )) {
if (EQ( pair_car( p ), key )) {
if (EQ( prev, FALSE_OBJ )) {
gvec_set( owner, slot, pair_cdr( p ) );
} else {
pair_set_cdr( prev, pair_cdr( p ) );
}
return 1;
}
prev = p;
p = pair_cdr( p );
}
return 0;
}
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
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_list_to_string(long argc) {
object l = sp[0];
long i, max = 0;
object s;
char *p;
while (PAIR_P(l)) {
object c = CAR(l);
if (!CHARACTER_P(c))
error(sp[0],"list contains a non-character");
max++;
l = CDR(l);
}
if (!NULL_P(l))
error(sp[0],"not a proper list");
s = make_string_of_size(max,0);
p = STRING_VALUE(s);
l = sp[0];
for (i=0; i<max; i++) {
*p++ = CHARACTER_VALUE(CAR(l));
l = CDR(l);
}
*p = '\0';
*sp = s;
}
