Пример #1
0
static Scheme_Object *write_set_bang(Scheme_Object *obj)
{
  Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj;
  return scheme_make_pair((sb->set_undef ? scheme_true : scheme_false),
                          scheme_make_pair(sb->var, 
                                           scheme_protect_quote(sb->val)));
}
Пример #2
0
Файл: sfs.c Проект: awest/racket
static void scheme_sfs_save(SFS_Info *info, Scheme_Object *v)
{
  if (info->pass)
    scheme_signal_error("internal error: wrong pass to save info");
  v = scheme_make_pair(v, info->saved);
  info->saved = v;
}
Пример #3
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;
}
Пример #4
0
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
    Scheme_Chaperone *px;
    Scheme_Object *val = argv[0];
    Scheme_Object *redirects;
    Scheme_Hash_Tree *props;

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

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

    props = scheme_parse_chaperone_props(name, 3, argc, argv);

    redirects = scheme_make_pair(argv[1], argv[2]);

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

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

    return (Scheme_Object *)px;
}
Пример #5
0
static Scheme_Object *
cons_prim (int argc, Scheme_Object *argv[])
{
  Scheme_Object *cons;

  cons = scheme_make_pair(argv[0], argv[1]);
  return (cons);
}
Пример #6
0
Scheme_Object *scheme_build_list(int size, Scheme_Object **argv)
{
  Scheme_Object *pair = scheme_null;
  int i;

  for (i = size; i--; ) {
    pair = scheme_make_pair(argv[i], pair);
  }

  return pair;
}
Пример #7
0
Scheme_Object *scheme_alloc_list(int size)
{
  Scheme_Object *pair = scheme_null;
  int i;

  for (i = size; i--; ) {
    pair = scheme_make_pair(scheme_false, pair);
  }

  return pair;
}
Пример #8
0
Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context)
  /* If lr is supplied as a letrec binding this closure, it may be used
     for JIT compilation. */
{
#ifdef MZ_USE_JIT
  Scheme_Lambda *data = (Scheme_Lambda *)code, *data2;

  /* We need to cache clones to support multiple references
     to a zero-sized closure in bytecode. We need either a clone
     or native code, and context determines which field is relevant,
     so we put the two possibilities in a union `u'. */

  if (!context)
    data2 = data->u.jit_clone;
  else
    data2 = NULL;

  if (!data2) {
    Scheme_Native_Lambda *ndata;
    
    data2 = MALLOC_ONE_TAGGED(Scheme_Lambda);
    memcpy(data2, code, sizeof(Scheme_Lambda));

    data2->context = context;

    ndata = scheme_generate_lambda(data2, 1, NULL);
    data2->u.native_code = ndata;

    if (current_linklet_native_lambdas)
      current_linklet_native_lambdas = scheme_make_pair((Scheme_Object *)ndata,
                                                        current_linklet_native_lambdas);

    if (!context)
      data->u.jit_clone = data2;

    if (current_linklet_native_lambdas) {
      /* Force jitprep on body, too, to discover all lambdas */
      Scheme_Object *body;
      body = jit_expr(data2->body);
      data2->body = body;
    }
  }

  /* If it's zero-sized, then create closure now */
  if (!data2->closure_size)
    return scheme_make_native_closure(data2->u.native_code);

  return (Scheme_Object *)data2;
#endif

  return code;
}
Пример #9
0
Scheme_Object *
scheme_vector_to_list (Scheme_Object *vec)
{
  int i;
  Scheme_Object *pair = scheme_null;

  i = SCHEME_VEC_SIZE(vec);

  if (i < 0xFFF) {
    for (; i--; ) {
      pair = scheme_make_pair(SCHEME_VEC_ELS(vec)[i], pair);
    }
  } else {
    for (; i--; ) {
      if (!(i & 0xFFF))
	SCHEME_USE_FUEL(0xFFF);
      pair = scheme_make_pair(SCHEME_VEC_ELS(vec)[i], pair);
    }
  }

  return pair;
}
Пример #10
0
/**
 * Convert an array of Scheme objects into a list of the same objects.
 */
Scheme_Object *
make_object_list (int n, Scheme_Object *values[])
{
  Scheme_Object *result;  // The result we're building
  int i;                  // Everyone's favorite counter variable
  result = scheme_null;
  // Step through the objects from right to left, adding each to the front
  // of the list.
  for (i = n-1; i >= 0; i--)
    {
      result = scheme_make_pair (values[i], result);
    } // for
  // And we're done.
  return result;
} // make_object_list
Пример #11
0
/**
 *For Server : Convert an array of Scheme objects into a list of the same objects for SchemeObject to Gvariant
<<<<<<< HEAD
 * 
=======
 *We have not used this recursive helper function. We did it iteratively below.
>>>>>>> 3cb492700f6fe2265add3da53ebfb79622e240de
 */
Scheme_Object *
g_variant_tuple_to_scheme_list (GVariant *tuple, int index, int size)
{
  // Base case: We reached the end of the tuple
  if (index == size)
    return scheme_null; // Or whatever the empty list value is
  else
    {
      Scheme_Object *car;
      Scheme_Object *cdr;

      car = gvariant_to_schemeobj (g_variant_get_child_value (tuple, index));
      cdr = g_variant_tuple_to_scheme_list (tuple, index+1, size);
      return scheme_make_pair (car, cdr); 
    } // if we're still in the tuple
} // g_variant_tuple_to_scheme_list
Пример #12
0
Scheme_Object *
scheme_named_map_1(char *name, Scheme_Object *(*fun)(Scheme_Object*, Scheme_Object*),
		   Scheme_Object *lst, Scheme_Object *form)
{
  if (SCHEME_STX_NULLP(lst))
      return (scheme_null);
  else if (SCHEME_STX_PAIRP(lst)) {
    Scheme_Object *v;
    v = SCHEME_STX_CAR(lst);
    v = fun(v, form);
    lst = SCHEME_STX_CDR(lst);
    return scheme_make_pair(v, scheme_named_map_1(name, fun, lst, form));
  } else {
    scheme_wrong_syntax(name, lst, form, "bad syntax (" IMPROPER_LIST_FORM ")");
    return scheme_void;
  }
}
Пример #13
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);
}
Пример #14
0
static Scheme_Object *
list_exec (int argc, Scheme_Object *argv[], int star)
{
  int i;
  Scheme_Object *l;

  if (star) {
    --argc;
    l = argv[argc];
  } else
    l = scheme_null;

  for (i = argc ; i--; ) {
    l = scheme_make_pair(argv[i], l);
  }

  return l;
}
Пример #15
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;
  }
}
Пример #16
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info)
{
  Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
  Scheme_Object *body, *rhs, *clears = scheme_null;
  int i, pos;

  scheme_sfs_start_sequence(info, 2, 1);

  rhs = scheme_sfs_expr(lv->value, info, -1);

  if (!info->pass
      || (info->ip < info->max_nontail)) {
    for (i = 0; i < lv->count; i++) {
      pos = lv->position + i;
      if (!info->pass)
        scheme_sfs_used(info, pos);
      else {
        int spos;
        spos = pos + info->stackpos;
        if ((info->max_used[spos] == info->ip)
            && (info->max_calls[spos] > info->ip)) {
          /* No one is using the id after we set it.
             We still need to set it, in case it's boxed and shared,
             but then remove the binding or box. */
          clears = scheme_make_pair(scheme_make_integer(pos),
                                    clears);
        }
      }
    }
  }

  body = scheme_sfs_expr(lv->body, info, -1);

  body = scheme_sfs_add_clears(body, clears, 1);

  lv->value = rhs;
  lv->body = body;
  
  return o;
}
Пример #17
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *
case_lambda_sfs(Scheme_Object *expr, SFS_Info *info)
{
  Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
  Scheme_Object *le, *clears = scheme_null;
  int i;

  scheme_sfs_start_sequence(info, seq->count, 0);

  for (i = 0; i < seq->count; i++) {
    le = seq->array[i];
    le = scheme_sfs_expr(le, info, -1);
    if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) {
      /* Some clearing actions were added to the closure.
         Lift them out. */
      int j;
      Scheme_Sequence *cseq = (Scheme_Sequence *)le;
      if (!cseq->count)
        scheme_signal_error("internal error: empty sequence");
      for (j = 1; j < cseq->count; j++) {
        int pos;
        pos = SCHEME_LOCAL_POS(cseq->array[j]);
        clears = scheme_make_pair(scheme_make_integer(pos), clears);
      }
      le = cseq->array[0];
    }
    if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type)
        && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) {
      scheme_signal_error("internal error: not a lambda for case-lambda: %d",
                          SCHEME_TYPE(le));
    }
    seq->array[i] = le;
  }

  if (!SCHEME_NULLP(clears)) {
    return scheme_sfs_add_clears(expr, clears, 0);
  } else
    return expr;
}
Пример #18
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info)
{
  Scheme_Letrec *lr = (Scheme_Letrec *)o;
  Scheme_Object **procs, *v, *clears = scheme_null;
  int i, count;

  count = lr->count;

  scheme_sfs_start_sequence(info, count + 1, 1);

  procs = lr->procs;

  for (i = 0; i < count; i++) { 
    v = scheme_sfs_expr(procs[i], info, i);

    if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) {
      /* Some clearing actions were added to the closure.
         Lift them out. */
      int j;
      Scheme_Sequence *cseq = (Scheme_Sequence *)v;
      for (j = 1; j < cseq->count; j++) {
        int pos;
        pos = SCHEME_LOCAL_POS(cseq->array[j]);
        clears = scheme_make_pair(scheme_make_integer(pos), clears);
      }
      v = cseq->array[0];
    }
    procs[i] = v;
  }

  v = scheme_sfs_expr(lr->body, info, -1);

  v = scheme_sfs_add_clears(v, clears, 1);

  lr->body = v;

  return o;
}
Пример #19
0
/**
 * Get all of the methods from a louDBus Proxy.
 */
Scheme_Object *
loudbus_methods (int argc, Scheme_Object **argv)
{
  Scheme_Object *result = NULL; // The result we're building
  Scheme_Object *val = NULL;    // One method in the result
  GDBusMethodInfo *method;      // Information on one method
  LouDBusProxy *proxy;            // The proxy
  int m;                        // Counter variable for methods

  MZ_GC_DECL_REG (2);
  MZ_GC_VAR_IN_REG (0, result);
  MZ_GC_VAR_IN_REG (1, val);

  // Get the proxy
  proxy = scheme_object_to_proxy (argv[0]);
  if (proxy == NULL)
    {
      scheme_wrong_type ("loudbus-methods", "LouDBusProxy *", 0, argc, argv);
    } // if proxy == NULL

  MZ_GC_REG ();

  // Build the list.  
  result = scheme_null;
  for (m = g_dbus_interface_info_num_methods (proxy->iinfo) - 1; m >= 0; m--)
    {
      method = proxy->iinfo->methods[m];
      val = scheme_make_locale_string (method->name);
      result = scheme_make_pair (val, result);
    } // for each method

  MZ_GC_UNREG ();

  // And we're done.
  return result;
} // loudbus_methods
Пример #20
0
/**
 * Convert a GVariant to a Scheme object.  Returns NULL if there's a
 * problem.
 */
static Scheme_Object *
g_variant_to_scheme_object (GVariant *gv)
{
  const GVariantType *type;     // The type of the GVariant
  const gchar *typestring;      // A string that describes the type
  int i;                        // A counter variable
  int len;                      // Length of arrays and tuples
  Scheme_Object *lst = NULL;    // A list that we build as a result
  Scheme_Object *sval = NULL;   // One value
  Scheme_Object *result = NULL; // One result to return.

  // Special case: We'll treat NULL as void.
  if (gv == NULL)
    {
      return scheme_void;
    } // if (gv == NULL)

  // Get the type
  type = g_variant_get_type (gv);
  typestring = g_variant_get_type_string (gv);

  // ** Handle most of the basic types **

  // Integer
  if (g_variant_type_equal (type, G_VARIANT_TYPE_INT32))
    {
      // We don't refer to any Scheme objects across allocating calls,
      // so no need for GC code.
      int i;
      i = g_variant_get_int32 (gv);
      result = scheme_make_integer (i);
      return result;
    } // if it's an integer

  // Double
  if (g_variant_type_equal (type, G_VARIANT_TYPE_DOUBLE))
    {
      double d;
      d = g_variant_get_double (gv);
      result = scheme_make_double (d);
      return result;
    } // if it's a double

  // String
  if (g_variant_type_equal (type, G_VARIANT_TYPE_STRING))
    {
      // We don't refer to any Scheme objects across allocating calls,
      // so no need for GC code.
      const gchar *str;
      str = g_variant_get_string (gv, NULL);
      result = scheme_make_locale_string (str);
      return result;
    } // if it's a string

  // ** Handle some special cases **

  // We treat arrays of bytes as bytestrings
  if (g_strcmp0 (typestring, "ay") == 0)
    {
      gsize size;
      guchar *data;
      data = (guchar *) g_variant_get_fixed_array (gv, &size, sizeof (guchar));
      return scheme_make_sized_byte_string ((char *) data, size, 1);
    } // if it's an array of bytes

  // ** Handle the compound types ** 

  // Tuple or Array
  if ( (g_variant_type_is_tuple (type))
       || (g_variant_type_is_array (type)) )
    {
      // Find out how many values to put into the list.
      len = g_variant_n_children (gv);

      // Here, we are referring to stuff across allocating calls, so we
      // need to be careful.
      MZ_GC_DECL_REG (2);
      MZ_GC_VAR_IN_REG (0, lst);
      MZ_GC_VAR_IN_REG (1, sval);
      MZ_GC_REG ();
     
      // Start with the empty list.
      lst = scheme_null;

      // Step through the items, right to left, adding them to the list.
      for (i = len-1; i >= 0; i--)
        {
          sval = g_variant_to_scheme_object (g_variant_get_child_value (gv, i));
          lst = scheme_make_pair (sval, lst);
        } // for

          // Okay, we've made it through the list, now we can clean up.
      MZ_GC_UNREG ();
      if ((g_variant_type_is_array (type)))
        {
          //If type is array, convert to vector
          scheme_list_to_vector ((char*)lst);
        }//If array
      // And we're done.
      return lst;


    } // if it's a tuple or an array

  // Unknown.  Give up.
  scheme_signal_error ("Unknown type %s", typestring);
  return scheme_void;
} // g_variant_to_scheme_object
Пример #21
0
/**
 * Get information on one method (annotations, parameters, return
 * values, etc).
 *
 * TODO:
 *   1. Add missing documentation (see ????)
 *   2. Check to make sure that the second parameter is a string.  (Also
 *      do other error checking.  See below.)
 *   3. Make sure that you get annotations for parameters and return
 *      values (if they exist).
 *   4. Add tags for the other parts of the record (if they aren't
 *      there already).  For example, something like
 *      '((name gimp_image_new)
 *        (annotations "...")
 *        (inputs (width integer "width of image"))
 *        (outputs (image integer "id of created image")))
 *      If you'd prefer, input and output could also have their own
 *      tags.
 *        (inputs ((name width) (type integer) (annotations "width of image")))
 *   5. Add a function to louDBus/unsafe that pretty prints this.  
 *      (If you'd prefer, you can add it to this file.  But you can't
 *      use printf to pretty print.)
 *   6. Add information for the garbage collector.  (Yup, you'll need to
 *      read really bad documentation on this.  But try.)
 */
static Scheme_Object *
loudbus_method_info (int argc, Scheme_Object **argv)
{
  Scheme_Object *val, *val2;            // ????
  Scheme_Object *result = NULL;         // The result we're building
  Scheme_Object *arglist = NULL;        // The list of arguments
  Scheme_Object *outarglist = NULL;     // The list of return values
  Scheme_Object *annolist = NULL;       // The list of annotations   
  Scheme_Object *name = NULL;           // The method's name
  Scheme_Object *parampair = NULL;      // ????
  Scheme_Object *outparampair = NULL;   // ????
  GDBusMethodInfo *method;              // Information on one method
  GDBusAnnotationInfo *anno;            // Information on the annotations
  GDBusArgInfo *args, *outargs;         // Information on the arguments
  LouDBusProxy *proxy;                  // The proxy
  gchar *methodName;                    // The method name
  int m;                                // Counter variable for methods

  // Get the proxy
  proxy = scheme_object_to_proxy (argv[0]);
  if (proxy == NULL)
    {
      scheme_wrong_type ("loudbus-methods", "LouDBusProxy *", 0, argc, argv);
    } // if proxy == NULL

  //Get the method name.  WHAT IF WE CAN'T CONVERT TO A STRING????
  methodName = scheme_object_to_string (argv[1]);

  // Permit the use of dashes in method names by converting them back
  // to underscores (which is what we use over DBus).
  score_it_all (methodName);

  //Get the method struct.  WHAT IF THE METHOD DOESN'T EXIST????
  method = g_dbus_interface_info_lookup_method (proxy->iinfo, methodName);

  // Build the list for arguments.
  arglist = scheme_null;
  for (m = parray_len ((gpointer *) method->in_args) - 1; m >= 0; m--)
    {
      args = method->in_args[m]; //Go through the arguments.
      val = scheme_make_symbol (args->name);
      val2 = scheme_make_symbol (args->signature);
      parampair = scheme_make_pair (val, val2);
      arglist = scheme_make_pair (parampair, arglist);
    } // for each argument
 
  //Build list for output.
  outarglist = scheme_null;
  for (m = parray_len ((gpointer *) method->out_args) - 1; m >= 0; m--)
    {
      outargs = method->out_args[m];
      val = scheme_make_symbol (outargs->name);
      val2 = scheme_make_symbol (outargs->signature);
      outparampair = scheme_make_pair (val, val2);
      outarglist =  scheme_make_pair (outparampair, outarglist);
    } // for each output formals

  // Build list of annotations
  annolist = scheme_null;
  for (m = parray_len ((gpointer *) method->annotations) - 1; m >= 0; m--)
    {
      anno = method->annotations[m]; //Go through the annotations.
      val = scheme_make_locale_string (anno->value);
      annolist = scheme_make_pair (val, annolist);
    } // for each annotation

  // Create the name entry
  name = scheme_null;
  name = scheme_make_pair (scheme_make_symbol(methodName), name);
  name = scheme_make_pair (scheme_make_symbol("name"), name);

  result = scheme_null;
  result = scheme_make_pair (annolist, result);
  result = scheme_make_pair (outarglist, result);
  result = scheme_make_pair (arglist, result);
  result = scheme_make_pair (name, result);

  // And we're done.
  return result;
} // loudbus_method_info
Пример #22
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;
}
Пример #23
0
/**
 * Convert a GVariant to a Scheme object.  Returns NULL if there's a
 * problem.
 */
static Scheme_Object *
g_variant_to_scheme_object (GVariant *gv)
{
  const GVariantType *type;     // The type of the GVariant
  int i;                        // A counter variable
  int len;                      // Length of arrays and tuples
  Scheme_Object *lst = NULL;    // A list that we build as a result
  Scheme_Object *sval = NULL;   // One value
  Scheme_Object *result = NULL; // One result to return.

  // Special case: We'll treat NULL as void.
  if (gv == NULL)
    {
      return scheme_void;
    } // if (gv == NULL)

  // Get the type
  type = g_variant_get_type (gv);

  // ** Handle most of the basic types **

  // Integer
  if (g_variant_type_equal (type, G_VARIANT_TYPE_INT32))
    {
      // We don't refer to any Scheme objects across allocating calls,
      // so no need for GC code.
      int i;
      i = g_variant_get_int32 (gv);
      result = scheme_make_integer (i);
      return result;
    } // if it's an integer

  // String
  if (g_variant_type_equal (type, G_VARIANT_TYPE_STRING))
    {
      // We don't refer to any Scheme objects across allocating calls,
      // so no need for GC code.
      const gchar *str;
      str = g_variant_get_string (gv, NULL);
      result = scheme_make_locale_string (str);
      return result;
    } // if it's a string

  // ** Handle the compound types ** 

  // Tuple or Array
  if ( (g_variant_type_is_tuple (type))
       || (g_variant_type_is_array (type)) )
    {
      // Find out how many values to put into the list.
      len = g_variant_n_children (gv);

      // Here, we are referring to stuff across allocating calls, so we
      // need to be careful.
      MZ_GC_DECL_REG (2);
      MZ_GC_VAR_IN_REG (0, lst);
      MZ_GC_VAR_IN_REG (1, sval);
      MZ_GC_REG ();
      
      // Start with the empty list.
      lst = scheme_null;

      // Step through the items, right to left, adding them to the list.
      for (i = len-1; i >= 0; i--)
        {
          sval = g_variant_to_scheme_object (g_variant_get_child_value (gv, i));
          lst = scheme_make_pair (sval, lst);
        } // for

      // Okay, we've made it through the list, now we can clean up.
      MZ_GC_UNREG ();

      // And we're done.
      return lst;
    } // if it's a tuple or an array

  // Unknown.  Give up.
  return NULL;
} // g_variant_to_scheme_object
Пример #24
0
Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr)
{
#ifdef MZ_USE_JIT
  Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr;

  if (!seqin->native_code) {
    Scheme_Case_Lambda *seqout;
    Scheme_Native_Lambda *ndata;
    Scheme_Object *val, *name;
    int i, cnt, size, all_closed = 1;

    cnt = seqin->count;
    
    size = sizeof(Scheme_Case_Lambda) + ((cnt - mzFLEX_DELTA) * sizeof(Scheme_Object *));

    seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size);
    memcpy(seqout, seqin, size);

    name = seqin->name;
    if (name && SCHEME_BOXP(name))
      name = SCHEME_BOX_VAL(name);

    for (i = 0; i < cnt; i++) {
      val = seqout->array[i];
      if (SCHEME_PROCP(val)) {
	/* Undo creation of empty closure */
	val = (Scheme_Object *)((Scheme_Closure *)val)->code;
	seqout->array[i] = val;
      }
      ((Scheme_Lambda *)val)->name = name;
      if (((Scheme_Lambda *)val)->closure_size)
	all_closed = 0;
    }

    /* Generating the code may cause empty closures to be formed: */
    ndata = scheme_generate_case_lambda(seqout);
    seqout->native_code = ndata;

    if (current_linklet_native_lambdas) {
      for (i = 0; i < cnt; i++) {
        val = seqout->array[i];
        {
          /* Force jitprep on body, too, to discover all lambdas */
          Scheme_Object *body;
          body = jit_expr(((Scheme_Lambda *)val)->body);
          ((Scheme_Lambda *)val)->body = body;
        }
        val = (Scheme_Object *)((Scheme_Lambda *)val)->u.native_code;
        current_linklet_native_lambdas = scheme_make_pair(val, current_linklet_native_lambdas);
      }
    }

    if (all_closed) {
      /* Native closures do not refer back to the original bytecode,
	 so no need to worry about clearing the reference. */
      Scheme_Native_Closure *nc;
      nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);
      for (i = 0; i < cnt; i++) {
	val = seqout->array[i];
	if (!SCHEME_PROCP(val)) {
	  val = scheme_make_native_closure(((Scheme_Lambda *)val)->u.native_code);
	}
	nc->vals[i] = val;
      }
      return (Scheme_Object *)nc;
    } else {
      /* The case-lambda data must point to the original closure-data
	 record, because that's where the closure maps are kept. But
	 we don't need the bytecode, anymore. So clone the
	 closure-data record and drop the bytecode in thte clone. */
      for (i = 0; i < cnt; i++) {
	val = seqout->array[i];
	if (!SCHEME_PROCP(val)) {
	  Scheme_Lambda *data;
	  data = MALLOC_ONE_TAGGED(Scheme_Lambda);
	  memcpy(data, val, sizeof(Scheme_Lambda));
	  data->body = NULL;
	  seqout->array[i] = (Scheme_Object *)data;
	}
      }
    }

    return (Scheme_Object *)seqout;
  }
#endif
 
  return expr;
}
Пример #25
0
/**
 *Translating the gvariant to Scheme Object
 */
Scheme_Object *
gvariant_to_schemeobj (GVariant *ivalue)
{
  gint32 i;
  GVariant *temp;
  const gchar *fstring;
  gsize length = 0;
  gsize size = 0;
  gint32 r1 = 0;
  gdouble r2 = 0;
  Scheme_Object *fint;
  Scheme_Object *fstringss;
  Scheme_Object *fdouble;
  Scheme_Object *sflist = NULL;
  gchar *tmp;

  //scheme_signal_error ("Not tuple yet");

  tmp = g_variant_print (ivalue, FALSE);
  fprintf (stderr, "gvariant_to_schemobj(%s)\n", tmp);
  g_free (tmp);
  
  size = g_variant_get_size (ivalue);
  //  fprintf (stderr, "Exploring the return value.\n");
  /* if (ivalue == NULL)
    {
      fprintf (stderr, "Return value is <NULL>\n");
    } // if (ivalue == NULL)
  else // if (ivalue != NULL)
    {
      type = g_variant_get_type (ivalue);
      typestring = g_variant_type_dup_string (type);
      fprintf (stderr, "Got type %s\n", typestring);
      g_free (typestring);
      description = g_variant_print (ivalue, TRUE);
      fprintf (stderr, "Got value %s\n", description);
      g_free (description);
      } // if (ivalue != NULL)*/
    
  if (ivalue == NULL)
    {
      return scheme_void;
    }
  
  if (g_variant_is_of_type  (ivalue, G_VARIANT_TYPE_INT32))
    {
      r1 = g_variant_get_int32 (ivalue);
      fint = scheme_make_integer_value(r1); 
      return fint;
    }// else if
  else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_STRING))
    {
      fprintf ( stderr, "Type_string\n");
     
      // scheme_signal_error ("%d", size);
      fstring  = g_variant_get_string(ivalue, &size);
      fstringss = scheme_make_locale_string(fstring);
      return fstringss;
    }// else if
  else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_BYTESTRING))
    {
      fprintf (stderr, "Bytestring\n");
      scheme_signal_error("stringbyeerror");
      fstring = g_variant_get_bytestring (ivalue);
      fstringss = scheme_make_locale_string(fstring);
      return fstringss;
    }// else if
  
  
  else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_DOUBLE))
    {
      r2 = g_variant_get_double (ivalue);
      fdouble = scheme_make_double (r2);
      return fdouble; 
    }// else if
  
  else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_TUPLE))
    {
      int i;
      Scheme_Object *result;  // The list we're building
      Scheme_Object *element; // One element of that list

      fprintf (stderr, "Handling a tuple.\n");

      result = scheme_null;
      for (i = g_variant_n_children (ivalue) - 1; i >= 0; i--)
	{
	  fprintf (stderr, "Handling child %d\n", i);
	  element = gvariant_to_schemeobj (g_variant_get_child_value (ivalue, i));
	  result = scheme_make_pair (element, result);
	} // for
      
      return result;
    } // if it's a tuple
  
      // Default.  Give up
  else
    {
      scheme_signal_error ("could not convert type");
    } // default
} //gvariant_to_schemeobj
Пример #26
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, 
                                     Scheme_Object *vec, int delta,
                                     Scheme_Object *tbranch)
{
  int t_min_t, t_max_t, t_cnt, n, stackpos, i, save_nt, b_end, nt;
  Scheme_Object *t_vec, *o;
  Scheme_Object *clears = scheme_null;

  info->min_touch = -1;
  info->max_touch = -1;
  save_nt = info->max_nontail;

  SFS_LOG(printf("%d %d %s %d\n", info->pass, ip, (delta ? "else" : "then"), ip));

  if (info->pass) {
    /* Re-install max_used entries that refer to the branch */
    o = SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W];
    t_min_t = SCHEME_INT_VAL(o);
    o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2];
    nt = SCHEME_INT_VAL(o);
    if (nt > info->max_nontail)
      info->max_nontail = nt;
    if (t_min_t > -1) {
      t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1];
      t_cnt = SCHEME_VEC_SIZE(t_vec);
      for (i = 0; i < t_cnt; i++) {
        o = SCHEME_VEC_ELS(t_vec)[i];
        if (SCHEME_INTP(o)) {
          n = SCHEME_INT_VAL(o);
          SFS_LOG(printf(" @%d %d\n", i + t_min_t, n));
          if (info->max_used[i + t_min_t] < n) {
            SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail));
            info->max_used[i + t_min_t] = n;
            info->max_calls[i + t_min_t] = info->max_nontail;
          }
        }
      }
    }
    /* If the other branch has last use for something not used in this
       branch, and if there's a non-tail call in this branch
       of later, then we'll have to start with explicit clears. 
       Note that it doesn't matter whether the other branch actually
       clears them (i.e., the relevant non-tail call might be only
       in this branch). */
    o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3];
    b_end = SCHEME_INT_VAL(o);
    SFS_LOG(printf(" %d %d %d %d\n", nt, ip, b_end, save_nt));
    if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */
        || ((ip + 1) < save_nt)) { /* => non-tail call after branches */
      SFS_LOG(printf(" other\n"));
      o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W];
      t_min_t = SCHEME_INT_VAL(o);
      if (t_min_t > -1) {
        int at_ip, pos;
        t_vec = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 1];
        t_cnt = SCHEME_VEC_SIZE(t_vec);
        o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 2];
        nt = SCHEME_INT_VAL(o);
        o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 3];
        b_end = SCHEME_INT_VAL(o);
        for (i = 0; i < t_cnt; i++) {
          o = SCHEME_VEC_ELS(t_vec)[i];
          if (SCHEME_INTP(o)) {
            n = SCHEME_INT_VAL(o);
            pos = i + t_min_t;
            at_ip = info->max_used[pos];
            SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip));
            /* is last use in other branch? */
            if (((!delta && (at_ip == ip))
                 || (delta && (at_ip == n)))) {
              /* Yes, so add clear */
              SFS_LOG(printf(" !%d %d %d\n", pos, n, at_ip));
              pos -= info->stackpos;
              clears = scheme_make_pair(scheme_make_integer(pos), 
                                        clears);
            }
          }
        }
      }
    }
  }

  stackpos = info->stackpos;

  tbranch = scheme_sfs_expr(tbranch, info, -1);

  if (info->pass)
    info->max_nontail = save_nt;
# if MAX_SFS_CLEARING
  else
    info->max_nontail = info->ip;
# endif

  tbranch = scheme_sfs_add_clears(tbranch, clears, 1);

  if (!info->pass) {
    t_min_t = info->min_touch;
    t_max_t = info->max_touch;
    if (t_min_t < stackpos)
      t_min_t = stackpos;
    if (t_max_t < stackpos)
      t_max_t = -1;
    SFS_LOG(printf("%d %s %d [%d,%d] /%d\n", info->pass, (delta ? "else" : "then"), ip, 
                   t_min_t, t_max_t, stackpos));
    if (t_max_t < 0) {
      t_min_t = -1;
      t_vec = scheme_false;
    } else {
      t_cnt = t_max_t - t_min_t + 1;
      t_vec = scheme_make_vector(t_cnt, NULL);
      for (i = 0; i < t_cnt; i++) {
        n = info->max_used[i + t_min_t];
        SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip, 
                       i + t_min_t, n, info->max_calls[i+ t_min_t]));
        if (n > ip) {
          SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n);
          info->max_used[i + t_min_t] = ip;
        } else {
          SCHEME_VEC_ELS(t_vec)[i] = scheme_false;
        }
      }
    }
    SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W] = scheme_make_integer(t_min_t);
    SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1] = t_vec;
    SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2] = scheme_make_integer(info->max_nontail);
    SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3] = scheme_make_integer(info->ip);
  }

  memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
  memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));

  info->stackpos = stackpos;

  return tbranch;
}
Пример #27
0
Scheme_Object *write_apply_values(Scheme_Object *o)
{
  return scheme_make_pair(scheme_protect_quote(SCHEME_PTR1_VAL(o)), 
                          scheme_protect_quote(SCHEME_PTR2_VAL(o)));
}
Пример #28
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_pos)
{
  Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
  Scheme_Object *code;
  int i, size, has_tl = 0;

  size = data->closure_size;
  if (size) {
    if (info->stackpos + data->closure_map[size - 1] == info->tlpos) {
      has_tl = 1;
      --size;
    }
  }

  if (!info->pass) {
    for (i = size; i--; ) {
      scheme_sfs_used(info, data->closure_map[i]);
    }
  } else {
    /* Check whether we need to zero out any stack positions
       after capturing them in a closure: */
    Scheme_Object *clears = scheme_null;

    if (info->ip < info->max_nontail) {
      int pos, ip;
      for (i = size; i--; ) {
        pos = data->closure_map[i] + info->stackpos;
        if (pos < info->depth) {
          ip = info->max_used[pos];
          if ((ip == info->ip)
              && (ip < info->max_calls[pos])) {
            pos -= info->stackpos;
            clears = scheme_make_pair(scheme_make_integer(pos),
                                      clears);
          }
        }
      }
    }

    return scheme_sfs_add_clears(expr, clears, 0);
  }

  if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SFS)) {
    SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SFS;
    info = scheme_new_sfs_info(data->max_let_depth);
    scheme_sfs_push(info, data->closure_size + data->num_params, 1);

    if (has_tl)
      info->tlpos = info->stackpos + data->closure_size - 1;

    if (self_pos >= 0) {
      for (i = size; i--; ) {
        if (data->closure_map[i] == self_pos) {
          info->selfpos = info->stackpos + i;
          info->selfstart = info->stackpos;
          info->selflen = data->closure_size;
          break;
        }
      }
    }

    code = scheme_sfs(data->code, info, data->max_let_depth);

    /* If any arguments go unused, and if there's a non-tail,
       non-immediate call in the body, then we flush the
       unused arguments at the start of the body. We assume that
       the closure values are used (otherwise they wouldn't
       be in the closure). */
    if (info->max_nontail) {
      int i, pos, cnt;
      Scheme_Object *clears = scheme_null;

      cnt = data->num_params;
      for (i = 0; i < cnt; i++) {
        pos = data->max_let_depth - (cnt - i);
        if (!info->max_used[pos]) {
          pos = i + data->closure_size;
          clears = scheme_make_pair(scheme_make_integer(pos),
                                    clears);
        }
      }
      
      if (SCHEME_PAIRP(clears))
        code = scheme_sfs_add_clears(code, clears, 1);

      if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
        SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR;
    }

    data->code = code;
  }

  return expr;
}
Пример #29
0
static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_pos)
{
  Scheme_Lambda *data = (Scheme_Lambda *)expr;
  Scheme_Object *code;
  int i, size, has_tl = 0;

  size = data->closure_size;
  if (size) {
    if (info->stackpos + data->closure_map[size - 1] == info->tlpos) {
      has_tl = 1;
      --size;
    }
  }

  if (!info->pass) {
    for (i = size; i--; ) {
      scheme_sfs_used(info, data->closure_map[i]);
    }
  } else {
    /* Check whether we need to zero out any stack positions
       after capturing them in a closure: */
    Scheme_Object *clears = scheme_null;

    if (info->ip < info->max_nontail) {
      int pos, ip;
      for (i = size; i--; ) {
        pos = data->closure_map[i] + info->stackpos;
        if (pos < info->depth) {
          ip = info->max_used[pos];
          if ((ip == info->ip)
              && (ip < info->max_calls[pos])) {
            pos -= info->stackpos;
            clears = scheme_make_pair(scheme_make_integer(pos),
                                      clears);
          }
        }
      }
    }

    return scheme_sfs_add_clears(expr, clears, 0);
  }

  if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_SFS)) {
    SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_SFS;
    info = scheme_new_sfs_info(data->max_let_depth);
    scheme_sfs_push(info, data->closure_size + data->num_params, 1);

    if (has_tl)
      info->tlpos = info->stackpos + data->closure_size - 1;

    if (self_pos >= 0) {
      for (i = size; i--; ) {
        if (data->closure_map[i] == self_pos) {
          info->selfpos = info->stackpos + i;
          info->selfstart = info->stackpos;
          info->selflen = data->closure_size;
          break;
        }
      }
    }

    /* Never clear typed arguments or typed closure elements: */
    if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) {
      int delta, size, ct, j, pos;
      mzshort *map;
      delta = data->closure_size;
      size = data->closure_size + data->num_params;
      map = data->closure_map;
      for (j = 0; j < size; j++) {
        ct = scheme_boxmap_get(map, j, delta);
        if (ct > LAMBDA_TYPE_TYPE_OFFSET) {
          if (j < data->num_params)
            pos = info->stackpos + delta + j;
          else
            pos = info->stackpos + (j - data->num_params);
          info->max_used[pos] = FAR_VALUE_FOR_MAX_USED;
        }
      }
    }

    code = scheme_sfs(data->body, info, data->max_let_depth);

    /* If any arguments go unused, and if there's a non-tail,
       non-immediate call in the body, then we flush the
       unused arguments at the start of the body. We assume that
       the closure values are used (otherwise they wouldn't
       be in the closure). */
    if (info->max_nontail) {
      int i, pos, cnt;
      Scheme_Object *clears = scheme_null;

      cnt = data->num_params;
      for (i = 0; i < cnt; i++) {
        pos = data->max_let_depth - (cnt - i);
        if (!info->max_used[pos]) {
          pos = i + data->closure_size;
          clears = scheme_make_pair(scheme_make_integer(pos),
                                    clears);
        }
      }
      
      if (SCHEME_PAIRP(clears))
        code = scheme_sfs_add_clears(code, clears, 1);

      if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST)
        SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_NEED_REST_CLEAR;
    }

    data->body = code;
  }

  return expr;
}
Пример #30
0
Scheme_Object *write_boxenv(Scheme_Object *o)
{
  return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o));
}