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
);
119 scm_misc_error (subr
, (char *) lt_dlerror (), SCM_EOL
);
124 /* Augment environment variable VARIABLE with VALUE, assuming VARIABLE
125 is a path kind of variable. */
127 augment_env (const char *variable
, const char *value
)
131 env
= getenv (variable
);
135 static const char path_sep
[] = { LT_PATHSEP_CHAR
, 0 };
137 new_value
= alloca (strlen (env
) + strlen (value
) + 2);
138 strcpy (new_value
, env
);
139 strcat (new_value
, path_sep
);
140 strcat (new_value
, value
);
142 setenv (variable
, new_value
, 1);
145 setenv (variable
, value
, 1);
155 env
= getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
156 if (env
&& strcmp (env
, "") == 0)
157 /* special-case interpret system-ltdl-path=="" as meaning no system path,
158 which is the case during the build */
161 /* FIXME: should this be a colon-separated path? Or is the only point to
162 allow the build system to turn off the installed extensions path? */
163 lt_dladdsearchdir (env
);
166 /* Add SCM_LIB_DIR and SCM_EXTENSIONS_DIR to the loader's search
167 path. `lt_dladdsearchdir' and $LTDL_LIBRARY_PATH can't be used
168 for that because they are searched before the system-dependent
169 search path, which is the one `libtool --mode=execute -dlopen'
170 fiddles with (info "(libtool) Libltdl Interface"). See
171 <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>
173 augment_env (SHARED_LIBRARY_PATH_VARIABLE
, SCM_LIB_DIR
);
174 augment_env (SHARED_LIBRARY_PATH_VARIABLE
, SCM_EXTENSIONS_DIR
);
178 scm_t_bits scm_tc16_dynamic_obj
;
180 #define DYNL_FILENAME SCM_SMOB_OBJECT
181 #define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x))
182 #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
187 dynl_obj_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
189 scm_puts ("#<dynamic-object ", port
);
190 scm_iprin1 (DYNL_FILENAME (exp
), port
, pstate
);
191 if (DYNL_HANDLE (exp
) == NULL
)
192 scm_puts (" (unlinked)", port
);
193 scm_putc ('>', port
);
198 SCM_DEFINE (scm_dynamic_link
, "dynamic-link", 0, 1, 0,
200 "Find the shared object (shared library) denoted by\n"
201 "@var{filename} and link it into the running Guile\n"
202 "application. The returned\n"
203 "scheme object is a ``handle'' for the library which can\n"
204 "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
205 "Searching for object files is system dependent. Normally,\n"
206 "if @var{filename} does have an explicit directory it will\n"
207 "be searched for in locations\n"
208 "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
209 "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
210 "returned. This handle provides access to the symbols\n"
211 "available to the program at run-time, including those exported\n"
212 "by the program itself and the shared libraries already loaded.\n")
213 #define FUNC_NAME s_scm_dynamic_link
218 scm_dynwind_begin (0);
220 if (SCM_UNBNDP (filename
))
224 file
= scm_to_locale_string (filename
);
225 scm_dynwind_free (file
);
228 handle
= sysdep_dynl_link (file
, FUNC_NAME
);
231 SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj
,
232 SCM_UNBNDP (filename
)
233 ? SCM_UNPACK (SCM_BOOL_F
) : SCM_UNPACK (filename
),
239 SCM_DEFINE (scm_dynamic_object_p
, "dynamic-object?", 1, 0, 0,
241 "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
242 "or @code{#f} otherwise.")
243 #define FUNC_NAME s_scm_dynamic_object_p
245 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj
, obj
));
250 SCM_DEFINE (scm_dynamic_unlink
, "dynamic-unlink", 1, 0, 0,
252 "Unlink a dynamic object from the application, if possible. The\n"
253 "object must have been linked by @code{dynamic-link}, with \n"
254 "@var{dobj} the corresponding handle. After this procedure\n"
255 "is called, the handle can no longer be used to access the\n"
257 #define FUNC_NAME s_scm_dynamic_unlink
259 /*fixme* GC-problem */
260 SCM_VALIDATE_SMOB (SCM_ARG1
, dobj
, dynamic_obj
);
261 if (DYNL_HANDLE (dobj
) == NULL
) {
262 SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj
));
264 sysdep_dynl_unlink (DYNL_HANDLE (dobj
), FUNC_NAME
);
265 SET_DYNL_HANDLE (dobj
, NULL
);
266 return SCM_UNSPECIFIED
;
272 SCM_DEFINE (scm_dynamic_pointer
, "dynamic-pointer", 2, 0, 0,
273 (SCM name
, SCM dobj
),
274 "Return a ``wrapped pointer'' to the symbol @var{name}\n"
275 "in the shared object referred to by @var{dobj}. The returned\n"
276 "pointer points to a C object.\n\n"
277 "Regardless whether your C compiler prepends an underscore\n"
278 "@samp{_} to the global names in a program, you should\n"
279 "@strong{not} include this underscore in @var{name}\n"
280 "since it will be added automatically when necessary.")
281 #define FUNC_NAME s_scm_dynamic_pointer
285 SCM_VALIDATE_STRING (1, name
);
286 SCM_VALIDATE_SMOB (SCM_ARG2
, dobj
, dynamic_obj
);
288 if (DYNL_HANDLE (dobj
) == NULL
)
289 SCM_MISC_ERROR ("Already unlinked: ~S", dobj
);
294 scm_dynwind_begin (0);
295 chars
= scm_to_locale_string (name
);
296 scm_dynwind_free (chars
);
297 val
= sysdep_dynl_value (chars
, DYNL_HANDLE (dobj
), FUNC_NAME
);
300 return scm_from_pointer (val
, NULL
);
306 SCM_DEFINE (scm_dynamic_func
, "dynamic-func", 2, 0, 0,
307 (SCM name
, SCM dobj
),
308 "Return a ``handle'' for the function @var{name} in the\n"
309 "shared object referred to by @var{dobj}. The handle\n"
310 "can be passed to @code{dynamic-call} to actually\n"
311 "call the function.\n\n"
312 "Regardless whether your C compiler prepends an underscore\n"
313 "@samp{_} to the global names in a program, you should\n"
314 "@strong{not} include this underscore in @var{name}\n"
315 "since it will be added automatically when necessary.")
316 #define FUNC_NAME s_scm_dynamic_func
318 return scm_dynamic_pointer (name
, dobj
);
323 SCM_DEFINE (scm_dynamic_call
, "dynamic-call", 2, 0, 0,
324 (SCM func
, SCM dobj
),
325 "Call a C function in a dynamic object. Two styles of\n"
326 "invocation are supported:\n\n"
328 "@item @var{func} can be a function handle returned by\n"
329 "@code{dynamic-func}. In this case @var{dobj} is\n"
331 "@item @var{func} can be a string with the name of the\n"
332 "function to call, with @var{dobj} the handle of the\n"
333 "dynamic object in which to find the function.\n"
334 "This is equivalent to\n"
336 "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
337 "@end smallexample\n"
339 "In either case, the function is passed no arguments\n"
340 "and its return value is ignored.")
341 #define FUNC_NAME s_scm_dynamic_call
345 if (scm_is_string (func
))
346 func
= scm_dynamic_func (func
, dobj
);
347 SCM_VALIDATE_POINTER (SCM_ARG1
, func
);
349 fptr
= SCM_POINTER_VALUE (func
);
351 return SCM_UNSPECIFIED
;
356 scm_init_dynamic_linking ()
358 scm_tc16_dynamic_obj
= scm_make_smob_type ("dynamic-object", 0);
359 scm_set_smob_print (scm_tc16_dynamic_obj
, dynl_obj_print
);
361 #include "libguile/dynl.x"