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_contract("vector-copy!", "(and/c vector? (not/c immutable?))", 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_contract("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_contract_error("vector-copy!", "not enough room in target vector", "target vector", 1, argv[2], "starting index", 1, scheme_make_integer(ostart), "element count", 1, scheme_make_integer(ofinish - ostart), NULL); 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 *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 * 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_contract("vector-fill!", "(and/c vector? (not/c immutable?))", 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; }
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]) { Scheme_Object *vec, *ovec, *v; intptr_t len, i; vec = argv[0]; if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec); if (!SCHEME_VECTORP(vec)) scheme_wrong_contract("vector->immutable-vector", "vector?", 0, argc, argv); if (SCHEME_IMMUTABLEP(vec)) return argv[0]; ovec = vec; len = SCHEME_VEC_SIZE(ovec); vec = scheme_make_vector(len, NULL); if (!SAME_OBJ(ovec, argv[0])) { for (i = 0; i < len; i++) { v = scheme_chaperone_vector_ref(argv[0], i); SCHEME_VEC_ELS(vec)[i] = v; } } else { for (i = 0; i < len; i++) { SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i]; } } SCHEME_SET_IMMUTABLE(vec); return vec; }
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i) { if (!SCHEME_NP_CHAPERONEP(o)) { return SCHEME_VEC_ELS(o)[i]; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[3], *red, *orig; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" return chaperone_vector_ref_overflow(o, i); } #endif orig = scheme_chaperone_vector_ref(px->prev, i); if (SCHEME_VECTORP(px->redirects)) { /* chaperone was on property accessors */ return orig; } a[0] = px->prev; a[1] = scheme_make_integer(i); a[2] = orig; red = SCHEME_CAR(px->redirects); o = _scheme_apply(red, 3, a); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(o, orig)) scheme_wrong_chaperoned("vector-ref", "result", orig, o); return o; } }
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v) { while (1) { if (!SCHEME_NP_CHAPERONEP(o)) { SCHEME_VEC_ELS(o)[i] = v; return; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[3], *red; o = px->prev; a[0] = o; a[1] = scheme_make_integer(i); a[2] = v; red = SCHEME_CDR(px->redirects); v = _scheme_apply(red, 3, a); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(v, a[2])) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V", v, a[2]); } } }
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]) { if (SCHEME_NP_CHAPERONEP(argv[0])) return scheme_chaperone_vector_ref(argv[0], SCHEME_INT_VAL(argv[1])); else return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])]; }
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]) { Scheme_Object *vec = argv[0]; intptr_t n; if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec); n = SCHEME_VEC_SIZE(vec); return scheme_make_integer(n); }
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[]) { if (SCHEME_NP_CHAPERONEP(argv[0])) scheme_chaperone_vector_set(argv[0], SCHEME_INT_VAL(argv[1]), argv[2]); else SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2]; return scheme_void; }
static Scheme_Object * bad_index(char *name, const char *which, Scheme_Object *i, Scheme_Object *vec, int bottom) { scheme_bad_vec_index(name, i, which, vec, bottom, (SCHEME_NP_CHAPERONEP(vec) ? SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec)) : SCHEME_VEC_SIZE(vec))); return NULL; }
static Scheme_Object * vector_length (int argc, Scheme_Object *argv[]) { Scheme_Object *vec = argv[0]; if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec); if (!SCHEME_VECTORP(vec)) scheme_wrong_contract("vector-length", "vector?", 0, argc, argv); return scheme_make_integer(SCHEME_VEC_SIZE(vec)); }
Scheme_Object *scheme_chaperone_vector_ref2(Scheme_Object *o, int i, Scheme_Object *outermost) { if (!SCHEME_NP_CHAPERONEP(o)) { return SCHEME_VEC_ELS(o)[i]; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[4], *red, *orig; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" return chaperone_vector_ref_overflow(o, i); } #endif if(SCHEME_FALSEP(px->redirects)) { /* unsafe chaperones */ return scheme_chaperone_vector_ref2(px->val, i, outermost); } orig = scheme_chaperone_vector_ref2(px->prev, i, outermost); if (SCHEME_REDIRECTS_PROP_ONLY_VECTORP(px->redirects)) { /* chaperone was on property accessors */ /* or vector chaperone is property only */ return orig; } red = SCHEME_CAR(px->redirects); if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR) { a[0] = outermost; a[1] = px->prev; a[2] = scheme_make_integer(i); a[3] = orig; o = _scheme_apply(red, 4, a); } else { a[0] = px->prev; a[1] = scheme_make_integer(i); a[2] = orig; o = _scheme_apply(red, 3, a); } if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(o, orig)) scheme_wrong_chaperoned("vector-ref", "result", orig, o); return o; } }
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v) { Scheme_Object *outermost = o; while (1) { if (!SCHEME_NP_CHAPERONEP(o)) { SCHEME_VEC_ELS(o)[i] = v; return; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[4], *red; int chap_star = SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR ? 1 : 0; red = px->redirects; if (SCHEME_FALSEP(red)) { o = px->val; continue; } o = px->prev; if (!SCHEME_REDIRECTS_PROP_ONLY_VECTORP(red)) { /* not a property only chaperone */ red = SCHEME_CDR(px->redirects); if (chap_star) { a[0] = outermost; a[1] = o; a[2] = scheme_make_integer(i); a[3] = v; v = _scheme_apply(red, 4, a); } else { a[0] = o; a[1] = scheme_make_integer(i); a[2] = v; v = _scheme_apply(red, 3, a); } if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(v, a[2 + chap_star])) scheme_wrong_chaperoned("vector-set!", "value", a[2 + chap_star], v); } } } }
static Scheme_Object * vector_to_list (int argc, Scheme_Object *argv[]) { Scheme_Object *vec = argv[0]; if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec); if (!SCHEME_VECTORP(vec)) { scheme_wrong_contract("vector->list", "vector?", 0, argc, argv); return NULL; } if (!SAME_OBJ(vec, argv[0])) return chaperone_vector_to_list(argv[0]); else return scheme_vector_to_list(vec); }
Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *vec) { int len; Scheme_Object *a[3], *vec2; if (SCHEME_NP_CHAPERONEP(vec)) len = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec)); else len = SCHEME_VEC_SIZE(vec); vec2 = scheme_make_vector(len, NULL); a[0] = vec2; a[1] = scheme_make_integer(0); a[2] = vec; (void)vector_copy_bang(3, a); return vec2; }
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i) { if (!SCHEME_NP_CHAPERONEP(o)) { return SCHEME_VEC_ELS(o)[i]; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[3], *red, *orig; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" return chaperone_vector_ref_overflow(o, i); } #endif orig = scheme_chaperone_vector_ref(px->prev, i); if (SCHEME_VECTORP(px->redirects)) { /* chaperone was on property accessors */ return orig; } a[0] = px->prev; a[1] = scheme_make_integer(i); a[2] = orig; red = SCHEME_CAR(px->redirects); o = _scheme_apply(red, 3, a); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(o, orig)) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V", o, orig); return o; } }
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v) { while (1) { if (!SCHEME_NP_CHAPERONEP(o)) { SCHEME_VEC_ELS(o)[i] = v; return; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[3], *red; o = px->prev; a[0] = o; a[1] = scheme_make_integer(i); a[2] = v; red = SCHEME_CDR(px->redirects); v = _scheme_apply(red, 3, a); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(v, a[2])) scheme_wrong_chaperoned("vector-set!", "value", a[2], v); } } }
static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]) { Scheme_Thread *p; Scheme_Object *vec, **a, *plain_vec; intptr_t len, start, finish, i; vec = argv[0]; if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec); if (!SCHEME_VECTORP(vec)) scheme_wrong_contract("vector->values", "vector?", 0, argc, argv); len = SCHEME_VEC_SIZE(vec); if (argc > 1) start = scheme_extract_index("vector->values", 1, argc, argv, len + 1, 0); else start = 0; if (argc > 2) finish = scheme_extract_index("vector->values", 2, argc, argv, len + 1, 0); else finish = len; if (!(start <= len)) { bad_index("vector->values", "starting ", argv[1], argv[0], 0); } if (!(finish >= start && finish <= len)) { bad_index("vector->values", "ending ", argv[2], argv[0], start); } len = finish - start; if (len == 1) { if (!SAME_OBJ(vec, argv[0])) return scheme_chaperone_vector_ref(argv[0], start); else return SCHEME_VEC_ELS(vec)[start]; } if (!SAME_OBJ(vec, argv[0])) { plain_vec = scheme_make_vector(len, NULL); for (i = 0; i < len; i++) { vec = scheme_chaperone_vector_ref(argv[0], start + i); SCHEME_VEC_ELS(plain_vec)[i] = vec; } vec = plain_vec; start = 0; } p = scheme_current_thread; if (p->values_buffer && (p->values_buffer_size >= len)) a = p->values_buffer; else { a = MALLOC_N(Scheme_Object *, len); p->values_buffer = a; p->values_buffer_size = len; } p->ku.multiple.array = a; p->ku.multiple.count = len; for (i = 0; i < len; i++) { a[i] = SCHEME_VEC_ELS(vec)[start + i]; } return SCHEME_MULTIPLE_VALUES; }