Beispiel #1
0
/**
 * Given some kind of Scheme string value, convert it to a C string
 * If scmval is not a string value, returns NULL.
 */
static char *
scheme_object_to_string (Scheme_Object *scmval)
{
  char *str = NULL;

  // Char strings are the normal Scheme strings.  They need to be 
  // converted to byte strings.
  if (SCHEME_CHAR_STRINGP (scmval))
    {
      scmval = scheme_char_string_to_byte_string_locale (scmval);
      str = SCHEME_BYTE_STR_VAL (scmval);
    } // if it's a char string

  // Byte strings are easy, but not the typical Scheme strings.
  else if (SCHEME_BYTE_STRINGP (scmval))
    {
      str = SCHEME_BYTE_STR_VAL (scmval);
    } // if it's a byte string

  // A design decision: We'll treat symbols as strings.  (It certainly
  // makes things easier for the client.)
  else if (SCHEME_SYMBOLP (scmval))
    {
      str = SCHEME_SYM_VAL (scmval);
    } // if it's a symbol

  // Everything else is not a string
  else
    {
      // Signal an error by setting the return value to NULL.
      str = NULL; 
    } // if it's not a string
  return str;
} // scheme_object_to_string
Beispiel #2
0
/**
 * Convert a Scheme_Object to a string.  Returns NULL if it fails.
 */
char *
tostring (Scheme_Object *obj)
{
  if (SCHEME_BYTE_STRINGP (obj))
    return SCHEME_BYTE_STR_VAL (obj);
  else if (SCHEME_CHAR_STRINGP (obj))
    return SCHEME_BYTE_STR_VAL (scheme_char_string_to_byte_string (obj));
  else
    return NULL;
} // tostring
Beispiel #3
0
/**
 * Convert a Scheme_Object to a string.  Returns NULL if it fails.
 */
char *
tostring (Scheme_Object *obj)
{
  if (SCHEME_BYTE_STRINGP (obj))
    return SCHEME_BYTE_STR_VAL (obj);
  else if (SCHEME_CHAR_STRINGP (obj))
    // (scheme_char_string_to_byte_string) to be able to convert it to byte string
    return SCHEME_BYTE_STR_VAL (scheme_char_string_to_byte_string (obj));
  else
    return NULL;
} // tostring
Beispiel #4
0
static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv)
{
  Scheme_Object *bs;

  if (!SCHEME_CHAR_STRINGP(argv[0]))
    scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv);

  bs = scheme_char_string_to_byte_string(argv[0]);
  
  return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs));
}
Beispiel #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
Beispiel #6
0
static Scheme_Object *fromull(int argc, Scheme_Object **argv)
{
  umzlonglong l;

  if (!SCHEME_BYTE_STRINGP(argv[0])
      || (SCHEME_BYTE_STRTAG_VAL(argv[0]) != sizeof(umzlonglong)))
    scheme_wrong_type("unsigned-long-long-bytes->integer", 
		      "byte string of mzlonglong size",
		      0, argc, argv);


  l = *(umzlonglong *)SCHEME_BYTE_STR_VAL(argv[0]);

  return scheme_make_integer_value_from_unsigned_long_long(l);
}
Beispiel #7
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
Beispiel #8
0
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;
  }
}
Beispiel #9
0
/**
 * Convert a Scheme object to a GVariant that will serve as one of
 * the parameters of a call go g_dbus_proxy_call_....  Returns NULL
 * if it is unable to do the conversion.
 */
static GVariant *
scheme_object_to_parameter (Scheme_Object *obj, gchar *type)
{
  gchar *str;           // A temporary string

  // Special case: Array of bytes
  if (g_strcmp0 (type, "ay") == 0) 
    {
      if (SCHEME_BYTE_STRINGP (obj))
        {
          return g_variant_new_fixed_array (G_VARIANT_TYPE_BYTE,
                                            SCHEME_BYTE_STR_VAL (obj),
                                            SCHEME_BYTE_STRLEN_VAL (obj),
                                            sizeof (guchar));
        } // if it's a byte string
    } // array of bytes

  // Handle normal cases
  switch (type[0])
    {
      // Arrays
      case 'a':
        return scheme_object_to_array (obj, type);

      // Doubles
      case 'd':
        if (SCHEME_DBLP (obj))
          return g_variant_new ("d", SCHEME_DBL_VAL (obj));
        else if (SCHEME_FLTP (obj))
          return g_variant_new ("d", (double) SCHEME_FLT_VAL (obj));
        else if (SCHEME_INTP (obj))
          return g_variant_new ("d", (double) SCHEME_INT_VAL (obj));
        else if (SCHEME_RATIONALP (obj))
          return g_variant_new ("d", (double) scheme_rational_to_double (obj));
        else
          return NULL;

      // 32 bit integers
      case 'i':
        if (SCHEME_INTP (obj))
          return g_variant_new ("i", (int) SCHEME_INT_VAL (obj));
        else if (SCHEME_DBLP (obj))
          return g_variant_new ("i", (int) SCHEME_DBL_VAL (obj));
        else if (SCHEME_FLTP (obj))
          return g_variant_new ("i", (int) SCHEME_FLT_VAL (obj));
        else if (SCHEME_RATIONALP (obj))
          return g_variant_new ("i", (int) scheme_rational_to_double (obj));
        else 
          return NULL;

      // Strings
      case 's':
        str = scheme_object_to_string (obj);
        if (str == NULL)
          return NULL;
        return g_variant_new ("s", str);

      // 32 bit unsigned integers
      case 'u':
        if (SCHEME_INTP (obj))
          return g_variant_new ("u", (unsigned int) SCHEME_INT_VAL (obj));
        else
          return NULL;

      // Everything else is currently unsupported
      default:
        return NULL;
    } // switch
} // scheme_object_to_parameter
Beispiel #10
0
static Scheme_Object *unsafe_bytes_ref (int argc, Scheme_Object *argv[])
{
    intptr_t v;
    v = (unsigned char)SCHEME_BYTE_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])];
    return scheme_make_integer(v);
}
Beispiel #11
0
static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[])
{
    SCHEME_BYTE_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])] = (char)SCHEME_INT_VAL(argv[2]);
    return scheme_void;
}
Beispiel #12
0
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht)
{
  Scheme_Object *new_so = so;
  if (SCHEME_INTP(so)) {
    return so;
  }
  if (ht) {
    Scheme_Object *r; 
    if ((r = scheme_hash_get(ht, so))) {
      return r;
    }
  }

  switch (so->type) {
    case scheme_true_type:
    case scheme_false_type:
    case scheme_null_type:
    case scheme_void_type:
    /* place_bi_channels are allocated in the master and can be passed along as is */
    case scheme_place_bi_channel_type:
      new_so = so;
      break;
    case scheme_place_type:
      new_so = ((Scheme_Place *) so)->channel;
      break;
    case scheme_char_type:
      new_so = scheme_make_char(SCHEME_CHAR_VAL(so));
      break;
    case scheme_rational_type:
      {
        Scheme_Object *n;
        Scheme_Object *d;
        n = scheme_rational_numerator(so);
        d = scheme_rational_denominator(so);
        n = scheme_places_deep_copy_worker(n, ht);
        d = scheme_places_deep_copy_worker(d, ht);
        new_so = scheme_make_rational(n, d);
      }
      break;
    case scheme_float_type:
      new_so = scheme_make_float(SCHEME_FLT_VAL(so));
      break;
    case scheme_double_type:
      new_so = scheme_make_double(SCHEME_DBL_VAL(so));
      break;
    case scheme_complex_type:
      {
        Scheme_Object *r;
        Scheme_Object *i;
        r = scheme_complex_real_part(so);
        i = scheme_complex_imaginary_part(so);
        r = scheme_places_deep_copy_worker(r, ht);
        i = scheme_places_deep_copy_worker(i, ht);
        new_so = scheme_make_complex(r, i);
      }
      break;
    case scheme_char_string_type:
      new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1);
      break;
    case scheme_byte_string_type:
      if (SHARED_ALLOCATEDP(so)) {
        new_so = so;
      }
      else {
        new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
      }
      break;
    case scheme_unix_path_type:
      new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
      break;
    case scheme_symbol_type:
      if (SCHEME_SYM_UNINTERNEDP(so)) {
        scheme_log_abort("cannot copy uninterned symbol");
        abort();
      } else {
        new_so = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(so), 0, SCHEME_SYM_LEN(so), 1);
        new_so->type = scheme_serialized_symbol_type;
      }
      break;
    case scheme_serialized_symbol_type:
        new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so));
      break;
    case scheme_pair_type:
      {
        Scheme_Object *car;
        Scheme_Object *cdr;
        Scheme_Object *pair;
        car = scheme_places_deep_copy_worker(SCHEME_CAR(so), ht);
        cdr = scheme_places_deep_copy_worker(SCHEME_CDR(so), ht);
        pair = scheme_make_pair(car, cdr);
        new_so = pair;
      }
      break;
    case scheme_vector_type:
      {
        Scheme_Object *vec;
        intptr_t i;
        intptr_t size = SCHEME_VEC_SIZE(so);
        vec = scheme_make_vector(size, 0);
        for (i = 0; i <size ; i++) {
          Scheme_Object *tmp;
          tmp = scheme_places_deep_copy_worker(SCHEME_VEC_ELS(so)[i], ht);
          SCHEME_VEC_ELS(vec)[i] = tmp;
        }
        SCHEME_SET_IMMUTABLE(vec);
        new_so = vec;
      }
      break;
    case scheme_fxvector_type:
      if (SHARED_ALLOCATEDP(so)) {
        new_so = so;
      }
      else {
        Scheme_Vector *vec;
        intptr_t i;
        intptr_t size = SCHEME_FXVEC_SIZE(so);
        vec = scheme_alloc_fxvector(size);

        for (i = 0; i < size; i++) {
          SCHEME_FXVEC_ELS(vec)[i] = SCHEME_FXVEC_ELS(so)[i];
        }
        new_so = (Scheme_Object *) vec;
      }
      break;
    case scheme_flvector_type:
      if (SHARED_ALLOCATEDP(so)) {
        new_so = so;
      }
      else {
        Scheme_Double_Vector *vec;
        intptr_t i;
        intptr_t size = SCHEME_FLVEC_SIZE(so);
        vec = scheme_alloc_flvector(size);

        for (i = 0; i < size; i++) {
          SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i];
        }
        new_so = (Scheme_Object *) vec;
      }
      break;
    case scheme_structure_type:
      {
        Scheme_Structure *st = (Scheme_Structure*)so;
        Scheme_Serialized_Structure *nst;
        Scheme_Struct_Type *stype = st->stype;
        Scheme_Struct_Type *ptype = stype->parent_types[stype->name_pos - 1];
        Scheme_Object *nprefab_key;
        intptr_t size = stype->num_slots;
        int local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0);
        int i = 0;

        if (!stype->prefab_key) {
          scheme_log_abort("cannot copy non prefab structure");
          abort();
        }
        {
          for (i = 0; i < local_slots; i++) {
            if (!stype->immutables || stype->immutables[i] != 1) {
              scheme_log_abort("cannot copy mutable prefab structure");
              abort();
            }
          }
        }
        nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht);
        nst = (Scheme_Serialized_Structure*) scheme_make_serialized_struct_instance(nprefab_key, size);
        for (i = 0; i <size ; i++) {
          Scheme_Object *tmp;
          tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht);
          nst->slots[i] = tmp;
        }
        new_so = (Scheme_Object*) nst;
      }
      break;

    case scheme_serialized_structure_type:
      {
        Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
        Scheme_Struct_Type *stype;
        Scheme_Structure *nst;
        intptr_t size;
        int i = 0;
      
        size = st->num_slots;
        stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size);
        nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype);
        for (i = 0; i <size ; i++) {
          Scheme_Object *tmp;
          tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht);
          nst->slots[i] = tmp;
        }
        new_so = (Scheme_Object*)nst;
      }
      break;

    case scheme_resolved_module_path_type:
    default:
      printf("places deep copy cannot copy object of type %hi at %p\n", so->type, so);
      scheme_log_abort("places deep copy cannot copy object");
      abort();
      break;
  }
  if (ht) {
    scheme_hash_set(ht, so, new_so);
  }
  return new_so;
}
Beispiel #13
0
Scheme_Object *scheme_places_deserialize_worker(Scheme_Object *so)
{
  Scheme_Object *new_so = so;
  if (SCHEME_INTP(so)) {
    return so;
  }
  switch (so->type) {
    case scheme_true_type:
    case scheme_false_type:
    case scheme_null_type:
    case scheme_void_type:
    /* place_bi_channels are allocated in the master and can be passed along as is */
    case scheme_place_bi_channel_type:
    case scheme_char_type:
    case scheme_rational_type:
    case scheme_float_type:
    case scheme_double_type:
    case scheme_complex_type:
    case scheme_char_string_type:
    case scheme_byte_string_type:
    case scheme_unix_path_type:
    case scheme_flvector_type:
    case scheme_fxvector_type:
        new_so = so;
      break;
    case scheme_symbol_type:
      scheme_log_abort("scheme_symbol_type: shouldn't be seen during deserialization step");
      break;
    case scheme_serialized_symbol_type:
        new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so));
      break;
    case scheme_pair_type:
      {
        Scheme_Object *tmp;
        tmp = scheme_places_deserialize_worker(SCHEME_CAR(so));
        SCHEME_CAR(so) = tmp;
        tmp = scheme_places_deserialize_worker(SCHEME_CDR(so));
        SCHEME_CDR(so) = tmp;
        new_so = so;
      }
      break;
    case scheme_vector_type:
      {
        intptr_t i;
        intptr_t size = SCHEME_VEC_SIZE(so);
        for (i = 0; i <size ; i++) {
          Scheme_Object *tmp;
          tmp = scheme_places_deserialize_worker(SCHEME_VEC_ELS(so)[i]);
          SCHEME_VEC_ELS(so)[i] = tmp;
        }
        new_so = so;
      }
      break;
    case scheme_structure_type:
      scheme_log_abort("scheme_structure_type: shouldn't be seen during deserialization step");
      break;
    case scheme_serialized_structure_type:
      {
        Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
        Scheme_Struct_Type *stype;
        Scheme_Structure *nst;
        intptr_t size;
        int i = 0;
      
        size = st->num_slots;
        stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size);
        nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype);
        for (i = 0; i <size ; i++) {
          Scheme_Object *tmp;
          tmp = scheme_places_deserialize_worker((Scheme_Object*) st->slots[i]);
          nst->slots[i] = tmp;
        }
        new_so = (Scheme_Object*)nst;
      }
      break;

    case scheme_resolved_module_path_type:
    default:
      scheme_log_abort("cannot deserialize object");
      abort();
      break;
  }
  return new_so;
}
Beispiel #14
0
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
  Scheme_Type t1, t2;
  int cmp;
  Scheme_Object *orig_obj1, *orig_obj2;

 top:
  orig_obj1 = obj1;
  orig_obj2 = obj2;

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

 top_after_next:
  cmp = is_fast_equal(obj1, obj2, eql->for_chaperone == 1);
  if (cmp > -1)
    return cmp;

  if (eql->for_chaperone 
      && SCHEME_CHAPERONEP(obj2)
      && scheme_is_noninterposing_chaperone(obj2)) {
    obj2 = ((Scheme_Chaperone *)obj2)->prev;
    goto top_after_next;
  }

  if (eql->for_chaperone 
      && SCHEME_CHAPERONEP(obj1)
      && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
          || (eql->for_chaperone > 1))) {
    /* `obj1` and `obj2` are not eq, otherwise is_fast_equal()
       would have returned true */
    if (SCHEME_CHAPERONEP(obj2)) {
      /* for immutable hashes, it's ok for the two objects to not be eq,
         as long as the interpositions are the same and the underlying
         values are `{impersonator,chaperone}-of?`: */
      if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val)
          && SCHEME_HASHTRP(((Scheme_Chaperone *)obj2)->val)
          /* eq redirects means redirects were propagated: */
          && SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects,
                      ((Scheme_Chaperone *)obj2)->redirects))
        obj2 = ((Scheme_Chaperone *)obj2)->prev;
    }
    obj1 = ((Scheme_Chaperone *)obj1)->prev;
    goto top_after_next;
  }

  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_after_next;
      } else if (t1 == scheme_hash_tree_indirection_type) {
        obj1 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj1);
        goto top_after_next;
      }
      if (SCHEME_CHAPERONEP(obj2)) {
        obj2 = ((Scheme_Chaperone *)obj2)->val;
        goto top_after_next;
      } else if (t2 == scheme_hash_tree_indirection_type) {
        obj2 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj2);
        goto top_after_next;
      }
    }
    return 0;
  } else {
    switch (t1) {
    case 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;
      }
    case 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;
      }
    case scheme_vector_type:
    case 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, orig_obj1, obj2, orig_obj2, eql);
      }
    case scheme_byte_string_type:
    case scheme_unix_path_type:
    case 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));
      }
    case 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)));
      }
    case 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;
      }
    case scheme_structure_type:
    case 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 = scheme_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 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
        }

        if (procs1 || procs2) {
          /* impersonator-of property trumps other forms of checking */
          if (procs1) { obj1 = procs1; orig_obj1 = obj1; }
          if (procs2) { obj2 = procs2; orig_obj2 = obj2; }
          goto top_after_next;
        } 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] = orig_obj1;
            a[1] = orig_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;
            if (scheme_struct_is_transparent(obj1))
              insp = NULL;
            else {
              insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
            }
            if (!insp || scheme_inspector_sees_part(obj1, insp, -2)) {
#       include "mzeqchk.inc"
              if (union_check(obj1, obj2, eql))
                return 1;
              return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
            } else
              return 0;
          }
        }
      }
    case 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;
        if (SAME_OBJ(obj1, orig_obj1))
          obj1 = SCHEME_BOX_VAL(obj1);
        else
          obj1 = scheme_unbox(orig_obj1);
        if (SAME_OBJ(obj2, orig_obj2))
          obj2 = SCHEME_BOX_VAL(obj2);
        else
          obj2 = scheme_unbox(orig_obj2);
        goto top;
      }
    case 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, orig_obj1, 
                                           (Scheme_Hash_Table *)obj2, orig_obj2,
                                           eql);
      }
    case scheme_hash_tree_type:
    case scheme_eq_hash_tree_type:
    case scheme_eqv_hash_tree_type:
    case scheme_hash_tree_indirection_type:
      {
#   include "mzeqchk.inc"
        if (union_check(obj1, obj2, eql))
          return 1;
        return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1,
                                          (Scheme_Hash_Tree *)obj2, orig_obj2,
                                          eql);
      } 
    case 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, orig_obj1,
                                             (Scheme_Bucket_Table *)obj2, orig_obj2,
                                             eql);
      }
    case scheme_wrap_chunk_type: {
      return vector_equal(obj1, obj1, obj2, obj2, eql);
    }
    case scheme_resolved_module_path_type:
      {
        obj1 = SCHEME_PTR_VAL(obj1);
        obj2 = SCHEME_PTR_VAL(obj2);
        goto top;
      }
    case scheme_module_index_type:
      {
        Scheme_Modidx *midx1, *midx2;
#   include "mzeqchk.inc"
        midx1 = (Scheme_Modidx *)obj1;
        midx2 = (Scheme_Modidx *)obj2;
        if (eql->eq_for_modidx
            && (SCHEME_FALSEP(midx1->path)
                || SCHEME_FALSEP(midx2->path)))
          return 0;
        else if (is_equal(midx1->path, midx2->path, eql)) {
          obj1 = midx1->base;
          obj2 = midx2->base;
          goto top;
        }
      }
    case scheme_scope_table_type:
      {
        Scheme_Scope_Table *mt1 = (Scheme_Scope_Table *)obj1;
        Scheme_Scope_Table *mt2 = (Scheme_Scope_Table *)obj2;
        if (!is_equal((Scheme_Object *)mt1->simple_scopes, (Scheme_Object *)mt2->simple_scopes, eql))
          return 0;
        obj1 = mt1->multi_scopes;
        obj2 = mt2->multi_scopes;
        goto top;
      }
    default:
      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_after_next;
      } 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;
      }
    }
  }
}
Beispiel #15
0
XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int for_chaperone)
{
  Scheme_Type t1, t2;
  int cmp;

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

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

  if (NOT_SAME_TYPE(t1, t2))
    return -1;

 switch (t1) {
 case 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;
   }
#ifdef MZ_LONG_DOUBLE
 case scheme_extflvector_type:
   {
     intptr_t l1, l2, i;
     l1 = SCHEME_EXTFLVEC_SIZE(obj1);
     l2 = SCHEME_EXTFLVEC_SIZE(obj2);
     if (l1 == l2) {
       for (i = 0; i < l1; i++) {
         if (!mz_long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
                                 SCHEME_EXTFLVEC_ELS(obj2)[i]))
           return 0;
       }
       return 1;
     }
     return 0;
   }
#endif
 case scheme_byte_string_type:
 case scheme_unix_path_type:
 case scheme_windows_path_type:
   {
     intptr_t l1, l2;
     if (for_chaperone) return -1;
     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));
   }
 case scheme_char_string_type:
   {
     intptr_t l1, l2;
     if (for_chaperone) return -1;
     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)));
   }
 case scheme_cpointer_type:
   {
     return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
             == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
   }
 case 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->link->recvch, bc2->link->recvch)
             && SAME_OBJ(bc1->link->sendch, bc2->link->sendch));
   }
 }

 return -1;
}