/* dynl.c - dynamic linking
*
* Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
- * 2003 Free Software Foundation, Inc.
+ * 2003, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* 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 2.1 of the License, or (at your option) any later version.
+ * 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 library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * 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.
*
* 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
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
Modified for libguile by Marius Vollmer */
}
#endif
+#include <stdlib.h>
#include <stdio.h>
#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/ports.h"
#include "libguile/strings.h"
#include "libguile/deprecation.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
+#include "libguile/foreign.h"
#include <ltdl.h>
sysdep_dynl_link (const char *fname, const char *subr)
{
lt_dlhandle handle;
- handle = lt_dlopenext (fname);
+
+ if (fname != NULL)
+ handle = lt_dlopenext (fname);
+ else
+ /* Return a handle for the program as a whole. */
+ handle = lt_dlopen (NULL);
+
if (NULL == handle)
{
SCM fn;
SCM msg;
- fn = scm_from_locale_string (fname);
+ fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
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;
fptr = lt_dlsym ((lt_dlhandle) handle, symb);
if (!fptr)
+ scm_misc_error (subr, "Symbol not found: ~a",
+ scm_list_1 (scm_from_locale_string (symb)));
+ return fptr;
+}
+
+/* Augment environment variable VARIABLE with VALUE, assuming VARIABLE
+ is a path kind of variable. */
+static void
+augment_env (const char *variable, const char *value)
+{
+ const char *env;
+
+ env = getenv (variable);
+ if (env != NULL)
{
- scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
+ char *new_value;
+ static const char path_sep[] = { LT_PATHSEP_CHAR, 0 };
+
+ new_value = alloca (strlen (env) + strlen (value) + 2);
+ strcpy (new_value, env);
+ strcat (new_value, path_sep);
+ strcat (new_value, value);
+
+ setenv (variable, new_value, 1);
}
- return fptr;
+ else
+ setenv (variable, value, 1);
}
static void
sysdep_dynl_init ()
{
+ char *env;
+
lt_dlinit ();
+
+ 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
+ {
+ /* Add SCM_LIB_DIR and SCM_EXTENSIONS_DIR to the loader's search
+ path. `lt_dladdsearchdir' and $LTDL_LIBRARY_PATH can't be used
+ for that because they are searched before the system-dependent
+ search path, which is the one `libtool --mode=execute -dlopen'
+ fiddles with (info "(libtool) Libltdl Interface"). See
+ <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>
+ for details. */
+ augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_LIB_DIR);
+ augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_EXTENSIONS_DIR);
+ }
}
scm_t_bits scm_tc16_dynamic_obj;
}
-SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
+SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0,
(SCM filename),
"Find the shared object (shared library) denoted by\n"
"@var{filename} and link it into the running Guile\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}.")
+ "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
+ "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
+ "returned. This handle provides access to the symbols\n"
+ "available to the program at run-time, including those exported\n"
+ "by the program itself and the shared libraries already loaded.\n")
#define FUNC_NAME s_scm_dynamic_link
{
void *handle;
char *file;
scm_dynwind_begin (0);
- file = scm_to_locale_string (filename);
- scm_dynwind_free (file);
+
+ if (SCM_UNBNDP (filename))
+ file = NULL;
+ else
+ {
+ 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);
+
+ SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
+ SCM_UNBNDP (filename)
+ ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
+ handle);
}
#undef FUNC_NAME
#undef FUNC_NAME
+SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
+ (SCM name, SCM dobj),
+ "Return a ``wrapped pointer'' to the symbol @var{name}\n"
+ "in the shared object referred to by @var{dobj}. The returned\n"
+ "pointer points to a C object.\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
+{
+ void *val;
+
+ SCM_VALIDATE_STRING (1, name);
+ SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
+
+ if (DYNL_HANDLE (dobj) == NULL)
+ SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
+ else
+ {
+ char *chars;
+
+ 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_from_pointer (val, 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"
"since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func
{
- /* 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) ();
-
- SCM_VALIDATE_STRING (1, name);
- /*fixme* GC-problem */
- SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
- if (DYNL_HANDLE (dobj) == NULL) {
- SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
- } else {
- char *chars;
-
- scm_dynwind_begin (0);
- chars = scm_to_locale_string (name);
- scm_dynwind_free (chars);
- func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
- FUNC_NAME);
- scm_dynwind_end ();
- return scm_from_ulong ((unsigned long) func);
- }
+ return scm_dynamic_pointer (name, dobj);
}
#undef FUNC_NAME
"and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call
{
- void (*fptr) ();
-
- if (scm_is_string (func))
- func = scm_dynamic_func (func, dobj);
- fptr = (void (*) ()) scm_to_ulong (func);
- fptr ();
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-static void
-free_string_pointers (void *data)
-{
- scm_i_free_string_pointers ((char **)data);
-}
-
-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"
- "just like @code{dynamic-call}, but pass it some arguments and\n"
- "return its return value. The C function is expected to take\n"
- "two arguments and return an @code{int}, just like @code{main}:\n"
- "@smallexample\n"
- "int c_func (int argc, char **argv);\n"
- "@end smallexample\n\n"
- "The parameter @var{args} must be a list of strings and is\n"
- "converted into an array of @code{char *}. The array is passed\n"
- "in @var{argv} and its size in @var{argc}. The return value is\n"
- "converted to a Scheme number and returned from the call to\n"
- "@code{dynamic-args-call}.")
-#define FUNC_NAME s_scm_dynamic_args_call
-{
- int (*fptr) (int argc, char **argv);
- int result, argc;
- char **argv;
-
- scm_dynwind_begin (0);
+ void (*fptr) (void);
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
+ SCM_VALIDATE_POINTER (SCM_ARG1, func);
- fptr = (int (*) (int, char **)) scm_to_ulong (func);
-
- argv = scm_i_allocate_string_pointers (args);
- scm_dynwind_unwind_handler (free_string_pointers, argv,
- SCM_F_WIND_EXPLICITLY);
- for (argc = 0; argv[argc]; argc++)
- ;
- result = (*fptr) (argc, argv);
-
- scm_dynwind_end ();
- return scm_from_int (result);
+ fptr = SCM_POINTER_VALUE (func);
+ fptr ();
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
HCoop / bpt / guile.git / blobdiff