C++ SCHEME_TYPE函数代码示例

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;
  }
}

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;
  }
}

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;
}

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;
    }
  }
}

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

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);
            }
          }
        }
      }
    }
  }
}

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;
}

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;
}

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);
}

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;
}

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;
}

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;
}

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;
}

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;
}

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;
}