[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] branch excise-ltdl updated: Change tack to define a new
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] branch excise-ltdl updated: Change tack to define a new interface and eventually replace the old one |
|
Date: |
Sat, 23 Jan 2021 06:30:47 -0500 |
This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch excise-ltdl
in repository guile.
The following commit(s) were added to refs/heads/excise-ltdl by this push:
new 45089a9 Change tack to define a new interface and eventually replace
the old one
45089a9 is described below
commit 45089a925403718354ab71f4fd21938ba9ad3858
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sat Jan 23 12:30:21 2021 +0100
Change tack to define a new interface and eventually replace the old one
---
am/bootstrap.am | 2 +-
libguile/deprecated.c | 19 ++---
libguile/deprecated.h | 3 +-
libguile/dynl.c | 52 ++++++++++----
libguile/dynl.h | 5 +-
module/Makefile.am | 3 +-
module/ice-9/boot-9.scm | 8 ---
module/ice-9/dynl.scm | 182 ------------------------------------------------
8 files changed, 49 insertions(+), 225 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 5f5bae2..acc00c7 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -96,7 +96,6 @@ 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 \
@@ -121,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 \
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index dc6c3b3..e4909df 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -603,24 +603,15 @@ scm_copy_tree (SCM obj)
-SCM
-scm_dynamic_func (SCM name, 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_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 ();
+ ("scm_dynamic_unlink has no effect and is deprecated. Unloading "
+ "shared libraries is no longer supported.");
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 50ee01c..c68decf 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -140,8 +140,7 @@ 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);
+SCM_DEPRECATED SCM scm_dynamic_unlink (SCM obj);
void scm_i_init_deprecated (void);
diff --git a/libguile/dynl.c b/libguile/dynl.c
index a042023..8e1cc90 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -125,37 +125,48 @@ SCM_DEFINE_STATIC (scm_dlsym, "dlsym", 2, 0, 0, (SCM obj,
SCM name), "")
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");
+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_call_1 (dynamic_link (), filename);
+ return scm_call_1 (load_foreign_library (), filename);
}
SCM
-scm_dynamic_unlink (SCM obj)
+scm_dynamic_object_p (SCM obj)
{
- return scm_call_1 (dynamic_unlink (), obj);
+ return scm_call_1 (foreign_library_p (), obj);
}
SCM
-scm_dynamic_object_p (SCM obj)
+scm_dynamic_pointer (SCM name, SCM obj)
{
- return scm_call_1 (dynamic_object_p (), obj);
+ return scm_call_2 (foreign_library_pointer (), obj, name);
}
SCM
-scm_dynamic_pointer (SCM name, SCM obj)
+scm_dynamic_func (SCM name, SCM obj)
+{
+ return scm_dynamic_pointer (name, obj);
+}
+
+SCM
+scm_dynamic_call (SCM name, SCM obj)
{
- return scm_call_2 (dynamic_pointer (), name, obj);
+ SCM pointer = scm_dynamic_pointer (name, obj);
+ void (*f)(void) = SCM_POINTER_VALUE (pointer);
+ f();
+ return SCM_UNSPECIFIED;
}
static void
-scm_init_ice_9_dynl (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));
@@ -169,7 +180,20 @@ void
scm_init_dynamic_linking ()
{
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_ice_9_dynl",
- (scm_t_extension_init_func) scm_init_ice_9_dynl,
+ "scm_init_system_foreign_library",
+ scm_init_system_foreign_library,
NULL);
+
+ // 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);
}
diff --git a/libguile/dynl.h b/libguile/dynl.h
index 35f4d9d..dd10bf4 100644
--- a/libguile/dynl.h
+++ b/libguile/dynl.h
@@ -27,9 +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_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);
diff --git a/module/Makefile.am b/module/Makefile.am
index 451bbe6..86d5401 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -108,7 +108,6 @@ 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 \
@@ -335,7 +334,7 @@ SOURCES = \
system/base/ck.scm \
\
system/foreign.scm \
- \
+ system/foreign-library.scm \
system/foreign-object.scm \
\
system/repl/debug.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d682dd5..89595f3 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4638,14 +4638,6 @@ 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
deleted file mode 100644
index f55b272..0000000
--- a/module/ice-9/dynl.scm
+++ /dev/null
@@ -1,182 +0,0 @@
-;;; 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 '())))))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] branch excise-ltdl updated: Change tack to define a new interface and eventually replace the old one,
Andy Wingo <=