C++ scheme_wrong_type函数代码示例

static Scheme_Object *make_immutable_hash_table(int argc, Scheme_Object *argv[])
{
  Scheme_Object *l = argv[0], *a;
  Scheme_Hash_Table *ht;

  if (scheme_proper_list_length(l) >= 0) {
    for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
      a = SCHEME_CAR(l);
      if (!SCHEME_PAIRP(a))
	break;
    }
  }

  if (!SCHEME_NULLP(l))
    scheme_wrong_type("make-immutable-hash-table", "list of pairs", 0, argc, argv);

  if (argc > 1) {
    if (!SAME_OBJ(equal_symbol, argv[1]))
      scheme_wrong_type("make-immutable-hash-table", "'equal", 1, argc, argv);
    ht = scheme_make_hash_table_equal();
  } else
    ht = scheme_make_hash_table(SCHEME_hash_ptr);

  for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
    a = SCHEME_CAR(l);
    scheme_hash_set(ht, SCHEME_CAR(a), SCHEME_CDR(a));
  }

  SCHEME_SET_IMMUTABLE((Scheme_Object *)ht);

  return (Scheme_Object *)ht;
}

static Scheme_Object *
scheme_append_bang (Scheme_Object *lst1, Scheme_Object *lst2)
{
  if (SCHEME_NULLP(lst1))
    return lst2;
  else {
    Scheme_Object *prev, *orig;

    orig = lst1;

    do {
      prev = lst1;
      if (!SCHEME_PAIRP(lst1))
	scheme_wrong_type("append!", "proper list", -1, 0, &lst1);
      lst1 = SCHEME_CDR(lst1);

      SCHEME_USE_FUEL(1);
    } while (!SCHEME_NULLP(lst1));

    if (!SCHEME_MUTABLE_PAIRP(prev))
      scheme_wrong_type("append!", "mutable proper list", -1, 0, &lst1);
    SCHEME_CDR(prev) = lst2;

    return orig;
  }
}

/**
 * A general call.  Parameters are
 *  0: The LouDBusProxy
 *  1: The method name (string)
 *  others: Parameters to the method
 */
Scheme_Object *
loudbus_call (int argc, Scheme_Object **argv)
{
  LouDBusProxy *proxy;
  gchar *name;

  // I don't think that I need to add annotations for garbage collection
  // because scheme_object_to_string is the only allocating call, and we've
  // dealt with all the other Scheme objects by the time we call it.
  proxy = scheme_object_to_proxy (argv[0]);
  name = scheme_object_to_string (argv[1]);

  // Sanity checks
  if (proxy == NULL)
    {
      scheme_wrong_type ("loudbus-call", "LouDBusProxy *", 0, argc, argv);
    } // if we could not get the proxy
  if (name == NULL)
    {
      scheme_wrong_type ("loudbus-call", "string", 1, argc, argv);
    } // if we could not get the name

  // Permit the use of dashes
  score_it_all (name);

  return dbus_call_kernel (proxy, name, name, argc-2, argv+2);
} // loudbus_call

static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
{
  Scheme_Object *s1, *s2;
  intptr_t istart, ifinish;
  intptr_t ostart, ofinish;
  int slow = 0;

  s1 = argv[0];
  if (SCHEME_NP_CHAPERONEP(s1)) {
    slow = 1;
    s1 = SCHEME_CHAPERONE_VAL(s1);
  }
  if (!SCHEME_MUTABLE_VECTORP(s1))
    scheme_wrong_type("vector-copy!", "mutable vector", 0, argc, argv);

  scheme_do_get_substring_indices("vector-copy!", s1, 
                                  argc, argv, 1, 5, 
                                  &ostart, &ofinish, SCHEME_VEC_SIZE(s1));

  s2 = argv[2];
  if (SCHEME_NP_CHAPERONEP(s2)) {
    slow = 1;
    s2 = SCHEME_CHAPERONE_VAL(s2);
  }
  if (!SCHEME_VECTORP(s2))
    scheme_wrong_type("vector-copy!", "vector", 2, argc, argv);

  scheme_do_get_substring_indices("vector-copy!", s2, 
                                  argc, argv, 3, 4, 
                                  &istart, &ifinish, SCHEME_VEC_SIZE(s2));

  if ((ofinish - ostart) < (ifinish - istart)) {
    scheme_arg_mismatch("vector-copy!",
			"not enough room in target vector: ",
			argv[2]);
    return NULL;
  }

  if (slow) {
    int i, o;
    for (i = istart, o = ostart; i < ifinish; i++, o++) {
      scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i));
    }
  } else {
    memmove(SCHEME_VEC_ELS(s1) + ostart,
            SCHEME_VEC_ELS(s2) + istart,
            (ifinish - istart) * sizeof(Scheme_Object*));
  }
  
  return scheme_void;
}

static Scheme_Object *
length_prim (int argc, Scheme_Object *argv[])
{
  int l;

  if (!SCHEME_LISTP(argv[0]))
    scheme_wrong_type("length", "proper list", 0, argc, argv);

  l = scheme_proper_list_length(argv[0]);

  if (l < 0)
    scheme_wrong_type("length", "proper list", 0, argc, argv);

  return scheme_make_integer(l);
}

Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
  Scheme_Object *vec;
  intptr_t i;

  if (size < 0) {
    vec = scheme_make_integer(size);
    scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
  }

  if (size < 1024) {
    vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
  } else {
    size_t sz;
    sz = VECTOR_BYTES(size);
    if (REV_VECTOR_BYTES(sz) != size)
      /* overflow */
      scheme_raise_out_of_memory(NULL, NULL);
    else
      vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz);
  }

  vec->type = scheme_vector_type;
  SCHEME_VEC_SIZE(vec) = size;

  if (fill) {
    for (i = 0; i < size; i++) {
      SCHEME_VEC_ELS(vec)[i] = fill;
    }
  }

  return vec;
}

static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[])
{
  if (SCHEME_HASHTP(argv[0])) {
    Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
    return scheme_make_integer(t->count);
  } else if (SCHEME_BUCKTP(argv[0])) {
    Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
    int count = 0, weak, i;
    Scheme_Bucket **buckets, *bucket;
    const char *key;

    buckets = t->buckets;
    weak = t->weak;

    for (i = t->size; i--; ) {
      bucket = buckets[i];
      if (bucket) {
	if (weak) {
	  key = (const char *)HT_EXTRACT_WEAK(bucket->key);
	} else {
	  key = bucket->key;
	}
	if (key)
	  count++;
      }
      SCHEME_USE_FUEL(1);
    }

    return scheme_make_integer(count);
  } else {
    scheme_wrong_type("hash-table-count", "hash-table", 0, argc, argv);
    return NULL;
  }
}

static Scheme_Object *
vector_fill (int argc, Scheme_Object *argv[])
{
  int i, sz;
  Scheme_Object *v, *vec = argv[0];

  if (SCHEME_NP_CHAPERONEP(vec))
    vec = SCHEME_CHAPERONE_VAL(vec);
  
  if (!SCHEME_MUTABLE_VECTORP(vec))
    scheme_wrong_type("vector-fill!", "mutable vector", 0, argc, argv);

  v = argv[1];
  sz = SCHEME_VEC_SIZE(vec);
  if (SAME_OBJ(vec, argv[0])) {
    for (i = 0; i < sz; i++) {
      SCHEME_VEC_ELS(argv[0])[i] = v;
    }
  } else {
    for (i = 0; i < sz; i++) {
      scheme_chaperone_vector_set(argv[0], i, v);
    }
  }

  return scheme_void;
}

Scheme_Object *
scheme_checked_vector_set(int argc, Scheme_Object *argv[])
{
  Scheme_Object *vec = argv[0];
  intptr_t i, len;

  if (SCHEME_CHAPERONEP(vec))
    vec = SCHEME_CHAPERONE_VAL(vec);

  if (!SCHEME_MUTABLE_VECTORP(vec))
    scheme_wrong_type("vector-set!", "mutable vector", 0, argc, argv);

  len = SCHEME_VEC_SIZE(vec);

  i = scheme_extract_index("vector-set!", 1, argc, argv, len, 0);

  if (i >= len)
    return bad_index("vector-set!", argv[1], argv[0], 0);

  if (!SAME_OBJ(vec, argv[0]))
    scheme_chaperone_vector_set(argv[0], i, argv[2]);
  else
    SCHEME_VEC_ELS(vec)[i] = argv[2];

  return scheme_void;
}

Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
  intptr_t i, len;
  Scheme_Object *vec;

  vec = argv[0];
  if (SCHEME_CHAPERONEP(vec))
    vec = SCHEME_CHAPERONE_VAL(vec);

  if (!SCHEME_VECTORP(vec))
    scheme_wrong_type("vector-ref", "vector", 0, argc, argv);

  len = SCHEME_VEC_SIZE(vec);

  i = scheme_extract_index("vector-ref", 1, argc, argv, len, 0);

  if (i >= len)
    return bad_index("vector-ref", argv[1], argv[0], 0);

  if (!SAME_OBJ(vec, argv[0]))
    /* chaperone */
    return scheme_chaperone_vector_ref(argv[0], i);
  else
    return (SCHEME_VEC_ELS(vec))[i];
}

Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
  Scheme_Object *vec;
  intptr_t i;

  if (size < 0) {
    vec = scheme_make_integer(size);
    scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
  }

  if (size < 1024) {
    vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
  } else {
    vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, VECTOR_BYTES(size));
  }

  vec->type = scheme_vector_type;
  SCHEME_VEC_SIZE(vec) = size;

  if (fill) {
    for (i = 0; i < size; i++) {
      SCHEME_VEC_ELS(vec)[i] = fill;
    }
  }

  return vec;
}

Scheme_Object *
scheme_make_vector (int size, Scheme_Object *fill)
{
  Scheme_Object *vec;
  int i;

  if (size <= 0) {
    if (size) {
      vec = scheme_make_integer(size);
      scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
    } else
      return zero_length_vector;
  }

  if (size < 1024) {
    vec = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector) 
						+ (size - 1) * sizeof(Scheme_Object *));
  } else {
    vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged,
						 sizeof(Scheme_Vector) 
						 + (size - 1) * sizeof(Scheme_Object *));
  }

  vec->type = scheme_vector_type;
  SCHEME_VEC_SIZE(vec) = size;

  if (fill) {
    for (i = 0; i < size; i++) {
      SCHEME_VEC_ELS(vec)[i] = fill;
    }
  }

  return vec;
}

static Scheme_Object *
car_prim (int argc, Scheme_Object *argv[])
{
  if (!SCHEME_PAIRP(argv[0]))
    scheme_wrong_type("car", "pair", 0, argc, argv);
  return (SCHEME_CAR (argv[0]));
}

static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
{
  void *v;

  if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])))
    scheme_wrong_type("hash-table-get", "hash-table", 0, argc, argv);

  if (SCHEME_BUCKTP(argv[0])){
    Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
    if (t->mutex) scheme_wait_sema(t->mutex, 0);
    v = scheme_lookup_in_table(t, (char *)argv[1]);
    if (t->mutex) scheme_post_sema(t->mutex);
  } else {
    Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
    if (t->mutex) scheme_wait_sema(t->mutex, 0);
    v = scheme_hash_get(t, argv[1]);
    if (t->mutex) scheme_post_sema(t->mutex);
  }

  if (v)
    return (Scheme_Object *)v;
  else if (argc == 3)
    return _scheme_tail_apply(argv[2], 0, NULL);
  else {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
		     "hash-table-get: no value found for key: %V",
		     argv[1]);
    return scheme_void;
  }
}

static Scheme_Object *
integer_to_char (int argc, Scheme_Object *argv[])
{
  if (SCHEME_INTP(argv[0])) {
    long v;
    v = SCHEME_INT_VAL(argv[0]);
    if ((v >= 0) 
	&& (v <= 0x10FFFF)
	&& ((v < 0xD800) || (v > 0xDFFF)))
      return _scheme_make_char(v);
  } else if (SCHEME_BIGNUMP(argv[0])
	     && SCHEME_BIGPOS(argv[0])) {
    /* On 32-bit machines, there's still a chance... */
    long y;
    if (scheme_get_int_val(argv[0], &y)) {
      if (y <= 0x10FFFF)
	return _scheme_make_char(y);
    }
  }

  scheme_wrong_type("integer->char", 
		    "exact integer in [0,#x10FFFF], not in [#xD800,#xDFFF]", 
		    0, argc, argv);
  return NULL;
}