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