Example #1
0
sexp sexp_mutex_unlock (sexp ctx, sexp self, sexp_sint_t n, sexp mutex, sexp condvar, sexp timeout) {
  sexp ls1, ls2;
  /* first unlock and unblock threads */
  if (sexp_truep(sexp_mutex_lockp(mutex))) {
    sexp_mutex_lockp(mutex) = SEXP_FALSE;
    sexp_mutex_thread(mutex) = ctx;
    /* search for threads blocked on this mutex */
    for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
         sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
      if (sexp_context_event(sexp_car(ls2)) == mutex) {
        if (ls1==SEXP_NULL)
          sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
        else
          sexp_cdr(ls1) = sexp_cdr(ls2);
        sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
        sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
        if (! sexp_pairp(sexp_cdr(ls2)))
          sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
        sexp_context_waitp(sexp_car(ls2))
          = sexp_context_timeoutp(sexp_car(ls2)) = 0;
        break;
      }
  }
  if (sexp_truep(condvar)) {
    /* wait on condition var if specified */
    sexp_context_waitp(ctx) = 1;
    sexp_context_event(ctx) = condvar;
    sexp_insert_timed(ctx, ctx, timeout);
    return SEXP_FALSE;
  }
  return SEXP_TRUE;
}
Example #2
0
static sexp sexp_qsort_less (sexp ctx, sexp *vec,
                             sexp_sint_t lo, sexp_sint_t hi,
                             sexp less, sexp key) {
  sexp_sint_t mid, i, j;
  sexp tmp, res, args1;
  sexp_gc_var3(a, b, args2);
  sexp_gc_preserve3(ctx, a, b, args2);
  args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
  args1 = sexp_cdr(args2);
 loop:
  if (lo >= hi) {
    res = SEXP_VOID;
  } else {
    mid = lo + (hi-lo)/2;
    swap(tmp, vec[mid], vec[hi]);
    if (sexp_truep(key)) {
      sexp_car(args1) = tmp;
      b = sexp_apply(ctx, key, args1);
    } else {
      b = tmp;
    }
    for (i=j=lo; i < hi; i++) {
      if (sexp_truep(key)) {
        sexp_car(args1) = vec[i];
        a = sexp_apply(ctx, key, args1);
      } else {
        a = vec[i];
      }
      sexp_car(args2) = a;
      sexp_car(args1) = b;
      res = sexp_apply(ctx, less, args2);
      if (sexp_exceptionp(res))
        goto done;
      else if (sexp_truep(res))
        swap(res, vec[i], vec[j]), j++;
    }
    swap(tmp, vec[j], vec[hi]);
    res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
    if (sexp_exceptionp(res))
      goto done;
    if (j < hi-1) {
      lo = j;
      goto loop; /* tail recurse on right side */
    }
  }
 done:
  sexp_gc_release3(ctx);
  return res;
}
Example #3
0
static int sexp_cookie_cleaner (void *cookie) {
  sexp vec = (sexp)cookie, ctx, res;
  if (! sexp_procedurep(sexp_cookie_close(vec))) return 0;
  ctx = sexp_cookie_ctx(vec);
  res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL);
  return (sexp_exceptionp(res) ? -1 : sexp_truep(res));
}
Example #4
0
sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) {
  sexp ls1, ls2;
  if (sexp_not(condvar)) {
    /* normal unlock - always succeeds, just need to unblock threads */
    if (sexp_truep(sexp_mutex_lockp(mutex))) {
      sexp_mutex_lockp(mutex) = SEXP_FALSE;
      sexp_mutex_thread(mutex) = ctx;
      /* search for threads blocked on this mutex */
      for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
           sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
        if (sexp_context_event(sexp_car(ls2)) == mutex) {
          if (ls1==SEXP_NULL)
            sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
          else
            sexp_cdr(ls1) = sexp_cdr(ls2);
          sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
          sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
          if (! sexp_pairp(sexp_cdr(ls2)))
            sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
          sexp_context_waitp(sexp_car(ls2))
            = sexp_context_timeoutp(sexp_car(ls2)) = 0;
          break;
        }
    }
    return SEXP_TRUE;
  } else {
    /* wait on condition var */
    sexp_context_waitp(ctx) = 1;
    sexp_context_event(ctx) = condvar;
    sexp_insert_timed(ctx, ctx, timeout);
    return SEXP_FALSE;
  }
}
Example #5
0
static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode,
                                   sexp read, sexp write,
                                   sexp seek, sexp close) {
  FILE *in;
  sexp res;
  sexp_gc_var1(vec);
  if (sexp_truep(read) && ! sexp_procedurep(read))
    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read);
  if (sexp_truep(write) && ! sexp_procedurep(write))
    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write);
  if (sexp_truep(seek) && ! sexp_procedurep(seek))
    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek);
  if (sexp_truep(close) && ! sexp_procedurep(close))
    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close);
  sexp_gc_preserve1(ctx, vec);
  vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
  sexp_cookie_ctx_set(vec, ctx);
  sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID));
  sexp_cookie_read_set(vec, read);
  sexp_cookie_write_set(vec, write);
  sexp_cookie_seek_set(vec, seek);
  sexp_cookie_close_set(vec, close);
#if SEXP_BSD
  in = funopen(vec,
               (sexp_procedurep(read) ? sexp_cookie_reader : NULL),
               (sexp_procedurep(write) ? sexp_cookie_writer : NULL),
               NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */
               (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL));
#else
  in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek));
#endif
  if (! in) {
    res = sexp_user_exception(ctx, self, "couldn't make custom port", read);
  } else {
    res = sexp_make_input_port(ctx, in, SEXP_FALSE);
    sexp_port_cookie(res) = vec;  /* for gc preserving */
  }
  if (mode && mode[0] == 'w')
    sexp_pointer_tag(res) = SEXP_OPORT;
  sexp_gc_release1(ctx);
  return res;
}
Example #6
0
sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) {
  sexp_assert_type(ctx, sexp_mutexp, sexp_mutex_id, mutex);
  if (sexp_truep(sexp_mutex_lockp(mutex))) {
    if (sexp_contextp(sexp_mutex_thread(mutex)))
      return sexp_mutex_thread(mutex);
    else
      return sexp_intern(ctx, "not-owned", -1);
  } else {
    return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1);
  }
}
Example #7
0
sexp sexp_mutex_state (sexp ctx, sexp self, sexp_sint_t n, sexp mutex) {
  if (!sexp_mutexp(ctx, mutex))
    return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID)), mutex);
  if (sexp_truep(sexp_mutex_lockp(mutex))) {
    if (sexp_contextp(sexp_mutex_thread(mutex)))
      return sexp_mutex_thread(mutex);
    else
      return sexp_intern(ctx, "not-owned", -1);
  } else {
    return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1);
  }
}
Example #8
0
static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq,
                         sexp less, sexp key) {
  sexp_sint_t len;
  sexp res, *data;
  sexp_gc_var1(vec);

  if (sexp_nullp(seq)) return seq;

  sexp_gc_preserve1(ctx, vec);

  vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);

  if (! sexp_vectorp(vec)) {
    res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
  } else {
    data = sexp_vector_data(vec);
    len = sexp_vector_length(vec);
    if (sexp_not(key) && sexp_basic_comparator(less)) {
      sexp_qsort(ctx, data, 0, len-1);
      if (sexp_opcodep(less) && sexp_opcode_inverse(less))
        sexp_vector_nreverse(ctx, vec);
      res = vec;
    } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
      res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less);
    } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
      res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
    } else {
      res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
    }
  }

  if (sexp_pairp(seq) && ! sexp_exceptionp(res))
    res = sexp_vector_copy_to_list(ctx, vec, seq);

  sexp_gc_release1(ctx);
  return res;
}
Example #9
0
static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) {
  int res;
  sexp oldaction;
  if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0
         && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM))
    return sexp_xtype_exception(ctx, self, "not a valid signal number", signum);
  if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction)
         || sexp_booleanp(newaction)))
    return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction);
  if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)))
    sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)
      = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE);
  oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
  res = sigaction(sexp_unbox_fixnum(signum),
                  (sexp_booleanp(newaction) ?
                   (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore)
                   : &call_sigaction),
                  NULL);
  if (res)
    return sexp_user_exception(ctx, self, "couldn't set signal", signum);
  sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction);
  sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx;
  return oldaction;
}
Example #10
0
sexp sexp_condition_variable_broadcast (sexp ctx, sexp self, sexp_sint_t n, sexp condvar) {
  sexp res = SEXP_FALSE;
  while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar)))
    res = SEXP_TRUE;
  return res;
}
Example #11
0
static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
  return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
    : sexp_make_fixnum(sexp_type_field_eq_len_base(t));
}
Example #12
0
sexp run_main (int argc, char **argv) {
#if SEXP_USE_MODULES
  char *impmod;
#endif
  char *arg;
  const char *prefix=NULL, *suffix=NULL, *main_symbol=NULL, *main_module=NULL;
  sexp_sint_t i, j, c, quit=0, print=0, init_loaded=0, mods_loaded=0,
    fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS, nonblocking=0;
  sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE;
  sexp out=SEXP_FALSE, ctx=NULL, ls;
  sexp_gc_var4(tmp, sym, args, env);
  args = SEXP_NULL;
  env = NULL;

  /* SRFI 22: invoke `main` procedure by default if the interpreter is */
  /* invoked as `scheme-r7rs`. */
  arg = strrchr(argv[0], '/');
  if (strncmp((arg == NULL ? argv[0] : arg + 1), "scheme-r7rs", strlen("scheme-r7rs")) == 0) {
    main_symbol = "main";
    /* skip option parsing since we can't pass `--` before the name of script */
    /* to avoid misinterpret the name as options when the interpreter is */
    /* executed via `#!/usr/env/bin scheme-r7rs` shebang.  */
    i = 1;
    goto done_options;
  }

  /* parse options */
  for (i=1; i < argc && argv[i][0] == '-'; i++) {
    switch ((c=argv[i][1])) {
    case 'D':
      init_context();
      arg = (argv[i][2] == '\0') ? argv[++i] : argv[i]+2;
      sym = sexp_intern(ctx, arg, -1);
      ls = sexp_global(ctx, SEXP_G_FEATURES);
      if (sexp_pairp(ls)) {
        for (; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls))
          ;
        sexp_cdr(ls) = sexp_cons(ctx, sym, SEXP_NULL);
      }
      break;
    case 'e':
    case 'p':
      mods_loaded = 1;
      load_init(0);
      print = (argv[i][1] == 'p');
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      check_nonull_arg('e', arg);
      tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env));
      if (print) {
        if (! sexp_oportp(out))
          out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
        sexp_write(ctx, tmp, out);
        sexp_write_char(ctx, '\n', out);
      }
      quit = 1;
      break;
    case 'l':
      mods_loaded = 1;
      load_init(0);
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      check_nonull_arg('l', arg);
      check_exception(ctx, sexp_load_module_file(ctx, arg, env));
      break;
    case 'x':
      prefix = sexp_environment_prefix;
      suffix = sexp_environment_suffix;
    case 'm':
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      if (c == 'x') {
        if (strcmp(arg, "chibi.primitive") == 0) {
          goto load_primitive;
        } else if (strcmp(arg, "scheme.small") == 0) {
          load_init(0);
          break;
        }
      } else {
        prefix = sexp_import_prefix;
        suffix = sexp_import_suffix;
      }
      mods_loaded = 1;
      load_init(c == 'x');
#if SEXP_USE_MODULES
      check_nonull_arg(c, arg);
      impmod = make_import(prefix, arg, suffix);
      tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, (c=='x' ? sexp_global(ctx, SEXP_G_META_ENV) : env)));
      free(impmod);
      if (c == 'x') {
        sexp_set_parameter(ctx, sexp_global(ctx, SEXP_G_META_ENV), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), tmp);
        sexp_context_env(ctx) = env = tmp;
        sexp_add_import_binding(ctx, env);
        tmp = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
        if (tmp != NULL && !sexp_oportp(tmp)) {
          sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0);
        }
      }
#endif
      break;
    load_primitive:
    case 'Q':
      init_context();
      mods_loaded = 1;
      if (! init_loaded++)
        sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0);
      handle_noarg();
      break;
    case 'q':
      argv[i--] = (char*)"-xchibi";
      break;
    case 'A':
      init_context();
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      check_nonull_arg('A', arg);
      sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE);
      break;
    case 'I':
      init_context();
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      check_nonull_arg('I', arg);
      sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE);
      break;
#if SEXP_USE_GREEN_THREADS
    case 'b':
      nonblocking = 1;
      break;
#endif
    case '-':
      if (argv[i][2] == '\0') {
        i++;
        goto done_options;
      }
      sexp_usage(1);
    case 'h':
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      check_nonull_arg('h', arg);
#if ! SEXP_USE_BOEHM
      heap_size = strtoul(arg, &arg, 0);
      if (sexp_isalpha((unsigned char)*arg)) heap_size *= multiplier(*arg++);
      if (*arg == '/') {
        heap_max_size = strtoul(arg+1, &arg, 0);
        if (sexp_isalpha((unsigned char)*arg)) heap_max_size *= multiplier(*arg++);
      }
#endif
      break;
#if SEXP_USE_IMAGE_LOADING
    case 'i':
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      if (ctx) {
        fprintf(stderr, "-i <file>: image files must be loaded before other command-line options are specified: %s\n", arg);
        if (sexp_truep(sexp_global(ctx, SEXP_G_STRICT_P)))
          exit_failure();
      }
      ctx = sexp_load_image(arg, 0, heap_size, heap_max_size);
      if (!ctx || !sexp_contextp(ctx)) {
        fprintf(stderr,
                "-i <file>: image failed to load, ignoring: %s\n"
                "           %s", arg, sexp_load_image_err());
        ctx = NULL;
      } else {
        env = sexp_load_standard_params(ctx, sexp_context_env(ctx), nonblocking);
        init_loaded++;
      }
      break;
    case 'd':
      if (! init_loaded++) {
        init_context();
        env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
      }
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
      if (sexp_save_image(ctx, arg) != SEXP_TRUE) {
        fprintf(stderr, "-d <file>: couldn't save image to file: %s\n", arg);
        fprintf(stderr, "           %s\n", sexp_load_image_err());
        exit_failure();
      }
      quit = 1;
      break;
#endif
    case 'V':
      load_init(1);
      if (! sexp_oportp(out))
        out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
      sexp_write_string(ctx, sexp_version_string, out);
      tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL);
      sexp_write(ctx, tmp, out);
      sexp_newline(ctx, out);
      return SEXP_TRUE;
#if SEXP_USE_FOLD_CASE_SYMS
    case 'f':
      fold_case = 1;
      init_context();
      sexp_global(ctx, SEXP_G_FOLD_CASE_P) = SEXP_TRUE;
      handle_noarg();
      break;
#endif
    case 'R':
      main_module = argv[i][2] != '\0' ? argv[i]+2 :
        (i+1 < argc && argv[i+1][0] != '-') ? argv[++i] : "chibi.repl";
      if (main_symbol == NULL) main_symbol = "main";
      if (strcmp(main_module, "chibi.repl") == 0)
        load_init(0);
      break;
    case 'r':
      main_symbol = argv[i][2] == '\0' ? "main" : argv[i]+2;
      break;
    case 's':
      init_context(); sexp_global(ctx, SEXP_G_STRICT_P) = SEXP_TRUE;
      handle_noarg();
      break;
    case 'T':
      init_context(); sexp_global(ctx, SEXP_G_NO_TAIL_CALLS_P) = SEXP_TRUE;
      handle_noarg();
      break;
    case 't':
      mods_loaded = 1;
      load_init(1);
      arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
#if SEXP_USE_MODULES
      check_nonull_arg('t', arg);
      suffix = strrchr(arg, '.');
      sym = sexp_intern(ctx, suffix + 1, -1);
      *(char*)suffix = '\0';
      impmod = make_import(sexp_trace_prefix, arg, sexp_trace_suffix);
      tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx)));
      if (!(tmp && sexp_envp(tmp))) {
        fprintf(stderr, "couldn't find library to trace: %s\n", impmod);
      } else if (!((sym = sexp_env_cell(ctx, tmp, sym, 0)))) {
        fprintf(stderr, "couldn't find binding to trace: %s in %s\n", suffix + 1, impmod);
      } else {
        sym = sexp_list1(ctx, sym);
        tmp = check_exception(ctx, sexp_eval_string(ctx, "(environment '(chibi trace))", -1, sexp_meta_env(ctx)));
        tmp = sexp_env_ref(ctx, tmp, sexp_intern(ctx, "trace-cell", -1), 0);
        if (tmp && sexp_procedurep(tmp))
          check_exception(ctx, sexp_apply(ctx, tmp, sym));
      }
      free(impmod);
#endif
      break;
    default:
      fprintf(stderr, "unknown option: %s\n", argv[i]);
      /* ... FALLTHROUGH ... */
    case '?':
      sexp_usage(1);
    }
  }

 done_options:
  if (!quit || main_symbol != NULL) {
    init_context();
    /* build argument list */
    if (i < argc)
      for (j=argc-1; j>=i; j--)
        args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
    load_init(i < argc || main_symbol != NULL);
    sexp_set_parameter(ctx, sexp_meta_env(ctx), sym=sexp_intern(ctx, sexp_argv_symbol, -1), args);
    if (i >= argc && main_symbol == NULL) {
      /* no script or main, run interactively */
      repl(ctx, env);
    } else {
#if SEXP_USE_MODULES
      /* load the module or script */
      if (main_module != NULL) {
        impmod = make_import("(load-module '(", main_module, "))");
        env = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx)));
        if (sexp_vectorp(env)) env = sexp_vector_ref(env, SEXP_ONE);
        free(impmod);
        check_exception(ctx, env);
        if (!sexp_envp(env)) {
          fprintf(stderr, "couldn't find module: %s\n", main_module);
          exit_failure();
        }
      } else
#endif
      if (i < argc) {   /* script usage */
#if SEXP_USE_MODULES
        /* reset the environment to have only the `import' and */
        /* `cond-expand' bindings */
        if (!mods_loaded) {
          env = sexp_make_env(ctx);
          sexp_set_parameter(ctx, sexp_meta_env(ctx),
                             sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
          sexp_context_env(ctx) = env;
          sym = sexp_intern(ctx, "repl-import", -1);
          tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID);
          sym = sexp_intern(ctx, "import", -1);
          check_exception(ctx, sexp_env_define(ctx, env, sym, tmp));
          sym = sexp_intern(ctx, "cond-expand", -1);
          tmp = sexp_env_cell(ctx, sexp_meta_env(ctx), sym, 0);
#if SEXP_USE_RENAME_BINDINGS
          sexp_env_rename(ctx, env, sym, tmp);
#endif
          sexp_env_define(ctx, env, sym, sexp_cdr(tmp));
        }
#endif
        sexp_context_tracep(ctx) = 1;
        tmp = sexp_env_bindings(env);
#if SEXP_USE_MODULES
        /* use scheme load if possible for better stack traces */
        sym = sexp_intern(ctx, "load", -1);
        tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_FALSE);
        if (sexp_procedurep(tmp)) {
          sym = sexp_c_string(ctx, argv[i], -1);
          sym = sexp_list2(ctx, sym, env);
          tmp = check_exception(ctx, sexp_apply(ctx, tmp, sym));
        } else
#endif
          tmp = check_exception(ctx, sexp_load(ctx, sym=sexp_c_string(ctx, argv[i], -1), env));
#if SEXP_USE_WARN_UNDEFS
        sexp_warn_undefs(ctx, env, tmp, SEXP_VOID);
#endif
#ifdef EMSCRIPTEN
        if (sexp_applicablep(tmp)) {
          sexp_resume_ctx = ctx;
          sexp_resume_proc = tmp;
          sexp_preserve_object(ctx, sexp_resume_proc);
          emscripten_exit_with_live_runtime();
        }
#endif
      }
      /* SRFI-22: run main if specified */
      if (main_symbol) {
        sym = sexp_intern(ctx, main_symbol, -1);
        tmp = sexp_env_ref(ctx, env, sym, SEXP_FALSE);
        if (sexp_procedurep(tmp)) {
          args = sexp_list1(ctx, sexp_cdr(args));
          check_exception(ctx, sexp_apply(ctx, tmp, args));
        } else {
          fprintf(stderr, "couldn't find main binding: %s in %s\n", main_symbol, main_module ? main_module : argv[i]);
        }
      }
    }
  }

  sexp_gc_release4(ctx);
  if (sexp_destroy_context(ctx) == SEXP_FALSE) {
    fprintf(stderr, "destroy_context error\n");
    return SEXP_FALSE;
  }
  return SEXP_TRUE;
}
Example #13
0
static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
  sexp_env_syntactic_p(e) = sexp_truep(synp);
  return SEXP_VOID;
}
Example #14
0
static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) {
  sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
  if (sexp_truep(e2)) sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
  sexp_env_parent(e1) = e2;
  return SEXP_VOID;
}