Пример #1
0
void scheme_sfs_used(SFS_Info *info, int pos)
{
  if (info->pass)
    return;

  pos += info->stackpos;

  if ((pos < 0) || (pos >= info->depth)) {
    scheme_signal_error("internal error: stack use out of bounds");
  }
  if (pos == info->tlpos)
    scheme_signal_error("internal error: misuse of toplevel pointer");

  SFS_LOG(printf("touch %d %d\n", pos, info->ip));

  if (info->max_used[pos] >= FAR_VALUE_FOR_MAX_USED) {
    info->max_used[pos] = (FAR_VALUE_FOR_MAX_USED + 1);
    return;
  }
  
  if ((info->min_touch == -1)
      || (pos < info->min_touch))
    info->min_touch = pos;
  if (pos > info->max_touch)
    info->max_touch = pos;

  info->max_used[pos] = info->ip;
}
Пример #2
0
/**
 * Create a list of available services.
 */
static Scheme_Object *
loudbus_services (int argc, Scheme_Object **argv)
{
  GDBusProxy *proxy;
  GError *error = NULL; 
  GVariant *result;

  //Build the proxy.
  proxy = g_dbus_proxy_new_for_bus_sync (G_BUS_TYPE_SESSION,
                                         G_DBUS_PROXY_FLAGS_NONE,
                                         NULL,
                                         "org.freedesktop.DBus",
                                         "/",
                                         "org.freedesktop.DBus",
                                         NULL,
                                         &error);

  // Check for an error
  if (proxy == NULL)
    {
      if (error != NULL)
        {
          scheme_signal_error ("Could not create proxy because %s", 
                               error->message);
        } // if (error != NULL)
      else // if (error == NULL)
        {
	  scheme_signal_error ("Could not create proxy for unknown reasons.");
	} // if (error == NULL)
      return scheme_void;
    } // if (proxy == NULL)

  // Get a list of available services.
  result = g_dbus_proxy_call_sync (proxy,
                                   "ListNames",
                                   NULL,
                                   0,
                                   -1,
                                   NULL,
                                   &error);

  // Check whether an error occurred.
  if (result == NULL)
    {
      if (error != NULL)
        {
	  scheme_signal_error ("Could not list services because: %s",
	                       error->message);
        } // if (error != NULL)
      else // if (error == NULL)
        {
	  scheme_signal_error ("Could not list services for unknown reason");
        } // if (error == NULL)
      return scheme_void; 
    } // if (error == NULL)
  
  // Return the created list.
  return g_variant_to_scheme_object (result);
} // loudbus_services
Пример #3
0
Файл: sfs.c Проект: awest/racket
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;
}
Пример #4
0
static Scheme_Object *startmidi(int argc, Scheme_Object **argv)
{
  int status=midi_io.initialise();
  if(status < 0){
    switch(status) {
      case ERROR_OPEN_INPUT: scheme_signal_error("Error opening input port");
      break;
      case ERROR_OPEN_OUTPUT: scheme_signal_error("Error opening output port");
      break;
      default: scheme_signal_error("Unknown error");
      break;
    } // switch
  }
  return scheme_void;
} // startmidi()
Пример #5
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;
}
Пример #6
0
void *dlopen(const char *filename, int flags)
{
  scheme_signal_error("load-extension: can't use with a statically-linked"
		      " MrEd");

  return NULL;
}
Пример #7
0
static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info)
{
  Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
  Scheme_Object *k, *v, *b, *vec;
  int pos, save_mnt;
  
  scheme_sfs_start_sequence(info, 3, 1);

  k = scheme_sfs_expr(wcm->key, info, -1);
  v = scheme_sfs_expr(wcm->val, info, -1);

  scheme_sfs_push(info, 1, 1);

  pos = info->stackpos;
  save_mnt = info->max_nontail;

  if (!info->pass) {
    vec = scheme_make_vector(3, NULL);
    scheme_sfs_save(info, vec);
  } else {
    vec = scheme_sfs_next_saved(info);
    if (SCHEME_VEC_SIZE(vec) != 3)
      scheme_signal_error("internal error: bad vector length");
    info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
    info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
    info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
  }
  
  b = scheme_sfs_expr(wcm->body, info, -1);
  
  wcm->key = k;
  wcm->val = v;
  wcm->body = b;

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

  if (!info->pass) {
    int n;
    info->max_calls[pos] = info->max_nontail;
    n = info->max_used[pos];
    SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
    n = info->max_calls[pos];
    SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
    SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
  } else {
    info->max_nontail = save_mnt;
  }

  return o;
}
Пример #8
0
/**
 * A wrapper for rdbus_get_object.
 */
Scheme_Object *pardbus_get_object (int argc, Scheme_Object *argv[])
{
  char *service;
  char *path;
  char *interface;
  int object;

  // Verify the number of parameters
  if (argc != 3)
    {
      scheme_signal_error ("rdbus-get-object: Requires exactly three parameters.\n");
      return scheme_void;
    } // if we have the wrong number of parameters

  // Verify the type of the parameters
  if ( (! stringp (argv[0]))
       || (! stringp (argv[1]))
       || (! stringp (argv[2])) )
    {
      scheme_signal_error ("rdbus-get-object: All three parameters must be strings");
    } // if one of the parameters is not a string

  // Extract the parameters
  service = tostring (argv[0]);
  path = tostring (argv[1]);
  interface = tostring (argv[2]);

  // Rely on rdbus_get_object to do the real work
  object = rdbus_get_object (service, path, interface);

  // Sanity check.  rdbus_get_object returns a negative number upon error.
  if (object < 0)   
    {
      scheme_signal_error ("Could not create bus object.");
      return scheme_void;
    } // if (object < 0)

  // We're done.  Return the damn integer.
  return scheme_make_integer (object);
} // pardbus_get_object
Пример #9
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;
}
Пример #10
0
Файл: sfs.c Проект: awest/racket
void scheme_sfs_push(SFS_Info *info, int cnt, int track)
{
  info->stackpos -= cnt;

  if (info->stackpos < 0)
    scheme_signal_error("internal error: pushed too deep");

  if (track) {
    while (cnt--) {
      scheme_sfs_used(info, cnt);
    }
  }
}
Пример #11
0
void scheme_sfs_push(SFS_Info *info, int cnt, int track)
{
  info->stackpos -= cnt;

  SFS_LOG(printf("push %d [%d]: %d\n", cnt, track, info->stackpos));

  if (info->stackpos < 0)
    scheme_signal_error("internal error: pushed too deep");

  if (track) {
    while (cnt--) {
      scheme_sfs_used(info, cnt);
    }
  }
}
Пример #12
0
/**
 * A wrapper for rdbus_call_method that makes it easier to export our function
 * to Scheme.
 */
Scheme_Object *
pardbus_call_method (int argc, Scheme_Object *argv[])
{
  // Verify that we have the appropriate number of arguments.
  if (argc < 2)
    {
      scheme_signal_error ("Call method needs at least two parameters.");
      return NULL;
    } // if there are insufficiently many arguments available.

  // rdbus_call_method does the heavy lifting
  // Hack!  Right now, we are going to assume zeroary procedures
  return rdbus_call_method (SCHEME_INT_VAL (argv[0]), argv[1], 
                            make_object_list (argc-2, argv+2));
} // pardbus_call_method
Пример #13
0
Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth)
{
  int init, i;

  SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o)));

  if (!info) {
    info = scheme_new_sfs_info(max_let_depth);
  }

  info->pass = 0;
  info->ip = 1;
  info->abs_ip = 1;
  info->saved = scheme_null;
  info->min_touch = -1;
  info->max_touch = -1;
  info->tail_pos = 1;
  init = info->stackpos;
  o = scheme_sfs_expr(o, info, -1);

  if (info->seqn)
    scheme_signal_error("ended in the middle of an expression?");

# if MAX_SFS_CLEARING
  info->max_nontail = info->ip;
  info->abs_max_nontail = info->abs_ip;
# endif

  for (i = info->depth; i-- > init; ) {
    info->max_calls[i] = info->max_nontail;
  }

  {
    Scheme_Object *v;
    v = scheme_reverse(info->saved);
    info->saved = v;
  }

  info->pass = 1;
  info->seqn = 0;
  info->ip = 1;
  info->abs_ip = 1;
  info->tail_pos = 1;
  info->stackpos = init;
  o = scheme_sfs_expr(o, info, -1);

  return o;
}
Пример #14
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info)
{
  Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
  Scheme_Object *body;
  int i, pos, save_mnt;
  Scheme_Object *vec;
    
  scheme_sfs_push(info, lv->count, 1);
  pos = info->stackpos;
  save_mnt = info->max_nontail;

  if (!info->pass) {
    vec = scheme_make_vector(lv->count + 1, NULL);
    scheme_sfs_save(info, vec);
  } else {
    vec = scheme_sfs_next_saved(info);
    if (!SCHEME_VECTORP(vec))
      scheme_signal_error("internal error: not a vector");
    for (i = 0; i < lv->count; i++) {
      info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]);
      info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
    }
    info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
  }

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

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

  if (!info->pass) {
    int n;
    SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail);
    for (i = 0; i < lv->count; i++) {
      n = info->max_used[pos + i];
      SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n);
    }
  } else {
    info->max_nontail = save_mnt;
  }

  lv->body = body;

  return o;
}
Пример #15
0
/**
 * Call a function, using the proxy, function name, and external name
 * stored in prim.
 *
 * argc/argv give the parameters for the function call.
 */
Scheme_Object *
loudbus_call_with_closure (int argc, Scheme_Object **argv, Scheme_Object *prim)
{
  Scheme_Object *wrapped_proxy = NULL;
  Scheme_Object *wrapped_dbus_name = NULL;
  Scheme_Object *wrapped_external_name = NULL;
  Scheme_Object *result = NULL;
  LouDBusProxy *proxy = NULL;
  gchar *dbus_name;
  gchar *external_name;

  // Probably too many things are annotated here, but better safe than
  // sorry.
  MZ_GC_DECL_REG (5);
  MZ_GC_VAR_IN_REG (0, argv);
  MZ_GC_VAR_IN_REG (1, prim);
  MZ_GC_VAR_IN_REG (2, wrapped_proxy);
  MZ_GC_VAR_IN_REG (3, wrapped_dbus_name);
  MZ_GC_VAR_IN_REG (4, wrapped_external_name);
  MZ_GC_REG ();

  // Extract information from the closure.
  wrapped_proxy = SCHEME_PRIM_CLOSURE_ELS (prim)[0];
  wrapped_dbus_name = SCHEME_PRIM_CLOSURE_ELS (prim)[1];
  wrapped_external_name = SCHEME_PRIM_CLOSURE_ELS (prim)[2];
  dbus_name = scheme_object_to_string (wrapped_dbus_name);
  external_name = scheme_object_to_string (wrapped_external_name);
  proxy = scheme_object_to_proxy (wrapped_proxy);

  // Sanity check
  if (proxy == NULL)
    {
      MZ_GC_UNREG ();
      scheme_signal_error ("Could not obtain proxy to call %s.\n",
                           external_name);
    } // if (proxy == NULL)
   
  // And do the dirty work
  result = dbus_call_kernel (proxy, 
                             dbus_name, external_name, 
                             argc, argv);

  MZ_GC_UNREG ();
  return result;
} // loudbus_call_with_closure
Пример #16
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *flatten_sequence(Scheme_Object *o)
{
  /* At this point, we sometimes have (begin ... (begin ... (begin ...))).
     Flatten those out. */
  Scheme_Sequence *s = (Scheme_Sequence *)o, *s2;
  int i, extra = 0;

  o = s->array[s->count - 1];

  while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
    s2 = (Scheme_Sequence *)o;
    extra += s2->count - 1;
    o = s2->array[s2->count - 1];
  }

  if (extra) {
    s2 = scheme_malloc_sequence(s->count + extra);
    s2->so.type = scheme_sequence_type;
    s2->count = s->count + extra;

    extra = 0;
    o = (Scheme_Object *)s;
    while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
      s = (Scheme_Sequence *)o;
      for (i = 0; i < s->count - 1; i++) {
        s2->array[extra++] = s->array[i];
      }
      o = s->array[i];
    }
    s2->array[extra++] = o;

    if (extra != s2->count) scheme_signal_error("internal error: flatten failed");

    return (Scheme_Object *)s2;
  } else
    return (Scheme_Object *)s;
}
Пример #17
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
Пример #18
0
/**
 * The kernel of the various mechanisms for calling D-Bus functions.
 */
static Scheme_Object *
dbus_call_kernel (LouDBusProxy *proxy,
                  gchar *dbus_name,
                  gchar *external_name,
                  int argc, 
                  Scheme_Object **argv)
{
  GDBusMethodInfo *method;
                        // Information on the actual method
  int arity;            // The arity of that method
  GVariant *actuals;    // The actual parameters
  GVariant *gresult;    // The result from the function call as a GVariant
  Scheme_Object *sresult;   
                        // That Scheme result as a Scheme object
  GError *error;        // Possible error from call

  // Grab the method information.
  method = g_dbus_interface_info_lookup_method (proxy->iinfo, dbus_name);
  if (method == NULL)
    {
      scheme_signal_error ("no such method: %s", dbus_name);
    } // if the method is invalid

  // Get the arity
  arity = g_dbus_method_info_num_formals (method);
  if (arity != argc)
    {
      scheme_signal_error ("%s expected %d params, received %d",
                           external_name, arity, argc);
    } // if the arity is incorrect

  // Build the actuals
  actuals = scheme_objects_to_parameter_tuple (external_name,
                                               argc,
                                               argv,
                                               method->in_args);
  if (actuals == NULL)
    {
      scheme_signal_error ("%s: could not convert parameters",
                           external_name);
    } // if (actuals == NULL)

  // Call the function.
  error = NULL;
  gresult = g_dbus_proxy_call_sync (proxy->proxy,
                                    dbus_name,
                                    actuals,
                                    0,
                                    -1,
                                    NULL,
                                    &error);
  if (gresult == NULL)
    {
      if (error != NULL)
        {
          scheme_signal_error ("%s: call failed because %s", 
                               external_name, error->message);
        } // if (error != NULL)
      else
        {
          scheme_signal_error ("%s: call failed for unknown reason", 
                               external_name);
        } // if something went wrong, but there's no error
    } // if (gresult == NULL)

  // Convert to Scheme form
  sresult = g_variant_to_scheme_object (gresult);
  if (sresult == NULL)
    {
      scheme_signal_error ("%s: could not convert return values", 
                           external_name);
    } // if (sresult == NULL)

  // And we're done.
  return sresult;
} // dbus_call_kernel
Пример #19
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
Пример #20
0
static Scheme_Object *write_let_one(Scheme_Object *obj)
{
  scheme_signal_error("let-one writer shouldn't be used");
  return NULL;
}
Пример #21
0
/**
 * Create a new proxy.
 */
static Scheme_Object *
loudbus_proxy (int argc, Scheme_Object **argv)
{
  gchar *service = NULL;        // A string giving the service
  gchar *path = NULL;           // A string giving the path to the object
  gchar *interface = NULL;      // A string giving the interface
  LouDBusProxy *proxy = NULL;   // The proxy we build
  Scheme_Object *result = NULL; // The proxy wrapped as a Scheme object
  GError *error = NULL;         // A place to hold errors

  service = scheme_object_to_string (argv[0]);

  // Annotations for garbage collection
  MZ_GC_DECL_REG (5);
  MZ_GC_VAR_IN_REG (0, argv);
  MZ_GC_VAR_IN_REG (1, service);
  MZ_GC_VAR_IN_REG (2, path);
  MZ_GC_VAR_IN_REG (3, interface);
  MZ_GC_VAR_IN_REG (4, result);
  MZ_GC_REG ();

  // Extract parameters
  service = scheme_object_to_string (argv[0]);
  path = scheme_object_to_string (argv[1]);
  interface = scheme_object_to_string (argv[2]);

  // Check parameters
  if (service == NULL)
    {
      MZ_GC_UNREG ();
      scheme_wrong_type ("loudbus-proxy", "string", 0, argc, argv);
    }
  if (path == NULL)
    {
      MZ_GC_UNREG ();
      scheme_wrong_type ("loudbus-proxy", "string", 1, argc, argv);
    }
  if (interface == NULL)
    {
      MZ_GC_UNREG ();
      scheme_wrong_type ("loudbus-proxy", "string", 2, argc, argv);
    }

  // Do the actual work in building the proxy.
  proxy = loudbus_proxy_new (service, path, interface, &error);
  if (proxy == NULL)
    {
      if (error == NULL)
        {
          MZ_GC_UNREG ();
          scheme_signal_error ("loudbus-proxy: "
                               "Could not create proxy for an unknown reason.");
        }
      else
        {
          MZ_GC_UNREG ();
          scheme_signal_error ("loudbus-proxy: "
                               "Could not create proxy because %s", 
                               error->message);
        }
    } // if (proxy == NULL)
  
  // Wrap the proxy into a Scheme type
  result = scheme_make_cptr (proxy, LOUDBUS_PROXY_TAG);

  // Log info during development
  LOG ("loudbus_proxy: Built proxy %p, Scheme object %p", proxy, result);

  // Find out information on what we just built.
  SCHEME_LOG ("result is", result);
  SCHEME_LOG ("result type is", SCHEME_CPTR_TYPE (result));
  
  // Register the finalizer
  scheme_register_finalizer (result, loudbus_proxy_finalize, NULL, NULL, NULL);

  // And we're done
  MZ_GC_UNREG ();
  return result;
} // loudbus_proxy
Пример #22
0
Файл: sfs.c Проект: awest/racket
static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
{
  Scheme_Let_One *lo = (Scheme_Let_One *)o;
  Scheme_Object *body, *rhs, *vec;
  int pos, save_mnt, ip, et;
  int unused = 0;

  scheme_sfs_start_sequence(info, 2, 1);

  scheme_sfs_push(info, 1, 1);
  ip = info->ip;
  pos = info->stackpos;
  save_mnt = info->max_nontail;

  if (!info->pass) {
    vec = scheme_make_vector(3, NULL);
    scheme_sfs_save(info, vec);
  } else {
    vec = scheme_sfs_next_saved(info);
    if (SCHEME_VEC_SIZE(vec) != 3)
      scheme_signal_error("internal error: bad vector length");
    info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
    info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
    info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
  }

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

# if MAX_SFS_CLEARING
  if (!info->pass)
    info->max_nontail = info->ip;
# endif
  
  if (!info->pass) {
    int n;
    info->max_calls[pos] = info->max_nontail;
    n = info->max_used[pos];
    SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
    n = info->max_calls[pos];
    SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
    SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
  } else {
    info->max_nontail = save_mnt;

    if (info->max_used[pos] <= ip) {
      /* No one is using it, so don't actually push the value at run time
         (but keep the check that the result is single-valued).
         The optimizer normally would have converted away the binding, but
         it might not because (1) it was introduced late by inlining,
         or (2) the rhs expression doesn't always produce a single
         value. */
      if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) {
        rhs = scheme_false;
      } else if ((ip < info->max_calls[pos])
                 && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {
        /* Unusual case: we can't just drop the global-variable access,
           because it might be undefined, but we don't need the value,
           and we want to avoid an SFS clear in the interpreter loop.
           So, bind #f and then access in the global in a `begin'. */
        Scheme_Sequence *s;
        s = scheme_malloc_sequence(2);
        s->so.type = scheme_sequence_type;
        s->count = 2;
        s->array[0] = rhs;
        s->array[1] = body;
        body = (Scheme_Object *)s;
        rhs = scheme_false;
      }
      unused = 1;
    }
  }

  lo->value = rhs;
  lo->body = body;

  et = scheme_get_eval_type(lo->value);
  SCHEME_LET_EVAL_TYPE(lo) = (et 
                              | (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM))
                              | (unused ? LET_ONE_UNUSED : 0));

  return o;
}
Пример #23
0
static Scheme_Object *write_application(Scheme_Object *obj)
{
  scheme_signal_error("app writer shouldn't be used");
  return NULL;
}
Пример #24
0
static Scheme_Object *write_branch(Scheme_Object *obj)
{
  scheme_signal_error("branch writer shouldn't be used");
  return NULL;
}
Пример #25
0
int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *syncing)
     /* When syncing is supplied, o can contain Scheme_Channel_Syncer
	and never-evt values, and just_try must be 0. */
{
  Scheme_Sema **semas = (Scheme_Sema **)o;
  int v, i, ii;

  if (just_try) {
    /* assert: n == 1, !syncing */
    Scheme_Sema *sema = semas[0];
    if (just_try > 0) {
      if (sema->so.type == scheme_sema_type) {
        v = scheme_try_plain_sema((Scheme_Object *)sema);
      } else {
	v = try_channel(sema, syncing, 0, NULL);
      }
    } else {
      Scheme_Cont_Frame_Data cframe;

      scheme_push_break_enable(&cframe, 1, 1);

      scheme_wait_sema((Scheme_Object *)sema, 0);

      scheme_pop_break_enable(&cframe, 0);

      return 1;
    }
  } else {
    int start_pos;

#if 0
    /* Use the "immutable" flag bit on a semaphore to check for
       inconsistent use in atomic and non-atomic modes, which
       can lead to an attempt to suspend in atomic mode. */
    if ((n == 1) && SCHEME_SEMAP(o[0])) {
      if (!do_atomic) {
        SCHEME_SET_IMMUTABLE(o[0]);
      } else if (SCHEME_IMMUTABLEP(o[0])) {
        if (!on_atomic_timeout
            || (do_atomic > atomic_timeout_atomic_level)) {
          scheme_signal_error("using a seaphore in both atomic and non-atomic mode");
        }
      }
    }
#endif

    if (n > 1) {
      if (syncing)
	start_pos = syncing->start_pos;
      else {
	Scheme_Object *rand_state;
	rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_SCHEDULER_RANDOM_STATE);
	start_pos = scheme_rand((Scheme_Random_State *)rand_state);
      }
    } else
      start_pos = 0;

    /* Initial poll */
    while (1) {
      i = 0;
      for (ii = 0; ii < n; ii++) {
        /* Randomized start position for poll ensures fairness: */
        i = (start_pos + ii) % n;

        if (semas[i]->so.type == scheme_sema_type) {
          if (semas[i]->value) {
            if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i]))
              --semas[i]->value;
            if (syncing) {
	      syncing->result = i + 1;
	      if (syncing->accepts && syncing->accepts[i])
		scheme_accept_sync(syncing, i);
	    }
            break;
          }
        } else if (semas[i]->so.type == scheme_never_evt_type) {
          /* Never ready. */
        } else if (semas[i]->so.type == scheme_channel_syncer_type) {
          if (((Scheme_Channel_Syncer *)semas[i])->picked)
            break;
        } else if (try_channel(semas[i], syncing, i, NULL))
          break;
      }

      if (ii >= n) {
        if (!scheme_wait_until_suspend_ok()) {
          break;
        } else {
          /* there may have been some action on one of the waitables;
             try again, if no result, yet */
          if (syncing && syncing->result) {
            i = syncing->result - 1;
            ii = 0;
            break;
          }
        }
      } else
        break;
    }

    /* In the following, syncers get changed back to channels,
       and channel puts */
    if (ii >= n) {
      Scheme_Channel_Syncer **ws, *w;

      ws = MALLOC_N(Scheme_Channel_Syncer*, n);
      for (i = 0; i < n; i++) {
	if (semas[i]->so.type == scheme_channel_syncer_type) {
	  ws[i] = (Scheme_Channel_Syncer *)semas[i];
	  semas[i] = (Scheme_Sema *)ws[i]->obj;
	} else {
	  w = MALLOC_ONE_RT(Scheme_Channel_Syncer);
	  ws[i] = w;
	  w->so.type = scheme_channel_syncer_type;
	  w->p = scheme_current_thread;
	  w->syncing = syncing;
	  w->obj = (Scheme_Object *)semas[i];
	  w->syncing_i = i;
	}
      }
      
      while (1) {
	int out_of_a_line;

	/* Get into line */
	for (i = 0; i < n; i++) {
	  if (!ws[i]->in_line) {
	    get_into_line(semas[i], ws[i]);
	  }
	}

	if (!scheme_current_thread->next) {
	  void **a;

	  /* We're not allowed to suspend the main thread. Delay
	     breaks so we get a chance to clean up. */
	  scheme_current_thread->suspend_break++;

	  a = MALLOC_N(void*, 3);
	  a[0] = scheme_make_integer(n);
	  a[1] = ws;
	  a[2] = scheme_current_thread;
	  
	  scheme_main_was_once_suspended = 0;

	  scheme_block_until(out_of_line, NULL, (Scheme_Object *)a, (float)0.0);
	  
	  --scheme_current_thread->suspend_break;
	} else {
	  /* Mark the thread to indicate that we need to clean up
	     if the thread is killed. */
	  int old_nkc;
	  old_nkc = (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP);
	  if (!old_nkc)
	    scheme_current_thread->running += MZTHREAD_NEED_KILL_CLEANUP;
	  scheme_weak_suspend_thread(scheme_current_thread);
	  if (!old_nkc && (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP))
	    scheme_current_thread->running -= MZTHREAD_NEED_KILL_CLEANUP;
	}

	/* We've been resumed. But was it for the semaphore, or a signal? */
	out_of_a_line = 0;
	
	/* If we get the post, we must return WITHOUT BLOCKING. 
	   GRacket, for example, depends on this special property, which
	   ensures that the thread can't be broken or killed between
	   receiving the post and returning. */

	if (!syncing) {
	  /* Poster can't be sure that we really will get it,
	     so we have to decrement the sema count here. */
	  i = 0;
	  for (ii = 0; ii < n; ii++) {
	    i = (start_pos + ii) % n;
	    if (ws[i]->picked) {
	      out_of_a_line = 1;
	      if (semas[i]->value) {
		if (semas[i]->value > 0)
		  --(semas[i]->value);
		break;
	      }
	    }
	  }
	  if (ii >= n)
	    i = n;
	} else {
	  if (syncing->result) {
	    out_of_a_line = 1;
	    i = syncing->result - 1;
	  } else {
	    out_of_a_line = 0;
	    i = n;
	  }
	}

	if (!out_of_a_line) {
	  /* We weren't woken by any semaphore/channel. Get out of line, block once 
	     (to handle breaks/kills) and then loop to get back into line. */
	  for (i = 0; i < n; i++) {
	    if (ws[i]->in_line)
	      get_outof_line(semas[i], ws[i]);
	  }
	  
	  scheme_thread_block(0); /* ok if it returns multiple times */ 
	  scheme_current_thread->ran_some = 1;
	  /* [but why would it return multiple times?! there must have been a reason...] */
	} else {

	  if ((scheme_current_thread->running & MZTHREAD_KILLED)
	      || ((scheme_current_thread->running & MZTHREAD_USER_SUSPENDED)
		  && !(scheme_current_thread->running & MZTHREAD_NEED_SUSPEND_CLEANUP))) {
	    /* We've been killed or suspended! */
	    i = -1;
	  }

	  /* We got a post from semas[i], or we were killed. 
	     Did any (other) semaphore pick us?
	     (This only happens when syncing == NULL.) */
	  if (!syncing) {
	    int j;

	    for (j = 0; j < n; j++) {
	      if (j != i) {
		if (ws[j]->picked) {
		  if (semas[j]->value) {
		    /* Consume the value and repost, because no one else
		       has been told to go, and we're accepting a different post. */
		    if (semas[j]->value > 0)
		      --semas[j]->value;
		    scheme_post_sema((Scheme_Object *)semas[j]);
		  }
		}
	      }
	    }
	  }

	  /* If we're done, get out of all lines that we're still in. */
	  if (i < n) {
	    int j;
	    for (j = 0; j < n; j++) {
	      if (ws[j]->in_line)
		get_outof_line(semas[j], ws[j]);
	    }
	  }

	  if (i == -1) {
	    scheme_thread_block(0); /* dies or suspends */
	    scheme_current_thread->ran_some = 1;
	  }

	  if (i < n)
	    break;
	}

	/* Otherwise: !syncing and someone stole the post, or we were
	   suspended and we have to start over. Either way, poll then
	   loop to get back in line an try again. */
	for (ii = 0; ii < n; ii++) {
	  i = (start_pos + ii) % n;

	  if (semas[i]->so.type == scheme_sema_type) {
	    if (semas[i]->value) {
	      if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i]))
		--semas[i]->value;
              if (syncing && syncing->accepts && syncing->accepts[i])
                scheme_accept_sync(syncing, i);
	      break;
	    }
	  }  else if (semas[i]->so.type == scheme_never_evt_type) {
	    /* Never ready. */
	  } else if (try_channel(semas[i], syncing, i, NULL))
	    break;
	}

	if (ii < n) {
	  /* Get out of any line that we still might be in: */
	  int j;
	  for (j = 0; j < n; j++) {
	    if (ws[j]->in_line)
	      get_outof_line(semas[j], ws[j]);
	  }

	  break;
	}

	if (!syncing) {
	  /* Looks like this thread is a victim of unfair semaphore access.
	     Go into fair mode by allocating a syncing: */
	  syncing = MALLOC_ONE_RT(Syncing);
#ifdef MZTAG_REQUIRED
	  syncing->type = scheme_rt_syncing;
#endif
	  syncing->start_pos = start_pos;

	  /* Get out of all lines, and set syncing field before we get back in line: */
	  {
	    int j;
	    for (j = 0; j < n; j++) {
	      if (ws[j]->in_line)
		get_outof_line(semas[j], ws[j]);
	      ws[j]->syncing = syncing;
	    }
	  }
	}
	/* Back to top of loop to sync again */
      }
Пример #26
0
Файл: sfs.c Проект: awest/racket
Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos)
/* closure_self_pos == -2 => immediately in sequence */
{
  Scheme_Type type = SCHEME_TYPE(expr);
  int seqn, stackpos, tp;

  seqn = info->seqn;
  stackpos = info->stackpos;
  tp = info->tail_pos;
  if (seqn) {
    info->seqn = 0;
    info->tail_pos = 0;
  }
  info->ip++;

  switch (type) {
  case scheme_local_type:
  case scheme_local_unbox_type:
    if (!info->pass)
      scheme_sfs_used(info, SCHEME_LOCAL_POS(expr));
    else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) {
      int pos, at_ip;
      pos = SCHEME_LOCAL_POS(expr);
      at_ip = info->max_used[info->stackpos + pos];
      if (at_ip < info->max_calls[info->stackpos + pos]) {
        if (at_ip == info->ip) {
          /* Clear on read: */
          expr = scheme_make_local(type, pos, SCHEME_LOCAL_CLEAR_ON_READ);
        } else {
          /* Someone else clears it: */
          expr = scheme_make_local(type, pos, SCHEME_LOCAL_OTHER_CLEARS);
        }
      } else {
# if MAX_SFS_CLEARING
        scheme_signal_error("should have been cleared somewhere");
# endif
      }
    }
    break;
  case scheme_application_type:
    expr = sfs_application(expr, info);
    break;
  case scheme_application2_type:
    expr = sfs_application2(expr, info);
    break;
  case scheme_application3_type:
    expr = sfs_application3(expr, info);
    break;
  case scheme_sequence_type:
    expr = sfs_sequence(expr, info, closure_self_pos != -2);
    break;
  case scheme_splice_sequence_type:
    expr = sfs_sequence(expr, info, 0);
    break;
  case scheme_branch_type:
    expr = sfs_branch(expr, info);
    break;
  case scheme_with_cont_mark_type:
    expr = sfs_wcm(expr, info);
    break;
  case scheme_unclosed_procedure_type:
    expr = sfs_closure(expr, info, closure_self_pos);
    break;
  case scheme_let_value_type:
    expr = sfs_let_value(expr, info);
    break;
  case scheme_let_void_type:
    expr = sfs_let_void(expr, info);
    break;
  case scheme_letrec_type:
    expr = sfs_letrec(expr, info);
    break;
  case scheme_let_one_type:
    expr = sfs_let_one(expr, info);
    break;
  case scheme_closure_type:
    {
      Scheme_Closure *c = (Scheme_Closure *)expr;
      if (ZERO_SIZED_CLOSUREP(c)) {
        Scheme_Object *code;
	code = sfs_closure((Scheme_Object *)c->code, info, closure_self_pos);
        if (SAME_TYPE(SCHEME_TYPE(code), scheme_begin0_sequence_type))  {
          Scheme_Sequence *seq = (Scheme_Sequence *)code;
          c->code = (Scheme_Closure_Data *)seq->array[0];
          seq->array[0] = expr;
          expr = code;
        } else {
          c->code = (Scheme_Closure_Data *)code;
        }
      }
    }
    break;
  case scheme_toplevel_type:
    {
      int c = SCHEME_TOPLEVEL_DEPTH(expr);
      if (info->stackpos + c != info->tlpos)
        scheme_signal_error("toplevel access not at expected place");
    }
    break;
  case scheme_case_closure_type:
    {
      /* FIXME: maybe need to handle eagerly created closure */
    }
    break;
  case scheme_define_values_type:
    expr = define_values_sfs(expr, info);
    break;
  case scheme_define_syntaxes_type:
    expr = define_syntaxes_sfs(expr, info);
    break;
  case scheme_begin_for_syntax_type:
    expr = begin_for_syntax_sfs(expr, info);
    break;
  case scheme_set_bang_type:
    expr = set_sfs(expr, info);
    break;
  case scheme_boxenv_type:
    expr = bangboxenv_sfs(expr, info);
    break;
  case scheme_begin0_sequence_type:
    expr = begin0_sfs(expr, info);
    break;
  case scheme_require_form_type:
    expr = top_level_require_sfs(expr, info);
    break;
  case scheme_varref_form_type:
    expr = ref_sfs(expr, info);
    break;
  case scheme_apply_values_type:
    expr = apply_values_sfs(expr, info);
    break;
  case scheme_case_lambda_sequence_type:
    expr = case_lambda_sfs(expr, info);
    break;
  case scheme_module_type:
    expr = module_sfs(expr, info);
    break;
  case scheme_inline_variant_type:
    expr = inline_variant_sfs(expr, info);
    break;
  default:
    break;
  }

  info->ip++;

  if (seqn) {
    info->seqn = seqn - 1;
    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;
    info->tail_pos = tp;
  }

  return expr;
}