mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Replace libltdl with raw dlopen, dlsym
* NEWS: Update. * am/bootstrap.am (SOURCES): * module/Makefile.am (SOURCES): Add system/foreign-library.scm. * configure.ac: Replace ltdl check with -ldl check. * libguile/dynl.c: Rewrite to just expose core dlopen / dlsym / etc to a helper Scheme module. (scm_dynamic_link, scm_dynamic_pointer, scm_dynamic_function) (scm_dynamic_object_p, scm_dynamic_call): Rewrite in terms of (system foreign-library). * libguile/extensions.c (load_extension): Avoid scm_dynamic_call. * module/system/foreign-library.scm: New file. * module/oop/goops.scm (<dynamic-object>): Hackily export <foreign-library> instead of a class here. * doc/ref/api-foreign.texi (Foreign Function Interface): Rewrite to only document the new interfaces. Eventually we will deprecate dynamic-link and friends. * doc/ref/guile.texi (API Reference): Move Foreign Objects after Foreign Function Interface. Seems there should be some closer relationship but this will do for now. * doc/ref/tour.texi (Putting Extensions into Modules): * doc/ref/libguile-parallel.texi (Parallel Installations): Update for rename of Modules and Extensions to Foreign Extensions. * libguile/deprecated.h: * libguile/deprecated.c (scm_dynamic_unlink): Deprecate. * libguile/guile.c: Remove ltdl include. * test-suite/tests/foreign.test: Update tests to use new API, and update error expectations.
This commit is contained in:
Andy Wingo
parent
480d86df68
commit
2e26538d6a
17 changed files with 934 additions and 911 deletions
55
NEWS
55
NEWS
|
|
@ -7,6 +7,46 @@ Please send Guile bug reports to bug-guile@gnu.org.
|
|||
|
||||
Changes in 3.0.6 (since 3.0.5)
|
||||
|
||||
* Notable changes
|
||||
|
||||
** Reimplement dynamic library loading ("dlopening") without libltdl
|
||||
|
||||
Guile used to load dynamic libraries with libltdl, a library provided by
|
||||
the Libtool project.
|
||||
|
||||
Libltdl provided some compatibility benefits when loading shared
|
||||
libraries made with older toolchains on older operating systems.
|
||||
However, no system from the last 10 years or so appears to need such a
|
||||
thick compatibility layer.
|
||||
|
||||
Besides being an unmaintained dependency of limited utility, libltdl
|
||||
also has the negative aspect that in its search for libraries to load,
|
||||
it could swallow useful errors for libraries that are found but not
|
||||
loadable, instead showing just errors for search path candidates that
|
||||
are not found.
|
||||
|
||||
Guile now implements dynamic library loading directly in terms of the
|
||||
standard "dlopen" interface, providing a limited shim for platforms with
|
||||
similar functionality exposed under different names (MinGW).
|
||||
|
||||
This change has a few practical impacts to Guile users. There is a new
|
||||
library search path variable, `GUILE_EXTENSIONS_DIR'. Also, errors when
|
||||
loading a library fails now have better errors. And Guile no longer has
|
||||
a libltdl dependency.
|
||||
|
||||
Although Guile no longer uses libltdl, for backwards compatibility Guile
|
||||
still adds `LTDL_LIBRARY_PATH' to the loadable library search path, and
|
||||
includes ad-hoc logic to support uninstalled dynamically loadable
|
||||
libraries via also adding the ".libs" subdirectories of
|
||||
`LTDL_LIBRARY_PATH' elements. See "Foreign Libraries" in the
|
||||
documentation for a full discussion.
|
||||
|
||||
** Updated Gnulib
|
||||
|
||||
The Gnulib compatibility library has been updated, for the first time
|
||||
since 2017 or so. We expect no functional change but look forward to
|
||||
any bug reports.
|
||||
|
||||
* New interfaces and functionality
|
||||
|
||||
** `call-with-port'
|
||||
|
|
@ -17,6 +57,21 @@ See "Ports" in the manual.
|
|||
|
||||
See "Bytevector Ports" in the manual.
|
||||
|
||||
** `GUILE_EXTENSIONS_DIR' environment variable.
|
||||
|
||||
** `(system foreign-library)' module
|
||||
|
||||
See the newly reorganized "Foreign Function Interface", for details.
|
||||
These new interfaces replace `dynamic-link', `dynamic-pointer' and
|
||||
similar, which will eventually be deprecated.
|
||||
|
||||
* New deprecations
|
||||
|
||||
** `dynamic-unlink'
|
||||
|
||||
This function now has no effect; Guile will not unload dynamically
|
||||
linked modules, as that can destabilize the system.
|
||||
|
||||
* Incompatible changes
|
||||
|
||||
** `call-with-output-string' closes port on normal exit
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
##
|
||||
|
|
@ -120,6 +120,7 @@ SOURCES = \
|
|||
system/vm/program.scm \
|
||||
system/vm/vm.scm \
|
||||
system/foreign.scm \
|
||||
system/foreign-library.scm \
|
||||
\
|
||||
language/tree-il/compile-cps.scm \
|
||||
language/tree-il/cps-primitives.scm \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -13,7 +13,7 @@
|
|||
@copying
|
||||
This manual documents Guile version @value{VERSION}.
|
||||
|
||||
Copyright (C) 1996-1997, 2000-2005, 2009-2020 Free Software Foundation,
|
||||
Copyright (C) 1996-1997, 2000-2005, 2009-2021 Free Software Foundation,
|
||||
Inc.
|
||||
|
||||
Permission is granted to copy, distribute and/or modify this document
|
||||
|
|
@ -299,8 +299,6 @@ available through both Scheme and C interfaces.
|
|||
* Initialization:: Initializing Guile.
|
||||
* Snarfing Macros:: Macros for snarfing initialization actions.
|
||||
* Data Types:: Representing values in Guile.
|
||||
* Foreign Objects:: Defining new data types in C.
|
||||
* Smobs:: Use foreign objects instead.
|
||||
* Procedures:: Procedures.
|
||||
* Macros:: Extending the syntax of Scheme.
|
||||
* Utility Functions:: General utility functions.
|
||||
|
|
@ -314,6 +312,8 @@ available through both Scheme and C interfaces.
|
|||
* Memory Management:: Memory management and garbage collection.
|
||||
* Modules:: Designing reusable code libraries.
|
||||
* Foreign Function Interface:: Interacting with C procedures and data.
|
||||
* Foreign Objects:: Defining new data types in C.
|
||||
* Smobs:: Use foreign objects instead.
|
||||
* Scheduling:: Threads, mutexes, asyncs and dynamic roots.
|
||||
* Options and Config:: Configuration, features and runtime options.
|
||||
* Other Languages:: Emacs Lisp, ECMAScript, and more.
|
||||
|
|
@ -328,8 +328,6 @@ available through both Scheme and C interfaces.
|
|||
@include api-init.texi
|
||||
@include api-snarf.texi
|
||||
@include api-data.texi
|
||||
@include api-foreign-objects.texi
|
||||
@include api-smobs.texi
|
||||
@include api-procedures.texi
|
||||
@include api-macros.texi
|
||||
@include api-utility.texi
|
||||
|
|
@ -343,6 +341,8 @@ available through both Scheme and C interfaces.
|
|||
@include api-memory.texi
|
||||
@include api-modules.texi
|
||||
@include api-foreign.texi
|
||||
@include api-foreign-objects.texi
|
||||
@include api-smobs.texi
|
||||
@include api-scheduling.texi
|
||||
@c object orientation support here
|
||||
@include api-options.texi
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011,
|
||||
@c 2013-2014 Free Software Foundation, Inc.
|
||||
@c 2013-2014, 2021 Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
@node Parallel Installations
|
||||
|
|
@ -52,8 +52,8 @@ how to use it from Autoconf.
|
|||
@item extensiondir
|
||||
@cindex @code{extensiondir}
|
||||
The default directory where Guile looks for extensions---i.e., shared
|
||||
libraries providing additional features (@pxref{Modules and
|
||||
Extensions}). Run @command{pkg-config guile-@value{EFFECTIVE-VERSION}
|
||||
libraries providing additional features (@pxref{Foreign Extensions}).
|
||||
Run @command{pkg-config guile-@value{EFFECTIVE-VERSION}
|
||||
--variable=extensiondir} to see its value.
|
||||
|
||||
@item guile
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011,
|
||||
@c 2012 Free Software Foundation, Inc.
|
||||
@c 2012, 2021 Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
@raisesections
|
||||
|
|
@ -280,7 +280,7 @@ scheme@@(guile-user)> (j0 2)
|
|||
$1 = 0.223890779141236
|
||||
@end smallexample
|
||||
|
||||
@xref{Modules and Extensions}, for more information.
|
||||
@xref{Foreign Extensions}, for more information.
|
||||
|
||||
@lowersections
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -599,6 +601,19 @@ scm_copy_tree (SCM obj)
|
|||
}
|
||||
|
||||
|
||||
|
||||
|
||||
SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, (SCM obj), "")
|
||||
#define FUNC_NAME s_scm_dynamic_unlink
|
||||
{
|
||||
scm_c_issue_deprecation_warning
|
||||
("scm_dynamic_unlink has no effect and is deprecated. Unloading "
|
||||
"shared libraries is no longer supported.");
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
|
||||
|
||||
void
|
||||
|
|
|
|||
|
|
@ -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,8 @@ 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_unlink (SCM obj);
|
||||
|
||||
void scm_i_init_deprecated (void);
|
||||
|
||||
#endif
|
||||
|
|
|
|||
439
libguile/dynl.c
439
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,172 @@
|
|||
# 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;
|
||||
int c_flags = scm_to_int (flags);
|
||||
|
||||
scm_dynwind_begin (0);
|
||||
scm_i_dynwind_pthread_mutex_lock (<dl_lock);
|
||||
|
||||
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 ();
|
||||
|
||||
SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
|
||||
SCM_UNBNDP (filename)
|
||||
? SCM_UNPACK (SCM_BOOL_F) : 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 object handle,\n"
|
||||
"or @code{#f} otherwise.")
|
||||
#define FUNC_NAME s_scm_dynamic_object_p
|
||||
{
|
||||
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 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 (!handle) {
|
||||
SCM message = dlerror_string ("Unknown error while opening module");
|
||||
SCM_MISC_ERROR ("file ~S, message ~S", scm_list_2 (name, message));
|
||||
}
|
||||
|
||||
return scm_from_pointer (handle, NULL);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE_STATIC (scm_dlclose, "dlclose", 1, 0, 0, (SCM obj), "")
|
||||
#define FUNC_NAME s_scm_dlclose
|
||||
{
|
||||
void *handle = scm_to_pointer (obj);
|
||||
|
||||
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;
|
||||
if (!sym) {
|
||||
SCM message = dlerror_string ("Unknown error");
|
||||
SCM_MISC_ERROR ("Error resolving ~S: ~S", scm_list_2 (name, message));
|
||||
}
|
||||
|
||||
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 ();
|
||||
|
||||
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); \
|
||||
}
|
||||
|
||||
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
|
||||
DEFINE_LAZY_VAR (load_foreign_library,
|
||||
"system foreign-library", "load-foreign-library");
|
||||
DEFINE_LAZY_VAR (foreign_library_p,
|
||||
"system foreign-library", "foreign-library?");
|
||||
DEFINE_LAZY_VAR (foreign_library_pointer,
|
||||
"system foreign-library", "foreign-library-pointer");
|
||||
|
||||
SCM
|
||||
scm_dynamic_link (SCM filename)
|
||||
{
|
||||
return scm_dynamic_pointer (name, dobj);
|
||||
return scm_call_1 (load_foreign_library (), filename);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
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_object_p (SCM obj)
|
||||
{
|
||||
void (*fptr) (void);
|
||||
return scm_call_1 (foreign_library_p (), obj);
|
||||
}
|
||||
|
||||
if (scm_is_string (func))
|
||||
func = scm_dynamic_func (func, dobj);
|
||||
SCM_VALIDATE_POINTER (SCM_ARG1, func);
|
||||
SCM
|
||||
scm_dynamic_pointer (SCM name, SCM obj)
|
||||
{
|
||||
return scm_call_2 (foreign_library_pointer (), obj, name);
|
||||
}
|
||||
|
||||
fptr = SCM_POINTER_VALUE (func);
|
||||
fptr ();
|
||||
SCM
|
||||
scm_dynamic_func (SCM name, SCM obj)
|
||||
{
|
||||
return scm_dynamic_pointer (name, obj);
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_dynamic_call (SCM name, SCM obj)
|
||||
{
|
||||
SCM pointer = scm_dynamic_pointer (name, obj);
|
||||
void (*f)(void) = SCM_POINTER_VALUE (pointer);
|
||||
f();
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static void
|
||||
scm_init_system_foreign_library (void *unused)
|
||||
{
|
||||
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));
|
||||
|
||||
#include "dynl.x"
|
||||
}
|
||||
|
||||
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);
|
||||
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
|
||||
"scm_init_system_foreign_library",
|
||||
scm_init_system_foreign_library,
|
||||
NULL);
|
||||
|
||||
/* 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"
|
||||
// FIXME: Deprecate all of these, once (system foreign-library) has
|
||||
// had enough time in the world.
|
||||
scm_c_define_gsubr
|
||||
("dynamic-link", 0, 1, 0, (scm_t_subr) scm_dynamic_link);
|
||||
scm_c_define_gsubr
|
||||
("dynamic-object?", 1, 0, 0, (scm_t_subr) scm_dynamic_object_p);
|
||||
scm_c_define_gsubr
|
||||
("dynamic-func", 2, 0, 0, (scm_t_subr) scm_dynamic_func);
|
||||
scm_c_define_gsubr
|
||||
("dynamic-pointer", 2, 0, 0, (scm_t_subr) scm_dynamic_pointer);
|
||||
scm_c_define_gsubr
|
||||
("dynamic-call", 2, 0, 0, (scm_t_subr) scm_dynamic_call);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
@ -27,11 +27,10 @@
|
|||
|
||||
|
||||
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_API SCM scm_dynamic_pointer (SCM name, SCM obj);
|
||||
SCM_API SCM scm_dynamic_func (SCM name, SCM obj);
|
||||
SCM_API SCM scm_dynamic_call (SCM name, SCM obj);
|
||||
|
||||
SCM_INTERNAL void scm_init_dynamic_linking (void);
|
||||
|
||||
|
|
|
|||
|
|
@ -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",
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
##
|
||||
|
|
@ -334,7 +334,7 @@ SOURCES = \
|
|||
system/base/ck.scm \
|
||||
\
|
||||
system/foreign.scm \
|
||||
\
|
||||
system/foreign-library.scm \
|
||||
system/foreign-object.scm \
|
||||
\
|
||||
system/repl/debug.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 '(system foreign-library)) '<foreign-library>))
|
||||
|
||||
(define (define-class-subtree class)
|
||||
(define! (class-name class) class)
|
||||
(for-each define-class-subtree (class-direct-subclasses class)))
|
||||
|
|
|
|||
231
module/system/foreign-library.scm
Normal file
231
module/system/foreign-library.scm
Normal file
|
|
@ -0,0 +1,231 @@
|
|||
;;; Dynamically linking foreign libraries 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 (system foreign-library)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (system foreign)
|
||||
#:export (guile-extensions-path
|
||||
ltdl-library-path
|
||||
guile-system-extensions-path
|
||||
|
||||
load-foreign-library
|
||||
foreign-library?
|
||||
foreign-library-pointer
|
||||
foreign-library-function))
|
||||
|
||||
(define-record-type <foreign-library>
|
||||
(make-foreign-library filename handle)
|
||||
foreign-library?
|
||||
(filename foreign-library-filename)
|
||||
(handle foreign-library-handle set-foreign-library-handle!))
|
||||
|
||||
(eval-when (expand load eval)
|
||||
(load-extension (string-append "libguile-" (effective-version))
|
||||
"scm_init_system_foreign_library"))
|
||||
|
||||
(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)
|
||||
(match exts
|
||||
(() #f)
|
||||
((ext . exts)
|
||||
(or (string-contains head ext)
|
||||
(has-extension? head exts)))))
|
||||
|
||||
(define (file-exists-with-extension head exts)
|
||||
(if (has-extension? head exts)
|
||||
(and (file-exists? head) head)
|
||||
(let lp ((exts exts))
|
||||
(match exts
|
||||
(() #f)
|
||||
((ext . exts)
|
||||
(let ((head (string-append head ext)))
|
||||
(if (file-exists? head)
|
||||
head
|
||||
(lp exts))))))))
|
||||
|
||||
(define (file-exists-in-path-with-extension basename path exts)
|
||||
(match path
|
||||
(() #f)
|
||||
((dir . path)
|
||||
(or (file-exists-with-extension (in-vicinity dir basename) exts)
|
||||
(file-exists-in-path-with-extension basename path exts)))))
|
||||
|
||||
(define path-separator
|
||||
(case (system-file-name-convention)
|
||||
((posix) #\:)
|
||||
((windows) #\;)
|
||||
(else (error "unreachable"))))
|
||||
|
||||
(define (parse-path var)
|
||||
(match (getenv var)
|
||||
(#f #f)
|
||||
;; Ignore e.g. "export GUILE_SYSTEM_EXTENSIONS_PATH=".
|
||||
("" '())
|
||||
(val (string-split val path-separator))))
|
||||
|
||||
(define guile-extensions-path
|
||||
(make-parameter
|
||||
(or (parse-path "GUILE_EXTENSIONS_PATH") '())))
|
||||
|
||||
(define ltdl-library-path
|
||||
(make-parameter
|
||||
(or (parse-path "LTDL_LIBRARY_PATH") '())))
|
||||
|
||||
(define guile-system-extensions-path
|
||||
(make-parameter
|
||||
(or (parse-path "GUILE_SYSTEM_EXTENSIONS_PATH")
|
||||
(list (assq-ref %guile-build-info 'libdir)
|
||||
(assq-ref %guile-build-info 'extensiondir)))))
|
||||
|
||||
;; There are a few messy situations here related to libtool.
|
||||
;;
|
||||
;; Guile used to use libltdl, the dynamic library loader provided by
|
||||
;; libtool. This loader used LTDL_LIBRARY_PATH, and for backwards
|
||||
;; compatibility we still support that path.
|
||||
;;
|
||||
;; However, libltdl would not only open ".so" (or ".dll", etc) files,
|
||||
;; but also the ".la" files created by libtool. In installed libraries
|
||||
;; -- libraries that are in the target directories of "make install" --
|
||||
;; .la files are never needed, to the extent that most GNU/Linux
|
||||
;; distributions remove them entirely. It is sufficient to just load
|
||||
;; the ".so" (or ".dll", etc) files.
|
||||
;;
|
||||
;; But for uninstalled dynamic libraries, like those in a build tree, it
|
||||
;; is a bit of a mess. If you have a project that uses libtool to build
|
||||
;; libraries -- which is the case for Guile, and for most projects using
|
||||
;; autotools -- and you build foo.so in directory D, libtool will put
|
||||
;; foo.la in D, but foo.so goes in D/.libs.
|
||||
;;
|
||||
;; The nice thing about ltdl was that it could load the .la file, even
|
||||
;; from a build tree, preventing the existence of ".libs" from leaking
|
||||
;; out to the user.
|
||||
;;
|
||||
;; We don't use libltdl now, essentially for flexibility and
|
||||
;; error-reporting reasons. But, it would be nice to keep this old
|
||||
;; use-case working. So as a stopgap solution, we add a ".libs" subdir
|
||||
;; to the path for each entry in LTDL_LIBRARY_PATH, in case the .so is
|
||||
;; there instead of alongside the .la file.
|
||||
(define (augment-ltdl-library-path path)
|
||||
(match path
|
||||
(() '())
|
||||
((dir . path)
|
||||
(cons* dir (in-vicinity dir ".libs")
|
||||
(augment-ltdl-library-path path)))))
|
||||
|
||||
(define (default-search-path search-ltdl-library-path?)
|
||||
(append
|
||||
(guile-extensions-path)
|
||||
(if search-ltdl-library-path?
|
||||
(augment-ltdl-library-path (ltdl-library-path))
|
||||
'())
|
||||
(guile-system-extensions-path)))
|
||||
|
||||
(define* (load-foreign-library #:optional filename #:key
|
||||
(extensions system-library-extensions)
|
||||
(search-ltdl-library-path? #t)
|
||||
(search-path (default-search-path
|
||||
search-ltdl-library-path?))
|
||||
(search-system-paths? #t)
|
||||
(lazy? #t) (global? #f))
|
||||
(define (error-not-found)
|
||||
(scm-error 'misc-error "load-foreign-library"
|
||||
"file: ~S, message: ~S"
|
||||
(list filename "file not found")
|
||||
#f))
|
||||
(define flags
|
||||
(logior (if lazy? RTLD_LAZY RTLD_NOW)
|
||||
(if global? RTLD_GLOBAL RTLD_LOCAL)))
|
||||
(define (dlopen* name) (dlopen name flags))
|
||||
(make-foreign-library
|
||||
filename
|
||||
(cond
|
||||
((not filename)
|
||||
;; The self-open trick.
|
||||
(dlopen* #f))
|
||||
((or (absolute-file-name? filename)
|
||||
(string-any file-name-separator? filename))
|
||||
(cond
|
||||
((or (file-exists-with-extension filename extensions)
|
||||
(and search-ltdl-library-path?
|
||||
(file-exists-with-extension
|
||||
(in-vicinity (in-vicinity (dirname filename) ".libs")
|
||||
(basename filename))
|
||||
extensions)))
|
||||
=> dlopen*)
|
||||
(else
|
||||
(error-not-found))))
|
||||
((file-exists-in-path-with-extension filename search-path extensions)
|
||||
=> dlopen*)
|
||||
(search-system-paths?
|
||||
(if (or (null? extensions) (has-extension? filename extensions))
|
||||
(dlopen* filename)
|
||||
(let lp ((extensions extensions))
|
||||
(match extensions
|
||||
((extension)
|
||||
;; Open in tail position to propagate any exception.
|
||||
(dlopen* (string-append filename extension)))
|
||||
((extension . extensions)
|
||||
;; If there is more than one extension, unfortunately we
|
||||
;; only report the error for the last extension. 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 (->foreign-library lib)
|
||||
(if (foreign-library? lib)
|
||||
lib
|
||||
(load-foreign-library lib)))
|
||||
|
||||
(define* (foreign-library-pointer lib name)
|
||||
(let ((handle (foreign-library-handle (->foreign-library lib))))
|
||||
(dlsym handle name)))
|
||||
|
||||
(define* (foreign-library-function lib name
|
||||
#:key
|
||||
(return-type void)
|
||||
(arg-types '())
|
||||
(return-errno? #f))
|
||||
(let ((pointer (foreign-library-pointer lib name)))
|
||||
(pointer->procedure return-type pointer arg-types
|
||||
#:return-errno? return-errno?)))
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2010, 2011, 2012, 2013, 2017 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2010, 2011, 2012, 2013, 2017, 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
|
||||
|
|
@ -21,6 +21,7 @@
|
|||
;;;
|
||||
|
||||
(define-module (test-foreign)
|
||||
#:use-module (system foreign-library)
|
||||
#:use-module (system foreign)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (srfi srfi-1)
|
||||
|
|
@ -29,12 +30,13 @@
|
|||
#:use-module (test-suite lib))
|
||||
|
||||
|
||||
(with-test-prefix "dynamic-pointer"
|
||||
(with-test-prefix "foreign-library-pointer"
|
||||
|
||||
(pass-if-exception
|
||||
"error message"
|
||||
'(misc-error . "^Symbol not found")
|
||||
(dynamic-func "does_not_exist___" (dynamic-link))))
|
||||
;; The error comes from dlsym, which is system-dependent.
|
||||
'(misc-error . "")
|
||||
(foreign-library-pointer #f "does_not_exist___")))
|
||||
|
||||
|
||||
(with-test-prefix "null pointer"
|
||||
|
|
@ -73,7 +75,7 @@
|
|||
|
||||
(pass-if "equal? modulo finalizer"
|
||||
(let ((finalizer (false-if-exception
|
||||
(dynamic-func "scm_is_pair" (dynamic-link)))))
|
||||
(foreign-library-pointer #f "scm_is_pair"))))
|
||||
(if (not finalizer)
|
||||
(throw 'unresolved) ; Windows or a static build
|
||||
(equal? (make-pointer 123)
|
||||
|
|
@ -81,7 +83,7 @@
|
|||
|
||||
(pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
|
||||
(let ((finalizer (false-if-exception
|
||||
(dynamic-func "scm_is_pair" (dynamic-link))))
|
||||
(foreign-library-pointer #f "scm_is_pair")))
|
||||
(ptr (make-pointer 123)))
|
||||
(if (not finalizer)
|
||||
(throw 'unresolved) ; Windows or a static build
|
||||
|
|
@ -232,19 +234,15 @@
|
|||
;; linking with `-export-dynamic'. Just skip these tests when it's
|
||||
;; not visible.
|
||||
(false-if-exception
|
||||
(pointer->procedure void
|
||||
(dynamic-func "qsort"
|
||||
(cond
|
||||
((string-contains %host-type "cygwin")
|
||||
;; On Cygwin, dynamic-link does
|
||||
;; not search recursively into
|
||||
;; linked DLLs. Thus, one needs
|
||||
;; to link to the core C
|
||||
;; library DLL explicitly.
|
||||
(dynamic-link "cygwin1"))
|
||||
(else
|
||||
(dynamic-link))))
|
||||
(list '* size_t size_t '*))))
|
||||
(foreign-library-function
|
||||
(cond
|
||||
((string-contains %host-type "cygwin")
|
||||
;; On Cygwin, load-foreign-library does not search recursively
|
||||
;; into linked DLLs. Thus, one needs to link to the core C
|
||||
;; library DLL explicitly.
|
||||
"cygwin1")
|
||||
(else #f))
|
||||
"qsort" #:arg-types (list '* size_t size_t '*))))
|
||||
|
||||
(define (dereference-pointer-to-byte ptr)
|
||||
(let ((b (pointer->bytevector ptr 1)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue