Exemple #1
0
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;
}
Exemple #2
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;
}
Exemple #3
0
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;
}
Exemple #4
0
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();
      }
}
Exemple #5
0
/* 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 ();
}
Exemple #6
0
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]);
}
Exemple #7
0
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;
}
Exemple #8
0
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;
}
Exemple #9
0
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);
	    }
	}
    }
}
Exemple #10
0
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;
}
Exemple #11
0
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;
}
Exemple #12
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;
}
Exemple #13
0
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;
}
Exemple #14
0
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);
	}
    }
}
Exemple #15
0
static void primop_string_p(long argc) {
	if (!STRING_P(*sp)) *sp = false_object;
}
Exemple #16
0
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));
}
Exemple #17
0
static void primop_string_length(long argc) {
	object o = *sp;
	TYPE_CHECK(STRING_P(o),1,"string",o);
	*sp = MAKE_FIXNUM(STRING_LENGTH(o));
}
Exemple #18
0
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;
}
Exemple #19
0
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);
}