Exemple #1
0
static Scheme_Object *read_quote_syntax(Scheme_Object *obj)
{
  Scheme_Quote_Syntax *qs;
  Scheme_Object *a;
  int c, i, p;
  
  if (!SCHEME_PAIRP(obj)) return NULL;

  a = SCHEME_CAR(obj);
  c = SCHEME_INT_VAL(a);

  obj = SCHEME_CDR(obj);
  if (!SCHEME_PAIRP(obj)) return NULL;
  
  a = SCHEME_CAR(obj);
  i = SCHEME_INT_VAL(a);

  a = SCHEME_CDR(obj);
  p = SCHEME_INT_VAL(a);

  qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
  qs->so.type = scheme_quote_syntax_type;
  qs->depth = c;
  qs->position = i;
  qs->midpoint = p;  

  return (Scheme_Object *)qs;
}
Exemple #2
0
static Scheme_Object *read_letrec(Scheme_Object *obj)
{
  Scheme_Letrec *lr;
  int i, c;
  Scheme_Object **sa;

  lr = MALLOC_ONE_TAGGED(Scheme_Letrec);

  lr->so.type = scheme_letrec_type;

  if (!SCHEME_PAIRP(obj)) return NULL;
  c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
  obj = SCHEME_CDR(obj);

  if (!SCHEME_PAIRP(obj)) return NULL;
  lr->body = SCHEME_CAR(obj);
  obj = SCHEME_CDR(obj);

  sa = MALLOC_N(Scheme_Object*, c);
  lr->procs = sa;
  for (i = 0; i < c; i++) {
    if (!SCHEME_PAIRP(obj)) return NULL;
    lr->procs[i] = SCHEME_CAR(obj);
    obj = SCHEME_CDR(obj);
  }

  return (Scheme_Object *)lr;
}
Exemple #3
0
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;
}
Exemple #4
0
static Scheme_Object *read_top(Scheme_Object *obj)
{
  Scheme_Compilation_Top *top;

  top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
  top->so.type = scheme_compilation_top_type;
  if (!SCHEME_PAIRP(obj)) return NULL;
  top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
  obj = SCHEME_CDR(obj);
  if (!SCHEME_PAIRP(obj)) return NULL;
  top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj);
  top->code = SCHEME_CDR(obj);

  return (Scheme_Object *)top;
}
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]));
}
Exemple #6
0
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;
    }
}
Scheme_Object *
scheme_append (Scheme_Object *lst1, Scheme_Object *lst2)
{
  Scheme_Object *first, *last, *orig1, *v;

  orig1 = lst1;

  first = last = NULL;
  while (SCHEME_PAIRP(lst1)) {
    v = scheme_make_pair(SCHEME_CAR(lst1), scheme_null);
    if (!first)
      first = v;
    else
      SCHEME_CDR(last) = v;
    last = v;
    lst1 = SCHEME_CDR(lst1);

    SCHEME_USE_FUEL(1);
  }

  if (!SCHEME_NULLP(lst1))
    scheme_wrong_type("append", "proper list", -1, 0, &orig1);

  if (!last)
    return lst2;

  SCHEME_CDR(last) = lst2;

  return first;
}
Exemple #8
0
static Scheme_Object *read_let_void(Scheme_Object *obj)
{
  Scheme_Let_Void *lv;
 
  lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void));
  lv->iso.so.type = scheme_let_void_type;
  
  if (!SCHEME_PAIRP(obj)) return NULL;
  lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
  obj = SCHEME_CDR(obj);
  if (!SCHEME_PAIRP(obj)) return NULL;
  SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
  lv->body = SCHEME_CDR(obj);

  return (Scheme_Object *)lv;
}
Exemple #9
0
Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre)
{
  int len, i;
  Scheme_Object *loc;
  Scheme_Sequence *s;

  if (SCHEME_NULLP(clears))
    return expr;

  len = scheme_list_length(clears);

  s = scheme_malloc_sequence(len + 1);
  s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type);
  s->count = len + 1;
  s->array[pre ? len : 0] = expr;

  for (i = 0; i < len; i++) {
    loc = scheme_make_local(scheme_local_type,
                            SCHEME_INT_VAL(SCHEME_CAR(clears)),
                            SCHEME_LOCAL_CLEAR_ON_READ);
    s->array[i + (pre ? 0 : 1)] = loc;
    clears = SCHEME_CDR(clears);    
  }

  return (Scheme_Object *)s;
}
Exemple #10
0
inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
{
  Scheme_Object *pr, *prev = NULL, *next;
  GC_Weak_Box *wb;
  Mark2_Proc cust_box_mark = gc->mark_table[btc_redirect_cust_box];

  /* cust boxes is a list of weak boxes to cust boxes */

  pr = cur->cust_boxes;
  while (pr) {
    wb = (GC_Weak_Box *)SCHEME_CAR(pr);
    next = SCHEME_CDR(pr);
    if (wb->val) {
      cust_box_mark(wb->val, gc);
      prev = pr;
    } else {
      if (prev)
        SCHEME_CDR(prev) = next;
      else
        cur->cust_boxes = next;
      --cur->num_cust_boxes;
    }
    pr = next;
  }
  cur->checked_cust_boxes = cur->num_cust_boxes;
}
Exemple #11
0
static Scheme_Object *read_set_bang(Scheme_Object *obj)
{
  Scheme_Set_Bang *sb;

  sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
  sb->so.type = scheme_set_bang_type;

  if (!SCHEME_PAIRP(obj)) return NULL;
  sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj));

  obj = SCHEME_CDR(obj);
  if (!SCHEME_PAIRP(obj)) return NULL;

  sb->var = SCHEME_CAR(obj);
  sb->val = SCHEME_CDR(obj);

  return (Scheme_Object *)sb;
}
Exemple #12
0
static Scheme_Object *
set_car_prim (int argc, Scheme_Object *argv[])
{
  if (!SCHEME_MUTABLE_PAIRP(argv[0]))
    scheme_wrong_type("set-car!", "mutable-pair", 0, argc, argv);

  SCHEME_CAR (argv[0]) = argv[1];
  return scheme_void;
}
Exemple #13
0
static Scheme_Object *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info)
{
  Scheme_Object *l, *a;

  if (!info->pass) {
    int depth;
    depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]);

    for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
      a = SCHEME_CAR(l);
      info = scheme_new_sfs_info(depth);
      a = scheme_sfs(a, info, depth);
      SCHEME_CAR(l) = a;
    }
  }

  return data;
}
Exemple #14
0
static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit)
{
  Resolve_Prefix *rp, *orig_rp;
  Scheme_Object *naya, *rhs;
  
  rhs = SCHEME_VEC_ELS(expr)[0];
#ifdef MZ_USE_JIT
  if (jit) {
    if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type))
      naya = scheme_jit_expr(rhs);
    else {
      int changed = 0;
      Scheme_Object *a, *l = rhs;
      naya = scheme_null;
      while (!SCHEME_NULLP(l)) {
        a = scheme_jit_expr(SCHEME_CAR(l));
        if (!SAME_OBJ(a, SCHEME_CAR(l)))
          changed = 1;
        naya = scheme_make_pair(a, naya);
        l = SCHEME_CDR(l);
      }
      if (changed)
        naya = scheme_reverse(naya);
      else
        naya = rhs;
    }
  } else
#endif
    naya = rhs;

  orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
  rp = scheme_prefix_eval_clone(orig_rp);
  
  if (SAME_OBJ(naya, rhs)
      && SAME_OBJ(orig_rp, rp))
    return expr;
  else {
    expr = scheme_clone_vector(expr, 0, 1);
    SCHEME_VEC_ELS(expr)[0] = naya;
    SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
    return expr;
  }
}
Exemple #15
0
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
{
  Scheme_Object *cons;

  cons = scheme_alloc_object();
  cons->type = scheme_pair_type;
  SCHEME_CAR(cons) = car;
  SCHEME_CDR(cons) = cdr;
  return cons;
}
Exemple #16
0
static Scheme_Object *read_case_lambda(Scheme_Object *obj)
{
  Scheme_Object *s, *a;
  int count, i, all_closed = 1;
  Scheme_Case_Lambda *cl;

  if (!SCHEME_PAIRP(obj)) return NULL;
  s = SCHEME_CDR(obj);
  for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) {
    count++;
  }

  cl = (Scheme_Case_Lambda *)
    scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
			 + (count - 1) * sizeof(Scheme_Object *));

  cl->so.type = scheme_case_lambda_sequence_type;
  cl->count = count;
  cl->name = SCHEME_CAR(obj);
  if (SCHEME_NULLP(cl->name))
    cl->name = NULL;

  s = SCHEME_CDR(obj);
  for (i = 0; i < count; i++, s = SCHEME_CDR(s)) {
    a = SCHEME_CAR(s);
    cl->array[i] = a;
    if (!SCHEME_PROCP(a)) {
      if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type))
        return NULL;
      all_closed = 0;
    }
  }

  if (all_closed) {
    /* Empty closure: produce procedure value directly.
       (We assume that this was generated by a direct write of
        a case-lambda data record in print.c, and that it's not
	in a CASE_LAMBDA_EXPD syntax record.) */
    return scheme_case_lambda_execute((Scheme_Object *)cl);
  }

  return (Scheme_Object *)cl;
}
Exemple #17
0
Scheme_Object *scheme_make_immutable_pair(Scheme_Object *car, Scheme_Object *cdr)
{
  Scheme_Object *cons;

  cons = scheme_alloc_object();
  cons->type = scheme_pair_type;
  SCHEME_CAR(cons) = car;
  SCHEME_CDR(cons) = cdr;
  SCHEME_SET_PAIR_IMMUTABLE(cons);
  return cons;
}
Exemple #18
0
static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info)
{
  Scheme_Object *v;

  if (!info->pass)
    scheme_signal_error("internal error: wrong pass to get saved info");
  if (!SCHEME_PAIRP(info->saved))
    scheme_signal_error("internal error: no saved info");

  v = SCHEME_CAR(info->saved);
  info->saved = SCHEME_CDR(info->saved);
  return v;
}
Exemple #19
0
Scheme_Object *read_boxenv(Scheme_Object *o)
{
  Scheme_Object *data;

  if (!SCHEME_PAIRP(o)) return NULL;

  data = scheme_alloc_object();
  data->type = scheme_boxenv_type;
  SCHEME_PTR1_VAL(data) = SCHEME_CAR(o);
  SCHEME_PTR2_VAL(data) = SCHEME_CDR(o);
  
  return data;
}
Exemple #20
0
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;
  }
}
Exemple #21
0
static Scheme_Object *read_with_cont_mark(Scheme_Object *obj)
{
  Scheme_With_Continuation_Mark *wcm;

  if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj)))
    return NULL; /* bad .zo */

  wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
  wcm->so.type = scheme_with_cont_mark_type;
  wcm->key = SCHEME_CAR(obj);
  wcm->val = SCHEME_CADR(obj);
  wcm->body = SCHEME_CDR(SCHEME_CDR(obj));

  return (Scheme_Object *)wcm;
}
/* This function applies a thunk, returning the Scheme value if there's no exception, 
   otherwise returning NULL and setting *exn to the raised value (usually an exn 
   structure). */
Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
{
  Scheme_Object *v;

  init_exn_catching_apply();
  
  v = _scheme_apply(exn_catching_apply, 1, &f);
  /* v is a pair: (cons #t value) or (cons #f exn) */

  if (SCHEME_TRUEP(SCHEME_CAR(v)))
    return SCHEME_CDR(v);
  else {
    *exn = SCHEME_CDR(v);
    return NULL;
  }
}
Exemple #23
0
static Scheme_Object *
reverse_prim (int argc, Scheme_Object *argv[])
{
  Scheme_Object *lst, *last;

  last = scheme_null;
  lst = argv[0];
  while (!SCHEME_NULLP (lst)) {
    if (!SCHEME_PAIRP(lst))
      scheme_wrong_type("reverse", "proper list", 0, argc, argv);
    last = scheme_make_pair (SCHEME_CAR (lst), last);
    lst = SCHEME_CDR (lst);

    SCHEME_USE_FUEL(1);
  }
  return (last);
}
Exemple #24
0
Scheme_Object *
scheme_list_to_vector (Scheme_Object *list)
{
    intptr_t len, i;
    Scheme_Object *vec, *orig = list;

    len = scheme_proper_list_length(list);
    if (len < 0)
        scheme_wrong_contract("list->vector", "list?", -1, 0, &orig);

    vec = scheme_make_vector(len, NULL);
    for (i = 0; i < len; i++) {
        SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(list);
        list = SCHEME_CDR(list);
    }

    return vec;
}
Exemple #25
0
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;
  }
}
Exemple #26
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;
  }
}
Exemple #27
0
/**
 * Convert a Scheme list or vector to a GVariant that represents an array.
 */
static GVariant *
scheme_object_to_array (Scheme_Object *lv, gchar *type)
{
  Scheme_Object *sval;  // One element of the list/array
  GVariant *gval;       // The converted element
  GVariantBuilder *builder;

  // Special case: The empty list gives the empty array.
  if (SCHEME_NULLP (lv))
    {
      // Note: For individual objects, D-Bus type signatures are acceptable
      // as GVariant type strings.
      builder = g_variant_builder_new ((GVariantType *) type);
      if (builder == NULL)
        return NULL;
      return g_variant_builder_end (builder);
    } // if it's null

  // A list, or so we think.
  if (SCHEME_PAIRP (lv))
    {
      builder = g_variant_builder_new ((GVariantType *) type);
      if (builder == NULL)
        return NULL;
      // Follow the cons cells through the list
      while (SCHEME_PAIRP (lv))
        {
          sval = SCHEME_CAR (lv);
          gval = scheme_object_to_parameter (sval, type+1);
          if (gval == NULL)
            {
              g_variant_builder_unref (builder);
              return NULL;
            } // if (gval == NULL)
          g_variant_builder_add_value (builder, gval);
          lv = SCHEME_CDR (lv);
        } // while

      // We've reached the end.  Was it really a list?
      if (! SCHEME_NULLP (lv))
        {
          g_variant_builder_unref (builder);
          return NULL;
        } // If the list does not end in null, so it's not a list.

      // We've hit the null at the end of the list.
      return g_variant_builder_end (builder);
    } // if it's a list

  // A vector
  else if (SCHEME_VECTORP (lv))
    {
      int len = SCHEME_VEC_SIZE (lv);
      int i;

      LOG ("scheme_object_to_array: Handling a vector of length %d", len);

      builder = g_variant_builder_new (G_VARIANT_TYPE_ARRAY);
      if (builder == NULL)
        return NULL;

      for (i = 0; i < len; i++)
        {
          sval = SCHEME_VEC_ELS(lv)[i];
          gval = scheme_object_to_parameter (sval, type + 1);
          if (gval == NULL)
            {
              g_variant_builder_unref (builder);
              return NULL;
            } // if we could not convert the object
          g_variant_builder_add_value (builder, gval);
        } // for each index

      return g_variant_builder_end (builder);
    } // if it's a vector

  // Can only convert lists and vectors.
  else
    return NULL;
} // scheme_object_to_array
Exemple #28
0
void TpMzScheme::evalDesign(Design::Ptr d){

  DesignStore::Ptr ds = Game::getGame()->getDesignStore();
  
  if (scheme_setjmp(scheme_error_buf)) {
    Logger::getLogger()->warning("MzScheme Error");
  } else {
    Scheme_Object* temp;

    std::ostringstream formater;
   
    formater.str("");
    formater << "(define-values (struct:designType make-designType designType? designType-ref designType-set!)(make-design-type "
	     << ds->getMaxPropertyId() << "))";
    temp = scheme_eval_string(formater.str().c_str(), env);
    
    temp = scheme_eval_string("(define property-designType-set! (lambda (design id val) (designType-set! design (- id 1) val)))", env);

    std::set<uint32_t> propids = ds->getPropertyIds();
    for(std::set<uint32_t>::iterator propit = propids.begin();
	propit != propids.end(); ++propit){
      // for each property type
      Property::Ptr p = ds->getProperty(*propit);
      if(p){
	formater.str("");
	formater << "(define designType." << p->getName() 
		 << " (make-property-accessor designType-ref "
		 << p->getPropertyId() << " \"" << p->getName() 
		 << "\" ))";
	temp = scheme_eval_string(formater.str().c_str(), env);
	
      }
    }
    propids.clear();

        IdMap complist = d->getComponents();

    temp = scheme_eval_string("(define design (make-designType))", env);
    
    for(std::set<uint32_t>::iterator propit = propids.begin();
            propit != propids.end(); ++propit){
        formater.str("");
        formater << "(property-designType-set! design " 
                 << *propit << " 0.0)";
        temp = scheme_eval_string(formater.str().c_str(), env);
    }

        std::map<uint32_t, std::map<uint32_t, std::list<std::string> > > propranking;
        for(IdMap::iterator compit = complist.begin();
                compit != complist.end(); ++compit){
            Component::Ptr c = ds->getComponent(compit->first);
            std::map<uint32_t, std::string> pilist = c->getPropertyList();
            for(std::map<uint32_t, std::string>::iterator piit = pilist.begin();
                    piit != pilist.end(); ++piit){
                Property::Ptr p = ds->getProperty(piit->first);
                for(uint32_t i = 0; i < compit->second; i++){
                    propranking[p->getRank()][p->getPropertyId()].push_back(piit->second);
                }
      }

    }

    std::map<uint32_t, PropertyValue> propertyvalues;

    for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin();
	rpiit != propranking.end(); ++rpiit){
      std::map<uint32_t, std::list<std::string> > pilist = rpiit->second;
      std::set<PropertyValue> localvalues;
      for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin();
	  piit != pilist.end(); ++piit){
	PropertyValue propval(piit->first,0.0);
	std::list<double> listvals;
	std::list<std::string> lambdas = piit->second;
	for(std::list<std::string>::iterator itlamb = lambdas.begin();
	    itlamb != lambdas.end(); ++itlamb){
	  temp = scheme_eval_string((std::string("(") + (*itlamb) + " design)").c_str(), env);
	  if(!SCHEME_NUMBERP(temp)){
	    Logger::getLogger()->warning("MzScheme: Return not a number");
	  }else{
	    listvals.push_back(scheme_real_to_double(temp));
	  }
	}
	Property::Ptr p = ds->getProperty(piit->first);
	formater.str("");
	formater << "(" <<  p->getTpclDisplayFunction() << " design '(";
	for(std::list<double>::iterator itvals = listvals.begin();
	    itvals != listvals.end(); ++itvals){
	  formater << *itvals << " ";
	}
	formater << "))";
	temp = scheme_eval_string(formater.str().c_str(), env);
#ifdef HAVE_MZSCHEME20X
	if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
	if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
	  Logger::getLogger()->warning("MzScheme: Return not a pair, or the wrong time in the pair");
	}else{
	  propval.setValue(scheme_real_to_double(SCHEME_CAR(temp)));
#ifdef HAVE_MZSCHEME20X
	  propval.setDisplayString(std::string(SCHEME_STR_VAL(SCHEME_CDR(temp)))); 
#else
	  propval.setDisplayString(std::string((char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp)))); 
#endif
	  localvalues.insert(propval);
	}
      }
      for(std::set<PropertyValue>::iterator pvit = localvalues.begin();
	  pvit != localvalues.end(); ++pvit){
	PropertyValue pv = *pvit;
	formater.str("");
	formater << "(property-designType-set! design " 
		 << pv.getPropertyId() << " " << pv.getValue()
		 << ")";
	temp = scheme_eval_string(formater.str().c_str(), env);
	propertyvalues[pv.getPropertyId()] = pv;
      }
    }

    d->setPropertyValues(propertyvalues);

    // now check if the design is valid
    
    bool valid = true;
    std::string feedback = "";
        Logger::getLogger()->debug("About to process requirement functions");

        for(IdMap::iterator compit = complist.begin();
                compit != complist.end();
                ++compit){
            uint32_t curval = compit->first;
      
      //for each component in the design
      temp = scheme_eval_string((std::string("(") + ds->getComponent(curval)->getTpclRequirementsFunction() + " design)").c_str(), env);
#ifdef HAVE_MZSCHEME20X
      if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
      if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
	Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair");
      }else{
	valid &= SCHEME_TRUEP(SCHEME_CAR(temp));
#ifdef HAVE_MZSCHEME20X
	std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp));
#else
	std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp));
#endif
	if(strtemp.length() > 0)
	  feedback += strtemp + " ";
      }
    }

        for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin();
                rpiit != propranking.end(); ++rpiit){
            std::map<uint32_t, std::list<std::string> > pilist = rpiit->second;
            for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin();
                    piit != pilist.end(); ++piit){
                temp = scheme_eval_string((std::string("(") + ds->getProperty(piit->first)->getTpclRequirementsFunction() + " design)").c_str(), env);
#ifdef HAVE_MZSCHEME20X
                if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
                if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
                    Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair");
                }else{
                    valid &= SCHEME_TRUEP(SCHEME_CAR(temp));
#ifdef HAVE_MZSCHEME20X
                    std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp));
#else
                    std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp));
#endif
                    if(strtemp.length() > 0)
                        feedback += strtemp + " ";
                }
            }
        }

        propranking.clear();

    d->setValid(valid, feedback);
    

    Logger::getLogger()->debug("Eval'ed design");
    if(!valid){
        Logger::getLogger()->debug("Design %s is not valid, reason: %s", d->getName().c_str(), feedback.c_str());
    }
  }
  
}

TpMzScheme::TpMzScheme(){
    //scheme_set_stack_base(NULL, 1); /* required for OS X, only. WILL NOT WORK HERE */
    bool loaded = false;
  env = scheme_basic_env();
  if (scheme_setjmp(scheme_error_buf)) {
    Logger::getLogger()->warning("MzScheme warning: could not load local file, trying installed file");
  } else {
      scheme_eval_string("(load \"../modules/tpcl/mzscheme/designstruct.scm\")",env);
        loaded = true;
  }
    if(loaded == false){
        if (scheme_setjmp(scheme_error_buf)) {
            Logger::getLogger()->warning("MzScheme warning: could not load installed file");
        } else {
            scheme_eval_string("(load \"" DATADIR "/tpserver/tpscheme/mzscheme/designstruct.scm\")", env);
            loaded = true;
        }
    }
    if(loaded == false){
        Logger::getLogger()->error("MzScheme Error: failed to load designstruct.scm file");
        //throw exception?
    }
}
Exemple #29
0
void force_hash_worker(Scheme_Object *so, Scheme_Hash_Table *ht)
{
  if (SCHEME_INTP(so)) {
    return;
  }
  if (ht) {
    Scheme_Object *r; 
    if ((r = scheme_hash_get(ht, so))) {
      return;
    }
  }

  switch (so->type) {
    case scheme_true_type:
    case scheme_false_type:
    case scheme_null_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_symbol_type:
    case scheme_place_bi_channel_type:
    case scheme_flvector_type:
      break;
    case scheme_pair_type:
      {
        force_hash_worker(SCHEME_CAR(so), ht);
        force_hash_worker(SCHEME_CDR(so), ht);
      }
      break;
    case scheme_vector_type:
      {
        intptr_t i;
        intptr_t size = SCHEME_VEC_SIZE(so);
        for (i = 0; i <size ; i++) {
          force_hash_worker(SCHEME_VEC_ELS(so)[i], ht);
        }
      }
      break;
    case scheme_structure_type:
      {
        Scheme_Structure *st = (Scheme_Structure*)so;
        Scheme_Struct_Type *stype = st->stype;
        intptr_t i;
        intptr_t size = stype->num_slots;

        if (stype->prefab_key)
          force_hash_worker((Scheme_Object*)stype->prefab_key, ht);
        
        for (i = 0; i <size ; i++) {
          force_hash_worker((Scheme_Object*) st->slots[i], ht);
        }
      }
      break;
    case scheme_resolved_module_path_type:
    default:
      scheme_log_abort("cannot force hash");
      abort();
      break;
  }
  if (ht) {
    scheme_hash_set(ht, so, NULL);
  }
  return;
}
Exemple #30
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;
}