1 /* dynl.c - dynamic linking
3 * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
4 * 2003, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public License
8 * as published by the Free Software Foundation; either version 3 of
9 * the License, or (at your option) any later version.
11 * This library is distributed in the hope that it will be useful, but
12 * WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Lesser General Public License for more details.
16 * You should have received a copy of the GNU Lesser General Public
17 * License along with this library; if not, write to the Free Software
18 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 /* "dynl.c" dynamically link&load object files.
32 Modified for libguile by Marius Vollmer */
34 #if 0 /* Disabled until we know for sure that it isn't needed */
35 /* XXX - This is only here to drag in a definition of __eprintf. This
36 is needed for proper operation of dynamic linking. The real
37 solution would probably be a shared libgcc. */
43 maybe_drag_in_eprintf ()
45 assert (!maybe_drag_in_eprintf
);
53 #include "libguile/_scm.h"
54 #include "libguile/libpath.h"
55 #include "libguile/dynl.h"
56 #include "libguile/smob.h"
57 #include "libguile/keywords.h"
58 #include "libguile/ports.h"
59 #include "libguile/strings.h"
60 #include "libguile/deprecation.h"
61 #include "libguile/validate.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/foreign.h"
68 From the libtool manual: "Note that libltdl is not threadsafe,
69 i.e. a multithreaded application has to use a mutex for libltdl.".
71 Guile does not currently support pre-emptive threads, so there is no
72 mutex. Previously SCM_CRITICAL_SECTION_START and
73 SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
74 somebody is grepping for thread problems ;)
76 /* njrev: not threadsafe, protection needed as described above */
79 sysdep_dynl_link (const char *fname
, const char *subr
)
84 handle
= lt_dlopenext (fname
);
86 /* Return a handle for the program as a whole. */
87 handle
= lt_dlopen (NULL
);
94 fn
= fname
!= NULL
? scm_from_locale_string (fname
) : SCM_BOOL_F
;
95 msg
= scm_from_locale_string (lt_dlerror ());
96 scm_misc_error (subr
, "file: ~S, message: ~S", scm_list_2 (fn
, msg
));
99 return (void *) handle
;
103 sysdep_dynl_unlink (void *handle
, const char *subr
)
105 if (lt_dlclose ((lt_dlhandle
) handle
))
107 scm_misc_error (subr
, (char *) lt_dlerror (), SCM_EOL
);
112 sysdep_dynl_value (const char *symb
, void *handle
, const char *subr
)
116 fptr
= lt_dlsym ((lt_dlhandle
) handle
, symb
);
118 scm_misc_error (subr
, "Symbol not found: ~a",
119 scm_list_1 (scm_from_locale_string (symb
)));
123 /* Augment environment variable VARIABLE with VALUE, assuming VARIABLE
124 is a path kind of variable. */
126 augment_env (const char *variable
, const char *value
)
130 env
= getenv (variable
);
134 static const char path_sep
[] = { LT_PATHSEP_CHAR
, 0 };
136 new_value
= alloca (strlen (env
) + strlen (value
) + 2);
137 strcpy (new_value
, env
);
138 strcat (new_value
, path_sep
);
139 strcat (new_value
, value
);
141 setenv (variable
, new_value
, 1);
144 setenv (variable
, value
, 1);
154 env
= getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
155 if (env
&& strcmp (env
, "") == 0)
156 /* special-case interpret system-ltdl-path=="" as meaning no system path,
157 which is the case during the build */
160 /* FIXME: should this be a colon-separated path? Or is the only point to
161 allow the build system to turn off the installed extensions path? */
162 lt_dladdsearchdir (env
);
165 /* Add SCM_LIB_DIR and SCM_EXTENSIONS_DIR to the loader's search
166 path. `lt_dladdsearchdir' and $LTDL_LIBRARY_PATH can't be used
167 for that because they are searched before the system-dependent
168 search path, which is the one `libtool --mode=execute -dlopen'
169 fiddles with (info "(libtool) Libltdl Interface"). See
170 <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>
172 augment_env (SHARED_LIBRARY_PATH_VARIABLE
, SCM_LIB_DIR
);
173 augment_env (SHARED_LIBRARY_PATH_VARIABLE
, SCM_EXTENSIONS_DIR
);
177 scm_t_bits scm_tc16_dynamic_obj
;
179 #define DYNL_FILENAME SCM_SMOB_OBJECT
180 #define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x))
181 #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
186 dynl_obj_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
188 scm_puts_unlocked ("#<dynamic-object ", port
);
189 scm_iprin1 (DYNL_FILENAME (exp
), port
, pstate
);
190 if (DYNL_HANDLE (exp
) == NULL
)
191 scm_puts_unlocked (" (unlinked)", port
);
192 scm_putc_unlocked ('>', port
);
197 SCM_DEFINE (scm_dynamic_link
, "dynamic-link", 0, 1, 0,
199 "Find the shared object (shared library) denoted by\n"
200 "@var{filename} and link it into the running Guile\n"
201 "application. The returned\n"
202 "scheme object is a ``handle'' for the library which can\n"
203 "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
204 "Searching for object files is system dependent. Normally,\n"
205 "if @var{filename} does have an explicit directory it will\n"
206 "be searched for in locations\n"
207 "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
208 "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
209 "returned. This handle provides access to the symbols\n"
210 "available to the program at run-time, including those exported\n"
211 "by the program itself and the shared libraries already loaded.\n")
212 #define FUNC_NAME s_scm_dynamic_link
217 scm_dynwind_begin (0);
219 if (SCM_UNBNDP (filename
))
223 file
= scm_to_locale_string (filename
);
224 scm_dynwind_free (file
);
227 handle
= sysdep_dynl_link (file
, FUNC_NAME
);
230 SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj
,
231 SCM_UNBNDP (filename
)
232 ? SCM_UNPACK (SCM_BOOL_F
) : SCM_UNPACK (filename
),
238 SCM_DEFINE (scm_dynamic_object_p
, "dynamic-object?", 1, 0, 0,
240 "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
241 "or @code{#f} otherwise.")
242 #define FUNC_NAME s_scm_dynamic_object_p
244 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj
, obj
));
249 SCM_DEFINE (scm_dynamic_unlink
, "dynamic-unlink", 1, 0, 0,
251 "Unlink a dynamic object from the application, if possible. The\n"
252 "object must have been linked by @code{dynamic-link}, with \n"
253 "@var{dobj} the corresponding handle. After this procedure\n"
254 "is called, the handle can no longer be used to access the\n"
256 #define FUNC_NAME s_scm_dynamic_unlink
258 /*fixme* GC-problem */
259 SCM_VALIDATE_SMOB (SCM_ARG1
, dobj
, dynamic_obj
);
260 if (DYNL_HANDLE (dobj
) == NULL
) {
261 SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj
));
263 sysdep_dynl_unlink (DYNL_HANDLE (dobj
), FUNC_NAME
);
264 SET_DYNL_HANDLE (dobj
, NULL
);
265 return SCM_UNSPECIFIED
;
271 SCM_DEFINE (scm_dynamic_pointer
, "dynamic-pointer", 2, 0, 0,
272 (SCM name
, SCM dobj
),
273 "Return a ``wrapped pointer'' to the symbol @var{name}\n"
274 "in the shared object referred to by @var{dobj}. The returned\n"
275 "pointer points to a C object.\n\n"
276 "Regardless whether your C compiler prepends an underscore\n"
277 "@samp{_} to the global names in a program, you should\n"
278 "@strong{not} include this underscore in @var{name}\n"
279 "since it will be added automatically when necessary.")
280 #define FUNC_NAME s_scm_dynamic_pointer
284 SCM_VALIDATE_STRING (1, name
);
285 SCM_VALIDATE_SMOB (SCM_ARG2
, dobj
, dynamic_obj
);
287 if (DYNL_HANDLE (dobj
) == NULL
)
288 SCM_MISC_ERROR ("Already unlinked: ~S", dobj
);
293 scm_dynwind_begin (0);
294 chars
= scm_to_locale_string (name
);
295 scm_dynwind_free (chars
);
296 val
= sysdep_dynl_value (chars
, DYNL_HANDLE (dobj
), FUNC_NAME
);
299 return scm_from_pointer (val
, NULL
);
305 SCM_DEFINE (scm_dynamic_func
, "dynamic-func", 2, 0, 0,
306 (SCM name
, SCM dobj
),
307 "Return a ``handle'' for the function @var{name} in the\n"
308 "shared object referred to by @var{dobj}. The handle\n"
309 "can be passed to @code{dynamic-call} to actually\n"
310 "call the function.\n\n"
311 "Regardless whether your C compiler prepends an underscore\n"
312 "@samp{_} to the global names in a program, you should\n"
313 "@strong{not} include this underscore in @var{name}\n"
314 "since it will be added automatically when necessary.")
315 #define FUNC_NAME s_scm_dynamic_func
317 return scm_dynamic_pointer (name
, dobj
);
322 SCM_DEFINE (scm_dynamic_call
, "dynamic-call", 2, 0, 0,
323 (SCM func
, SCM dobj
),
324 "Call a C function in a dynamic object. Two styles of\n"
325 "invocation are supported:\n\n"
327 "@item @var{func} can be a function handle returned by\n"
328 "@code{dynamic-func}. In this case @var{dobj} is\n"
330 "@item @var{func} can be a string with the name of the\n"
331 "function to call, with @var{dobj} the handle of the\n"
332 "dynamic object in which to find the function.\n"
333 "This is equivalent to\n"
335 "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
336 "@end smallexample\n"
338 "In either case, the function is passed no arguments\n"
339 "and its return value is ignored.")
340 #define FUNC_NAME s_scm_dynamic_call
344 if (scm_is_string (func
))
345 func
= scm_dynamic_func (func
, dobj
);
346 SCM_VALIDATE_POINTER (SCM_ARG1
, func
);
348 fptr
= SCM_POINTER_VALUE (func
);
350 return SCM_UNSPECIFIED
;
355 scm_init_dynamic_linking ()
357 scm_tc16_dynamic_obj
= scm_make_smob_type ("dynamic-object", 0);
358 scm_set_smob_print (scm_tc16_dynamic_obj
, dynl_obj_print
);
360 #include "libguile/dynl.x"