1 /* dynl.c - dynamic linking
2 *
3 * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
4 * 2003, 2008 Free Software Foundation, Inc.
5 *
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public
8 * License as published by the Free Software Foundation; either
9 * version 2.1 of the License, or (at your option) any later version.
10 *
11 * This library is distributed in the hope that it will be useful,
12 * but 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.
15 *
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 02110-1301 USA
19 */
20
21
22
23 #ifdef HAVE_CONFIG_H
24 # include <config.h>
25 #endif
26
27 /* "dynl.c" dynamically link&load object files.
28 Author: Aubrey Jaffer
29 Modified for libguile by Marius Vollmer */
30
31 #if 0 /* Disabled until we know for sure that it isn't needed */
32 /* XXX - This is only here to drag in a definition of __eprintf. This
33 is needed for proper operation of dynamic linking. The real
34 solution would probably be a shared libgcc. */
35
36 #undef NDEBUG
37 #include <assert.h>
38
39 static void
40 maybe_drag_in_eprintf ()
41 {
42 assert (!maybe_drag_in_eprintf);
43 }
44 #endif
45
46 #include <stdio.h>
47 #include <string.h>
48
49 #include "libguile/_scm.h"
50 #include "libguile/dynl.h"
51 #include "libguile/smob.h"
52 #include "libguile/keywords.h"
53 #include "libguile/ports.h"
54 #include "libguile/strings.h"
55 #include "libguile/deprecation.h"
56 #include "libguile/lang.h"
57 #include "libguile/validate.h"
58 #include "libguile/dynwind.h"
59
60 #include <ltdl.h>
61
62 /*
63 From the libtool manual: "Note that libltdl is not threadsafe,
64 i.e. a multithreaded application has to use a mutex for libltdl.".
65
66 Guile does not currently support pre-emptive threads, so there is no
67 mutex. Previously SCM_CRITICAL_SECTION_START and
68 SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
69 somebody is grepping for thread problems ;)
70 */
71 /* njrev: not threadsafe, protection needed as described above */
72
73 static void *
sysdep_dynl_link(const char * fname,const char * subr)74 sysdep_dynl_link (const char *fname, const char *subr)
75 {
76 lt_dlhandle handle;
77 handle = lt_dlopenext (fname);
78 if (NULL == handle)
79 {
80 SCM fn;
81 SCM msg;
82
83 fn = scm_from_locale_string (fname);
84 msg = scm_from_locale_string (lt_dlerror ());
85 scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
86 }
87 return (void *) handle;
88 }
89
90 static void
sysdep_dynl_unlink(void * handle,const char * subr)91 sysdep_dynl_unlink (void *handle, const char *subr)
92 {
93 if (lt_dlclose ((lt_dlhandle) handle))
94 {
95 scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
96 }
97 }
98
99 static void *
sysdep_dynl_func(const char * symb,void * handle,const char * subr)100 sysdep_dynl_func (const char *symb, void *handle, const char *subr)
101 {
102 void *fptr;
103
104 fptr = lt_dlsym ((lt_dlhandle) handle, symb);
105 if (!fptr)
106 {
107 scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
108 }
109 return fptr;
110 }
111
112 static void
sysdep_dynl_init()113 sysdep_dynl_init ()
114 {
115 lt_dlinit ();
116 }
117
118 scm_t_bits scm_tc16_dynamic_obj;
119
120 #define DYNL_FILENAME SCM_SMOB_OBJECT
121 #define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x))
122 #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
123
124
125 static SCM
dynl_obj_mark(SCM ptr)126 dynl_obj_mark (SCM ptr)
127 {
128 return DYNL_FILENAME (ptr);
129 }
130
131
132 static int
dynl_obj_print(SCM exp,SCM port,scm_print_state * pstate)133 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
134 {
135 scm_puts ("#<dynamic-object ", port);
136 scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
137 if (DYNL_HANDLE (exp) == NULL)
138 scm_puts (" (unlinked)", port);
139 scm_putc ('>', port);
140 return 1;
141 }
142
143
144 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
145 (SCM filename),
146 "Find the shared object (shared library) denoted by\n"
147 "@var{filename} and link it into the running Guile\n"
148 "application. The returned\n"
149 "scheme object is a ``handle'' for the library which can\n"
150 "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
151 "Searching for object files is system dependent. Normally,\n"
152 "if @var{filename} does have an explicit directory it will\n"
153 "be searched for in locations\n"
154 "such as @file{/usr/lib} and @file{/usr/local/lib}.")
155 #define FUNC_NAME s_scm_dynamic_link
156 {
157 void *handle;
158 char *file;
159
160 scm_dynwind_begin (0);
161 file = scm_to_locale_string (filename);
162 scm_dynwind_free (file);
163 handle = sysdep_dynl_link (file, FUNC_NAME);
164 scm_dynwind_end ();
165 SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
166 }
167 #undef FUNC_NAME
168
169
170 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
171 (SCM obj),
172 "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
173 "or @code{#f} otherwise.")
174 #define FUNC_NAME s_scm_dynamic_object_p
175 {
176 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
177 }
178 #undef FUNC_NAME
179
180
181 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
182 (SCM dobj),
183 "Unlink a dynamic object from the application, if possible. The\n"
184 "object must have been linked by @code{dynamic-link}, with \n"
185 "@var{dobj} the corresponding handle. After this procedure\n"
186 "is called, the handle can no longer be used to access the\n"
187 "object.")
188 #define FUNC_NAME s_scm_dynamic_unlink
189 {
190 /*fixme* GC-problem */
191 SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
192 if (DYNL_HANDLE (dobj) == NULL) {
193 SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
194 } else {
195 sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
196 SET_DYNL_HANDLE (dobj, NULL);
197 return SCM_UNSPECIFIED;
198 }
199 }
200 #undef FUNC_NAME
201
202
203 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
204 (SCM name, SCM dobj),
205 "Return a ``handle'' for the function @var{name} in the\n"
206 "shared object referred to by @var{dobj}. The handle\n"
207 "can be passed to @code{dynamic-call} to actually\n"
208 "call the function.\n\n"
209 "Regardless whether your C compiler prepends an underscore\n"
210 "@samp{_} to the global names in a program, you should\n"
211 "@strong{not} include this underscore in @var{name}\n"
212 "since it will be added automatically when necessary.")
213 #define FUNC_NAME s_scm_dynamic_func
214 {
215 /* The returned handle is formed by casting the address of the function to a
216 * long value and converting this to a scheme number
217 */
218
219 void (*func) ();
220
221 SCM_VALIDATE_STRING (1, name);
222 /*fixme* GC-problem */
223 SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
224 if (DYNL_HANDLE (dobj) == NULL) {
225 SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
226 } else {
227 char *chars;
228
229 scm_dynwind_begin (0);
230 chars = scm_to_locale_string (name);
231 scm_dynwind_free (chars);
232 func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
233 FUNC_NAME);
234 scm_dynwind_end ();
235 return scm_from_ulong ((unsigned long) func);
236 }
237 }
238 #undef FUNC_NAME
239
240
241 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
242 (SCM func, SCM dobj),
243 "Call a C function in a dynamic object. Two styles of\n"
244 "invocation are supported:\n\n"
245 "@itemize @bullet\n"
246 "@item @var{func} can be a function handle returned by\n"
247 "@code{dynamic-func}. In this case @var{dobj} is\n"
248 "ignored\n"
249 "@item @var{func} can be a string with the name of the\n"
250 "function to call, with @var{dobj} the handle of the\n"
251 "dynamic object in which to find the function.\n"
252 "This is equivalent to\n"
253 "@smallexample\n\n"
254 "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
255 "@end smallexample\n"
256 "@end itemize\n\n"
257 "In either case, the function is passed no arguments\n"
258 "and its return value is ignored.")
259 #define FUNC_NAME s_scm_dynamic_call
260 {
261 void (*fptr) ();
262
263 if (scm_is_string (func))
264 func = scm_dynamic_func (func, dobj);
265 fptr = (void (*) ()) scm_to_ulong (func);
266 fptr ();
267 return SCM_UNSPECIFIED;
268 }
269 #undef FUNC_NAME
270
271 static void
free_string_pointers(void * data)272 free_string_pointers (void *data)
273 {
274 scm_i_free_string_pointers ((char **)data);
275 }
276
277 SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
278 (SCM func, SCM dobj, SCM args),
279 "Call the C function indicated by @var{func} and @var{dobj},\n"
280 "just like @code{dynamic-call}, but pass it some arguments and\n"
281 "return its return value. The C function is expected to take\n"
282 "two arguments and return an @code{int}, just like @code{main}:\n"
283 "@smallexample\n"
284 "int c_func (int argc, char **argv);\n"
285 "@end smallexample\n\n"
286 "The parameter @var{args} must be a list of strings and is\n"
287 "converted into an array of @code{char *}. The array is passed\n"
288 "in @var{argv} and its size in @var{argc}. The return value is\n"
289 "converted to a Scheme number and returned from the call to\n"
290 "@code{dynamic-args-call}.")
291 #define FUNC_NAME s_scm_dynamic_args_call
292 {
293 int (*fptr) (int argc, char **argv);
294 int result, argc;
295 char **argv;
296
297 scm_dynwind_begin (0);
298
299 if (scm_is_string (func))
300 func = scm_dynamic_func (func, dobj);
301
302 fptr = (int (*) (int, char **)) scm_to_ulong (func);
303
304 argv = scm_i_allocate_string_pointers (args);
305 scm_dynwind_unwind_handler (free_string_pointers, argv,
306 SCM_F_WIND_EXPLICITLY);
307 for (argc = 0; argv[argc]; argc++)
308 ;
309 result = (*fptr) (argc, argv);
310
311 scm_dynwind_end ();
312 return scm_from_int (result);
313 }
314 #undef FUNC_NAME
315
316 void
scm_init_dynamic_linking()317 scm_init_dynamic_linking ()
318 {
319 scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
320 scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
321 scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
322 sysdep_dynl_init ();
323 #include "libguile/dynl.x"
324 }
325
326 /*
327 Local Variables:
328 c-file-style: "gnu"
329 End:
330 */
331