Example #1
0
sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
  sexp ls;
  sexp_gc_var1(res);
  sexp_gc_preserve1(ctx, res);
  res = SEXP_NULL;
#if SEXP_USE_GREEN_THREADS
  for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
    sexp_push(ctx, res, sexp_car(ls));
  for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
    sexp_push(ctx, res, sexp_car(ls));
#endif
  if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx);
  sexp_gc_release1(ctx);
  return res;
}
Example #2
0
static sexp sexp_get_time_of_day_stub (sexp ctx, sexp self, sexp_sint_t n) {
  int err;
  struct timeval* tmp0;
  struct timezone* tmp1;
  sexp_gc_var3(res, res0, res1);
  sexp_gc_preserve3(ctx, res, res0, res1);
  tmp0 = (struct timeval*) calloc(1, 1 + sizeof(tmp0[0]));
  tmp1 = (struct timezone*) calloc(1, 1 + sizeof(tmp1[0]));
  err = gettimeofday(tmp0, tmp1);
  if (err) {
  res = SEXP_FALSE;
  } else {
  res0 = sexp_make_cpointer(ctx, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), tmp0, SEXP_FALSE, 1);
  res1 = sexp_make_cpointer(ctx, sexp_unbox_fixnum(sexp_opcode_arg2_type(self)), tmp1, SEXP_FALSE, 1);
  res = SEXP_NULL;
  sexp_push(ctx, res, res1);
  sexp_push(ctx, res, res0);
  }
  sexp_gc_release3(ctx);
  return res;
}
Example #3
0
File: sexpio.c Project: tonyg/hop
unsigned short sexp_write(IOHandle *h, sexp_t *x) {
  sexp_t *stack = NULL; /* held */
  sexp_t *current = x;

 write1:
  if (current == NULL) {
    iohandle_write(h, cmsg_cstring_bytes("()"));
  } else {
    switch (current->kind) {
      case SEXP_BYTES:
      case SEXP_SLICE:
	write_simple_string(h, current);
	break;

      case SEXP_DISPLAY_HINT:
	iohandle_write(h, cmsg_cstring_bytes("["));
	write_simple_string(h, sexp_hint(current));
	iohandle_write(h, cmsg_cstring_bytes("]"));
	write_simple_string(h, sexp_body(current));
	break;

      case SEXP_PAIR:
	iohandle_write(h, cmsg_cstring_bytes("("));
	stack = sexp_push(stack, current);
	break;

      default:
	die("Unknown sexp kind %d in sexp_write\n", current->kind);
    }
  }

 check_stack:
  if (stack == NULL) {
    return 0;
  }

  {
    sexp_t *cell = sexp_head(stack);
    if (cell == NULL) {
      iohandle_write(h, cmsg_cstring_bytes(")"));
      stack = sexp_pop(stack, NULL); /* no need to worry about incref/decref: val is NULL! */
      goto check_stack;
    }

    if (sexp_pairp(cell)) {
      current = sexp_head(cell);
      sexp_sethead(stack, sexp_tail(cell));
      goto write1;
    }

    return SEXP_ERROR_SYNTAX;
  }
}
Example #4
0
static sexp sexp_open_pipe_stub (sexp ctx, sexp self, sexp_sint_t n) {
  int i, err;
  int tmp0[2];
  sexp res;
  sexp_gc_var1(res0);
  sexp_gc_preserve1(ctx, res0);
  err = pipe(tmp0);
  if (err) {
  res = SEXP_FALSE;
  } else {
  res0 = SEXP_NULL;
  for (i=2-1; i>=0; i--) {
    sexp_push(ctx, res0, SEXP_VOID);
    sexp_car(res0) = sexp_make_fileno(ctx, sexp_make_fixnum(tmp0[i]), SEXP_FALSE);
  }
  res = res0;
  }
  sexp_gc_release1(ctx);
  return res;
}
Example #5
0
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
  sexp sexp_timezone_type_obj;
  sexp sexp_timeval_type_obj;
  sexp sexp_tm_type_obj;
  sexp_gc_var3(name, tmp, op);
  if (!(sexp_version_compatible(ctx, version, sexp_version)
        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
    return SEXP_ABI_ERROR;
  sexp_gc_preserve3(ctx, name, tmp, op);
  name = sexp_c_string(ctx, "timezone", -1);
  sexp_timezone_type_obj = sexp_register_c_type(ctx, name, sexp_finalize_c_type);
  tmp = sexp_string_to_symbol(ctx, name);
  sexp_env_define(ctx, env, tmp, sexp_timezone_type_obj);
  sexp_type_slots(sexp_timezone_type_obj) = SEXP_NULL;
  sexp_push(ctx, sexp_type_slots(sexp_timezone_type_obj), sexp_intern(ctx, "tz_dsttime", -1));
  sexp_push(ctx, sexp_type_slots(sexp_timezone_type_obj), sexp_intern(ctx, "tz_minuteswest", -1));
  sexp_type_getters(sexp_timezone_type_obj) = sexp_make_vector(ctx, SEXP_TWO, SEXP_FALSE);
  sexp_type_setters(sexp_timezone_type_obj) = sexp_make_vector(ctx, SEXP_TWO, SEXP_FALSE);
  tmp = sexp_make_type_predicate(ctx, name, sexp_timezone_type_obj);
  name = sexp_intern(ctx, "timezone?", 9);
  sexp_env_define(ctx, env, name, tmp);
  name = sexp_c_string(ctx, "timeval", -1);
  sexp_timeval_type_obj = sexp_register_c_type(ctx, name, sexp_finalize_c_type);
  tmp = sexp_string_to_symbol(ctx, name);
  sexp_env_define(ctx, env, tmp, sexp_timeval_type_obj);
  sexp_type_slots(sexp_timeval_type_obj) = SEXP_NULL;
  sexp_push(ctx, sexp_type_slots(sexp_timeval_type_obj), sexp_intern(ctx, "tv_usec", -1));
  sexp_push(ctx, sexp_type_slots(sexp_timeval_type_obj), sexp_intern(ctx, "tv_sec", -1));
  sexp_type_getters(sexp_timeval_type_obj) = sexp_make_vector(ctx, SEXP_TWO, SEXP_FALSE);
  sexp_type_setters(sexp_timeval_type_obj) = sexp_make_vector(ctx, SEXP_TWO, SEXP_FALSE);
  tmp = sexp_make_type_predicate(ctx, name, sexp_timeval_type_obj);
  name = sexp_intern(ctx, "timeval?", 8);
  sexp_env_define(ctx, env, name, tmp);
  name = sexp_c_string(ctx, "tm", -1);
  sexp_tm_type_obj = sexp_register_c_type(ctx, name, sexp_finalize_c_type);
  tmp = sexp_string_to_symbol(ctx, name);
  sexp_env_define(ctx, env, tmp, sexp_tm_type_obj);
  sexp_type_slots(sexp_tm_type_obj) = SEXP_NULL;
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_gmtoff", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_zone", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_isdst", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_yday", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_wday", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_year", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_mon", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_mday", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_hour", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_min", -1));
  sexp_push(ctx, sexp_type_slots(sexp_tm_type_obj), sexp_intern(ctx, "tm_sec", -1));
  sexp_type_getters(sexp_tm_type_obj) = sexp_make_vector(ctx, sexp_make_fixnum(11), SEXP_FALSE);
  sexp_type_setters(sexp_tm_type_obj) = sexp_make_vector(ctx, sexp_make_fixnum(11), SEXP_FALSE);
  tmp = sexp_make_type_predicate(ctx, name, sexp_tm_type_obj);
  name = sexp_intern(ctx, "tm?", 3);
  sexp_env_define(ctx, env, name, tmp);
  op = sexp_define_foreign(ctx, env, "time-offset", 1, (sexp_proc1)sexp_tm_get_tm_gmtoff);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_TEN, op);
  op = sexp_define_foreign(ctx, env, "time-timezone-name", 1, (sexp_proc1)sexp_tm_get_tm_zone);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_NINE, op);
  op = sexp_define_foreign(ctx, env, "time-dst?", 1, (sexp_proc1)sexp_tm_get_tm_isdst);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_EIGHT, op);
  op = sexp_define_foreign(ctx, env, "time-day-of-year", 1, (sexp_proc1)sexp_tm_get_tm_yday);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_SEVEN, op);
  op = sexp_define_foreign(ctx, env, "time-day-of-week", 1, (sexp_proc1)sexp_tm_get_tm_wday);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_SIX, op);
  op = sexp_define_foreign(ctx, env, "time-year", 1, (sexp_proc1)sexp_tm_get_tm_year);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_FIVE, op);
  op = sexp_define_foreign(ctx, env, "time-month", 1, (sexp_proc1)sexp_tm_get_tm_mon);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_FOUR, op);
  op = sexp_define_foreign(ctx, env, "time-day", 1, (sexp_proc1)sexp_tm_get_tm_mday);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_THREE, op);
  op = sexp_define_foreign(ctx, env, "time-hour", 1, (sexp_proc1)sexp_tm_get_tm_hour);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_TWO, op);
  op = sexp_define_foreign(ctx, env, "time-minute", 1, (sexp_proc1)sexp_tm_get_tm_min);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_ONE, op);
  op = sexp_define_foreign(ctx, env, "time-second", 1, (sexp_proc1)sexp_tm_get_tm_sec);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_tm_type_obj))) sexp_vector_set(sexp_type_getters(sexp_tm_type_obj), SEXP_ZERO, op);
  op = sexp_define_foreign(ctx, env, "make-tm", 7, (sexp_proc1)sexp_make_tm_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_argn_type(op) = sexp_make_vector(ctx, SEXP_FOUR, sexp_make_fixnum(SEXP_OBJECT));
    sexp_vector_set(sexp_opcode_argn_type(op), SEXP_ZERO, sexp_make_fixnum(SEXP_FIXNUM));
    sexp_vector_set(sexp_opcode_argn_type(op), SEXP_ONE, sexp_make_fixnum(SEXP_FIXNUM));
    sexp_vector_set(sexp_opcode_argn_type(op), SEXP_TWO, sexp_make_fixnum(SEXP_FIXNUM));
    sexp_vector_set(sexp_opcode_argn_type(op), SEXP_THREE, sexp_make_fixnum(SEXP_FIXNUM));
  }
  op = sexp_define_foreign(ctx, env, "timeval-microseconds", 1, (sexp_proc1)sexp_timeval_get_tv_usec);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timeval_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_timeval_type_obj))) sexp_vector_set(sexp_type_getters(sexp_timeval_type_obj), SEXP_ONE, op);
  op = sexp_define_foreign(ctx, env, "timeval-seconds", 1, (sexp_proc1)sexp_timeval_get_tv_sec);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timeval_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_timeval_type_obj))) sexp_vector_set(sexp_type_getters(sexp_timeval_type_obj), SEXP_ZERO, op);
  op = sexp_define_foreign(ctx, env, "make-timeval", 2, (sexp_proc1)sexp_make_timeval_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timeval_type_obj));
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "timezone-dst-time", 1, (sexp_proc1)sexp_timezone_get_tz_dsttime);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timezone_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_timezone_type_obj))) sexp_vector_set(sexp_type_getters(sexp_timezone_type_obj), SEXP_ONE, op);
  op = sexp_define_foreign(ctx, env, "timezone-offset", 1, (sexp_proc1)sexp_timezone_get_tz_minuteswest);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timezone_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_timezone_type_obj))) sexp_vector_set(sexp_type_getters(sexp_timezone_type_obj), SEXP_ZERO, op);
  op = sexp_define_foreign(ctx, env, "time->string", 1, (sexp_proc1)sexp_time_3e_string_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_CHAR);
  }
  op = sexp_define_foreign(ctx, env, "seconds->string", 1, (sexp_proc1)sexp_seconds_3e_string_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_CHAR);
  }
  op = sexp_define_foreign(ctx, env, "time->seconds", 1, (sexp_proc1)sexp_time_3e_seconds_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "seconds->time", 1, (sexp_proc1)sexp_seconds_3e_time_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_tm_type_obj));
  }
  op = sexp_define_foreign_opt(ctx, env, "set-time-of-day!", 2, (sexp_proc1)sexp_set_time_of_day_x_stub, SEXP_FALSE);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timeval_type_obj));
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timezone_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "get-time-of-day", 0, (sexp_proc1)sexp_get_time_of_day_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timeval_type_obj));
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_timezone_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "current-seconds", 0, (sexp_proc1)sexp_current_seconds_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
  }
  sexp_gc_release3(ctx);
  return SEXP_VOID;
}
Example #6
0
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
  sexp sexp_stat_type_obj;
  sexp sexp_dirent_type_obj;
  sexp sexp_DIR_type_obj;
  sexp_gc_var3(name, tmp, op);
  if (!(sexp_version_compatible(ctx, version, sexp_version)
        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
    return SEXP_ABI_ERROR;
  sexp_gc_preserve3(ctx, name, tmp, op);
  name = sexp_intern(ctx, "lock/unlock", 11);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, LOCK_UN));
  name = sexp_intern(ctx, "lock/non-blocking", 17);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, LOCK_NB));
  name = sexp_intern(ctx, "lock/exclusive", 14);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, LOCK_EX));
  name = sexp_intern(ctx, "lock/shared", 11);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, LOCK_SH));
  name = sexp_intern(ctx, "access/execute", 14);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, X_OK));
  name = sexp_intern(ctx, "access/write", 12);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, W_OK));
  name = sexp_intern(ctx, "access/read", 11);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, R_OK));
  name = sexp_intern(ctx, "open/non-block", 14);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_NONBLOCK));
  name = sexp_intern(ctx, "open/append", 11);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_APPEND));
  name = sexp_intern(ctx, "open/truncate", 13);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_TRUNC));
  name = sexp_intern(ctx, "open/exclusive", 14);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_EXCL));
  name = sexp_intern(ctx, "open/create", 11);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_CREAT));
  name = sexp_intern(ctx, "open/read-write", 15);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_RDWR));
  name = sexp_intern(ctx, "open/write", 10);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_WRONLY));
  name = sexp_intern(ctx, "open/read", 9);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, O_RDONLY));
  name = sexp_intern(ctx, "perm/others-execute", 19);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IXOTH));
  name = sexp_intern(ctx, "perm/others-write", 17);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IWOTH));
  name = sexp_intern(ctx, "perm/others-read", 16);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IROTH));
  name = sexp_intern(ctx, "perm/group-execute", 18);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IXGRP));
  name = sexp_intern(ctx, "perm/group-write", 16);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IWGRP));
  name = sexp_intern(ctx, "perm/group-read", 15);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IRGRP));
  name = sexp_intern(ctx, "perm/user-execute", 17);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IXUSR));
  name = sexp_intern(ctx, "perm/user-write", 15);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IWUSR));
  name = sexp_intern(ctx, "perm/user-read", 14);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IRUSR));
  name = sexp_intern(ctx, "file/sticky", 11);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_ISVTX));
  name = sexp_intern(ctx, "file/sgid", 9);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_ISGID));
  name = sexp_intern(ctx, "file/suid", 9);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_ISUID));
  name = sexp_intern(ctx, "file/fifo", 9);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IFIFO));
  name = sexp_intern(ctx, "file/character", 14);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IFCHR));
  name = sexp_intern(ctx, "file/directory", 14);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IFDIR));
  name = sexp_intern(ctx, "file/block", 10);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IFBLK));
  name = sexp_intern(ctx, "file/regular", 12);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IFREG));
  name = sexp_intern(ctx, "file/link", 9);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IFLNK));
  name = sexp_intern(ctx, "file/socket", 11);
  sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, S_IFSOCK));
  name = sexp_c_string(ctx, "stat", -1);
  sexp_stat_type_obj = sexp_register_c_type(ctx, name, sexp_finalize_c_type);
  tmp = sexp_string_to_symbol(ctx, name);
  sexp_env_define(ctx, env, tmp, sexp_stat_type_obj);
  sexp_type_slots(sexp_stat_type_obj) = SEXP_NULL;
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_ctime", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_mtime", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_atime", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_blocks", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_blksize", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_size", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_rdev", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_gid", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_uid", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_nlink", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_mode", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_ino", -1));
  sexp_push(ctx, sexp_type_slots(sexp_stat_type_obj), sexp_intern(ctx, "st_dev", -1));
  sexp_type_getters(sexp_stat_type_obj) = sexp_make_vector(ctx, sexp_make_fixnum(13), SEXP_FALSE);
  sexp_type_setters(sexp_stat_type_obj) = sexp_make_vector(ctx, sexp_make_fixnum(13), SEXP_FALSE);
  tmp = sexp_make_type_predicate(ctx, name, sexp_stat_type_obj);
  name = sexp_intern(ctx, "stat?", 5);
  sexp_env_define(ctx, env, name, tmp);
  name = sexp_c_string(ctx, "dirent", -1);
  sexp_dirent_type_obj = sexp_register_c_type(ctx, name, sexp_finalize_c_type);
  tmp = sexp_string_to_symbol(ctx, name);
  sexp_env_define(ctx, env, tmp, sexp_dirent_type_obj);
  sexp_type_slots(sexp_dirent_type_obj) = SEXP_NULL;
  sexp_push(ctx, sexp_type_slots(sexp_dirent_type_obj), sexp_intern(ctx, "d_name", -1));
  sexp_type_getters(sexp_dirent_type_obj) = sexp_make_vector(ctx, SEXP_ONE, SEXP_FALSE);
  sexp_type_setters(sexp_dirent_type_obj) = sexp_make_vector(ctx, SEXP_ONE, SEXP_FALSE);
  name = sexp_c_string(ctx, "DIR", -1);
  sexp_DIR_type_obj = sexp_register_c_type(ctx, name, sexp_closedir_stub);
  tmp = sexp_string_to_symbol(ctx, name);
  sexp_env_define(ctx, env, tmp, sexp_DIR_type_obj);
  op = sexp_define_foreign(ctx, env, "closedir", 1, (sexp_proc1)sexp_closedir_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = SEXP_VOID;
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_DIR_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "dirent-name", 1, (sexp_proc1)sexp_dirent_get_d_name);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_dirent_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_dirent_type_obj))) sexp_vector_set(sexp_type_getters(sexp_dirent_type_obj), SEXP_ZERO, op);
  op = sexp_define_foreign(ctx, env, "stat-ctime", 1, (sexp_proc1)sexp_stat_get_st_ctime);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), sexp_make_fixnum(12), op);
  op = sexp_define_foreign(ctx, env, "stat-mtime", 1, (sexp_proc1)sexp_stat_get_st_mtime);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), sexp_make_fixnum(11), op);
  op = sexp_define_foreign(ctx, env, "stat-atime", 1, (sexp_proc1)sexp_stat_get_st_atime);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_TEN, op);
  op = sexp_define_foreign(ctx, env, "stat-blocks", 1, (sexp_proc1)sexp_stat_get_st_blocks);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_NINE, op);
  op = sexp_define_foreign(ctx, env, "stat-blksize", 1, (sexp_proc1)sexp_stat_get_st_blksize);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_EIGHT, op);
  op = sexp_define_foreign(ctx, env, "stat-size", 1, (sexp_proc1)sexp_stat_get_st_size);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_SEVEN, op);
  op = sexp_define_foreign(ctx, env, "stat-rdev", 1, (sexp_proc1)sexp_stat_get_st_rdev);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_SIX, op);
  op = sexp_define_foreign(ctx, env, "stat-gid", 1, (sexp_proc1)sexp_stat_get_st_gid);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_FIVE, op);
  op = sexp_define_foreign(ctx, env, "stat-uid", 1, (sexp_proc1)sexp_stat_get_st_uid);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_FOUR, op);
  op = sexp_define_foreign(ctx, env, "stat-nlinks", 1, (sexp_proc1)sexp_stat_get_st_nlink);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_THREE, op);
  op = sexp_define_foreign(ctx, env, "stat-mode", 1, (sexp_proc1)sexp_stat_get_st_mode);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_TWO, op);
  op = sexp_define_foreign(ctx, env, "stat-ino", 1, (sexp_proc1)sexp_stat_get_st_ino);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_ONE, op);
  op = sexp_define_foreign(ctx, env, "stat-dev", 1, (sexp_proc1)sexp_stat_get_st_dev);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_stat_type_obj))) sexp_vector_set(sexp_type_getters(sexp_stat_type_obj), SEXP_ZERO, op);
  op = sexp_define_foreign(ctx, env, "is-a-tty?", 1, (sexp_proc1)sexp_is_a_tty_p_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
  }
  op = sexp_define_foreign(ctx, env, "chmod", 2, (sexp_proc1)sexp_chmod_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "file-lock", 2, (sexp_proc1)sexp_file_lock_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "file-access", 2, (sexp_proc1)sexp_file_access_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "file-truncate", 2, (sexp_proc1)sexp_file_truncate_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "set-file-descriptor-status!", 2, (sexp_proc1)sexp_set_file_descriptor_status_x_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "get-file-descriptor-status", 1, (sexp_proc1)sexp_get_file_descriptor_status_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "set-file-descriptor-flags!", 2, (sexp_proc1)sexp_set_file_descriptor_flags_x_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "get-file-descriptor-flags", 1, (sexp_proc1)sexp_get_file_descriptor_flags_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign_opt(ctx, env, "make-fifo", 2, (sexp_proc1)sexp_make_fifo_stub, sexp_make_integer(ctx, 436));
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "open-pipe", 0, (sexp_proc1)sexp_open_pipe_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FILENO);
  }
  op = sexp_define_foreign_opt(ctx, env, "open", 3, (sexp_proc1)sexp_open_stub, sexp_make_integer(ctx, 420));
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FILENO);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "close-file-descriptor", 1, (sexp_proc1)sexp_close_file_descriptor_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FILENO);
  }
  op = sexp_define_foreign(ctx, env, "duplicate-file-descriptor-to", 2, (sexp_proc1)sexp_duplicate_file_descriptor_to_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FILENO);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FILENO);
  }
  op = sexp_define_foreign(ctx, env, "duplicate-file-descriptor", 1, (sexp_proc1)sexp_duplicate_file_descriptor_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FILENO);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FILENO);
  }
  op = sexp_define_foreign(ctx, env, "readdir", 1, (sexp_proc1)sexp_readdir_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_dirent_type_obj));
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_DIR_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "opendir", 1, (sexp_proc1)sexp_opendir_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_DIR_type_obj));
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
  }
  op = sexp_define_foreign(ctx, env, "delete-directory", 1, (sexp_proc1)sexp_delete_directory_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
  }
  op = sexp_define_foreign_opt(ctx, env, "create-directory", 2, (sexp_proc1)sexp_create_directory_stub, sexp_make_integer(ctx, 509));
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "change-directory", 1, (sexp_proc1)sexp_change_directory_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
  }
  op = sexp_define_foreign(ctx, env, "current-directory", 0, (sexp_proc1)sexp_current_directory_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CHAR);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "rename-file", 2, (sexp_proc1)sexp_rename_file_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_STRING);
  }
  op = sexp_define_foreign(ctx, env, "symbolic-link-file", 2, (sexp_proc1)sexp_symbolic_link_file_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_STRING);
  }
  op = sexp_define_foreign(ctx, env, "link-file", 2, (sexp_proc1)sexp_link_file_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_STRING);
  }
  op = sexp_define_foreign(ctx, env, "%delete-file", 1, (sexp_proc1)sexp_25_delete_file_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
  }
  op = sexp_define_foreign(ctx, env, "readlink", 3, (sexp_proc1)sexp_readlink_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "file-link-status", 1, (sexp_proc1)sexp_file_link_status_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "fstat", 1, (sexp_proc1)sexp_fstat_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "stat", 1, (sexp_proc1)sexp_stat_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_stat_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "S_ISSOCK", 1, (sexp_proc1)sexp_S_ISSOCK_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "S_ISLNK", 1, (sexp_proc1)sexp_S_ISLNK_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "S_ISFIFO", 1, (sexp_proc1)sexp_S_ISFIFO_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "S_ISBLK", 1, (sexp_proc1)sexp_S_ISBLK_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "S_ISCHR", 1, (sexp_proc1)sexp_S_ISCHR_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "S_ISDIR", 1, (sexp_proc1)sexp_S_ISDIR_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "S_ISREG", 1, (sexp_proc1)sexp_S_ISREG_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  sexp_gc_release3(ctx);
  return SEXP_VOID;
}
Example #7
0
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
  sexp sexp_player_type_obj;
  sexp_gc_var3(name, tmp, op);
  if (!(sexp_version_compatible(ctx, version, sexp_version)
        && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
    return SEXP_ABI_ERROR;
  sexp_gc_preserve3(ctx, name, tmp, op);
  name = sexp_c_string(ctx, "player", -1);
  sexp_player_type_obj = sexp_register_c_type(ctx, name, sexp_finalize_c_type);
  tmp = sexp_string_to_symbol(ctx, name);
  sexp_env_define(ctx, env, tmp, sexp_player_type_obj);
  sexp_type_slots(sexp_player_type_obj) = SEXP_NULL;
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "y", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "x", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "hp_max", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "hp", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "exp", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "level", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "race", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "gender", -1));
  sexp_push(ctx, sexp_type_slots(sexp_player_type_obj), sexp_intern(ctx, "name", -1));
  sexp_type_getters(sexp_player_type_obj) = sexp_make_vector(ctx, SEXP_NINE, SEXP_FALSE);
  sexp_type_setters(sexp_player_type_obj) = sexp_make_vector(ctx, SEXP_NINE, SEXP_FALSE);
  tmp = sexp_make_type_predicate(ctx, name, sexp_player_type_obj);
  name = sexp_intern(ctx, "player?", 7);
  sexp_env_define(ctx, env, name, tmp);
  op = sexp_define_foreign(ctx, env, "player-y", 1, (sexp_proc1)sexp_player_get_y);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_EIGHT, op);
  op = sexp_define_foreign(ctx, env, "player-x", 1, (sexp_proc1)sexp_player_get_x);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_SEVEN, op);
  op = sexp_define_foreign(ctx, env, "player-hp-max", 1, (sexp_proc1)sexp_player_get_hp_max);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_SIX, op);
  op = sexp_define_foreign(ctx, env, "player-hp", 1, (sexp_proc1)sexp_player_get_hp);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_FIVE, op);
  op = sexp_define_foreign(ctx, env, "player-exp", 1, (sexp_proc1)sexp_player_get_exp);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_FOUR, op);
  op = sexp_define_foreign(ctx, env, "player-level", 1, (sexp_proc1)sexp_player_get_level);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_THREE, op);
  op = sexp_define_foreign(ctx, env, "player-race", 1, (sexp_proc1)sexp_player_get_race);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_TWO, op);
  op = sexp_define_foreign(ctx, env, "player-gender", 1, (sexp_proc1)sexp_player_get_gender);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_ONE, op);
  op = sexp_define_foreign(ctx, env, "player-name", 1, (sexp_proc1)sexp_player_get_name);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_STRING);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  if (sexp_vectorp(sexp_type_getters(sexp_player_type_obj))) sexp_vector_set(sexp_type_getters(sexp_player_type_obj), SEXP_ZERO, op);
  op = sexp_define_foreign(ctx, env, "random_uint_range", 2, (sexp_proc1)sexp_random_uint_range_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "random_uint", 1, (sexp_proc1)sexp_random_uint_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "random_reseed_time", 0, (sexp_proc1)sexp_random_reseed_time_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = SEXP_VOID;
  }
  op = sexp_define_foreign(ctx, env, "random_reseed", 1, (sexp_proc1)sexp_random_reseed_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = SEXP_VOID;
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "random_init", 1, (sexp_proc1)sexp_random_init_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = SEXP_VOID;
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "player_move", 3, (sexp_proc1)sexp_player_move_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = SEXP_VOID;
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
    sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
    sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  op = sexp_define_foreign(ctx, env, "player_delete", 1, (sexp_proc1)sexp_player_delete_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = SEXP_VOID;
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "player_new", 0, (sexp_proc1)sexp_player_new_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_type_tag(sexp_player_type_obj));
  }
  op = sexp_define_foreign(ctx, env, "sleep", 1, (sexp_proc1)sexp_sleep_stub);
  if (sexp_opcodep(op)) {
    sexp_opcode_return_type(op) = SEXP_VOID;
    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
  }
  sexp_gc_release3(ctx);
  return SEXP_VOID;
}
Example #8
0
static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
  int check;
  sexp ls1, ls2, p1, p2, sv;
  sexp_gc_var5(res, substs, tmp, app, ctx2);
  sexp_gc_preserve5(ctx, res, substs, tmp, app, ctx2);
  res = ast;                    /* return the ast as-is by default */
  substs = init_substs;

 loop:
  switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) {

  case SEXP_PAIR:
    /* don't simplify the operator if it's a lambda because we
       simplify that as a special case below, with the appropriate
       substs list */
    app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
                     : (tmp=simplify(ctx, sexp_car(res), substs, lambda)));
    sexp_pair_source(app) = sexp_pair_source(res);
    for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
      sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda));
      if (sexp_pairp(app)) sexp_pair_source(app) = sexp_pair_source(ls1);
    }
    app = sexp_nreverse(ctx, app);
    /* app now holds a copy of the list, and is the default result
       (res = app below) if we don't replace it with a simplification */
    if (sexp_opcodep(sexp_car(app))) {
      /* opcode app - right now we just constant fold arithmetic */
      if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) {
        for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
          if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
            check = 0;
            break;
          }
        }
        if (check) {
          ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0, 0);
          sexp_generate(ctx2, 0, 0, 0, app);
          res = sexp_complete_bytecode(ctx2);
          if (! sexp_exceptionp(res)) {
            tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
            tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp);
            if (! sexp_exceptionp(tmp)) {
              tmp = sexp_apply(ctx2, tmp, SEXP_NULL);
              if (! sexp_exceptionp(tmp))
                app = sexp_make_lit(ctx2, tmp);
            }
          }
        }
      }
    } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */
      p1 = NULL;
      p2 = sexp_lambda_params(sexp_car(app));
      ls1 = app;
      ls2 = sexp_cdr(app);
      sv = sexp_lambda_sv(sexp_car(app));
      if (sexp_length(ctx, p2) == sexp_length(ctx, ls2)) {
        for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) {
          if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv))
              && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2))
                  || (sexp_refp(sexp_car(ls2))
                      && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))
                      && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)),
                                            sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) {
            tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2));
            tmp = sexp_cons(ctx, sexp_car(p2), tmp);
            sexp_push(ctx, substs, tmp);
            sexp_cdr(ls1) = sexp_cdr(ls2);
            if (p1)
              sexp_cdr(p1) = sexp_cdr(p2);
            else
              sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2);
          } else {
            p1 = p2;
            ls1 = ls2;
          }
        }
        sexp_lambda_body(sexp_car(app))
          = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
        if (sexp_nullp(sexp_cdr(app))
            && sexp_nullp(sexp_lambda_params(sexp_car(app)))
            && sexp_nullp(sexp_lambda_defs(sexp_car(app))))
          app = sexp_lambda_body(sexp_car(app));
      }
    }
    res = app;
    break;

  case SEXP_LAMBDA:
    sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res);
    break;

  case SEXP_CND:
    tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda);
    if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) {
      res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp))
        ? sexp_cnd_fail(res) : sexp_cnd_pass(res);
      goto loop;
    } else {
      sexp_cnd_test(res) = tmp;
      simplify_it(sexp_cnd_pass(res));
      simplify_it(sexp_cnd_fail(res));
    }
    break;

  case SEXP_REF:
    tmp = sexp_ref_name(res);
    for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
      if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) {
        res = sexp_cddar(ls1);
        break;
      }
    break;

  case SEXP_SET:
    simplify_it(sexp_set_value(res));
    break;

  case SEXP_SEQ:
    app = SEXP_NULL;
    for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) {
      tmp = simplify(ctx, sexp_car(ls2), substs, lambda);
      if (! (sexp_pairp(sexp_cdr(ls2))
             && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
                 || sexp_lambdap(tmp))))
        sexp_push(ctx, app, tmp);
    }
    if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
      res = sexp_car(app);
    else
      sexp_seq_ls(res) = sexp_nreverse(ctx, app);
    break;

  }

  sexp_gc_release5(ctx);
  return res;
}
Example #9
0
File: sexpio.c Project: tonyg/hop
int sexp_read(IOHandle *h, sexp_t **result_ptr) {
  cmsg_bytes_t buf;
  sexp_t *stack = NULL; /* held */
  sexp_t *hint = NULL; /* held */
  sexp_t *body = NULL; /* held */
  sexp_t *accumulator = NULL; /* not held */

  while (1) {
    READ1;
    switch (buf.bytes[0]) {
      case '[': {
	iohandle_drain(h, 1);
	hint = INCREF(read_simple_string(h, EMPTY_BYTES));
	if (hint == NULL) goto error;
	READ1;
	if (buf.bytes[0] != ']') {
	  h->error_kind = SEXP_ERROR_SYNTAX;
	  goto error;
	}
	iohandle_drain(h, 1);
      skip_whitespace_in_display_hint:
	READ1;
	if (isspace(buf.bytes[0])) {
	  iohandle_drain(h, 1);
	  goto skip_whitespace_in_display_hint;
	}
	body = INCREF(read_simple_string(h, EMPTY_BYTES));
	if (body == NULL) goto error;
	accumulator = sexp_display_hint(hint, body);
	DECREF(hint, sexp_destructor); /* these could be UNGRABs */
	DECREF(body, sexp_destructor);
	break;
      }

      case '(':
	iohandle_drain(h, 1);
	stack = sexp_push(stack, sexp_cons(NULL, NULL));
	continue;

      case ')': {
	sexp_t *current;
	if (stack == NULL) {
	  h->error_kind = SEXP_ERROR_SYNTAX;
	  goto error;
	}
	stack = sexp_pop(stack, &current);
	INCREF(current);
	iohandle_drain(h, 1);
	accumulator = INCREF(sexp_head(current));
	DECREF(current, sexp_destructor);
	UNGRAB(accumulator);
	break;
      }

      default:
	if (isspace(buf.bytes[0])) {
	  iohandle_drain(h, 1);
	  continue;
	}
	buf.len = 1; /* needed to avoid reading too much in read_simple_string */
	accumulator = read_simple_string(h, buf);
	if (accumulator == NULL) goto error;
	break;
    }

    if (stack == NULL) {
      *result_ptr = accumulator;
      return 1;
    } else {
      sexp_t *current = sexp_head(stack); /* not held */
      sexp_t *cell = sexp_cons(accumulator, NULL);
      if (sexp_tail(current) == NULL) {
	sexp_sethead(current, cell);
      } else {
	sexp_settail(sexp_tail(current), cell);
      }
      sexp_settail(current, cell);
    }
  }

 error:
  DECREF(stack, sexp_destructor);
  DECREF(hint, sexp_destructor);
  DECREF(body, sexp_destructor);
  return 0;
}