libguile/dynl.c

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