mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-12 06:41:13 +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
|
Author: Aubrey Jaffer
|
||||||
Modified for libguile by Marius Vollmer */
|
Modified for libguile by Marius Vollmer */
|
||||||
|
|
||||||
#include "_scm.h"
|
|
||||||
#include "genio.h"
|
|
||||||
#include "smob.h"
|
|
||||||
|
|
||||||
#include <dlfcn.h>
|
#include <dlfcn.h>
|
||||||
|
|
||||||
#define SHL(obj) ((void*)SCM_CDR(obj))
|
|
||||||
|
|
||||||
#ifdef RTLD_LAZY /* Solaris 2. */
|
#ifdef RTLD_LAZY /* Solaris 2. */
|
||||||
# define DLOPEN_MODE RTLD_LAZY
|
# define DLOPEN_MODE RTLD_LAZY
|
||||||
#else
|
#else
|
||||||
# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
|
# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
static scm_sizet frshl SCM_P ((SCM ptr));
|
static void *
|
||||||
|
sysdep_dynl_link (fname, subr)
|
||||||
static scm_sizet
|
char *fname;
|
||||||
frshl (ptr)
|
char *subr;
|
||||||
SCM ptr;
|
|
||||||
{
|
{
|
||||||
#if 0
|
void *handle = dlopen (fname, DLOPEN_MODE);
|
||||||
/* Should freeing a shl close and possibly unmap the object file it */
|
if (NULL == handle)
|
||||||
/* refers to? */
|
scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
|
||||||
if (SHL(ptr))
|
return handle;
|
||||||
dlclose (SHL(ptr));
|
|
||||||
#endif
|
|
||||||
return 0;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
static int prinshl SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
|
static void
|
||||||
|
sysdep_dynl_unlink (handle, subr)
|
||||||
static int
|
void *handle;
|
||||||
prinshl (exp, port, pstate)
|
char *subr;
|
||||||
SCM exp;
|
|
||||||
SCM port;
|
|
||||||
scm_print_state *pstate;
|
|
||||||
{
|
{
|
||||||
scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port);
|
int status;
|
||||||
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);
|
|
||||||
|
|
||||||
SCM_DEFER_INTS;
|
SCM_DEFER_INTS;
|
||||||
handle = dlopen (SCM_CHARS (fname), DLOPEN_MODE);
|
status = dlclose (handle);
|
||||||
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);
|
|
||||||
SCM_ALLOW_INTS;
|
SCM_ALLOW_INTS;
|
||||||
|
if(status)
|
||||||
return z;
|
scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
|
||||||
}
|
}
|
||||||
|
|
||||||
static void *get_func SCM_P ((void *handle, char *func, char *subr));
|
|
||||||
|
|
||||||
static void *
|
static void *
|
||||||
get_func (handle, func, subr)
|
sysdep_dynl_func (symb, handle, subr)
|
||||||
|
char *symb;
|
||||||
void *handle;
|
void *handle;
|
||||||
char *func;
|
|
||||||
char *subr;
|
char *subr;
|
||||||
{
|
{
|
||||||
void *fptr;
|
void *fptr;
|
||||||
char *err;
|
char *err;
|
||||||
|
|
||||||
fptr = dlsym (handle, func);
|
SCM_DEFER_INTS;
|
||||||
|
fptr = dlsym (handle, symb);
|
||||||
err = (char *)dlerror ();
|
err = (char *)dlerror ();
|
||||||
|
SCM_ALLOW_INTS;
|
||||||
|
|
||||||
if (!fptr)
|
if (!fptr)
|
||||||
scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL);
|
scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL);
|
||||||
return fptr;
|
return fptr;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
|
static void
|
||||||
|
sysdep_dynl_init ()
|
||||||
SCM
|
|
||||||
scm_dynamic_call (symb, shl)
|
|
||||||
SCM symb, shl;
|
|
||||||
{
|
{
|
||||||
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
|
Author: Aubrey Jaffer
|
||||||
Modified for libguile by Marius Vollmer */
|
Modified for libguile by Marius Vollmer */
|
||||||
|
|
||||||
#include "_scm.h"
|
|
||||||
#include "genio.h"
|
|
||||||
#include "smob.h"
|
|
||||||
|
|
||||||
#include "dld.h"
|
#include "dld.h"
|
||||||
|
|
||||||
static void listundef SCM_P ((void));
|
static void listundef SCM_P ((void));
|
||||||
|
|
@ -67,108 +63,55 @@ listundefs ()
|
||||||
free(undefs);
|
free(undefs);
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
|
static void *
|
||||||
|
sysdep_dynl_link (fname, subr)
|
||||||
SCM
|
char *fname;
|
||||||
scm_dynamic_link (fname)
|
char *subr;
|
||||||
SCM fname;
|
|
||||||
{
|
{
|
||||||
int status;
|
int status;
|
||||||
|
|
||||||
fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
|
|
||||||
|
|
||||||
SCM_DEFER_INTS;
|
status = dld_link (fname);
|
||||||
status = dld_link (SCM_CHARS (fname));
|
|
||||||
SCM_ALLOW_INTS;
|
|
||||||
if (status)
|
if (status)
|
||||||
scm_misc_error (s_dynamic_link, dld_strerror (status), SCM_EOL);
|
scm_misc_error (subr, dld_strerror (status), SCM_EOL);
|
||||||
return fname;
|
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 *
|
static void *
|
||||||
get_func (subr, fname)
|
sysdep_dynl_func (symb, handle, subr)
|
||||||
|
char *symb;
|
||||||
|
void *handle;
|
||||||
char *subr;
|
char *subr;
|
||||||
char *fname;
|
|
||||||
{
|
{
|
||||||
void *func;
|
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)) {
|
if (!dld_function_executable_p (func)) {
|
||||||
listundefs ();
|
listundefs ();
|
||||||
scm_misc_error (subr, "unresolved symbols remain", SCM_EOL);
|
scm_misc_error (subr, "unresolved symbols remain", SCM_EOL);
|
||||||
}
|
}
|
||||||
func = (void *) dld_get_func (func);
|
SCM_ALLOW_INTS;
|
||||||
if (func == 0)
|
|
||||||
scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL);
|
|
||||||
return func;
|
return func;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
|
static void
|
||||||
|
sysdep_dynl_init ()
|
||||||
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 ()
|
|
||||||
{
|
{
|
||||||
#ifndef RTL
|
#ifndef RTL
|
||||||
if (!execpath)
|
if (!execpath)
|
||||||
|
|
@ -179,8 +122,6 @@ scm_init_dynamic_linking ()
|
||||||
}
|
}
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#include "dynl.x"
|
|
||||||
|
|
||||||
#ifdef DLD_DYNCM /* XXX - what's this? */
|
#ifdef DLD_DYNCM /* XXX - what's this? */
|
||||||
add_feature("dld:dyncm");
|
add_feature("dld:dyncm");
|
||||||
#endif
|
#endif
|
||||||
|
|
|
||||||
|
|
@ -45,128 +45,54 @@
|
||||||
Author: Aubrey Jaffer
|
Author: Aubrey Jaffer
|
||||||
Modified for libguile by Marius Vollmer */
|
Modified for libguile by Marius Vollmer */
|
||||||
|
|
||||||
#include "_scm.h"
|
|
||||||
#include "genio.h"
|
|
||||||
#include "smob.h"
|
|
||||||
|
|
||||||
#include "dl.h"
|
#include "dl.h"
|
||||||
|
|
||||||
#define SHL(obj) ((shl_t*)SCM_CDR(obj))
|
static void *
|
||||||
|
sysdep_dynl_link (fname, subr)
|
||||||
static int printshl SCM_P ((SCM exp, SCM port, scm_printstate *pstate));
|
char *fname;
|
||||||
|
char *subr;
|
||||||
static int
|
|
||||||
prinshl (exp, port, pstate)
|
|
||||||
SCM exp;
|
|
||||||
SCM port;
|
|
||||||
scm_printstate *pstate;
|
|
||||||
{
|
{
|
||||||
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;
|
shl_t shl;
|
||||||
|
|
||||||
fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
|
shl = shl_load (fname, BIND_DEFERRED , 0L);
|
||||||
|
|
||||||
SCM_DEFER_INTS;
|
|
||||||
shl = shl_load (SCM_CHARS (fname), BIND_DEFERRED , 0L);
|
|
||||||
if (NULL==shl)
|
if (NULL==shl)
|
||||||
scm_misc_error (s_dynamic_link, "dynamic linking failed", SCM_EOL);
|
scm_misc_error (subr, "dynamic linking failed", SCM_EOL);
|
||||||
SCM_NEWCELL (z);
|
return shl;
|
||||||
SCM_SETCHARS (z, shl);
|
|
||||||
SCM_SETCAR (z, scm_tc16_shl);
|
|
||||||
SCM_ALLOW_INTS;
|
|
||||||
|
|
||||||
return z;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
|
static void
|
||||||
|
sysdep_dynl_unlink (handle, subr)
|
||||||
SCM
|
void *handle;
|
||||||
scm_dynamic_call (symb, shl)
|
char *subr;
|
||||||
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;
|
|
||||||
{
|
{
|
||||||
int status;
|
int status;
|
||||||
SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
|
|
||||||
SCM_ARG1, s_dynamic_unlink);
|
|
||||||
|
|
||||||
SCM_DEFER_INTS;
|
SCM_DEFER_INTS;
|
||||||
status = shl_unload (SHL (shl));
|
status = shl_unload ((shl_t) handle);
|
||||||
SCM_ALLOW_INTS;
|
SCM_ALLOW_INTS;
|
||||||
if (!status)
|
if (status)
|
||||||
return SCM_BOOL_T;
|
scm_misc_error (subr, "dynamic unlinking failed", SCM_EOL);
|
||||||
return SCM_BOOL_F;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
void
|
static void *
|
||||||
scm_init_dynamic_linking ()
|
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
|
Author: Aubrey Jaffer
|
||||||
Modified for libguile by Marius Vollmer */
|
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 "_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
|
/* 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
|
have ints disabled for the whole lifetime of the created argv (from
|
||||||
|
|
@ -119,10 +137,92 @@ scm_coerce_rostring (rostr, subr, argn)
|
||||||
return rostr;
|
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
|
#ifdef HAVE_LIBDL
|
||||||
#include "dynl-dl.c"
|
#include "dynl-dl.c"
|
||||||
#else
|
#else
|
||||||
|
|
@ -132,16 +232,176 @@ scm_coerce_rostring (rostr, subr, argn)
|
||||||
#ifdef HAVE_DLD
|
#ifdef HAVE_DLD
|
||||||
#include "dynl-dld.c"
|
#include "dynl-dld.c"
|
||||||
#else /* no dynamic linking available */
|
#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
|
void
|
||||||
scm_init_dynamic_linking ()
|
scm_init_dynamic_linking ()
|
||||||
{
|
{
|
||||||
|
scm_tc16_dynamic_obj = scm_newsmob (&dynl_obj_smob);
|
||||||
|
sysdep_dynl_init ();
|
||||||
|
#include "dynl.x"
|
||||||
}
|
}
|
||||||
#endif
|
|
||||||
#endif
|
#else /* not DYNAMIC_LINKING */
|
||||||
#endif
|
|
||||||
#else /* dynamic linking disabled */
|
|
||||||
void
|
void
|
||||||
scm_init_dynamic_linking ()
|
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_link SCM_P ((SCM fname));
|
||||||
SCM scm_dynamic_call SCM_P ((SCM symb, SCM shl));
|
SCM scm_dynamic_unlink SCM_P ((SCM dobj));
|
||||||
SCM scm_dynamic_args_call SCM_P ((SCM symb, SCM shl, SCM args));
|
SCM scm_dynamic_object_p SCM_P ((SCM obj));
|
||||||
SCM scm_dynamic_unlink SCM_P ((SCM shl));
|
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));
|
void scm_init_dynamic_linking SCM_P ((void));
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue