Exemplo n.º 1
0
static char *get_init_filename(Scheme_Env *env)
{
  Scheme_Object *f;
  Scheme_Thread * volatile p;
  mz_jmp_buf * volatile save, newbuf;

  p = scheme_get_current_thread();
  save = p->error_buf;
  p->error_buf = &newbuf;

  if (!scheme_setjmp(newbuf)) {
    f = scheme_builtin_value("find-system-path");
    if (f) {
      Scheme_Object *a[1];

      a[0] = scheme_intern_symbol("init-file");

      f = _scheme_apply(f, 1, a);

      if (SCHEME_PATHP(f)) {
	p->error_buf = save;
	return SCHEME_PATH_VAL(f);
      }
    }
  }
  p->error_buf = save;

  return NULL;
}
Exemplo n.º 2
0
static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
{
  Scheme_Closure_Data *data;
  Scheme_Object *name, *l, *code, *ds, *tl_map;
  int svec_size, pos;
  Scheme_Marshal_Tables *mt;

  data = (Scheme_Closure_Data *)obj;

  if (data->name) {
    name = data->name;
    if (SCHEME_VECTORP(name)) {
      /* We can only save marshalable src names, which includes
	 paths, symbols, and strings: */
      Scheme_Object *src;
      src = SCHEME_VEC_ELS(name)[1];
      if (!SCHEME_PATHP(src)
	  && !SCHEME_PATHP(src)
	  && !SCHEME_SYMBOLP(src)) {
	/* Just keep the name */
	name = SCHEME_VEC_ELS(name)[0];
      }
    }
  } else {
    name = scheme_null;
  }

  svec_size = data->closure_size;
  if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
    svec_size += ((2 * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT;
  }

  if (SCHEME_RPAIRP(data->code)) {
    /* This can happen if loaded bytecode is printed out and the procedure
       body has never been needed before.
       It's also possible in non-JIT mode if an empty closure is embedded 
       as a 3-D value in compiled code. */
    scheme_delay_load_closure(data);
  }

  /* If the body is simple enough, write it directly.
     Otherwise, create a delay indirection so that the body
     is loaded on demand. */
  code = data->code;
  switch (SCHEME_TYPE(code)) {
  case scheme_toplevel_type:
  case scheme_local_type:
  case scheme_local_unbox_type:
  case scheme_integer_type:
  case scheme_true_type:
  case scheme_false_type:
  case scheme_void_type:
  case scheme_quote_syntax_type:
    ds = code;
    break;
  default:
    ds = NULL;
    break;
  }
  
  if (!ds) {
    mt = scheme_current_thread->current_mt;
    if (!mt->pass) {
      int key;

      pos = mt->cdata_counter;
      if ((!mt->cdata_map || (pos >= 32))
          && !(pos & (pos - 1))) {
        /* Need to grow the array */
        Scheme_Object **a;
        a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32));
        memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *));
        mt->cdata_map = a;
      }
Exemplo n.º 3
0
Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
  Scheme_Place          *place;
  Place_Start_Data      *place_data;
  mz_proc_thread        *proc_thread;
  Scheme_Object         *collection_paths;
  mzrt_sema             *ready;

  /* create place object */
  place = MALLOC_ONE_TAGGED(Scheme_Place);
  place->so.type = scheme_place_type;

  mzrt_sema_create(&ready, 0);

  /* pass critical info to new place */
  place_data = MALLOC_ONE(Place_Start_Data);
  place_data->ready    = ready;

  if (argc == 2) {
    Scheme_Object *so;

    if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0])) {
      scheme_wrong_type("place", "module-path or path", 0, argc, args);
    }
    if (!SCHEME_SYMBOLP(args[1])) {
      scheme_wrong_type("place", "symbol", 1, argc, args);
    }

    so = scheme_places_deep_copy_to_master(args[0]);
    place_data->module   = so;
    so = scheme_places_deep_copy_to_master(args[1]);
    place_data->function = so;
    place_data->ready    = ready;
    
    /* create channel */
    {
      Scheme_Place_Bi_Channel *channel;
      channel = scheme_place_bi_channel_create();
      place->channel = (Scheme_Object *) channel;
      channel = scheme_place_bi_peer_channel_create(channel);
      place_data->channel = (Scheme_Object *) channel;
    }
  }
  else {
    scheme_wrong_count_m("place", 2, 2, argc, args, 0);
  }

  collection_paths = scheme_current_library_collection_paths(0, NULL);
  collection_paths = scheme_places_deep_copy_to_master(collection_paths);
  place_data->current_library_collection_paths = collection_paths;

  /* create new place */
  proc_thread = mz_proc_thread_create(place_start_proc, place_data);

  /* wait until the place has started and grabbed the value
     from `place_data'; it's important that a GC doesn't happen
     here until the other place is far enough. */
  mzrt_sema_wait(ready);
  mzrt_sema_destroy(ready);
  
  place->proc_thread = proc_thread;

  return (Scheme_Object*) place;
}
Exemplo n.º 4
0
/*
 * Get the init filename for the system
 * * First look to see if <addon-dir>/interactive.rkt exists
 * * Otherwise check config file for location
 */
static Scheme_Object *get_init_filename(Scheme_Env *env,
                                        char *init_filename_sym,
                                        char *default_init_module,
                                        char *user_init_module)
{
  Scheme_Object *f, *a[2], *build_path;
  Scheme_Thread * volatile p;
  mz_jmp_buf * volatile save, newbuf;

  p = scheme_get_current_thread();
  save = p->error_buf;
  p->error_buf = &newbuf;

  if(!scheme_setjmp(newbuf)) {
    build_path = scheme_builtin_value("build-path");

    /* First test to see if user init file exists */
    f = scheme_builtin_value("find-system-path");
    a[0] = scheme_intern_symbol("addon-dir");
    a[0] = _scheme_apply(f, 1, a);
    a[1] = scheme_make_path(user_init_module);
    f = _scheme_apply(build_path, 2, a);
    if (SCHEME_PATHP(f)) {
      char *filename;
      filename = scheme_expand_filename(SCHEME_PATH_VAL(f), -1, "startup", NULL, SCHEME_GUARD_FILE_EXISTS);
      if(scheme_file_exists(filename)) {
        p->error_buf = save;
        return scheme_make_path(filename);
      }
    }

    /* Failed, next check config.rkt fo system init file */
    f = scheme_builtin_value("find-main-config");
    a[0] = _scheme_apply(f, 0, NULL);
    a[1] = scheme_make_path("config.rktd");
    f = _scheme_apply(build_path, 2, a);
    if (SCHEME_PATHP(f)) {
      char *filename;
      filename = scheme_expand_filename(SCHEME_PATH_VAL(f), -1, "startup", NULL,
                                        SCHEME_GUARD_FILE_EXISTS | SCHEME_GUARD_FILE_READ);
      if(scheme_file_exists(filename)) {
        Scheme_Object * port;
        port = scheme_open_input_file(SCHEME_PATH_VAL(f), "get-init-filename");
        f = scheme_read(port);
        scheme_close_input_port(port);
        if(SCHEME_HASHTRP(f)) {
          f = scheme_hash_tree_get((Scheme_Hash_Tree *)f, scheme_intern_symbol(init_filename_sym));
          if(f) {
            p->error_buf = save;
            return f;
          }
        }
      }
    }

    /* Failed to load custom init file, load racket/interactive */
    f = scheme_intern_symbol(default_init_module);
    p->error_buf = save;
    return f;
  }

  p->error_buf = save;

  return NULL;
}