mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
* dynl.c (scm_dynamic_func): New function to get the address of a
function in a dynamic object. (scm_dynamic_call, scm_dynamic_args_call): Accept the values produced by scm_dynamic_func as the thing to call. * dynl.c, dynl-dl.c, dynl-dld.c, dynl-shl.c: Restructured. (scm_register_module_xxx, scm_registered_modules, scm_clear_registered_modules): New functions.
This commit is contained in:
Marius Vollmer
parent
d914fd5fbf
commit
80bc78903a
5 changed files with 364 additions and 340 deletions
|
|
@ -45,168 +45,59 @@
|
|||
Author: Aubrey Jaffer
|
||||
Modified for libguile by Marius Vollmer */
|
||||
|
||||
#include "_scm.h"
|
||||
#include "genio.h"
|
||||
#include "smob.h"
|
||||
|
||||
#include <dlfcn.h>
|
||||
|
||||
#define SHL(obj) ((void*)SCM_CDR(obj))
|
||||
|
||||
#ifdef RTLD_LAZY /* Solaris 2. */
|
||||
# define DLOPEN_MODE RTLD_LAZY
|
||||
#else
|
||||
# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
|
||||
#endif
|
||||
|
||||
static scm_sizet frshl SCM_P ((SCM ptr));
|
||||
|
||||
static scm_sizet
|
||||
frshl (ptr)
|
||||
SCM ptr;
|
||||
static void *
|
||||
sysdep_dynl_link (fname, subr)
|
||||
char *fname;
|
||||
char *subr;
|
||||
{
|
||||
#if 0
|
||||
/* Should freeing a shl close and possibly unmap the object file it */
|
||||
/* refers to? */
|
||||
if (SHL(ptr))
|
||||
dlclose (SHL(ptr));
|
||||
#endif
|
||||
return 0;
|
||||
void *handle = dlopen (fname, DLOPEN_MODE);
|
||||
if (NULL == handle)
|
||||
scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
|
||||
return handle;
|
||||
}
|
||||
|
||||
static int prinshl SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
|
||||
|
||||
static int
|
||||
prinshl (exp, port, pstate)
|
||||
SCM exp;
|
||||
SCM port;
|
||||
scm_print_state *pstate;
|
||||
static void
|
||||
sysdep_dynl_unlink (handle, subr)
|
||||
void *handle;
|
||||
char *subr;
|
||||
{
|
||||
scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port);
|
||||
scm_intprint (SCM_CDR (exp), 16, port);
|
||||
scm_gen_putc ('>', port);
|
||||
return 1;
|
||||
}
|
||||
|
||||
int scm_tc16_shl;
|
||||
static scm_smobfuns shlsmob = { scm_mark0, frshl, prinshl };
|
||||
|
||||
SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
|
||||
|
||||
SCM
|
||||
scm_dynamic_link (fname)
|
||||
SCM fname;
|
||||
{
|
||||
SCM z;
|
||||
void *handle;
|
||||
|
||||
/* if FALSEP(fname) return fname; XXX - ? */
|
||||
|
||||
fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
|
||||
int status;
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
handle = dlopen (SCM_CHARS (fname), DLOPEN_MODE);
|
||||
if (NULL == handle)
|
||||
scm_misc_error (s_dynamic_link, (char *)dlerror (), SCM_EOL);
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCHARS (z, handle);
|
||||
SCM_SETCAR (z, scm_tc16_shl);
|
||||
status = dlclose (handle);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
return z;
|
||||
if(status)
|
||||
scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
|
||||
}
|
||||
|
||||
static void *get_func SCM_P ((void *handle, char *func, char *subr));
|
||||
|
||||
|
||||
static void *
|
||||
get_func (handle, func, subr)
|
||||
sysdep_dynl_func (symb, handle, subr)
|
||||
char *symb;
|
||||
void *handle;
|
||||
char *func;
|
||||
char *subr;
|
||||
{
|
||||
void *fptr;
|
||||
char *err;
|
||||
|
||||
fptr = dlsym (handle, func);
|
||||
SCM_DEFER_INTS;
|
||||
fptr = dlsym (handle, symb);
|
||||
err = (char *)dlerror ();
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
if (!fptr)
|
||||
scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL);
|
||||
return fptr;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_call (symb, shl)
|
||||
SCM symb, shl;
|
||||
static void
|
||||
sysdep_dynl_init ()
|
||||
{
|
||||
void (*func) SCM_P ((void)) = 0;
|
||||
|
||||
symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1);
|
||||
SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
|
||||
SCM_ARG2, s_dynamic_call);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_call);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
(*func) ();
|
||||
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_args_call (symb, shl, args)
|
||||
SCM symb, shl, args;
|
||||
{
|
||||
int i, argc;
|
||||
char **argv;
|
||||
int (*func) SCM_P ((int argc, char **argv)) = 0;
|
||||
|
||||
symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1);
|
||||
SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
|
||||
SCM_ARG2, s_dynamic_args_call);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_args_call);
|
||||
argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
|
||||
SCM_ARG3);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
i = (*func) (argc, argv);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
scm_must_free_argv(argv);
|
||||
SCM_ALLOW_INTS;
|
||||
return SCM_MAKINUM(0L+i);
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
|
||||
|
||||
SCM
|
||||
scm_dynamic_unlink (shl)
|
||||
SCM shl;
|
||||
{
|
||||
int status;
|
||||
|
||||
SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
|
||||
SCM_ARG1, s_dynamic_unlink);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
status = dlclose (SHL(shl));
|
||||
SCM_SETCHARS (shl, NULL);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
if (status)
|
||||
scm_misc_error (s_dynamic_unlink, (char *)dlerror (), SCM_EOL);
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
void
|
||||
scm_init_dynamic_linking ()
|
||||
{
|
||||
scm_tc16_shl = scm_newsmob (&shlsmob);
|
||||
#include "dynl.x"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -45,10 +45,6 @@
|
|||
Author: Aubrey Jaffer
|
||||
Modified for libguile by Marius Vollmer */
|
||||
|
||||
#include "_scm.h"
|
||||
#include "genio.h"
|
||||
#include "smob.h"
|
||||
|
||||
#include "dld.h"
|
||||
|
||||
static void listundef SCM_P ((void));
|
||||
|
|
@ -67,108 +63,55 @@ listundefs ()
|
|||
free(undefs);
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
|
||||
|
||||
SCM
|
||||
scm_dynamic_link (fname)
|
||||
SCM fname;
|
||||
static void *
|
||||
sysdep_dynl_link (fname, subr)
|
||||
char *fname;
|
||||
char *subr;
|
||||
{
|
||||
int status;
|
||||
|
||||
fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
status = dld_link (SCM_CHARS (fname));
|
||||
SCM_ALLOW_INTS;
|
||||
status = dld_link (fname);
|
||||
if (status)
|
||||
scm_misc_error (s_dynamic_link, dld_strerror (status), SCM_EOL);
|
||||
scm_misc_error (subr, dld_strerror (status), SCM_EOL);
|
||||
return fname;
|
||||
}
|
||||
|
||||
static void *get_func SCM_P ((char *subr, char *fname));
|
||||
static void
|
||||
sysdep_dynl_unlink (handle, subr)
|
||||
void *handle;
|
||||
char *subr;
|
||||
{
|
||||
int status;
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
status = dld_unlink_by_file ((char *)fname, 1);
|
||||
SCM_ALLOW_INTS;
|
||||
if (status)
|
||||
scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL);
|
||||
}
|
||||
|
||||
static void *
|
||||
get_func (subr, fname)
|
||||
sysdep_dynl_func (symb, handle, subr)
|
||||
char *symb;
|
||||
void *handle;
|
||||
char *subr;
|
||||
char *fname;
|
||||
{
|
||||
void *func;
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
func = (void *) dld_get_func (func);
|
||||
if (func == 0)
|
||||
scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL);
|
||||
if (!dld_function_executable_p (func)) {
|
||||
listundefs ();
|
||||
scm_misc_error (subr, "unresolved symbols remain", SCM_EOL);
|
||||
}
|
||||
func = (void *) dld_get_func (func);
|
||||
if (func == 0)
|
||||
scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL);
|
||||
SCM_ALLOW_INTS;
|
||||
return func;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_call (symb, shl)
|
||||
SCM symb;
|
||||
SCM shl;
|
||||
{
|
||||
void (*func)() = 0;
|
||||
|
||||
symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
func = get_func (s_dynamic_call, SCM_CHARS (symb));
|
||||
SCM_ALLOW_INST;
|
||||
(*func) ();
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_args_call (symb, shl, args)
|
||||
SCM symb, shl, args;
|
||||
{
|
||||
int i, argc;
|
||||
char **argv;
|
||||
int (*func) SCM_P ((int argc, char **argv)) = 0;
|
||||
|
||||
symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
func = get_func (SCM_CHARS (symb), s_dynamic_args_call);
|
||||
argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
|
||||
SCM_ARG3);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
i = (*func) (argc, argv);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
scm_must_free_argv(argv);
|
||||
SCM_ALLOW_INTS;
|
||||
return SCM_MAKINUM(0L+i);
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
|
||||
|
||||
SCM
|
||||
scm_dynamic_unlink(fname)
|
||||
SCM fname;
|
||||
{
|
||||
int status;
|
||||
|
||||
fname = scm_coerce_rostring (fname, s_dynamic_unlink, SCM_ARG1);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
status = dld_unlink_by_file (SCM_CHARS (fname), 1);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
if (status)
|
||||
scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL);
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
void
|
||||
scm_init_dynamic_linking ()
|
||||
static void
|
||||
sysdep_dynl_init ()
|
||||
{
|
||||
#ifndef RTL
|
||||
if (!execpath)
|
||||
|
|
@ -179,8 +122,6 @@ scm_init_dynamic_linking ()
|
|||
}
|
||||
#endif
|
||||
|
||||
#include "dynl.x"
|
||||
|
||||
#ifdef DLD_DYNCM /* XXX - what's this? */
|
||||
add_feature("dld:dyncm");
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -45,128 +45,54 @@
|
|||
Author: Aubrey Jaffer
|
||||
Modified for libguile by Marius Vollmer */
|
||||
|
||||
#include "_scm.h"
|
||||
#include "genio.h"
|
||||
#include "smob.h"
|
||||
|
||||
#include "dl.h"
|
||||
|
||||
#define SHL(obj) ((shl_t*)SCM_CDR(obj))
|
||||
|
||||
static int printshl SCM_P ((SCM exp, SCM port, scm_printstate *pstate));
|
||||
|
||||
static int
|
||||
prinshl (exp, port, pstate)
|
||||
SCM exp;
|
||||
SCM port;
|
||||
scm_printstate *pstate;
|
||||
static void *
|
||||
sysdep_dynl_link (fname, subr)
|
||||
char *fname;
|
||||
char *subr;
|
||||
{
|
||||
scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port);
|
||||
scm_intprint (SCM_CDR (exp), 16, port);
|
||||
scm_gen_putc ('>', port);
|
||||
return 1;
|
||||
}
|
||||
|
||||
int scm_tc16_shl;
|
||||
static scm_smobfuns shlsmob = { scm_mark0, scm_free0, prinshl };
|
||||
|
||||
SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
|
||||
|
||||
SCM
|
||||
scm_dynamic_link (fname)
|
||||
SCM fname;
|
||||
{
|
||||
SCM z;
|
||||
shl_t shl;
|
||||
|
||||
fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
shl = shl_load (SCM_CHARS (fname), BIND_DEFERRED , 0L);
|
||||
shl = shl_load (fname, BIND_DEFERRED , 0L);
|
||||
if (NULL==shl)
|
||||
scm_misc_error (s_dynamic_link, "dynamic linking failed", SCM_EOL);
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCHARS (z, shl);
|
||||
SCM_SETCAR (z, scm_tc16_shl);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
return z;
|
||||
scm_misc_error (subr, "dynamic linking failed", SCM_EOL);
|
||||
return shl;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_call (symb, shl)
|
||||
SCM symb, shl;
|
||||
{
|
||||
void (*func)() = 0;
|
||||
int i;
|
||||
|
||||
symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1);
|
||||
SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, SCM_ARG2,
|
||||
s_dynamic_call);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
if (shl_findsym (&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func))
|
||||
scm_misc_error (s_dynamic_call, "undefined function",
|
||||
scm_cons (symb, SCM_EOL));
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
(*func) ();
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_args_call (symb, shl, args)
|
||||
SCM symb, shl, args;
|
||||
{
|
||||
int i, argc;
|
||||
char **argv;
|
||||
int (*func) SCM_P ((int argc, char **argv)) = 0;
|
||||
|
||||
symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1);
|
||||
SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR(shl) == scm_tc16_shl, shl, SCM_ARG2,
|
||||
s_dynamic_args_call);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
if (shl_findsym(&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func))
|
||||
scm_misc_error (s_dynamic_call, "undefined function: %s",
|
||||
scm_cons (symb, SCM_EOL));
|
||||
argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
|
||||
SCM_ARG3);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
i = (*func) (argc, argv);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
scm_must_free_argv (argv);
|
||||
SCM_ALLOW_INTS;
|
||||
return SCM_MAKINUM (0L+i);
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
|
||||
|
||||
SCM
|
||||
scm_dynamic_unlink (shl)
|
||||
SCM shl;
|
||||
static void
|
||||
sysdep_dynl_unlink (handle, subr)
|
||||
void *handle;
|
||||
char *subr;
|
||||
{
|
||||
int status;
|
||||
SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
|
||||
SCM_ARG1, s_dynamic_unlink);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
status = shl_unload (SHL (shl));
|
||||
status = shl_unload ((shl_t) handle);
|
||||
SCM_ALLOW_INTS;
|
||||
if (!status)
|
||||
return SCM_BOOL_T;
|
||||
return SCM_BOOL_F;
|
||||
if (status)
|
||||
scm_misc_error (subr, "dynamic unlinking failed", SCM_EOL);
|
||||
}
|
||||
|
||||
void
|
||||
scm_init_dynamic_linking ()
|
||||
static void *
|
||||
sysdep_dynl_func (symb, handle, subr)
|
||||
char *symb;
|
||||
void *handle;
|
||||
char *subr;
|
||||
{
|
||||
void (*func)() = NULL;
|
||||
int status;
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
status = shl_findsym ((shl_t) handle, symb, TYPE_PROCEDURE, &func);
|
||||
SCM_ALLOW_INTS;
|
||||
if (status)
|
||||
scm_misc_error (s_dynamic_call, "undefined function",
|
||||
scm_cons (scm_makfrom0str (symb), SCM_EOL));
|
||||
return func;
|
||||
}
|
||||
|
||||
static void
|
||||
sysdep_dynl_init ()
|
||||
{
|
||||
scm_tc16_shl = scm_newsmob (&shlsmob);
|
||||
#include "dynl.x"
|
||||
}
|
||||
|
|
|
|||
274
libguile/dynl.c
274
libguile/dynl.c
|
|
@ -45,7 +45,25 @@
|
|||
Author: Aubrey Jaffer
|
||||
Modified for libguile by Marius Vollmer */
|
||||
|
||||
/* XXX - This is only here to drag in a definition of __eprintf. This
|
||||
is needed for proper operation of dynamic linking. The real
|
||||
solution would probably be a shared libgcc. */
|
||||
|
||||
#undef NDEBUG
|
||||
#include <assert.h>
|
||||
|
||||
static void
|
||||
maybe_drag_in_eprintf ()
|
||||
{
|
||||
assert (!maybe_drag_in_eprintf);
|
||||
}
|
||||
|
||||
#include "_scm.h"
|
||||
#include "dynl.h"
|
||||
#include "genio.h"
|
||||
#include "smob.h"
|
||||
|
||||
#ifdef DYNAMIC_LINKING
|
||||
|
||||
/* Converting a list of SCM strings into a argv-style array. You must
|
||||
have ints disabled for the whole lifetime of the created argv (from
|
||||
|
|
@ -119,10 +137,92 @@ scm_coerce_rostring (rostr, subr, argn)
|
|||
return rostr;
|
||||
}
|
||||
|
||||
/* Dispatch to the system dependent files
|
||||
/* Module registry
|
||||
*/
|
||||
|
||||
#ifdef DYNAMIC_LINKING
|
||||
/* We can't use SCM objects here. One should be able to call
|
||||
SCM_REGISTER_MODULE from a C++ constructor for a static
|
||||
object. This happens before main and thus before libguile is
|
||||
initialized. */
|
||||
|
||||
struct moddata {
|
||||
struct moddata *link;
|
||||
char *module_name;
|
||||
void *init_func;
|
||||
};
|
||||
|
||||
static struct moddata *registered_mods = NULL;
|
||||
|
||||
void
|
||||
scm_register_module_xxx (module_name, init_func)
|
||||
char *module_name;
|
||||
void *init_func;
|
||||
{
|
||||
struct moddata *md;
|
||||
|
||||
/* XXX - should we (and can we) DEFER_INTS here? */
|
||||
|
||||
for (md = registered_mods; md; md = md->link)
|
||||
if (!strcmp (md->module_name, module_name)) {
|
||||
md->init_func = init_func;
|
||||
return;
|
||||
}
|
||||
|
||||
md = (struct moddata *)malloc (sizeof (struct moddata));
|
||||
if (md == NULL)
|
||||
return;
|
||||
|
||||
md->module_name = module_name;
|
||||
md->init_func = init_func;
|
||||
md->link = registered_mods;
|
||||
registered_mods = md;
|
||||
}
|
||||
|
||||
SCM_PROC (s_registered_modules, "c-registered-modules", 0, 0, 0, scm_registered_modules);
|
||||
|
||||
SCM
|
||||
scm_registered_modules ()
|
||||
{
|
||||
SCM res;
|
||||
struct moddata *md;
|
||||
|
||||
res = SCM_EOL;
|
||||
for (md = registered_mods; md; md = md->link)
|
||||
res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
|
||||
scm_ulong2num ((unsigned long) md->init_func)),
|
||||
res);
|
||||
return res;
|
||||
}
|
||||
|
||||
SCM_PROC (s_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, scm_clear_registered_modules);
|
||||
|
||||
SCM
|
||||
scm_clear_registered_modules ()
|
||||
{
|
||||
struct moddata *md1, *md2;
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
|
||||
for (md1 = registered_mods; md1; md1 = md2) {
|
||||
md2 = md1->link;
|
||||
free (md1);
|
||||
}
|
||||
registered_mods = NULL;
|
||||
|
||||
SCM_ALLOW_INTS;
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
/* Dispatch to the system dependent files
|
||||
*
|
||||
* They define these static functions:
|
||||
*/
|
||||
|
||||
static void sysdep_dynl_init SCM_P ((void));
|
||||
static void *sysdep_dynl_link SCM_P ((char *filename, char *subr));
|
||||
static void sysdep_dynl_unlink SCM_P ((void *handle, char *subr));
|
||||
static void *sysdep_dynl_func SCM_P ((char *symbol, void *handle, char *subr));
|
||||
|
||||
#ifdef HAVE_LIBDL
|
||||
#include "dynl-dl.c"
|
||||
#else
|
||||
|
|
@ -132,16 +232,176 @@ scm_coerce_rostring (rostr, subr, argn)
|
|||
#ifdef HAVE_DLD
|
||||
#include "dynl-dld.c"
|
||||
#else /* no dynamic linking available */
|
||||
/* configure should not have defined DYNAMIC_LINKING in this case */
|
||||
#error Dynamic linking not implemented for your system.
|
||||
#endif
|
||||
#endif
|
||||
#endif
|
||||
|
||||
int scm_tc16_dynamic_obj;
|
||||
|
||||
struct dynl_obj {
|
||||
SCM filename;
|
||||
void *handle;
|
||||
};
|
||||
|
||||
static SCM mark_dynl_obj SCM_P ((SCM ptr));
|
||||
static SCM
|
||||
mark_dynl_obj (ptr)
|
||||
SCM ptr;
|
||||
{
|
||||
struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr);
|
||||
SCM_SETGC8MARK (ptr);
|
||||
return d->filename;
|
||||
}
|
||||
|
||||
static int print_dynl_obj SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
|
||||
static int
|
||||
print_dynl_obj (exp, port, pstate)
|
||||
SCM exp;
|
||||
SCM port;
|
||||
scm_print_state *pstate;
|
||||
{
|
||||
struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
|
||||
scm_gen_puts (scm_regular_string, "#<dynamic-object ", port);
|
||||
scm_iprin1 (d->filename, port, pstate);
|
||||
scm_gen_putc ('>', port);
|
||||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns dynl_obj_smob = {
|
||||
mark_dynl_obj,
|
||||
scm_free0,
|
||||
print_dynl_obj
|
||||
};
|
||||
|
||||
SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
|
||||
|
||||
SCM
|
||||
scm_dynamic_link (fname)
|
||||
SCM fname;
|
||||
{
|
||||
SCM z;
|
||||
struct dynl_obj *d;
|
||||
|
||||
fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
|
||||
d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj),
|
||||
s_dynamic_link);
|
||||
d->filename = fname;
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
d->handle = sysdep_dynl_link (SCM_CHARS (fname), s_dynamic_link);
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCHARS (z, d);
|
||||
SCM_SETCAR (z, scm_tc16_dynamic_obj);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
return z;
|
||||
}
|
||||
|
||||
static struct dynl_obj *get_dynl_obj SCM_P ((SCM obj, char *subr, int argn));
|
||||
static struct dynl_obj *
|
||||
get_dynl_obj (dobj, subr, argn)
|
||||
SCM dobj;
|
||||
char *subr;
|
||||
int argn;
|
||||
{
|
||||
struct dynl_obj *d;
|
||||
SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
|
||||
dobj, argn, subr);
|
||||
d = (struct dynl_obj *)SCM_CDR (dobj);
|
||||
SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
|
||||
return d;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_object_p, "dynamic-object?", 1, 0, 0, scm_dynamic_object_p);
|
||||
|
||||
SCM
|
||||
scm_dynamic_object_p (SCM obj)
|
||||
{
|
||||
return (SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj)?
|
||||
SCM_BOOL_T : SCM_BOOL_F;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
|
||||
|
||||
SCM
|
||||
scm_dynamic_unlink (dobj)
|
||||
SCM dobj;
|
||||
{
|
||||
struct dynl_obj *d = get_dynl_obj (dobj, s_dynamic_unlink, SCM_ARG1);
|
||||
sysdep_dynl_unlink (d->handle, s_dynamic_unlink);
|
||||
d->handle = NULL;
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_func, "dynamic-func", 2, 0, 0, scm_dynamic_func);
|
||||
|
||||
SCM
|
||||
scm_dynamic_func (SCM symb, SCM dobj)
|
||||
{
|
||||
struct dynl_obj *d;
|
||||
void (*func) ();
|
||||
|
||||
symb = scm_coerce_rostring (symb, s_dynamic_func, SCM_ARG1);
|
||||
d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
|
||||
|
||||
func = sysdep_dynl_func (d->handle, SCM_CHARS (symb), s_dynamic_func);
|
||||
return scm_ulong2num ((unsigned long)func);
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_call (SCM func, SCM dobj)
|
||||
{
|
||||
void (*fptr)();
|
||||
|
||||
if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
|
||||
func = scm_dynamic_func (func, dobj);
|
||||
fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, s_dynamic_call);
|
||||
fptr ();
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
|
||||
|
||||
SCM
|
||||
scm_dynamic_args_call (func, dobj, args)
|
||||
SCM func, dobj, args;
|
||||
{
|
||||
int (*fptr) (int argc, char **argv);
|
||||
int result, argc;
|
||||
char **argv;
|
||||
|
||||
if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
|
||||
func = scm_dynamic_func (func, dobj);
|
||||
|
||||
fptr = (int (*)(int, char **)) scm_num2ulong (func, (char *)SCM_ARG1,
|
||||
s_dynamic_args_call);
|
||||
argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
|
||||
SCM_ARG3);
|
||||
|
||||
result = (*fptr) (argc, argv);
|
||||
|
||||
scm_must_free_argv (argv);
|
||||
return SCM_MAKINUM(0L+result);
|
||||
}
|
||||
|
||||
void
|
||||
scm_init_dynamic_linking ()
|
||||
{
|
||||
scm_tc16_dynamic_obj = scm_newsmob (&dynl_obj_smob);
|
||||
sysdep_dynl_init ();
|
||||
#include "dynl.x"
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
#endif
|
||||
#else /* dynamic linking disabled */
|
||||
|
||||
#else /* not DYNAMIC_LINKING */
|
||||
|
||||
void
|
||||
scm_init_dynamic_linking ()
|
||||
{
|
||||
#include "dynl.x"
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif /* not DYNAMIC_LINKING */
|
||||
|
|
|
|||
|
|
@ -47,10 +47,16 @@
|
|||
|
||||
|
||||
|
||||
void scm_register_module_xxx SCM_P ((char *module_name, void *init_func));
|
||||
SCM scm_registered_modules SCM_P (());
|
||||
SCM scm_clear_registered_modules SCM_P (());
|
||||
|
||||
SCM scm_dynamic_link SCM_P ((SCM fname));
|
||||
SCM scm_dynamic_call SCM_P ((SCM symb, SCM shl));
|
||||
SCM scm_dynamic_args_call SCM_P ((SCM symb, SCM shl, SCM args));
|
||||
SCM scm_dynamic_unlink SCM_P ((SCM shl));
|
||||
SCM scm_dynamic_unlink SCM_P ((SCM dobj));
|
||||
SCM scm_dynamic_object_p SCM_P ((SCM obj));
|
||||
SCM scm_dynamic_func SCM_P ((SCM symb, SCM dobj));
|
||||
SCM scm_dynamic_call SCM_P ((SCM symb, SCM dobj));
|
||||
SCM scm_dynamic_args_call SCM_P ((SCM symb, SCM dobj, SCM args));
|
||||
|
||||
void scm_init_dynamic_linking SCM_P ((void));
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue