/* dynl.c - dynamic linking
*
- * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc.
+ * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
+ * 2003, 2008, 2009, 2010 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
#include <string.h>
#include "libguile/_scm.h"
+#include "libguile/libpath.h"
#include "libguile/dynl.h"
#include "libguile/smob.h"
#include "libguile/keywords.h"
#include "libguile/deprecation.h"
#include "libguile/lang.h"
#include "libguile/validate.h"
+#include "libguile/dynwind.h"
+#include "libguile/foreign.h"
-#ifdef DYNAMIC_LINKING
-
-#include "libltdl/ltdl.h"
+#include <ltdl.h>
-/* From the libtool manual: "Note that libltdl is not threadsafe,
- i.e. a multithreaded application has to use a mutex for libltdl.".
+/*
+ From the libtool manual: "Note that libltdl is not threadsafe,
+ i.e. a multithreaded application has to use a mutex for libltdl.".
- Guile does not currently support pre-emptive threads, so there is
- no mutex. Previously SCM_DEFER_INTS and SCM_ALLOW_INTS were used:
- they are mentioned here in case somebody is grepping for thread
- problems ;)
+ Guile does not currently support pre-emptive threads, so there is no
+ mutex. Previously SCM_CRITICAL_SECTION_START and
+ SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
+ somebody is grepping for thread problems ;)
*/
+/* njrev: not threadsafe, protection needed as described above */
static void *
sysdep_dynl_link (const char *fname, const char *subr)
SCM fn;
SCM msg;
- fn = scm_makfrom0str (fname);
- msg = scm_makfrom0str (lt_dlerror ());
+ fn = scm_from_locale_string (fname);
+ msg = scm_from_locale_string (lt_dlerror ());
scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
}
return (void *) handle;
}
static void *
-sysdep_dynl_func (const char *symb, void *handle, const char *subr)
+sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{
void *fptr;
static void
sysdep_dynl_init ()
{
- lt_dlinit ();
-}
-
-#else
+ char *env;
-/* no dynamic linking available, throw errors. */
-
-static void
-sysdep_dynl_init (void)
-{
-}
-
-static void
-no_dynl_error (const char *subr)
-{
- scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
-}
-
-static void *
-sysdep_dynl_link (const char *filename, const char *subr)
-{
- no_dynl_error (subr);
- return NULL;
-}
-
-static void
-sysdep_dynl_unlink (void *handle,
- const char *subr)
-{
- no_dynl_error (subr);
-}
+ lt_dlinit ();
-static void *
-sysdep_dynl_func (const char *symbol,
- void *handle,
- const char *subr)
-{
- no_dynl_error (subr);
- return NULL;
+ env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
+ if (env && strcmp (env, "") == 0)
+ /* special-case interpret system-ltdl-path=="" as meaning no system path,
+ which is the case during the build */
+ ;
+ else if (env)
+ /* FIXME: should this be a colon-separated path? Or is the only point to
+ allow the build system to turn off the installed extensions path? */
+ lt_dladdsearchdir (env);
+ else
+ {
+ lt_dladdsearchdir (SCM_LIB_DIR);
+ lt_dladdsearchdir (SCM_EXTENSIONS_DIR);
+ }
}
-#endif
-
scm_t_bits scm_tc16_dynamic_obj;
-#define DYNL_FILENAME(x) (SCM_CELL_OBJECT_1 (x))
-#define DYNL_HANDLE(x) ((void *) SCM_CELL_WORD_2 (x))
-#define SET_DYNL_HANDLE(x, v) (SCM_SET_CELL_WORD_2 ((x), (v)))
+#define DYNL_FILENAME SCM_SMOB_OBJECT
+#define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x))
+#define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
-static SCM
-dynl_obj_mark (SCM ptr)
-{
- return DYNL_FILENAME (ptr);
-}
-
static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
(SCM filename),
- "Open the dynamic library called @var{filename}. A library\n"
- "handle representing the opened library is returned; this handle\n"
- "should be used as the @var{dobj} argument to the following\n"
- "functions.")
+ "Find the shared object (shared library) denoted by\n"
+ "@var{filename} and link it into the running Guile\n"
+ "application. The returned\n"
+ "scheme object is a ``handle'' for the library which can\n"
+ "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
+ "Searching for object files is system dependent. Normally,\n"
+ "if @var{filename} does have an explicit directory it will\n"
+ "be searched for in locations\n"
+ "such as @file{/usr/lib} and @file{/usr/local/lib}.")
#define FUNC_NAME s_scm_dynamic_link
{
void *handle;
+ char *file;
- SCM_VALIDATE_STRING (1, filename);
- handle = sysdep_dynl_link (SCM_STRING_CHARS (filename), FUNC_NAME);
+ scm_dynwind_begin (0);
+ file = scm_to_locale_string (filename);
+ scm_dynwind_free (file);
+ handle = sysdep_dynl_link (file, FUNC_NAME);
+ scm_dynwind_end ();
SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
}
#undef FUNC_NAME
SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
(SCM obj),
- "Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}\n"
- "otherwise.")
+ "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
+ "or @code{#f} otherwise.")
#define FUNC_NAME s_scm_dynamic_object_p
{
- return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
+ return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
(SCM dobj),
- "Unlink the indicated object file from the application. The\n"
- "argument @var{dobj} must have been obtained by a call to\n"
- "@code{dynamic-link}. After @code{dynamic-unlink} has been\n"
- "called on @var{dobj}, its content is no longer accessible.")
+ "Unlink a dynamic object from the application, if possible. The\n"
+ "object must have been linked by @code{dynamic-link}, with \n"
+ "@var{dobj} the corresponding handle. After this procedure\n"
+ "is called, the handle can no longer be used to access the\n"
+ "object.")
#define FUNC_NAME s_scm_dynamic_unlink
{
/*fixme* GC-problem */
SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL) {
- SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
+ SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
} else {
sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
SET_DYNL_HANDLE (dobj, NULL);
#undef FUNC_NAME
-SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
- (SCM name, SCM dobj),
- "Search the dynamic object @var{dobj} for the C function\n"
- "indicated by the string @var{name} and return some Scheme\n"
- "handle that can later be used with @code{dynamic-call} to\n"
- "actually call the function.\n\n"
- "Regardless whether your C compiler prepends an underscore @samp{_} to\n"
- "the global names in a program, you should @strong{not} include this\n"
- "underscore in @var{function}. Guile knows whether the underscore is\n"
- "needed or not and will add it when necessary.")
-#define FUNC_NAME s_scm_dynamic_func
+SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
+ (SCM name, SCM type, SCM dobj, SCM len),
+ "Return a ``handle'' for the pointer @var{name} in the\n"
+ "shared object referred to by @var{dobj}. The handle\n"
+ "aliases a C value, and is declared to be of type\n"
+ "@var{type}. Valid types are defined in the\n"
+ "@code{(system vm ffi)} module.\n\n"
+ "This facility works by asking the operating system for\n"
+ "the address of a symbol, then assuming that it aliases a\n"
+ "value of a given type. Obviously, the user must be very\n"
+ "careful to ensure that the value actually is of the\n"
+ "declared type, or bad things will happen.\n\n"
+ "Regardless whether your C compiler prepends an underscore\n"
+ "@samp{_} to the global names in a program, you should\n"
+ "@strong{not} include this underscore in @var{name}\n"
+ "since it will be added automatically when necessary.")
+#define FUNC_NAME s_scm_dynamic_pointer
{
- /* The returned handle is formed by casting the address of the function to a
- * long value and converting this to a scheme number
- */
-
- void (*func) ();
+ void *val;
+ scm_t_foreign_type t;
SCM_VALIDATE_STRING (1, name);
+ t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
/*fixme* GC-problem */
- SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
+ SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL) {
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
} else {
char *chars;
- chars = SCM_STRING_CHARS (name);
- func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME);
- return scm_ulong2num ((unsigned long) func);
+ scm_dynwind_begin (0);
+ chars = scm_to_locale_string (name);
+ scm_dynwind_free (chars);
+ val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
+ scm_dynwind_end ();
+ return scm_take_foreign_pointer (t, val,
+ SCM_UNBNDP (len) ? 0 : scm_to_size_t (len),
+ NULL);
}
}
#undef FUNC_NAME
+SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
+ (SCM name, SCM dobj),
+ "Return a ``handle'' for the function @var{name} in the\n"
+ "shared object referred to by @var{dobj}. The handle\n"
+ "can be passed to @code{dynamic-call} to actually\n"
+ "call the function.\n\n"
+ "Regardless whether your C compiler prepends an underscore\n"
+ "@samp{_} to the global names in a program, you should\n"
+ "@strong{not} include this underscore in @var{name}\n"
+ "since it will be added automatically when necessary.")
+#define FUNC_NAME s_scm_dynamic_func
+{
+ return scm_dynamic_pointer (name,
+ scm_from_uint (SCM_FOREIGN_TYPE_VOID),
+ dobj,
+ SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
(SCM func, SCM dobj),
- "Call the C function indicated by @var{func} and @var{dobj}.\n"
- "The function is passed no arguments and its return value is\n"
- "ignored. When @var{function} is something returned by\n"
- "@code{dynamic-func}, call that function and ignore @var{dobj}.\n"
- "When @var{func} is a string , look it up in @var{dynobj}; this\n"
- "is equivalent to\n"
- "@smallexample\n"
- "(dynamic-call (dynamic-func @var{func} @var{dobj} #f))\n"
- "@end smallexample\n\n")
+ "Call a C function in a dynamic object. Two styles of\n"
+ "invocation are supported:\n\n"
+ "@itemize @bullet\n"
+ "@item @var{func} can be a function handle returned by\n"
+ "@code{dynamic-func}. In this case @var{dobj} is\n"
+ "ignored\n"
+ "@item @var{func} can be a string with the name of the\n"
+ "function to call, with @var{dobj} the handle of the\n"
+ "dynamic object in which to find the function.\n"
+ "This is equivalent to\n"
+ "@smallexample\n\n"
+ "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
+ "@end smallexample\n"
+ "@end itemize\n\n"
+ "In either case, the function is passed no arguments\n"
+ "and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call
{
void (*fptr) ();
- if (SCM_STRINGP (func))
+ if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- fptr = (void (*) ()) SCM_NUM2ULONG (1, func);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
+
+ fptr = SCM_FOREIGN_POINTER (func, void);
fptr ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-/* return a newly allocated array of char pointers to each of the strings
- in args, with a terminating NULL pointer. */
-/* Note: a similar function is defined in posix.c, but we don't necessarily
- want to export it. */
-static char **allocate_string_pointers (SCM args, int *num_args_return)
-{
- char **result;
- int n_args = scm_ilength (args);
- int i;
-
- SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers");
- result = (char **) scm_malloc ((n_args + 1) * sizeof (char *));
- result[n_args] = NULL;
- for (i = 0; i < n_args; i++)
- {
- SCM car = SCM_CAR (args);
-
- if (!SCM_STRINGP (car))
- {
- free (result);
- scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car);
- }
- result[i] = SCM_STRING_CHARS (SCM_CAR (args));
- args = SCM_CDR (args);
- }
- *num_args_return = n_args;
- return result;
-}
-
SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
(SCM func, SCM dobj, SCM args),
"Call the C function indicated by @var{func} and @var{dobj},\n"
int result, argc;
char **argv;
- if (SCM_STRINGP (func))
+ if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
+
+ fptr = SCM_FOREIGN_POINTER (func, void);
- fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func);
- argv = allocate_string_pointers (args, &argc);
- /* if the procedure mutates its arguments, the original strings will be
- changed -- in Guile 1.6 and earlier, this wasn't the case since a
- new copy of each string was allocated. */
+ argv = scm_i_allocate_string_pointers (args);
+ for (argc = 0; argv[argc]; argc++)
+ ;
result = (*fptr) (argc, argv);
- free (argv);
- return SCM_MAKINUM (0L + result);
+ return scm_from_int (result);
}
#undef FUNC_NAME
scm_init_dynamic_linking ()
{
scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
- scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
sysdep_dynl_init ();
#include "libguile/dynl.x"
HCoop / bpt / guile.git / blobdiff