Beispiel #1
0
SCM
random2scm(Random* rnd)
{
  SCM_DEFER_INTS;
  SCM smob;
  SCM_NEWCELL (smob);
  SCM_SETCDR (smob, rnd);
  SCM_SETCAR (smob, random_tag_type);
  SCM_ALLOW_INTS;
  return smob;
}
Beispiel #2
0
SCM      
gconf2scm (GConfEngine* conf)
{
  SCM smob;

  gh_defer_ints();

  SCM_NEWCELL (smob);
  SCM_SETCDR (smob, conf);
  SCM_SETCAR (smob, gconf_type_tag);

  gh_allow_ints();
  return smob;
}
Beispiel #3
0
inline void tmscm_set_cdr (tmscm a, tmscm b) { SCM_SETCDR(a,b); }
Beispiel #4
0
void
scm_i_rehash (SCM table,
	      scm_t_hash_fn hash_fn,
	      void *closure,
	      const char* func_name)
{
  SCM buckets, new_buckets;
  int i;
  unsigned long old_size;
  unsigned long new_size;

  if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
    {
      /* rehashing is not triggered when i <= min_size */
      i = SCM_HASHTABLE (table)->size_index;
      do
	--i;
      while (i > SCM_HASHTABLE (table)->min_size_index
	     && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
    }
  else
    {
      i = SCM_HASHTABLE (table)->size_index + 1;
      if (i >= HASHTABLE_SIZE_N)
	/* don't rehash */
	return;
    }
  SCM_HASHTABLE (table)->size_index = i;
  
  new_size = hashtable_size[i];
  if (i <= SCM_HASHTABLE (table)->min_size_index)
    SCM_HASHTABLE (table)->lower = 0;
  else
    SCM_HASHTABLE (table)->lower = new_size / 4;
  SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
  buckets = SCM_HASHTABLE_VECTOR (table);

  new_buckets = scm_c_make_vector (new_size, SCM_EOL);

  SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
  SCM_SET_HASHTABLE_N_ITEMS (table, 0);

  old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
  for (i = 0; i < old_size; ++i)
    {
      SCM ls, cell, handle;

      ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
      SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);

      while (scm_is_pair (ls))
	{
	  unsigned long h;

	  cell = ls;
	  handle = SCM_CAR (cell);
	  ls = SCM_CDR (ls);

	  h = hash_fn (SCM_CAR (handle), new_size, closure);
	  if (h >= new_size)
	    scm_out_of_range (func_name, scm_from_ulong (h));
	  SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
	  SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
	  SCM_HASHTABLE_INCREMENT (table);
	}
    }
}
Beispiel #5
0
void gwave_main(void *p, int argc, char **argv)
{
	int c;
	int i;
	int nobacktrace = 0;

	/* In guile-1.5 and later, need to use scm_primitive_eval_x
	 * in order to change modules so that our C primitives
	 * registered below become globals, instead of hidden away
	 * in the guile-user module
	 */
	{
		SCM exp = scm_c_read_string("(define-module (guile))");
		scm_primitive_eval_x(exp);
	}

	init_scwm_guile();
	init_gtkmisc();
	init_gwave();
	init_cmd();
	init_wavewin();
	init_wavelist();
	init_wavepanel();
	init_event();
	init_draw();
	
	gtk_init(&argc, &argv);

	prog_name = argv[0];

	/* simple pre-processing of debugging options that we need to set up
	 * before we get into guile.   These options cannot be bundled.
	 * Most of the general user options are handled in std-args.scm  */
	for(i = 1; i < argc; i++) {
		if(strcmp(argv[i], "-n") == 0) {
			nobacktrace = 1;
		} else if (strcmp(argv[i], "-v") == 0) {
			v_flag = 1;
		} else if (strcmp(argv[i], "-x") == 0) {
			x_flag = 1;
			SCM_SETCDR(scm_gwave_debug, SCM_BOOL_T);
		}
	}

	gtk_rc_parse_string(gwave_base_gtkrc);
	gtk_rc_parse("gwave.gtkrc");
//	assert( SCM_CONSP(scm_gwave_tooltips) );

#ifdef GUILE_GTK_EXTRA_LOADPATH
	scm_c_eval_string("(set! %load-path (cons \"" GUILE_GTK_EXTRA_LOADPATH "\" %load-path))");
#endif

	/* the default for this seems to have changed between guile-1.3
	   and guile-1.3.2;  only the first clause is needed when 
	   we drop support for guile-1.3.2 */
	if (!nobacktrace) {
		scm_c_eval_string("(debug-enable 'debug)(debug-enable 'backtrace) (read-enable 'positions)");
	} /* else {
	scm_c_eval_str("(debug-disable 'debug)(read-disable 'positions)");
	}*/

	/* the compiled-in initial scheme code comes from minimal.scm,
	   built into init_scheme_string.c by the Makefile
	   Among other things, it finds and loads system and user .gwaverc
	   files.
	*/
	{ /* scope */
		extern char *init_scheme_string;
		SCM res;
		if(v_flag) {fprintf(stderr, "running init_scheme_string\n");}
		res = scwm_safe_eval_str(init_scheme_string);
		if(v_flag) {
			printf("result="); fflush(stdout);
			scm_display(res, scm_cur_outp);
			printf("\n"); fflush(stdout);
		}
                if(!SCM_NFALSEP(res)) {
                        fprintf(stderr, "gwave: aborting due to errors.\n");
                        exit(1);
                }

	} /* end scope */

	wtable = g_new0(WaveTable, 1);
	wtable->cursor[0] = g_new0(VBCursor, 1);
	wtable->cursor[1] = g_new0(VBCursor, 1);
	wtable->srange = g_new0(SelRange, 1);
	wtable->npanels = 0;
	wtable->panels = NULL;

	setup_colors(wtable);
	setup_waveform_window();

	xg_init(NULL);  /* X-server interprocess communication for Gtk+ */

	gtk_main();
	exit(0);
}