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 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
  62 #include <ltdl.h>
  63
  64 /*
  65   From the libtool manual: "Note that libltdl is not threadsafe,
  66   i.e. a multithreaded application has to use a mutex for libltdl.".
  67
  68   Guile does not currently support pre-emptive threads, so there is no
  69   mutex.  Previously SCM_CRITICAL_SECTION_START and
  70   SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
  71   somebody is grepping for thread problems ;)
  72 */
  73 /* njrev: not threadsafe, protection needed as described above */
  74
  75 static void *
  76 sysdep_dynl_link (const char *fname, const char *subr)
  77 {
  78   lt_dlhandle handle;
  79   handle = lt_dlopenext (fname);
  80   if (NULL == handle)
  81     {
  82       SCM fn;
  83       SCM msg;
  84
  85       fn = scm_from_locale_string (fname);
  86       msg = scm_from_locale_string (lt_dlerror ());
  87       scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
  88     }
  89   return (void *) handle;
  90 }
  91
  92 static void
  93 sysdep_dynl_unlink (void *handle, const char *subr)
  94 {
  95   if (lt_dlclose ((lt_dlhandle) handle))
  96     {
  97       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
  98     }
  99 }
 100
 101 static void *
 102 sysdep_dynl_func (const char *symb, void *handle, const char *subr)
 103 {
 104   void *fptr;
 105
 106   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 107   if (!fptr)
 108     {
 109       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 110     }
 111   return fptr;
 112 }
 113
 114 static void
 115 sysdep_dynl_init ()
 116 {
 117   char *env;
 118
 119   lt_dlinit ();
 120
 121   env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
 122   if (env && strcmp (env, "") == 0)
 123     /* special-case interpret system-ltdl-path=="" as meaning no system path,
 124        which is the case during the build */
 125     ;
 126   else if (env)
 127     /* FIXME: should this be a colon-separated path? Or is the only point to
 128        allow the build system to turn off the installed extensions path? */
 129     lt_dladdsearchdir (env);
 130   else
 131     {
 132       lt_dladdsearchdir (SCM_LIB_DIR);
 133       lt_dladdsearchdir (SCM_EXTENSIONS_DIR);
 134     }
 135 }
 136
 137 scm_t_bits scm_tc16_dynamic_obj;
 138
 139 #define DYNL_FILENAME         SCM_SMOB_OBJECT
 140 #define DYNL_HANDLE(x)        ((void *) SCM_SMOB_DATA_2 (x))
 141 #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
 142
 143
 144
 145 static int
 146 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 147 {
 148   scm_puts ("#<dynamic-object ", port);
 149   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 150   if (DYNL_HANDLE (exp) == NULL)
 151     scm_puts (" (unlinked)", port);
 152   scm_putc ('>', port);
 153   return 1;
 154 }
 155
 156
 157 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
 158             (SCM filename),
 159             "Find the shared object (shared library) denoted by\n"
 160             "@var{filename} and link it into the running Guile\n"
 161             "application.  The returned\n"
 162             "scheme object is a ``handle'' for the library which can\n"
 163             "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
 164             "Searching for object files is system dependent.  Normally,\n"
 165             "if @var{filename} does have an explicit directory it will\n"
 166             "be searched for in locations\n"
 167             "such as @file{/usr/lib} and @file{/usr/local/lib}.")
 168 #define FUNC_NAME s_scm_dynamic_link
 169 {
 170   void *handle;
 171   char *file;
 172
 173   scm_dynwind_begin (0);
 174   file = scm_to_locale_string (filename);
 175   scm_dynwind_free (file);
 176   handle = sysdep_dynl_link (file, FUNC_NAME);
 177   scm_dynwind_end ();
 178   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
 179 }
 180 #undef FUNC_NAME
 181
 182
 183 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 184             (SCM obj),
 185             "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
 186             "or @code{#f} otherwise.")
 187 #define FUNC_NAME s_scm_dynamic_object_p
 188 {
 189   return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 190 }
 191 #undef FUNC_NAME
 192
 193
 194 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 195             (SCM dobj),
 196             "Unlink a dynamic object from the application, if possible.  The\n"
 197             "object must have been linked by @code{dynamic-link}, with \n"
 198             "@var{dobj} the corresponding handle.  After this procedure\n"
 199             "is called, the handle can no longer be used to access the\n"
 200             "object.")
 201 #define FUNC_NAME s_scm_dynamic_unlink
 202 {
 203   /*fixme* GC-problem */
 204   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 205   if (DYNL_HANDLE (dobj) == NULL) {
 206     SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
 207   } else {
 208     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 209     SET_DYNL_HANDLE (dobj, NULL);
 210     return SCM_UNSPECIFIED;
 211   }
 212 }
 213 #undef FUNC_NAME
 214
 215
 216 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 217             (SCM name, SCM dobj),
 218             "Return a ``handle'' for the function @var{name} in the\n"
 219             "shared object referred to by @var{dobj}.  The handle\n"
 220             "can be passed to @code{dynamic-call} to actually\n"
 221             "call the function.\n\n"
 222             "Regardless whether your C compiler prepends an underscore\n"
 223             "@samp{_} to the global names in a program, you should\n"
 224             "@strong{not} include this underscore in @var{name}\n"
 225             "since it will be added automatically when necessary.")
 226 #define FUNC_NAME s_scm_dynamic_func
 227 {
 228   /* The returned handle is formed by casting the address of the function to a
 229    * long value and converting this to a scheme number
 230    */
 231
 232   void (*func) ();
 233
 234   SCM_VALIDATE_STRING (1, name);
 235   /*fixme* GC-problem */
 236   SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
 237   if (DYNL_HANDLE (dobj) == NULL) {
 238     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 239   } else {
 240     char *chars;
 241
 242     scm_dynwind_begin (0);
 243     chars = scm_to_locale_string (name);
 244     scm_dynwind_free (chars);
 245     func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
 246                                            FUNC_NAME);
 247     scm_dynwind_end ();
 248     return scm_from_ulong ((unsigned long) func);
 249   }
 250 }
 251 #undef FUNC_NAME
 252
 253
 254 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 255             (SCM func, SCM dobj),
 256             "Call a C function in a dynamic object.  Two styles of\n"
 257             "invocation are supported:\n\n"
 258             "@itemize @bullet\n"
 259             "@item @var{func} can be a function handle returned by\n"
 260             "@code{dynamic-func}.  In this case @var{dobj} is\n"
 261             "ignored\n"
 262             "@item @var{func} can be a string with the name of the\n"
 263             "function to call, with @var{dobj} the handle of the\n"
 264             "dynamic object in which to find the function.\n"
 265             "This is equivalent to\n"
 266             "@smallexample\n\n"
 267             "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
 268             "@end smallexample\n"
 269             "@end itemize\n\n"
 270             "In either case, the function is passed no arguments\n"
 271             "and its return value is ignored.")
 272 #define FUNC_NAME s_scm_dynamic_call
 273 {
 274   void (*fptr) ();
 275
 276   if (scm_is_string (func))
 277     func = scm_dynamic_func (func, dobj);
 278   fptr = (void (*) ()) scm_to_ulong (func);
 279   fptr ();
 280   return SCM_UNSPECIFIED;
 281 }
 282 #undef FUNC_NAME
 283
 284 SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
 285             (SCM func, SCM dobj, SCM args),
 286             "Call the C function indicated by @var{func} and @var{dobj},\n"
 287             "just like @code{dynamic-call}, but pass it some arguments and\n"
 288             "return its return value.  The C function is expected to take\n"
 289             "two arguments and return an @code{int}, just like @code{main}:\n"
 290             "@smallexample\n"
 291             "int c_func (int argc, char **argv);\n"
 292             "@end smallexample\n\n"
 293             "The parameter @var{args} must be a list of strings and is\n"
 294             "converted into an array of @code{char *}.  The array is passed\n"
 295             "in @var{argv} and its size in @var{argc}.  The return value is\n"
 296             "converted to a Scheme number and returned from the call to\n"
 297             "@code{dynamic-args-call}.")
 298 #define FUNC_NAME s_scm_dynamic_args_call
 299 {
 300   int (*fptr) (int argc, char **argv);
 301   int result, argc;
 302   char **argv;
 303
 304   if (scm_is_string (func))
 305     func = scm_dynamic_func (func, dobj);
 306
 307   fptr = (int (*) (int, char **)) scm_to_ulong (func);
 308
 309   argv = scm_i_allocate_string_pointers (args);
 310   for (argc = 0; argv[argc]; argc++)
 311     ;
 312   result = (*fptr) (argc, argv);
 313
 314   return scm_from_int (result);
 315 }
 316 #undef FUNC_NAME
 317
 318 void
 319 scm_init_dynamic_linking ()
 320 {
 321   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 322   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 323   sysdep_dynl_init ();
 324 #include "libguile/dynl.x"
 325 }
 326
 327 /*
 328   Local Variables:
 329   c-file-style: "gnu"
 330   End:
 331 */