Esempio n. 1
0
File: bool.c Progetto: SamB/racket
static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
{
  Scheme_Object *a[1], *v, *oprocs;

  a[0] = obj;
  v = _scheme_apply(SCHEME_CDR(procs), 1, a);
  
  if (SCHEME_FALSEP(v))
    return NULL;
  
  oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);  
  if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
    scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
                          "impersonator-of property procedure returned a value with a different prop:impersonator-of source",
                          "original value", 1, obj,
                          "returned value", 1, v,
                          NULL);

  procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
  oprocs = scheme_struct_type_property_ref(scheme_equal_property, v);  
  if (procs || oprocs)
    if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0], 
                                       SCHEME_VEC_ELS(procs)[0]))
      scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
                            "impersonator-of property procedure returned a value with a different prop:equal+hash source",
                            "original value", 1, obj,
                            "returned value", 1, v,
                            NULL);

  return v;
}
Esempio n. 2
0
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;
}
Esempio n. 3
0
static void check_always_fixnum(const char *name, Scheme_Object *o)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v < -1073741824) || (v > 1073741823)) {
      scheme_contract_error(name, 
                            "cannot fold to result that is not a fixnum on some platforms",
                            "result", 1, o,
                            NULL);
    }
  }
}
Esempio n. 4
0
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int pass_self, int unsafe, int argc, Scheme_Object **argv)
{
  Scheme_Chaperone *px;
  Scheme_Object *val = argv[0];
  Scheme_Object *redirects;
  Scheme_Object *props;

  if (SCHEME_CHAPERONEP(val)) {
    val = SCHEME_CHAPERONE_VAL(val);
  }

  if (!SCHEME_VECTORP(val)
      || (is_impersonator && !SCHEME_MUTABLEP(val)))
    scheme_wrong_contract(name, is_impersonator ? "(and/c vector? (not/c immutable?))" : "vector?", 0, argc, argv);

  if (unsafe) {
    /* We cannot dispatch the operations on an unsafe vector chaperone to a chaperoned vector because of the invariant
       that the val field of a vector chaperone must point to a non-chaperoned vector.
       To ensure this we error if the second argument passed to `unsafe-chaperone-vector` is not a unchaperoned vector */
    if (!SCHEME_VECTORP(argv[1])) {
      scheme_wrong_contract(name, "(and/c vector? (not/c impersonator?))", 1, argc, argv);
    }
    val = argv[1];
  }
  else {
    /* allow false for interposition procedures */
    scheme_check_proc_arity2(name, 3 + (pass_self ? 1 : 0), 1, argc, argv, 1);
    scheme_check_proc_arity2(name, 3 + (pass_self ? 1 : 0), 2, argc, argv, 1);

    /* but only allow `#f` if both are `#f` */
    if (SCHEME_FALSEP(argv[1]) != SCHEME_FALSEP(argv[2])) {
      scheme_contract_error(name,
                            "accessor and mutator wrapper must be both `#f` or neither `#f`",
                            "accessor wrapper", 1, argv[1],
                            "mutator wrapper", 1, argv[2],
                            NULL);
    }
  }

  props = scheme_parse_chaperone_props(name, unsafe ? 2 : 3, argc, argv);

  /*
     Regular vector chaperones store redirect procedures in a pair, (cons getter setter).
     Property only vector chaperones have no redirection procedures, and redirects is assigned an empty vector.
     Unsafe vector chaperones dispatch operations to another vector stored in a box in redirects.
   */
  if (SCHEME_FALSEP(argv[1])) {
    redirects = scheme_make_vector(0, NULL);
  }
  else if (unsafe) {
    redirects = scheme_false;
  }
  else {
    redirects = scheme_make_pair(argv[1], argv[2]);
  }

  px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
  px->iso.so.type = scheme_chaperone_type;
  px->props = props;
  px->val = val;
  px->prev = argv[0];
  px->redirects = redirects;

  if (is_impersonator)
    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;

  /* Use flag to tell if the chaperone is a chaperone* */
  if (pass_self) {
    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_VEC_CHAPERONE_STAR;
  }
  return (Scheme_Object *)px;
}