Beispiel #1
0
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;
}
Beispiel #2
0
static Scheme_Object *
scheme_append_bang (Scheme_Object *lst1, Scheme_Object *lst2)
{
  if (SCHEME_NULLP(lst1))
    return lst2;
  else {
    Scheme_Object *prev, *orig;

    orig = lst1;

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

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

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

    return orig;
  }
}
Beispiel #3
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;
}
Beispiel #4
0
static Scheme_Object *
list_p_prim (int argc, Scheme_Object *argv[])
{
  Scheme_Object *obj1, *obj2;

  obj1 = obj2 = argv[0];
  do {
    if (SCHEME_NULLP(obj1))
      return scheme_true;
    if (!SCHEME_PAIRP(obj1))
      return (scheme_false);

    obj1 = SCHEME_CDR (obj1);

    if (SCHEME_NULLP(obj1))
      return scheme_true;
    if (!SCHEME_PAIRP(obj1))
      return scheme_false;

    obj1 = SCHEME_CDR(obj1);

    obj2 = SCHEME_CDR(obj2);
  } while (NOT_SAME_OBJ(obj1, obj2));

  return scheme_false;
}
Beispiel #5
0
int
scheme_proper_list_length (Scheme_Object *list)
{
  int len;
  Scheme_Object *turtle;

  len = 0;
  turtle = list;
  while (SCHEME_PAIRP(list)) {
    len++;
    list = SCHEME_CDR(list);
    if (!SCHEME_PAIRP(list))
      break;
    len++;
    list = SCHEME_CDR(list);

    if (SAME_OBJ(turtle, list))
      break;

    turtle = SCHEME_CDR(turtle);
  }

  if (SCHEME_NULLP(list))
    return len;

  return -1;
}
Beispiel #6
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;
}
Beispiel #7
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;
}
Beispiel #8
0
static Scheme_Object *
reverse_bang_prim (int argc, Scheme_Object *argv[])
{
  Scheme_Object *lst, *prev, *next;

  prev = NULL;
  lst = argv[0];
  while (!SCHEME_NULLP(lst)) {
    if (!SCHEME_MUTABLE_PAIRP(lst))
      scheme_wrong_type("reverse!", "mutable proper list", 0, argc, argv);
    next = SCHEME_CDR(lst);
    if (prev)
      SCHEME_CDR(lst) = prev;
    else
      SCHEME_CDR(lst) = scheme_null;
    prev = lst;
    lst = next;

    SCHEME_USE_FUEL(1);
  }

  if (prev)
    return prev;
  else
    return scheme_null;
}
Beispiel #9
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;
}
Beispiel #10
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;
}
Beispiel #11
0
void scheme_make_list_immutable(Scheme_Object *l)
{
  for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
    if (SCHEME_MUTABLEP(l))
      SCHEME_SET_IMMUTABLE(l);
  }
}
Beispiel #12
0
/* 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;
  }
}
Beispiel #13
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;
}
Beispiel #14
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;
}
Beispiel #15
0
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]);
    }
  }
}
Beispiel #16
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;
}
Beispiel #17
0
static Scheme_Object *
cdr_prim (int argc, Scheme_Object *argv[])
{
  if (!SCHEME_PAIRP(argv[0]))
    scheme_wrong_type("cdr", "pair", 0, argc, argv);

  return (SCHEME_CDR (argv[0]));
}
Beispiel #18
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;
}
Beispiel #19
0
static Scheme_Object *
set_cdr_prim (int argc, Scheme_Object *argv[])
{
  if (!SCHEME_MUTABLE_PAIRP(argv[0]))
    scheme_wrong_type("set-cdr!", "mutable-pair", 0, argc, argv);

  SCHEME_CDR (argv[0]) = argv[1];
  return scheme_void;
}
Beispiel #20
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;
}
Beispiel #21
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;
}
Beispiel #22
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;
}
Beispiel #23
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;
}
Beispiel #24
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;
}
Beispiel #25
0
int
scheme_list_length (Scheme_Object *list)
{
  int len;

  len = 0;
  while (!SCHEME_NULLP(list)) {
    len++;
    if (SCHEME_PAIRP(list))
      list = SCHEME_CDR(list);
    else
      list = scheme_null;
  }

  return len;
}
Beispiel #26
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);
}
Beispiel #27
0
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);
      }
    }
  }
}
Beispiel #28
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;
}
Beispiel #29
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;
}
Beispiel #30
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;
  }
}