Esempio n. 1
0
static Scheme_Object *define_values_jit(Scheme_Object *data)
{
  Scheme_Object *orig = SCHEME_DEFN_RHS(data), *naya;

  if (SAME_TYPE(SCHEME_TYPE(orig), scheme_lambda_type)
      && (SCHEME_DEFN_VAR_COUNT(data) == 1))
    naya = scheme_jit_closure(orig, SCHEME_DEFN_VAR_(data, 0));
  else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type)
           && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_lambda_type)
           && (SCHEME_DEFN_VAR_COUNT(data) == 1)) {
    naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_DEFN_VAR_(data, 0));
    if (!SAME_OBJ(naya, SCHEME_DEFN_RHS(orig)))
      naya = clone_inline_variant(orig, naya);
  } else
    naya = jit_expr(orig);

  if (SAME_OBJ(naya, orig))
    return data;
  else {
    orig = naya;
    naya = scheme_clone_vector(data, 0, 1);
    SCHEME_DEFN_RHS(naya) = orig;
    return naya;
  }
}
Esempio n. 2
0
static Scheme_Object *define_values_jit(Scheme_Object *data)
{
  Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya;

  if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type)
      && (SCHEME_VEC_SIZE(data) == 2))
    naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]);
  else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type)
           && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_unclosed_procedure_type)
           && (SCHEME_VEC_SIZE(data) == 2)) {
    naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_VEC_ELS(data)[1]);
    if (!SAME_OBJ(naya, SCHEME_VEC_ELS(orig)[0]))
      naya = clone_inline_variant(orig, naya);
  } else
    naya = scheme_jit_expr(orig);

  if (SAME_OBJ(naya, orig))
    return data;
  else {
    orig = naya;
    naya = scheme_clone_vector(data, 0, 1);
    SCHEME_VEC_ELS(naya)[0] = orig;
    return naya;
  }
}
Esempio n. 3
0
File: places.c Progetto: 4z3/racket
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) {
  if (argc == 1) {
    Scheme_Object *mso;
    Scheme_Place_Bi_Channel *ch;
    if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
      ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
    }
    else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
      ch = (Scheme_Place_Bi_Channel *) args[0];
    }
    else {
      ch = NULL;
      scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args);
    }
    {
      void *msg_memory = NULL;
      mso = scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch, &msg_memory);
      return scheme_places_deserialize(mso, msg_memory);
    }
  }
  else {
    scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0);
  }
  return scheme_true;
}
Esempio n. 4
0
XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
{
  Scheme_Type t1, t2;

  if (SAME_OBJ(obj1, obj2))
    return 1;

  t1 = SCHEME_TYPE(obj1);
  t2 = SCHEME_TYPE(obj2);

  if (NOT_SAME_TYPE(t1, t2)) {
#ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS
    /* If one is a float and the other is a double, coerce to double */
    if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
      return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
    else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
      return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
    return -1;
  } else {
    switch (t1) {
#ifdef MZ_LONG_DOUBLE
    case scheme_long_double_type:
      return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
    case scheme_float_type:
      return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
    case scheme_double_type:
      return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
    case scheme_bignum_type:
      return scheme_bignum_eq(obj1, obj2);
    case scheme_rational_type:
      return scheme_rational_eq(obj1, obj2);
    case scheme_complex_type:
      {
        Scheme_Complex *c1 = (Scheme_Complex *)obj1;
        Scheme_Complex *c2 = (Scheme_Complex *)obj2;
        return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
      }
    case scheme_char_type:
      return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
    case scheme_symbol_type:
    case scheme_keyword_type:
    case scheme_scope_type:
      /* `eqv?` requires `eq?` */
      return 0;
    default:
      return -1;
    }
  }
}
Esempio n. 5
0
GVariant *
scheme_obj_to_gvariant (Scheme_Object *list)
{
 
  GVariant *rvalue;
  Scheme_Object *firstelement;
  int length;
  long i;
  char* rstring;
  double rdouble;

  rvalue = NULL; 
  length = scheme_list_length (list);
  if (length == 0)
    {
      return rvalue ;
    }  
  
  else if (length == 1)
    {
      // Get the first element of the argument
      firstelement = scheme_car (list);
 
      // checking the scheme_type to see whether it is an integer or not
      // Eventually see if we can convert this to a switch statement.
      if (SCHEME_TYPE (firstelement)== scheme_integer_type)
	{
	  // we saved the return value at &i
	  scheme_get_int_val (list,&i);
	  // we concert it to g_variant
          rvalue = g_variant_new ("(i)", i);
	  return rvalue;
	} // if it's an integer
      else if (SCHEME_TYPE (firstelement) == scheme_char_type)
	{
	  //getting the string out of the scheme_object
	  rstring = SCHEME_BYTE_STR_VAL(list);
	  // we will convert it to g_variant
	  rvalue = g_variant_new_string(rstring);
	  return rvalue;
	} // if it's a character
      else if (SCHEME_TYPE (firstelement) == scheme_double_type)
	{
	  //getting the double out of the scheme_object
	  rdouble = scheme_real_to_double(list);
	  // we will convert it to g_variant
	  rvalue = g_variant_new_double(rdouble);
	  return rvalue;
	} // if it's a double
    } // if we have a single element
 
  return rvalue;
} // scheme_obj_to_gvariant
Esempio n. 6
0
File: sfs.c Progetto: awest/racket
static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
{
  if (!info->pass) {
    if (!info->tail_pos) {
      if (SAME_OBJ(scheme_values_func, rator))
        /* no need to clear for app of `values' */
        return;
      if (SCHEME_PRIMP(rator)) {
        int opt;
        opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
        if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
          /* Don't need to clear stack before an immediate/folding call */
          return;
      }
      info->max_nontail = info->ip;
    } else {
      if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) {
        if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) {
          if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
            /* No point in clearing out any of the closure before the
               tail call. */
            int i;
            for (i = info->selflen; i--; ) {
              if ((info->selfstart + i) != info->tlpos)
                scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
            }
          }
        }
      }
    }
  }
}
Esempio n. 7
0
static Scheme_Object *read_sequence_splice(Scheme_Object *obj)
{
  obj = scheme_make_sequence_compilation(obj, 1);
  if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type))
    obj->type = scheme_splice_sequence_type;
  return obj;
}
Esempio n. 8
0
intptr_t BTC_get_memory_use(NewGC* gc, void *o)
{
  Scheme_Object *arg = (Scheme_Object*)o;
  if(SAME_TYPE(SCHEME_TYPE(arg), scheme_custodian_type)) {
    return custodian_usage(gc, arg);
  }

  return 0;
}
Esempio n. 9
0
XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
{
  Scheme_Type t1, t2;

  if (SAME_OBJ(obj1, obj2))
    return 1;

  t1 = SCHEME_TYPE(obj1);
  t2 = SCHEME_TYPE(obj2);

  if (NOT_SAME_TYPE(t1, t2)) {
#ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS
    /* If one is a float and the other is a double, coerce to double */
    if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
      return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
    else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
      return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
    return -1;
#ifdef MZ_LONG_DOUBLE
  } else if (t1 == scheme_long_double_type) {
    return long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
  } else if (t1 == scheme_float_type) {
    return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
  } else if (t1 == scheme_double_type) {
    return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
  } else if (t1 == scheme_bignum_type)
    return scheme_bignum_eq(obj1, obj2);
  else if (t1 == scheme_rational_type)
    return scheme_rational_eq(obj1, obj2);
  else if (t1 == scheme_complex_type) {
    Scheme_Complex *c1 = (Scheme_Complex *)obj1;
    Scheme_Complex *c2 = (Scheme_Complex *)obj2;
    return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
  } else if (t1 == scheme_char_type)
    return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
  else
    return -1;
}
Esempio n. 10
0
File: places.c Progetto: 4z3/racket
static int scheme_place_channel_ready(Scheme_Object *so) {
  Scheme_Place_Bi_Channel *ch;
  if (SAME_TYPE(SCHEME_TYPE(so), scheme_place_type)) {
    ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) so)->channel;
  }
  else {
    ch = (Scheme_Place_Bi_Channel *)so;
  }

  return scheme_place_async_ch_ready((Scheme_Place_Async_Channel *) ch->recvch);
}
Esempio n. 11
0
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) {
  if (argc == 1) {
    Scheme_Place_Bi_Channel *ch;
    if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
      ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
    }
    else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
      ch = (Scheme_Place_Bi_Channel *) args[0];
    }
    else {
      ch = NULL;
      scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args);
    }
    return scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch);
  }
  else {
    scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0);
  }
  return scheme_true;
}
Esempio n. 12
0
Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]) {
  if (argc == 2) {
    Scheme_Place_Bi_Channel *ch;
    if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
      ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
    }
    else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
      ch = (Scheme_Place_Bi_Channel *) args[0];
    }
    else {
      ch = NULL;
      scheme_wrong_type("place-channel-send", "place-channel", 0, argc, args);
    }
    scheme_place_async_send((Scheme_Place_Async_Channel *) ch->sendch, args[1]);
  }
  else {
    scheme_wrong_count_m("place-channel-send", 2, 2, argc, args, 0);
  }
  return scheme_true;
}
Esempio n. 13
0
File: sfs.c Progetto: awest/racket
static Scheme_Object *
case_lambda_sfs(Scheme_Object *expr, SFS_Info *info)
{
  Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
  Scheme_Object *le, *clears = scheme_null;
  int i;

  scheme_sfs_start_sequence(info, seq->count, 0);

  for (i = 0; i < seq->count; i++) {
    le = seq->array[i];
    le = scheme_sfs_expr(le, info, -1);
    if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) {
      /* Some clearing actions were added to the closure.
         Lift them out. */
      int j;
      Scheme_Sequence *cseq = (Scheme_Sequence *)le;
      if (!cseq->count)
        scheme_signal_error("internal error: empty sequence");
      for (j = 1; j < cseq->count; j++) {
        int pos;
        pos = SCHEME_LOCAL_POS(cseq->array[j]);
        clears = scheme_make_pair(scheme_make_integer(pos), clears);
      }
      le = cseq->array[0];
    }
    if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type)
        && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) {
      scheme_signal_error("internal error: not a lambda for case-lambda: %d",
                          SCHEME_TYPE(le));
    }
    seq->array[i] = le;
  }

  if (!SCHEME_NULLP(clears)) {
    return scheme_sfs_add_clears(expr, clears, 0);
  } else
    return expr;
}
Esempio n. 14
0
File: sfs.c Progetto: awest/racket
static Scheme_Object *flatten_sequence(Scheme_Object *o)
{
  /* At this point, we sometimes have (begin ... (begin ... (begin ...))).
     Flatten those out. */
  Scheme_Sequence *s = (Scheme_Sequence *)o, *s2;
  int i, extra = 0;

  o = s->array[s->count - 1];

  while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
    s2 = (Scheme_Sequence *)o;
    extra += s2->count - 1;
    o = s2->array[s2->count - 1];
  }

  if (extra) {
    s2 = scheme_malloc_sequence(s->count + extra);
    s2->so.type = scheme_sequence_type;
    s2->count = s->count + extra;

    extra = 0;
    o = (Scheme_Object *)s;
    while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
      s = (Scheme_Sequence *)o;
      for (i = 0; i < s->count - 1; i++) {
        s2->array[extra++] = s->array[i];
      }
      o = s->array[i];
    }
    s2->array[extra++] = o;

    if (extra != s2->count) scheme_signal_error("internal error: flatten failed");

    return (Scheme_Object *)s2;
  } else
    return (Scheme_Object *)s;
}
Esempio n. 15
0
Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth)
{
  int init, i;

  SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o)));

  if (!info) {
    info = scheme_new_sfs_info(max_let_depth);
  }

  info->pass = 0;
  info->ip = 1;
  info->abs_ip = 1;
  info->saved = scheme_null;
  info->min_touch = -1;
  info->max_touch = -1;
  info->tail_pos = 1;
  init = info->stackpos;
  o = scheme_sfs_expr(o, info, -1);

  if (info->seqn)
    scheme_signal_error("ended in the middle of an expression?");

# if MAX_SFS_CLEARING
  info->max_nontail = info->ip;
  info->abs_max_nontail = info->abs_ip;
# endif

  for (i = info->depth; i-- > init; ) {
    info->max_calls[i] = info->max_nontail;
  }

  {
    Scheme_Object *v;
    v = scheme_reverse(info->saved);
    info->saved = v;
  }

  info->pass = 1;
  info->seqn = 0;
  info->ip = 1;
  info->abs_ip = 1;
  info->tail_pos = 1;
  info->stackpos = init;
  o = scheme_sfs_expr(o, info, -1);

  return o;
}
Esempio n. 16
0
long
gpioread(Chan *c, void *va, long n, vlong off)
{
	int type, scheme;
	uint pin;
	char *a;
	
	a = va;
	
	if(c->qid.type & QTDIR)
	{
		return devdirread(c, va, n, 0, 0, gpiogen);
	}

	type = FILE_TYPE(c->qid);
	scheme = SCHEME_TYPE(c->qid);
	
	if(scheme != Qgeneric && scheme != pinscheme)
	{
		error(nil);
	}

	switch(type)
	{
	case Qdata:
		pin = PIN_NUMBER(c->qid);
		a[0] = (gpioin(pin))?'1':'0';
		n = 1;
		break;
	case Qctl:
		break;
	case Qevent:
		if(off >= 4)
		{
			off %= 4;
			eventvalue = 0;
		}
		sleep(&rend, isset, 0);
			
		if(off + n > 4)
		{
			n = 4 - off;
		}
		memmove(a, &eventvalue + off, n);
	}

	return n;
}
Esempio n. 17
0
static int scheme_place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo) {
  Scheme_Place_Bi_Channel *ch;
  Scheme_Object *msg = NULL;
  if (SAME_TYPE(SCHEME_TYPE(so), scheme_place_type)) {
    ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) so)->channel;
  }
  else {
    ch = (Scheme_Place_Bi_Channel *)so;
  }
  
  msg = scheme_place_async_try_recv((Scheme_Place_Async_Channel *) ch->recvch);
  if (msg != NULL) {
    scheme_set_sync_target(sinfo, msg, NULL, NULL, 0, 0, NULL);
    return 1;
  }
  return 0;
}
Esempio n. 18
0
static Scheme_Object *read_case_lambda(Scheme_Object *obj)
{
  Scheme_Object *s, *a;
  int count, i, all_closed = 1;
  Scheme_Case_Lambda *cl;

  if (!SCHEME_PAIRP(obj)) return NULL;
  s = SCHEME_CDR(obj);
  for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) {
    count++;
  }

  cl = (Scheme_Case_Lambda *)
    scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
			 + (count - 1) * sizeof(Scheme_Object *));

  cl->so.type = scheme_case_lambda_sequence_type;
  cl->count = count;
  cl->name = SCHEME_CAR(obj);
  if (SCHEME_NULLP(cl->name))
    cl->name = NULL;

  s = SCHEME_CDR(obj);
  for (i = 0; i < count; i++, s = SCHEME_CDR(s)) {
    a = SCHEME_CAR(s);
    cl->array[i] = a;
    if (!SCHEME_PROCP(a)) {
      if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type))
        return NULL;
      all_closed = 0;
    }
  }

  if (all_closed) {
    /* Empty closure: produce procedure value directly.
       (We assume that this was generated by a direct write of
        a case-lambda data record in print.c, and that it's not
	in a CASE_LAMBDA_EXPD syntax record.) */
    return scheme_case_lambda_execute((Scheme_Object *)cl);
  }

  return (Scheme_Object *)cl;
}
Esempio n. 19
0
static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit)
{
  Resolve_Prefix *rp, *orig_rp;
  Scheme_Object *naya, *rhs;
  
  rhs = SCHEME_VEC_ELS(expr)[0];
#ifdef MZ_USE_JIT
  if (jit) {
    if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type))
      naya = scheme_jit_expr(rhs);
    else {
      int changed = 0;
      Scheme_Object *a, *l = rhs;
      naya = scheme_null;
      while (!SCHEME_NULLP(l)) {
        a = scheme_jit_expr(SCHEME_CAR(l));
        if (!SAME_OBJ(a, SCHEME_CAR(l)))
          changed = 1;
        naya = scheme_make_pair(a, naya);
        l = SCHEME_CDR(l);
      }
      if (changed)
        naya = scheme_reverse(naya);
      else
        naya = rhs;
    }
  } else
#endif
    naya = rhs;

  orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
  rp = scheme_prefix_eval_clone(orig_rp);
  
  if (SAME_OBJ(naya, rhs)
      && SAME_OBJ(orig_rp, rp))
    return expr;
  else {
    expr = scheme_clone_vector(expr, 0, 1);
    SCHEME_VEC_ELS(expr)[0] = naya;
    SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
    return expr;
  }
}
Esempio n. 20
0
static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) {
  Scheme_Place          *place;
  place = (Scheme_Place *) args[0];

  if (argc != 1) {
    scheme_wrong_count_m("place-wait", 1, 1, argc, args, 0);
  }
  if (!SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
    scheme_wrong_type("place-wait", "place", 0, argc, args);
  }
 
# ifdef MZ_PRECISE_GC
   {
    Scheme_Object *rc;
    mz_proc_thread *worker_thread;
    Scheme_Place *waiting_place;
    int *wake_fd;

    proc_thread_wait_data *wd;
    wd = (proc_thread_wait_data*) malloc(sizeof(proc_thread_wait_data));
    wd->proc_thread = (mz_proc_thread *)place->proc_thread;
    wd->waiting_place = waiting_place;
    wake_fd = scheme_get_signal_handle();
    wd->wake_fd = wake_fd;
    wd->ready   = 0;

    worker_thread = mz_proc_thread_create(mz_proc_thread_wait_worker, wd);
    mz_proc_thread_detach(worker_thread);
    scheme_block_until(place_wait_ready, NULL, (Scheme_Object *) wd, 0);

    rc = scheme_make_integer((intptr_t)wd->rc);
    free(wd);
    return rc;
  }
# else
  {
    void *rcvoid;
    rcvoid = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread);
    return scheme_make_integer((intptr_t) rcvoid);
  }
# endif
}
Esempio n. 21
0
File: sema.c Progetto: sindoc/racket
static void get_outof_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w)
{
  Scheme_Channel_Syncer *last, *first;

  if (!w->in_line)
    return;
  w->in_line = 0;

  if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
    return; /* !!!! skip everything else */
  } else if (SCHEME_SEMAP(sema)) {
    last = sema->last;
    first = sema->first;
  } else if (SCHEME_CHANNELP(sema)) {
    last = ((Scheme_Channel *)sema)->get_last;
    first = ((Scheme_Channel *)sema)->get_first;
  } else {
    last = ((Scheme_Channel_Put *)sema)->ch->put_last;
    first = ((Scheme_Channel_Put *)sema)->ch->put_first;
  }

  if (w->prev)
    w->prev->next = w->next;
  else
    first = w->next;
  if (w->next)
    w->next->prev = w->prev;
  else
    last = w->prev;

  if (SCHEME_SEMAP(sema)) {
    sema->last = last;
    sema->first = first;
  } else if (SCHEME_CHANNELP(sema)) {
    ((Scheme_Channel *)sema)->get_last = last;
    ((Scheme_Channel *)sema)->get_first = first;
  } else {
    ((Scheme_Channel_Put *)sema)->ch->put_last = last;
    ((Scheme_Channel_Put *)sema)->ch->put_first = first;
  }
}
Esempio n. 22
0
File: sema.c Progetto: sindoc/racket
static void get_into_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w)
  /* Can be called multiple times. */
{
  Scheme_Channel_Syncer *last, *first;
  
  w->in_line = 1;
  w->picked = 0;

  if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
    return; /* !!!! skip everything else */
  } else if (SCHEME_SEMAP(sema)) {
    last = sema->last;
    first = sema->first;
  } else if (SCHEME_CHANNELP(sema)) {
    last = ((Scheme_Channel *)sema)->get_last;
    first = ((Scheme_Channel *)sema)->get_first;
  } else {
    last = ((Scheme_Channel_Put *)sema)->ch->put_last;
    first = ((Scheme_Channel_Put *)sema)->ch->put_first;
  }

  w->prev = last;
  if (last)
    last->next = w;
  else
    first = w;
  last = w;
  w->next = NULL;

  if (SCHEME_SEMAP(sema)) {
    sema->last = last;
    sema->first = first;
  } else if (SCHEME_CHANNELP(sema)) {
    ((Scheme_Channel *)sema)->get_last = last;
    ((Scheme_Channel *)sema)->get_first = first;
  } else {
    ((Scheme_Channel_Put *)sema)->ch->put_last = last;
    ((Scheme_Channel_Put *)sema)->ch->put_first = first;
  }
}
Esempio n. 23
0
void count_tagged(void *p, int size, void *data)
{
  int which = SCHEME_TYPE((Scheme_Object *)p);
  if ((which >= 0) && (which < _scheme_last_type_)) {
    scheme_count_memory((Scheme_Object *)p, smc_ht);
  } else if (which >= scheme_num_types())
    bad_seeds++;
  else {
    if (which >= NUM_TYPE_SLOTS)
      which = NUM_TYPE_SLOTS - 1;
    scheme_memory_count[which]++;
    scheme_memory_size[which] += size;
  }

  if (which == obj_type) {
    if (obj_buffer_pos < OBJ_BUFFER_SIZE) {
      obj_buffer[obj_buffer_pos++] = p;
    }
  }

  if (which == scheme_application_type) {
    Scheme_App_Rec *app = (Scheme_App_Rec *)p;
    int cnt;
    cnt = app->num_args;
    if (cnt >= NUM_RECORDED_APP_SIZES) {
      cnt = NUM_RECORDED_APP_SIZES;
    } else {
      int i, devals, kind;
      devals = sizeof(Scheme_App_Rec) + (app->num_args * sizeof(Scheme_Object *));
      for (i = 0; i <= cnt; i++) {
	kind = ((char *)app + devals)[i];
	if ((kind >= 0) && (kind <= 4)) {
	  app_arg_kinds[cnt][i][kind]++;
	}
      }
    }
    app_sizes[cnt]++;
  }
}
Esempio n. 24
0
File: sfs.c Progetto: awest/racket
static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info)
{
  Scheme_Letrec *lr = (Scheme_Letrec *)o;
  Scheme_Object **procs, *v, *clears = scheme_null;
  int i, count;

  count = lr->count;

  scheme_sfs_start_sequence(info, count + 1, 1);

  procs = lr->procs;

  for (i = 0; i < count; i++) { 
    v = scheme_sfs_expr(procs[i], info, i);

    if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) {
      /* Some clearing actions were added to the closure.
         Lift them out. */
      int j;
      Scheme_Sequence *cseq = (Scheme_Sequence *)v;
      for (j = 1; j < cseq->count; j++) {
        int pos;
        pos = SCHEME_LOCAL_POS(cseq->array[j]);
        clears = scheme_make_pair(scheme_make_integer(pos), clears);
      }
      v = cseq->array[0];
    }
    procs[i] = v;
  }

  v = scheme_sfs_expr(lr->body, info, -1);

  v = scheme_sfs_add_clears(v, clears, 1);

  lr->body = v;

  return o;
}
Esempio n. 25
0
static void trace_count(void *p, int size)
{
  int which = SCHEME_TYPE((Scheme_Object *)p);
  if ((which >= 0) && (which <= _scheme_last_type_)) {
   /* fall through to below */ 
  } else if (which >= scheme_num_types()) {
    bad_seeds++;
    return;
  } else {
    if (which >= NUM_TYPE_SLOTS)
      which = NUM_TYPE_SLOTS - 1;
   /* fall through to below */ 
  }

  {
    unsigned long s = (unsigned long)p;
    scheme_memory_actual_count[which]++;
    scheme_memory_actual_size[which] += size;
    if (!scheme_memory_lo[which] || (s < scheme_memory_lo[which]))
      scheme_memory_lo[which] = s;
    if (!scheme_memory_hi[which] || (s > scheme_memory_hi[which]))
      scheme_memory_hi[which] = s;
  }
}
Esempio n. 26
0
/**
 *Translating the scheme_object to gvariant type for the client
 *This step is used on sending input values onto the DBus
 */
GVariant *
scheme_obj_to_gvariant (Scheme_Object *list)
{
  GVariantBuilder *builder;
  GVariant *finalr;
  GVariant *rvalue = NULL;
  Scheme_Object *firstelement;
  int length = 0;
  gint32 i;
  char* rstring;
  double rdouble;
  
  builder = g_variant_builder_new(G_VARIANT_TYPE_TUPLE);
  length = scheme_list_length (list);
  // rvalue = g_new(GVariant *, length);

  if (length == 0)
    {
      //  scheme_signal_error("length 0");
      return rvalue ;
    }  // if
  else{
    while (length != 0)
      {
	// Get the first element of the argument
	firstelement = scheme_car (list);
	list = scheme_cdr(list);
	length = scheme_list_length(list);
	// checking the scheme_type to see whether it is an integer or not
	// Eventually see if we can convert this to a switch statement.
	if (SCHEME_INTP (firstelement))
	  {
	    // we saved the return value at &i
	     i = SCHEME_INT_VAL(firstelement); 
	     rvalue = g_variant_new ("i",i);
	     g_variant_builder_add_value(builder,rvalue);
	    // return rvalue;
	  } // if it's an integer
	else if (SCHEME_BYTE_STRINGP (firstelement)|| SCHEME_CHAR_STRINGP(firstelement))
	  {
	    //scheme_signal_error ("We are in Character");
	    //getting the string out of the scheme_object
	    rstring = SCHEME_BYTE_STR_VAL(list);
	    // we will convert it to g_variant
	    rvalue = g_variant_new ("(&s)", rstring);
            g_variant_builder_add_value(builder, rvalue);
	  } // if it's a character
	else if (SCHEME_TYPE (firstelement) == scheme_double_type)
	  {
	    //getting the double out of the scheme_object
	    rdouble = scheme_real_to_double(list);
	    // we will convert it to g_variant
	    rvalue = g_variant_new_double(rdouble);
	    g_variant_builder_add_value(builder, rvalue);
	  } // if it's a double
      } // while loop
 
    finalr = g_variant_builder_end (builder);
    return finalr;
  } //else
  return finalr;
} // scheme_obj_to_gvariant
Esempio n. 27
0
long
gpiowrite(Chan *c, void *va, long n, vlong)
{
	int type, i, scheme;
	uint pin;
	char *arg;

	Cmdbuf *cb;
	Cmdtab *ct;

	if(c->qid.type & QTDIR)
	{
		error(Eisdir);
	}

	type = FILE_TYPE(c->qid);

	scheme = SCHEME_TYPE(c->qid);
	
	if(scheme != Qgeneric && scheme != pinscheme)
	{
		error(nil);
	}

	cb = parsecmd(va, n);
	if(waserror())
	{
		free(cb);
		nexterror();
	}
	ct = lookupcmd(cb, gpiocmd,  nelem(gpiocmd));
	if(ct == nil)
	{
		error(Ebadctl);
	}
	
	switch(type)
	{
	case Qdata:
		pin = PIN_NUMBER(c->qid);

		switch(ct->index)
		{
		case CMzero:
			gpioout(pin, 0);
			break;
		case CMone:
			gpioout(pin, 1);
			break;
		default:
			error(Ebadctl);
		}
		break;
	case Qctl:
		switch(ct->index)
		{
		case CMscheme:
			arg = cb->f[1];
			for(i = 0; i < nelem(schemename); i++)
			{
				if(strncmp(schemename[i], arg, strlen(schemename[i])) == 0)
				{
					pinscheme = i;
					break;
				}
			}
			break;
		case CMfunc:
			pin = getpin(cb->f[2]);
			arg = cb->f[1];
			if(pin == -1) {
				error(Ebadctl);
			}
			for(i = 0; i < nelem(funcname); i++)
			{
				if(strncmp(funcname[i], arg, strlen(funcname[i])) == 0)
				{
					gpiofuncset(pin, i);
					break;
				}
			}
			break;
		case CMpull:
			pin = getpin(cb->f[2]);
			if(pin == -1) {
				error(Ebadctl);
			}
			arg = cb->f[1];
			for(i = 0; i < nelem(pudname); i++)
			{
				if(strncmp(pudname[i], arg, strlen(pudname[i])) == 0)
				{
					gpiopullset(pin, i);
					break;
				}
			}
			break;
		case CMevent:
			pin = getpin(cb->f[3]);
			if(pin == -1) {
				error(Ebadctl);
			}
				
			arg = cb->f[1];
			for(i = 0; i < nelem(evtypename); i++)
			{
				if(strncmp(evtypename[i], arg, strlen(evtypename[i])) == 0)
				{
					gpioevent(pin, i, (cb->f[2][0] == 'e'));
					break;
				}
			}
			break;
		default:
			error(Ebadctl);
		}
		break;
	}
	
	free(cb);

	poperror();
	return n;
}
Esempio n. 28
0
static int
gpiogen(Chan *c, char *, Dirtab *, int , int s, Dir *db)
{
	Qid qid;
	int parent, scheme, l;
	char **pintable = getpintable();
	
	qid.vers = 0;
	parent = PARENT_TYPE(c->qid);
	scheme = SCHEME_TYPE(c->qid);
	
	if(s == DEVDOTDOT)
	{
		switch(parent)
		{
		case Qtopdir:
		case Qgpiodir:
			mkdeventry(c, qid, &topdir, db);
			break;
		default:
			return -1;
		}
		return 1;
	}

	if(parent == Qtopdir)
	{
		switch(s)
		{
		case 0:
			mkdeventry(c, qid, &gpiodir, db);
			break;
		default:
			return -1;
		}
	return 1;
	}

	if(scheme != Qgeneric && scheme != pinscheme)
	{
		error(nil);
	}

	if(parent == Qgpiodir)
	{
		l = nelem(typedir);
		if(s < l)
		{
			mkdeventry(c, qid, &typedir[s], db);
		} else if (s < l + PIN_TABLE_SIZE)
		{
			s -= l;
			
			if(pintable[s] == 0)
			{
				return 0;
			}
			mkqid(&qid, PATH(s, pinscheme, Qgpiodir, Qdata), 0, QTFILE);
			snprint(up->genbuf, sizeof up->genbuf, "%s", pintable[s]);
			devdir(c, qid, up->genbuf, 0, eve, 0666, db);
		}
		else
		{
			return -1;
		}
		return 1;
	}

	return 1;
}
Esempio n. 29
0
File: bool.c Progetto: SamB/racket
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
  Scheme_Type t1, t2;
  int cmp;

 top:
  if (eql->next_next) {
    if (eql->next) {
      Scheme_Object *a[2];
      a[0] = obj1;
      a[1] = obj2;
      obj1 = _scheme_apply(eql->next, 2, a);
      return SCHEME_TRUEP(obj1);
    }
    eql->next = eql->next_next;
  }

  cmp = is_eqv(obj1, obj2);
  if (cmp > -1)
    return cmp;

  if (eql->for_chaperone 
      && SCHEME_CHAPERONEP(obj1)
      && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
          || (eql->for_chaperone > 1))) {
    obj1 = ((Scheme_Chaperone *)obj1)->prev;
    goto top;
  }

  t1 = SCHEME_TYPE(obj1);
  t2 = SCHEME_TYPE(obj2);

  if (NOT_SAME_TYPE(t1, t2)) {
    if (!eql->for_chaperone) {
      if (SCHEME_CHAPERONEP(obj1)) {
        obj1 = ((Scheme_Chaperone *)obj1)->val;
        goto top;
      }
      if (SCHEME_CHAPERONEP(obj2)) {
        obj2 = ((Scheme_Chaperone *)obj2)->val;
        goto top;
      }
    }
    return 0;
  } else if (t1 == scheme_pair_type) {
#   include "mzeqchk.inc"
    if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
      if (union_check(obj1, obj2, eql))
        return 1;
    }
    eql->car_depth += 2;
    if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
      eql->car_depth -= 2;
      obj1 = SCHEME_CDR(obj1);
      obj2 = SCHEME_CDR(obj2);
      goto top;
    } else
      return 0;
  } else if (t1 == scheme_mutable_pair_type) {
#   include "mzeqchk.inc"
    if (eql->for_chaperone == 1)
      return 0;
    if (union_check(obj1, obj2, eql))
      return 1;
    if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
      obj1 = SCHEME_CDR(obj1);
      obj2 = SCHEME_CDR(obj2);
      goto top;
    } else
      return 0;
  } else if ((t1 == scheme_vector_type)
             || (t1 == scheme_fxvector_type)) {
#   include "mzeqchk.inc"
    if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
                                      || !SCHEME_IMMUTABLEP(obj2)))
      return 0;
    if (union_check(obj1, obj2, eql))
      return 1;
    return vector_equal(obj1, obj2, eql);
  } else if (t1 == scheme_flvector_type) {
    intptr_t l1, l2, i;
    l1 = SCHEME_FLVEC_SIZE(obj1);
    l2 = SCHEME_FLVEC_SIZE(obj2);
    if (l1 == l2) {
      for (i = 0; i < l1; i++) {
        if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
                        SCHEME_FLVEC_ELS(obj2)[i]))
          return 0;
      }
      return 1;
    }
    return 0;
  } else if ((t1 == scheme_byte_string_type)
             || ((t1 >= scheme_unix_path_type) 
                 && (t1 <= scheme_windows_path_type))) {
    intptr_t l1, l2;
    if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
                                      || !SCHEME_IMMUTABLEP(obj2)))
      return 0;
    l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
    l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
    return ((l1 == l2)
	    && !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
  } else if (t1 == scheme_char_string_type) {
    intptr_t l1, l2;
    if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
                                      || !SCHEME_IMMUTABLEP(obj2)))
      return 0;
    l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
    l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
    return ((l1 == l2)
	    && !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
  } else if (t1 == scheme_regexp_type) {
    if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
      return 0;
    if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
      return 0;
    obj1 = scheme_regexp_source(obj1);
    obj2 = scheme_regexp_source(obj2);
    goto top;
  } else if ((t1 == scheme_structure_type)
             || (t1 == scheme_proc_struct_type)) {
    Scheme_Struct_Type *st1, *st2;
    Scheme_Object *procs1, *procs2;

    st1 = SCHEME_STRUCT_TYPE(obj1);
    st2 = SCHEME_STRUCT_TYPE(obj2);

    if (eql->for_chaperone == 1)
      procs1 = NULL;
    else
      procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
    if (procs1)
      procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
    if (eql->for_chaperone)
      procs2 = NULL;
    else {
      procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
      if (procs2)
        procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
    }

    if (procs1 || procs2) {
      /* impersonator-of property trumps other forms of checking */
      if (procs1) obj1 = procs1;
      if (procs2) obj2 = procs2;
      goto top;
    } else {
      procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
      if (procs1 && (st1 != st2)) {
        procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
        if (!procs2
            || !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
          procs1 = NULL;
      }

      if (procs1) {
        /* Has an equality property: */
        Scheme_Object *a[3], *recur;
        Equal_Info *eql2;
#     include "mzeqchk.inc"

        if (union_check(obj1, obj2, eql))
          return 1;

        /* Create/cache closure to use for recursive equality checks: */
        if (eql->recur) {
          recur = eql->recur;
          eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
        } else {
          eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
          a[0] = (Scheme_Object *)eql2;
          recur = scheme_make_prim_closure_w_arity(equal_recur,
                                                   1, a,
                                                   "equal?/recur",
                                                   2, 2);
          eql->recur = recur;
        }
        memcpy(eql2, eql, sizeof(Equal_Info));

        a[0] = obj1;
        a[1] = obj2;
        a[2] = recur;

        procs1 = SCHEME_VEC_ELS(procs1)[1];

        recur = _scheme_apply(procs1, 3, a);

        memcpy(eql, eql2, sizeof(Equal_Info));

        return SCHEME_TRUEP(recur);
      } else if (st1 != st2) {
        return 0;
      } else if ((eql->for_chaperone == 1)
                 && !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
        return 0;
      } else {
        /* Same types, but doesn't have an equality property
           (or checking for chaperone), so check transparency: */
        Scheme_Object *insp;
        insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
        if (scheme_inspector_sees_part(obj1, insp, -2)
            && scheme_inspector_sees_part(obj2, insp, -2)) {
#       include "mzeqchk.inc"
          if (union_check(obj1, obj2, eql))
            return 1;
          return struct_equal(obj1, obj2, eql);
        } else
          return 0;
      }
    }
  } else if (t1 == scheme_box_type) {
    SCHEME_USE_FUEL(1);
    if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
                                      || !SCHEME_IMMUTABLEP(obj2)))
      return 0;
    if (union_check(obj1, obj2, eql))
      return 1;
    obj1 = SCHEME_BOX_VAL(obj1);
    obj2 = SCHEME_BOX_VAL(obj2);
    goto top;
  } else if (t1 == scheme_hash_table_type) {
#   include "mzeqchk.inc"
    if (eql->for_chaperone == 1) 
      return 0;
    if (union_check(obj1, obj2, eql))
      return 1;
    return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2, eql);
  } else if (t1 == scheme_hash_tree_type) {
#   include "mzeqchk.inc"
    if (union_check(obj1, obj2, eql))
      return 1;
    return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql);
  } else if (t1 == scheme_bucket_table_type) {
#   include "mzeqchk.inc"
    if (eql->for_chaperone == 1) 
      return 0;
    if (union_check(obj1, obj2, eql))
      return 1;
    return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql);
  } else if (t1 == scheme_cpointer_type) {
    return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
            == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
  } else if (t1 == scheme_wrap_chunk_type) {
    return vector_equal(obj1, obj2, eql);
  } else if (t1 == scheme_resolved_module_path_type) {
    obj1 = SCHEME_PTR_VAL(obj1);
    obj2 = SCHEME_PTR_VAL(obj2);
    goto top;
  } else if (t1 == scheme_place_bi_channel_type) {
    Scheme_Place_Bi_Channel *bc1, *bc2;
    bc1 = (Scheme_Place_Bi_Channel *)obj1;
    bc2 = (Scheme_Place_Bi_Channel *)obj2;
   return (SAME_OBJ(bc1->recvch, bc2->recvch)
           && SAME_OBJ(bc1->sendch, bc2->sendch));
  } else if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
                                     || (t1 == scheme_proc_chaperone_type))) {
    /* both chaperones */
    obj1 = ((Scheme_Chaperone *)obj1)->val;
    obj2 = ((Scheme_Chaperone *)obj2)->val;
    goto top;
  } else {
    Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
    if (eqlp) {
      if (union_check(obj1, obj2, eql))
        return 1;
      return eqlp(obj1, obj2, eql);
    } else
      return 0;
  }
}
Esempio n. 30
0
File: sfs.c Progetto: awest/racket
static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
{
  Scheme_Let_One *lo = (Scheme_Let_One *)o;
  Scheme_Object *body, *rhs, *vec;
  int pos, save_mnt, ip, et;
  int unused = 0;

  scheme_sfs_start_sequence(info, 2, 1);

  scheme_sfs_push(info, 1, 1);
  ip = info->ip;
  pos = info->stackpos;
  save_mnt = info->max_nontail;

  if (!info->pass) {
    vec = scheme_make_vector(3, NULL);
    scheme_sfs_save(info, vec);
  } else {
    vec = scheme_sfs_next_saved(info);
    if (SCHEME_VEC_SIZE(vec) != 3)
      scheme_signal_error("internal error: bad vector length");
    info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
    info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
    info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
  }

  rhs = scheme_sfs_expr(lo->value, info, -1);
  body = scheme_sfs_expr(lo->body, info, -1);

# if MAX_SFS_CLEARING
  if (!info->pass)
    info->max_nontail = info->ip;
# endif
  
  if (!info->pass) {
    int n;
    info->max_calls[pos] = info->max_nontail;
    n = info->max_used[pos];
    SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
    n = info->max_calls[pos];
    SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
    SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
  } else {
    info->max_nontail = save_mnt;

    if (info->max_used[pos] <= ip) {
      /* No one is using it, so don't actually push the value at run time
         (but keep the check that the result is single-valued).
         The optimizer normally would have converted away the binding, but
         it might not because (1) it was introduced late by inlining,
         or (2) the rhs expression doesn't always produce a single
         value. */
      if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) {
        rhs = scheme_false;
      } else if ((ip < info->max_calls[pos])
                 && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {
        /* Unusual case: we can't just drop the global-variable access,
           because it might be undefined, but we don't need the value,
           and we want to avoid an SFS clear in the interpreter loop.
           So, bind #f and then access in the global in a `begin'. */
        Scheme_Sequence *s;
        s = scheme_malloc_sequence(2);
        s->so.type = scheme_sequence_type;
        s->count = 2;
        s->array[0] = rhs;
        s->array[1] = body;
        body = (Scheme_Object *)s;
        rhs = scheme_false;
      }
      unused = 1;
    }
  }

  lo->value = rhs;
  lo->body = body;

  et = scheme_get_eval_type(lo->value);
  SCHEME_LET_EVAL_TYPE(lo) = (et 
                              | (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM))
                              | (unused ? LET_ONE_UNUSED : 0));

  return o;
}