X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/b380b88547226544d5a2b7d09379c79fbe300e10..7cf1a27e9c71a16d4d15516640c2e8c6ebd003b5:/libguile/dynl.c diff --git a/libguile/dynl.c b/libguile/dynl.c index a5833e3e8..4005e40e2 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -1,6 +1,6 @@ /* dynl.c - dynamic linking * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999 Free Software Foundation, Inc. + * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -71,7 +71,7 @@ maybe_drag_in_eprintf () #include "smob.h" #include "keywords.h" -#include "scm_validate.h" +#include "validate.h" /* 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 @@ -84,38 +84,38 @@ maybe_drag_in_eprintf () static char ** scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) { - char **argv; - int argc, i; - - argc = scm_ilength(args); - argv = (char **) scm_must_malloc ((1L+argc)*sizeof(char *), subr); - for(i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) { - size_t len; - char *dst, *src; - SCM str = SCM_CAR (args); - - SCM_ASSERT (SCM_ROSTRINGP (str), str, argn, subr); - len = 1 + SCM_ROLENGTH (str); - dst = (char *) scm_must_malloc ((long)len, subr); - src = SCM_ROCHARS (str); - while (len--) - dst[len] = src[len]; - argv[i] = dst; - } - - if (argcp) - *argcp = argc; - argv[argc] = 0; - return argv; + char **argv; + int argc, i; + + argc = scm_ilength (args); + argv = (char **) scm_must_malloc ((1L + argc) * sizeof (char *), subr); + for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) { + size_t len; + char *dst, *src; + SCM str = SCM_CAR (args); + + SCM_ASSERT (SCM_ROSTRINGP (str), str, argn, subr); + len = 1 + SCM_ROLENGTH (str); + dst = (char *) scm_must_malloc ((long) len, subr); + src = SCM_ROCHARS (str); + while (len--) + dst[len] = src[len]; + argv[i] = dst; + } + + if (argcp) + *argcp = argc; + argv[argc] = 0; + return argv; } static void scm_must_free_argv(char **argv) { - char **av = argv; - while (*av) - free(*(av++)); - free(argv); + char **av = argv; + while (*av) + free (*(av++)); + free (argv); } /* Coerce an arbitrary readonly-string into a zero-terminated string. @@ -124,10 +124,10 @@ scm_must_free_argv(char **argv) static SCM scm_coerce_rostring (SCM rostr,const char *subr,int argn) { - SCM_ASSERT (SCM_ROSTRINGP (rostr), rostr, argn, subr); - if (SCM_SUBSTRP (rostr)) - rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0); - return rostr; + SCM_ASSERT (SCM_ROSTRINGP (rostr), rostr, argn, subr); + if (SCM_SUBSTRP (rostr)) + rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0); + return rostr; } /* Module registry @@ -139,9 +139,9 @@ scm_coerce_rostring (SCM rostr,const char *subr,int argn) initialized. */ struct moddata { - struct moddata *link; - char *module_name; - void *init_func; + struct moddata *link; + char *module_name; + void *init_func; }; static struct moddata *registered_mods = NULL; @@ -149,48 +149,50 @@ static struct moddata *registered_mods = NULL; void scm_register_module_xxx (char *module_name, void *init_func) { - struct moddata *md; + 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; - } + /* XXX - should we (and can we) DEFER_INTS here? */ - md = (struct moddata *)malloc (sizeof (struct moddata)); - if (md == NULL) { - fprintf (stderr, - "guile: can't register module (%s): not enough memory", - module_name); + 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) + { + fprintf (stderr, + "guile: can't register module (%s): not enough memory", + module_name); + return; } - md->module_name = module_name; - md->init_func = init_func; - md->link = registered_mods; - registered_mods = md; + md->module_name = module_name; + md->init_func = init_func; + md->link = registered_mods; + registered_mods = md; } SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0, (), "Return a list of the object code modules that have been imported into\n" "the current Guile process. Each element of the list is a pair whose\n" - "car is the name of the module (as it might be used by\n" - "@code{use-modules}, for instance), and whose cdr is the function handle\n" - "for that module's initializer function.") + "car is the name of the module, and whose cdr is the function handle\n" + "for that module's initializer function. The name is the string that\n" + "has been passed to scm_register_module_xxx.") #define FUNC_NAME s_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 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; } #undef FUNC_NAME @@ -203,18 +205,19 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, "only by module bookkeeping operations.") #define FUNC_NAME s_scm_clear_registered_modules { - struct moddata *md1, *md2; + struct moddata *md1, *md2; - SCM_DEFER_INTS; + SCM_DEFER_INTS; - for (md1 = registered_mods; md1; md1 = md2) { - md2 = md1->link; - free (md1); + for (md1 = registered_mods; md1; md1 = md2) + { + md2 = md1->link; + free (md1); } - registered_mods = NULL; + registered_mods = NULL; - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -237,11 +240,12 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, static void * sysdep_dynl_link (const char *fname, int flags, const char *subr) { - lt_dlhandle handle = lt_dlopenext (fname); + lt_dlhandle handle; + handle = lt_dlopenext (fname); if (NULL == handle) { SCM_ALLOW_INTS; - scm_misc_error (subr, (char *)lt_dlerror (), SCM_EOL); + scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL); } return (void *) handle; } @@ -252,7 +256,7 @@ sysdep_dynl_unlink (void *handle, const char *subr) if (lt_dlclose ((lt_dlhandle) handle)) { SCM_ALLOW_INTS; - scm_misc_error (subr, (char *)lt_dlerror (), SCM_EOL); + scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL); } } @@ -265,7 +269,7 @@ sysdep_dynl_func (const char *symb, void *handle, const char *subr) if (!fptr) { SCM_ALLOW_INTS; - scm_misc_error (subr, (char *)lt_dlerror (), SCM_EOL); + scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL); } return fptr; } @@ -297,15 +301,15 @@ sysdep_dynl_link (const char *filename, int flags, const char *subr) { - no_dynl_error (subr); - return NULL; + no_dynl_error (subr); + return NULL; } static void sysdep_dynl_unlink (void *handle, const char *subr) { - no_dynl_error (subr); + no_dynl_error (subr); } static void * @@ -313,8 +317,8 @@ sysdep_dynl_func (const char *symbol, void *handle, const char *subr) { - no_dynl_error (subr); - return NULL; + no_dynl_error (subr); + return NULL; } #endif @@ -322,34 +326,30 @@ sysdep_dynl_func (const char *symbol, int scm_tc16_dynamic_obj; struct dynl_obj { - SCM filename; - void *handle; + SCM filename; + void *handle; }; +#define DYNL_OBJ(x) ((struct dynl_obj *) &SCM_CDR (x)) + +#define DYNL_FILENAME(x) (DYNL_OBJ (x)->filename) +#define DYNL_HANDLE(x) (DYNL_OBJ (x)->handle) + static SCM mark_dynl_obj (SCM ptr) { - struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr); - return d->filename; -} - -static scm_sizet -free_dynl_obj (SCM ptr) -{ - scm_must_free ((char *)SCM_CDR (ptr)); - return sizeof (struct dynl_obj); + return DYNL_FILENAME (ptr); } static int print_dynl_obj (SCM exp,SCM port,scm_print_state *pstate) { - struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp); - scm_puts ("#filename, port, pstate); - if (d->handle == NULL) - scm_puts (" (unlinked)", port); - scm_putc ('>', port); - return 1; + scm_puts ("#', port); + return 1; } static SCM kw_global; @@ -362,63 +362,50 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 1, "as the @var{lib} argument to the following functions.") #define FUNC_NAME s_scm_dynamic_link { - SCM z; - void *handle; - struct dynl_obj *d; - int flags = DYNL_GLOBAL; + void *handle; + int flags = DYNL_GLOBAL; - SCM_COERCE_ROSTRING (1, fname); + SCM_COERCE_ROSTRING (1, fname); - /* collect flags */ - while (SCM_CONSP (rest)) - { - SCM kw, val; + /* collect flags */ + while (SCM_CONSP (rest)) + { + SCM kw, val; - kw = SCM_CAR (rest); - rest = SCM_CDR (rest); + kw = SCM_CAR (rest); + rest = SCM_CDR (rest); + + if (!SCM_CONSP (rest)) + SCM_MISC_ERROR ("keyword without value", SCM_EOL); - if (!SCM_CONSP (rest)) - SCM_MISC_ERROR ("keyword without value", SCM_EOL); - - val = SCM_CAR (rest); - rest = SCM_CDR (rest); - - if (kw == kw_global) - { - if (SCM_FALSEP (val)) - flags &= ~DYNL_GLOBAL; - } - else - SCM_MISC_ERROR ("unknown keyword argument: ~A", - scm_cons (kw, SCM_EOL)); - } + val = SCM_CAR (rest); + rest = SCM_CDR (rest); - SCM_DEFER_INTS; - handle = sysdep_dynl_link (SCM_CHARS (fname), flags, FUNC_NAME); - - d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj), - FUNC_NAME); - d->filename = fname; - d->handle = handle; - - SCM_NEWCELL (z); - SCM_SETCHARS (z, d); - SCM_SETCAR (z, scm_tc16_dynamic_obj); - SCM_ALLOW_INTS; + if (kw == kw_global) + { + if (SCM_FALSEP (val)) + flags &= ~DYNL_GLOBAL; + } + else + SCM_MISC_ERROR ("unknown keyword argument: ~A", + scm_cons (kw, SCM_EOL)); + } - return z; + handle = sysdep_dynl_link (SCM_CHARS (fname), flags, FUNC_NAME); + + SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, fname, handle); } #undef FUNC_NAME static struct dynl_obj * -get_dynl_obj (SCM dobj,const char *subr,int argn) +get_dynl_obj (SCM dobj, const 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; + struct dynl_obj *d; + SCM_ASSERT (SCM_NIMP (dobj) && SCM_UNPACK_CAR (dobj) == scm_tc16_dynamic_obj, + dobj, argn, subr); + d = DYNL_OBJ (dobj); + SCM_ASSERT (d->handle != NULL, dobj, argn, subr); + return d; } SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, @@ -427,7 +414,8 @@ SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_dynamic_object_p { - return SCM_BOOL(SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj); + return SCM_BOOL (SCM_NIMP (obj) + && SCM_UNPACK_CAR (obj) == scm_tc16_dynamic_obj); } #undef FUNC_NAME @@ -444,12 +432,13 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, "") #define FUNC_NAME s_scm_dynamic_unlink { - struct dynl_obj *d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG1); - SCM_DEFER_INTS; - sysdep_dynl_unlink (d->handle, FUNC_NAME); - d->handle = NULL; - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; + /*fixme* GC-problem */ + struct dynl_obj *d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG1); + SCM_DEFER_INTS; + sysdep_dynl_unlink (d->handle, FUNC_NAME); + d->handle = NULL; + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -470,18 +459,20 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, "") #define FUNC_NAME s_scm_dynamic_func { - struct dynl_obj *d; - void (*func) (); + struct dynl_obj *d; + void (*func) (); - SCM_COERCE_ROSTRING (1, symb); - d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG2); + SCM_COERCE_ROSTRING (1, symb); + /*fixme* GC-problem */ + d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG2); - SCM_DEFER_INTS; - func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), d->handle, - FUNC_NAME); - SCM_ALLOW_INTS; + SCM_DEFER_INTS; + func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), + d->handle, + FUNC_NAME); + SCM_ALLOW_INTS; - return scm_ulong2num ((unsigned long)func); + return scm_ulong2num ((unsigned long) func); } #undef FUNC_NAME @@ -506,15 +497,15 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, "") #define FUNC_NAME s_scm_dynamic_call { - void (*fptr)(); - - if (SCM_ROSTRINGP (func)) - func = scm_dynamic_func (func, dobj); - fptr = (void (*)()) SCM_NUM2ULONG (1, func); - SCM_DEFER_INTS; - fptr (); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; + void (*fptr) (); + + if (SCM_ROSTRINGP (func)) + func = scm_dynamic_func (func, dobj); + fptr = (void (*) ()) SCM_NUM2ULONG (1, func); + SCM_DEFER_INTS; + fptr (); + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -541,32 +532,31 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, "") #define FUNC_NAME s_scm_dynamic_args_call { - int (*fptr) (int argc, char **argv); - int result, argc; - char **argv; - - if (SCM_ROSTRINGP (func)) - func = scm_dynamic_func (func, dobj); - - fptr = (int (*)(int, char **)) SCM_NUM2ULONG (1,func); - SCM_DEFER_INTS; - argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME, - SCM_ARG3); - result = (*fptr) (argc, argv); - scm_must_free_argv (argv); - SCM_ALLOW_INTS; - - return SCM_MAKINUM(0L+result); + int (*fptr) (int argc, char **argv); + int result, argc; + char **argv; + + if (SCM_ROSTRINGP (func)) + func = scm_dynamic_func (func, dobj); + + fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func); + SCM_DEFER_INTS; + argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME, SCM_ARG3); + result = (*fptr) (argc, argv); + scm_must_free_argv (argv); + SCM_ALLOW_INTS; + + return SCM_MAKINUM (0L + result); } #undef FUNC_NAME void scm_init_dynamic_linking () { - scm_tc16_dynamic_obj = scm_make_smob_type_mfpe ("dynamic-object", sizeof (struct dynl_obj), - mark_dynl_obj, free_dynl_obj, - print_dynl_obj, NULL); - sysdep_dynl_init (); + scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0); + scm_set_smob_mark (scm_tc16_dynamic_obj, mark_dynl_obj); + scm_set_smob_print (scm_tc16_dynamic_obj, print_dynl_obj); + sysdep_dynl_init (); #include "dynl.x" - kw_global = scm_make_keyword_from_dash_symbol (sym_global); + kw_global = scm_make_keyword_from_dash_symbol (sym_global); }