[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Replace libltdl with raw dlopen, dlsym
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Replace libltdl with raw dlopen, dlsym |
|
Date: |
Fri, 22 Jan 2021 11:01:17 -0500 (EST) |
wingo pushed a commit to branch excise-ltdl
in repository guile.
commit 888bd9255fdddcb51b20a47f35f35eca8075e48f
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Jan 22 16:39:11 2021 +0100
Replace libltdl with raw dlopen, dlsym
* am/bootstrap.am (SOURCES):
* module/Makefile.am (SOURCES): Add ice-9/dynl.scm.
* configure.ac: Replace ltdl check with -ldl check.
* libguile/deprecated.c (scm_dynamic_func, scm_dynamic_call):
Deprecate.
* libguile/dynl.c: Rewrite to just expose core dlopen / dlsym / etc to a
helper Scheme module.
* libguile/extensions.c (load_extension): Avoid scm_dynamic_call.
* module/ice-9/boot-9.scm: Use (ice-9 dynl).
* module/ice-9/dynl.scm: New file.
* module/oop/goops.scm (<dynamic-object>): Hackily export a record type
instead of a class here.
---
am/bootstrap.am | 3 +-
configure.ac | 8 +-
doc/ref/api-foreign.texi | 6 +-
libguile/deprecated.c | 26 ++-
libguile/deprecated.h | 5 +-
libguile/dynl.c | 405 +++++++++++------------------------------------
libguile/dynl.h | 4 +-
libguile/extensions.c | 7 +-
libguile/guile.c | 3 +-
module/Makefile.am | 3 +-
module/ice-9/boot-9.scm | 8 +
module/ice-9/dynl.scm | 182 +++++++++++++++++++++
module/oop/goops.scm | 9 +-
13 files changed, 333 insertions(+), 336 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 2821304..5f5bae2 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -1,4 +1,4 @@
-## Copyright (C) 2009-2020 Free Software Foundation, Inc.
+## Copyright (C) 2009-2021 Free Software Foundation, Inc.
##
## This file is part of GNU Guile.
##
@@ -96,6 +96,7 @@ SOURCES = \
ice-9/binary-ports.scm \
ice-9/command-line.scm \
ice-9/control.scm \
+ ice-9/dynl.scm \
ice-9/format.scm \
ice-9/getopt-long.scm \
ice-9/i18n.scm \
diff --git a/configure.ac b/configure.ac
index bc7bfc6..8166a56 100644
--- a/configure.ac
+++ b/configure.ac
@@ -105,12 +105,8 @@ AC_PROG_LIBTOOL
AM_CONDITIONAL([HAVE_SHARED_LIBRARIES], [test "x$enable_shared" = "xyes"])
-dnl Check for libltdl.
-AC_LIB_HAVE_LINKFLAGS([ltdl], [], [#include <ltdl.h>],
- [lt_dlopenext ("foo");])
-if test "x$HAVE_LIBLTDL" != "xyes"; then
- AC_MSG_ERROR([GNU libltdl (Libtool) not found, see README.])
-fi
+# Some systems provide dlopen via libc; others require -ldl.
+AC_SEARCH_LIBS([dlopen], [dl])
AC_CHECK_PROG(have_makeinfo, makeinfo, yes, no)
AM_CONDITIONAL(HAVE_MAKEINFO, test "$have_makeinfo" = yes)
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index b0d6c24..4679c56 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016-2017
+@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016-2017, 2021
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -84,9 +84,7 @@ as @file{/usr/lib} and @file{/usr/local/lib}.
@var{library} should not contain an extension such as @code{.so}, unless
@var{library} represents the absolute file name to the shared library. The
correct file name extension for the host operating system is provided
-automatically, according to libltdl's rules (@pxref{Libltdl interface,
-lt_dlopenext, @code{lt_dlopenext}, libtool, Shared Library Support for
-GNU}).
+automatically.
When @var{library} is omitted, a @dfn{global symbol handle} is returned. This
handle provides access to the symbols available to the program at run-time,
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index fcc4e83..dc6c3b3 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -1,4 +1,4 @@
-/* Copyright 2003-2004,2006,2008-2018,2020
+/* Copyright 2003-2004,2006,2008-2018,2020,2021
Free Software Foundation, Inc.
This file is part of Guile.
@@ -31,7 +31,9 @@
#include "boolean.h"
#include "bitvectors.h"
#include "deprecation.h"
+#include "dynl.h"
#include "eval.h"
+#include "foreign.h"
#include "gc.h"
#include "gsubr.h"
#include "modules.h"
@@ -601,6 +603,28 @@ scm_copy_tree (SCM obj)
+SCM
+scm_dynamic_func (SCM name, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_dynamic_func is deprecated. Use scm_dynamic_pointer instead.");
+ return scm_dynamic_pointer (name, obj);
+}
+
+SCM
+scm_dynamic_call (SCM name, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_dynamic_call is deprecated. Use the FFI instead.");
+ SCM pointer = scm_dynamic_pointer (name, obj);
+ void (*f)(void) = SCM_POINTER_VALUE (pointer);
+ f ();
+ return SCM_UNSPECIFIED;
+}
+
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index c95f919..50ee01c 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -1,7 +1,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
-/* Copyright 2003-2007,2009-2018,2020
+/* Copyright 2003-2007,2009-2018,2020,2021
Free Software Foundation, Inc.
This file is part of Guile.
@@ -140,6 +140,9 @@ SCM_DEPRECATED SCM scm_make_srcprops (long line, int col,
SCM filename,
SCM_DEPRECATED SCM scm_copy_tree (SCM obj);
+SCM_DEPRECATED SCM scm_dynamic_func (SCM symb, SCM dobj);
+SCM_DEPRECATED SCM scm_dynamic_call (SCM symb, SCM dobj);
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/dynl.c b/libguile/dynl.c
index e9c03e9..a042023 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -1,6 +1,6 @@
/* dynl.c - dynamic linking
- Copyright 1990-2003,2008-2011,2017-2018
+ Copyright 1990-2003,2008-2011,2017-2018,2021
Free Software Foundation, Inc.
This file is part of Guile.
@@ -28,369 +28,148 @@
# include <config.h>
#endif
-#include <alloca.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include <ltdl.h>
+#include <dlfcn.h>
+#include "boolean.h"
#include "deprecation.h"
-#include "dynwind.h"
+#include "eval.h"
+#include "extensions.h"
#include "foreign.h"
-#include "gc.h"
#include "gsubr.h"
-#include "keywords.h"
-#include "libpath.h"
#include "list.h"
-#include "ports.h"
-#include "smob.h"
+#include "modules.h"
+#include "numbers.h"
#include "strings.h"
#include "threads.h"
+#include "variable.h"
+#include "version.h"
#include "dynl.h"
-/* From the libtool manual: "Note that libltdl is not threadsafe,
- i.e. a multithreaded application has to use a mutex for libltdl.".
- Note: We initialize it as a recursive mutex below. */
-static scm_i_pthread_mutex_t ltdl_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
-/* LT_PATH_SEP-separated extension library search path, searched last */
-static char *system_extensions_path;
-
-static void *
-sysdep_dynl_link (const char *fname, const char *subr)
+static SCM
+dlerror_string (const char *fallback)
{
- lt_dlhandle handle;
-
- /* Try the literal filename first or, if NULL, the program itself */
- handle = lt_dlopen (fname);
- if (handle == NULL)
- {
- handle = lt_dlopenext (fname);
-
- if (handle == NULL
-#ifdef LT_DIRSEP_CHAR
- && strchr (fname, LT_DIRSEP_CHAR) == NULL
-#endif
- && strchr (fname, '/') == NULL)
- {
- /* FNAME contains no directory separators and was not in the
- usual library search paths, so now we search for it in
- SYSTEM_EXTENSIONS_PATH. */
- char *fname_attempt
- = scm_gc_malloc_pointerless (strlen (system_extensions_path)
- + strlen (fname) + 2,
- "dynl fname_attempt");
- char *path; /* remaining path to search */
- char *end; /* end of current path component */
- char *s;
-
- /* Iterate over the components of SYSTEM_EXTENSIONS_PATH */
- for (path = system_extensions_path;
- *path != '\0';
- path = (*end == '\0') ? end : (end + 1))
- {
- /* Find end of path component */
- end = strchr (path, LT_PATHSEP_CHAR);
- if (end == NULL)
- end = strchr (path, '\0');
-
- /* Skip empty path components */
- if (path == end)
- continue;
-
- /* Construct FNAME_ATTEMPT, starting with path component */
- s = fname_attempt;
- memcpy (s, path, end - path);
- s += end - path;
-
- /* Append directory separator, but avoid duplicates */
- if (s[-1] != '/'
-#ifdef LT_DIRSEP_CHAR
- && s[-1] != LT_DIRSEP_CHAR
-#endif
- )
- *s++ = '/';
-
- /* Finally, append FNAME (including null terminator) */
- strcpy (s, fname);
-
- /* Try to load it, and terminate the search if successful */
- handle = lt_dlopenext (fname_attempt);
- if (handle != NULL)
- break;
- }
- }
- }
-
- if (handle == NULL)
- {
- SCM fn;
- SCM msg;
-
- 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;
+ const char *message = dlerror ();
+ if (message)
+ return scm_from_locale_string (message);
+ return scm_from_utf8_string ("Unknown error");
}
-static void
-sysdep_dynl_unlink (void *handle, const char *subr)
-{
- if (lt_dlclose ((lt_dlhandle) handle))
- {
- scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
- }
-}
-
-static void *
-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;
-}
-
-static void
-sysdep_dynl_init ()
-{
- char *env;
-
- lt_dlinit ();
-
- /* Initialize 'system_extensions_path' from
- $GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set:
- <SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>.
-
- 'lt_dladdsearchdir' can't be used because it is 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>.
-
- The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH
- can't be used because they would be propagated to subprocesses
- which may cause problems for other programs. See
- <http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */
-
- env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
- if (env)
- system_extensions_path = env;
- else
- {
- system_extensions_path
- = scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR)
- + strlen (SCM_EXTENSIONS_DIR) + 2,
- "system_extensions_path");
- sprintf (system_extensions_path, "%s%c%s",
- SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR);
- }
-}
-
-scm_t_bits scm_tc16_dynamic_obj;
-
-#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 int
-dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
-{
- scm_puts ("#<dynamic-object ", port);
- scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
- if (DYNL_HANDLE (exp) == NULL)
- scm_puts (" (unlinked)", port);
- scm_putc ('>', port);
- return 1;
-}
-
-
-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"
- "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}.\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
+SCM_DEFINE_STATIC (scm_dlopen, "dlopen", 2, 0, 0, (SCM name, SCM flags), "")
+#define FUNC_NAME s_scm_dlopen
{
void *handle;
- char *file;
-
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (<dl_lock);
+ int c_flags = scm_to_int (flags);
- if (SCM_UNBNDP (filename))
- file = NULL;
+ if (scm_is_false (name))
+ handle = dlopen (NULL, c_flags);
else
{
- file = scm_to_locale_string (filename);
- scm_dynwind_free (file);
+ char *c_name = scm_to_locale_string (name);
+ handle = dlopen (c_name, c_flags);
+ free (c_name);
}
- handle = sysdep_dynl_link (file, FUNC_NAME);
- scm_dynwind_end ();
+ if (!handle) {
+ SCM message = dlerror_string ("Unknown error while opening module");
+ SCM_MISC_ERROR ("file ~S, message ~S", scm_list_2 (name, message));
+ }
- SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
- SCM_UNBNDP (filename)
- ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
- handle);
+ return scm_from_pointer (handle, NULL);
}
#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 object handle,\n"
- "or @code{#f} otherwise.")
-#define FUNC_NAME s_scm_dynamic_object_p
+SCM_DEFINE_STATIC (scm_dlclose, "dlclose", 1, 0, 0, (SCM obj), "")
+#define FUNC_NAME s_scm_dlclose
{
- return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
-}
-#undef FUNC_NAME
-
+ void *handle = scm_to_pointer (obj);
-SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
- (SCM dobj),
- "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);
-
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (<dl_lock);
- if (DYNL_HANDLE (dobj) == NULL) {
- SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
- } else {
- sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
- SET_DYNL_HANDLE (dobj, NULL);
+ if (dlclose (handle) != 0) {
+ SCM message = dlerror_string ("Unknown error");
+ SCM_MISC_ERROR ("Error closing module: ~S", scm_list_1 (message));
}
- scm_dynwind_end ();
return SCM_UNSPECIFIED;
}
#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
+SCM_DEFINE_STATIC (scm_dlsym, "dlsym", 2, 0, 0, (SCM obj, SCM name), "")
+#define FUNC_NAME s_scm_dlsym
{
- void *val;
+ void *handle = scm_to_pointer (obj);
+ char *c_name = scm_to_utf8_string (name);
- SCM_VALIDATE_STRING (1, name);
- SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
+ void *sym = dlsym (handle, c_name);
+ free (c_name);
- if (DYNL_HANDLE (dobj) == NULL)
- SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
- else
- {
- char *chars;
-
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (<dl_lock);
- chars = scm_to_locale_string (name);
- scm_dynwind_free (chars);
- val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
- scm_dynwind_end ();
+ if (!sym) {
+ SCM message = dlerror_string ("Unknown error");
+ SCM_MISC_ERROR ("Error resolving ~S: ~S", scm_list_2 (name, message));
+ }
- return scm_from_pointer (val, NULL);
- }
+ return scm_from_pointer (sym, NULL);
}
#undef FUNC_NAME
+#define DEFINE_LAZY_VAR(c_name, mod_name, sym_name) \
+ static SCM c_name##_var; \
+ static void init_##c_name##_var (void) \
+ { \
+ c_name##_var = scm_c_public_lookup (mod_name, sym_name); \
+ } \
+ static SCM c_name (void) \
+ { \
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; \
+ scm_i_pthread_once (&once, init_##c_name##_var); \
+ return scm_variable_ref (c_name##_var); \
+ }
+
+DEFINE_LAZY_VAR (dynamic_link, "ice-9 dynl", "dynamic-link");
+DEFINE_LAZY_VAR (dynamic_unlink, "ice-9 dynl", "dynamic-unlink");
+DEFINE_LAZY_VAR (dynamic_object_p, "ice-9 dynl", "dynamic-object?");
+DEFINE_LAZY_VAR (dynamic_pointer, "ice-9 dynl", "dynamic-pointer");
-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
+SCM
+scm_dynamic_link (SCM filename)
{
- return scm_dynamic_pointer (name, dobj);
+ return scm_call_1 (dynamic_link (), filename);
}
-#undef FUNC_NAME
+SCM
+scm_dynamic_unlink (SCM obj)
+{
+ return scm_call_1 (dynamic_unlink (), obj);
+}
+
+SCM
+scm_dynamic_object_p (SCM obj)
+{
+ return scm_call_1 (dynamic_object_p (), obj);
+}
-SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
- (SCM func, SCM dobj),
- "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
+SCM
+scm_dynamic_pointer (SCM name, SCM obj)
{
- void (*fptr) (void);
+ return scm_call_2 (dynamic_pointer (), name, obj);
+}
- if (scm_is_string (func))
- func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_POINTER (SCM_ARG1, func);
+static void
+scm_init_ice_9_dynl (void)
+{
+ scm_c_define ("RTLD_LAZY", scm_from_int (RTLD_LAZY));
+ scm_c_define ("RTLD_NOW", scm_from_int (RTLD_NOW));
+ scm_c_define ("RTLD_GLOBAL", scm_from_int (RTLD_GLOBAL));
+ scm_c_define ("RTLD_LOCAL", scm_from_int (RTLD_LOCAL));
- fptr = SCM_POINTER_VALUE (func);
- fptr ();
- return SCM_UNSPECIFIED;
+#include "dynl.x"
}
-#undef FUNC_NAME
void
scm_init_dynamic_linking ()
{
- scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
- scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
-
- /* Make LTDL_LOCK recursive so that a pre-unwind handler can still use
- 'dynamic-link', as is the case at the REPL. See
- <https://bugs.gnu.org/29275>. */
- scm_i_pthread_mutex_init (<dl_lock,
- scm_i_pthread_mutexattr_recursive);
-
- sysdep_dynl_init ();
-#include "dynl.x"
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_ice_9_dynl",
+ (scm_t_extension_init_func) scm_init_ice_9_dynl,
+ NULL);
}
diff --git a/libguile/dynl.h b/libguile/dynl.h
index 3178c9a..35f4d9d 100644
--- a/libguile/dynl.h
+++ b/libguile/dynl.h
@@ -1,7 +1,7 @@
#ifndef SCM_DYNL_H
#define SCM_DYNL_H
-/* Copyright 1996,1998,2000-2001,2006,2008,2010,2018
+/* Copyright 1996,1998,2000-2001,2006,2008,2010,2018,2021
Free Software Foundation, Inc.
This file is part of Guile.
@@ -30,8 +30,6 @@ SCM_API SCM scm_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj);
SCM_API SCM scm_dynamic_pointer (SCM name, SCM dobj);
-SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
-SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
SCM_INTERNAL void scm_init_dynamic_linking (void);
diff --git a/libguile/extensions.c b/libguile/extensions.c
index a094159..61c975e 100644
--- a/libguile/extensions.c
+++ b/libguile/extensions.c
@@ -1,4 +1,4 @@
-/* Copyright 2001,2002,2004,2006,2009-2011,2018-2019
+/* Copyright 2001,2002,2004,2006,2009-2011,2018-2019,2021
Free Software Foundation, Inc.
This file is part of Guile.
@@ -27,6 +27,7 @@
#include "dynwind.h"
#include "gc.h"
#include "gsubr.h"
+#include "foreign.h"
#include "strings.h"
#include "threads.h"
@@ -113,7 +114,9 @@ load_extension (SCM lib, SCM init)
/* Dynamically link the library. */
#if HAVE_MODULES
- scm_dynamic_call (init, scm_dynamic_link (lib));
+ SCM pointer = scm_dynamic_pointer (init, scm_dynamic_link (lib));
+ void (*f)(void) = scm_to_pointer (pointer);
+ f ();
#else
scm_misc_error ("load-extension",
"extension ~S:~S not registered and dynamic-link disabled",
diff --git a/libguile/guile.c b/libguile/guile.c
index ae592ed..bafe5d6 100644
--- a/libguile/guile.c
+++ b/libguile/guile.c
@@ -1,4 +1,4 @@
-/* Copyright 1996-1997,2000-2001,2006,2008,2011,2013,2018
+/* Copyright 1996-1997,2000-2001,2006,2008,2011,2013,2018,2021
Free Software Foundation, Inc.
This file is part of Guile.
@@ -28,7 +28,6 @@
# include <config.h>
#endif
-#include <ltdl.h>
#include <locale.h>
#include <stdio.h>
diff --git a/module/Makefile.am b/module/Makefile.am
index 45113b5..451bbe6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2009-2020 Free Software Foundation, Inc.
+## Copyright (C) 2009-2021 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -108,6 +108,7 @@ SOURCES = \
ice-9/curried-definitions.scm \
ice-9/deprecated.scm \
ice-9/documentation.scm \
+ ice-9/dynl.scm \
ice-9/eval-string.scm \
ice-9/exceptions.scm \
ice-9/expect.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 89595f3..d682dd5 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4638,6 +4638,14 @@ R7RS."
+;;; {Dynamic linkins}
+;;;
+
+;; Allow users of (guile) to see dynamic-link et al.
+(module-use! the-scm-module (resolve-interface '(ice-9 dynl)))
+
+
+
;;; SRFI-4 in the default environment. FIXME: we should figure out how
;;; to deprecate this.
;;;
diff --git a/module/ice-9/dynl.scm b/module/ice-9/dynl.scm
new file mode 100644
index 0000000..f55b272
--- /dev/null
+++ b/module/ice-9/dynl.scm
@@ -0,0 +1,182 @@
+;;; Support for dynamic linking via dlopen and dlsym
+;;; Copyright (C) 2021 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 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
+;;; 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Implementation of dynamic-link.
+;;;
+;;; Code:
+
+
+(define-module (ice-9 dynl)
+ #:export (dynamic-link
+ dynamic-unlink
+ dynamic-object?
+ dynamic-pointer))
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_ice_9_dynl")
+
+(define (system-library-extensions)
+ (cond
+ ((string-contains %host-type "-darwin-")
+ '(".bundle" ".so" ".dylib"))
+ ((or (string-contains %host-type "cygwin")
+ (string-contains %host-type "mingw")
+ (string-contains %host-type "msys"))
+ '(".dll"))
+ (else
+ '(".so"))))
+
+(define (has-extension? head exts)
+ (and (pair? exts)
+ (or (string-suffix? (car exts) head)
+ (has-extension? head (cdr exts)))))
+
+(define (file-exists-with-extension head exts)
+ (if (has-extension? head exts)
+ (and (file-exists? head) head)
+ (let lp ((exts exts))
+ (and (pair? exts)
+ (let ((head (string-append head (car exts))))
+ (if (file-exists? head)
+ head
+ (lp (cdr exts))))))))
+
+(define (file-exists-in-path-with-extension basename path exts)
+ (and (pair? path)
+ (or (file-exists-with-extension (in-vicinity (car path) basename) exts)
+ (file-exists-in-path-with-extension basename (cdr path) exts))))
+
+(define path-separator
+ (case (system-file-name-convention)
+ ((posix) #\:)
+ ((windows) #\;)
+ (else (error "unreachable"))))
+
+(define (default-library-path search-ltdl-library-path?)
+ (define (parse-path var default)
+ (let ((val (getenv var)))
+ (if val
+ (string-split val path-separator)
+ (default))))
+ (append
+ (parse-path "GUILE_EXTENSIONS_PATH" (lambda () '()))
+ (if search-ltdl-library-path?
+ (parse-path "LTDL_LIBRARY_PATH" (lambda () '()))
+ '())
+ (parse-path "GUILE_SYSTEM_EXTENSIONS_PATH"
+ (lambda ()
+ (list (assq-ref %guile-build-info 'libdir)
+ (assq-ref %guile-build-info 'extensionsdir))))))
+
+(define <dynamic-object>
+ (make-record-type '<dynamic-object> '(filename handle)))
+(define make-dynamic-object
+ (record-constructor <dynamic-object>))
+(define dynamic-object-filename
+ (record-accessor <dynamic-object> 'filename))
+(define dynamic-object-handle
+ (record-accessor <dynamic-object> 'handle))
+(define set-dynamic-object-handle!
+ (record-modifier <dynamic-object> 'handle))
+
+(define* (dynamic-link #:optional filename #:key
+ (extensions (system-library-extensions))
+ (search-ltdl-library-path? #t)
+ (library-path (default-library-path
+ search-ltdl-library-path?))
+ (search-system-paths? #t)
+ (flags (logior RTLD_LAZY RTLD_LOCAL)))
+ (define (error-not-found)
+ (scm-error 'misc-error "dynamic-link"
+ "file: ~S, message: ~S"
+ (list filename "file not found")
+ #f))
+ (define (dlopen* name) (dlopen name flags))
+ (make-dynamic-object
+ filename
+ (cond
+ ((not filename)
+ ;; The self-open trick.
+ (dlopen* #f))
+ ((or (absolute-file-name? filename)
+ (string-any file-name-separator? filename))
+ (cond
+ ((file-exists-with-extension filename extensions)
+ => dlopen*)
+ (else
+ (error-not-found))))
+ ((file-exists-in-path-with-extension filename library-path extensions)
+ => dlopen*)
+ (search-system-paths?
+ (if (or (null? extensions) (has-extension? filename extensions))
+ (dlopen* filename)
+ (let lp ((extensions extensions))
+ (let ((extension (car extensions))
+ (extensions (cdr extensions)))
+ (if (null? extensions)
+ ;; Open in tail position to propagate any exception.
+ (dlopen* (string-append filename extension))
+ ;; If there is more than one extension, unfortunately we
+ ;; swallow any error for previous extensions. This is
+ ;; not great because maybe the library was found with
+ ;; the first extension, failed to load and had an
+ ;; interesting error, but then we swallowed that
+ ;; interesting error and proceeded, eventually throwing
+ ;; a "file not found" exception. FIXME to use more
+ ;; structured exceptions and stop if the error that we
+ ;; get is more specific than just "file not found".
+ (or (false-if-exception
+ (dlopen* (string-append filename extension)))
+ (lp extensions)))))))
+ (else
+ (error-not-found)))))
+
+(define dynamic-object? (record-predicate <dynamic-object>))
+
+(define (dynamic-unlink obj)
+ (let ((handle (dynamic-object-handle obj)))
+ (unless handle
+ (scm-error 'misc-error "dynamic-unlink" "Already unlinked: ~S"
+ (list obj) #f))
+ (dlclose handle)
+ (set-dynamic-object-handle! obj #f)))
+
+(define (dynamic-pointer name obj)
+ (let ((handle (dynamic-object-handle obj)))
+ (unless handle
+ (scm-error 'misc-error "dynamic-unlink" "Already unlinked: ~S"
+ (list obj) #f))
+ (dlsym handle name)))
+
+(begin-deprecated
+ (define-public (dynamic-func name obj)
+ (issue-deprecation-warning
+ "dynamic-func is deprecated. Use dynamic-pointer instead.")
+ (dynamic-pointer name obj))
+
+ (define-public (dynamic-call func obj)
+ (issue-deprecation-warning
+ "dynamic-call is deprecated. Use the FFI in (system foreign) instead.")
+ (let* ((func (if (string? func)
+ (dynamic-func func obj)))
+ ;; Use module-ref etc to avoid ffi in boot closure
+ (ffi (resolve-interface '(system foreign)))
+ (void (module-ref ffi 'void))
+ (pointer->procedure (module-ref ffi 'pointer->procedure)))
+ ((pointer->procedure void func '())))))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index df6df4f..d88a76b 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
;;;; goops.scm -- The Guile Object-Oriented Programming System
;;;;
-;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018
+;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018,2021
;;;; Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
@@ -3307,10 +3307,15 @@ var{initargs}."
(define <directory> (find-subclass <top> '<directory>))
(define <array> (find-subclass <top> '<array>))
(define <character-set> (find-subclass <top> '<character-set>))
-(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
(define <guardian> (find-subclass <applicable> '<guardian>))
(define <macro> (find-subclass <top> '<macro>))
+;; <dynamic-object> used to be a SMOB type, albeit not exported even to
+;; C. However now it's a record type, though still private. Cross our
+;; fingers that nobody is using it in anger!
+(define <dynamic-object>
+ (module-ref (resolve-module '(ice-9 dynl)) '<dynamic-object>))
+
(define (define-class-subtree class)
(define! (class-name class) class)
(for-each define-class-subtree (class-direct-subclasses class)))