libguile/dynl.c

   1 /* dynl.c - dynamic linking
   2  *
   3  * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2, or (at your option)
   8  * any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this software; see the file COPYING.  If not, write to
  17  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18  * Boston, MA 02111-1307 USA
  19  *
  20  * As a special exception, the Free Software Foundation gives permission
  21  * for additional uses of the text contained in its release of GUILE.
  22  *
  23  * The exception is that, if you link the GUILE library with other files
  24  * to produce an executable, this does not by itself cause the
  25  * resulting executable to be covered by the GNU General Public License.
  26  * Your use of that executable is in no way restricted on account of
  27  * linking the GUILE library code into it.
  28  *
  29  * This exception does not however invalidate any other reasons why
  30  * the executable file might be covered by the GNU General Public License.
  31  *
  32  * This exception applies only to the code released by the
  33  * Free Software Foundation under the name GUILE.  If you copy
  34  * code from other Free Software Foundation releases into a copy of
  35  * GUILE, as the General Public License permits, the exception does
  36  * not apply to the code that you add in this way.  To avoid misleading
  37  * anyone as to the status of such modified files, you must delete
  38  * this exception notice from them.
  39  *
  40  * If you write modifications of your own for GUILE, it is your choice
  41  * whether to permit this exception to apply to your modifications.
  42  * If you do not wish that, delete this exception notice.  */
  43
  44
  45
  46 /* "dynl.c" dynamically link&load object files.
  47    Author: Aubrey Jaffer
  48    Modified for libguile by Marius Vollmer */
  49
  50 #if 0 /* Disabled until we know for sure that it isn't needed */
  51 /* XXX - This is only here to drag in a definition of __eprintf. This
  52    is needed for proper operation of dynamic linking. The real
  53    solution would probably be a shared libgcc. */
  54
  55 #undef NDEBUG
  56 #include <assert.h>
  57
  58 static void
  59 maybe_drag_in_eprintf ()
  60 {
  61   assert (!maybe_drag_in_eprintf);
  62 }
  63 #endif
  64
  65 #include <stdio.h>
  66 #include <string.h>
  67
  68 #include "libguile/_scm.h"
  69 #include "libguile/dynl.h"
  70 #include "libguile/smob.h"
  71 #include "libguile/keywords.h"
  72 #include "libguile/ports.h"
  73 #include "libguile/strings.h"
  74 #include "libguile/deprecation.h"
  75 #include "libguile/lang.h"
  76 #include "libguile/validate.h"
  77
  78 #ifdef DYNAMIC_LINKING
  79
  80 #include "libltdl/ltdl.h"
  81
  82 /* From the libtool manual: "Note that libltdl is not threadsafe,
  83    i.e. a multithreaded application has to use a mutex for libltdl.".
  84
  85    Guile does not currently support pre-emptive threads, so there is
  86    no mutex.  Previously SCM_DEFER_INTS and SCM_ALLOW_INTS were used:
  87    they are mentioned here in case somebody is grepping for thread
  88    problems ;)
  89 */
  90
  91 static void *
  92 sysdep_dynl_link (const char *fname, const char *subr)
  93 {
  94   lt_dlhandle handle;
  95   handle = lt_dlopenext (fname);
  96   if (NULL == handle)
  97     {
  98       SCM fn;
  99       SCM msg;
 100
 101       fn = scm_makfrom0str (fname);
 102       msg = scm_makfrom0str (lt_dlerror ());
 103       scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
 104     }
 105   return (void *) handle;
 106 }
 107
 108 static void
 109 sysdep_dynl_unlink (void *handle, const char *subr)
 110 {
 111   if (lt_dlclose ((lt_dlhandle) handle))
 112     {
 113       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 114     }
 115 }
 116
 117 static void *
 118 sysdep_dynl_func (const char *symb, void *handle, const char *subr)
 119 {
 120   void *fptr;
 121
 122   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 123   if (!fptr)
 124     {
 125       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 126     }
 127   return fptr;
 128 }
 129
 130 static void
 131 sysdep_dynl_init ()
 132 {
 133   lt_dlinit ();
 134 }
 135
 136 #else
 137
 138 /* no dynamic linking available, throw errors. */
 139
 140 static void
 141 sysdep_dynl_init (void)
 142 {
 143 }
 144
 145 static void
 146 no_dynl_error (const char *subr)
 147 {
 148   scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 149 }
 150
 151 static void *
 152 sysdep_dynl_link (const char *filename, const char *subr)
 153 {
 154   no_dynl_error (subr);
 155   return NULL;
 156 }
 157
 158 static void
 159 sysdep_dynl_unlink (void *handle,
 160                     const char *subr)
 161 {
 162   no_dynl_error (subr);
 163 }
 164
 165 static void *
 166 sysdep_dynl_func (const char *symbol,
 167                   void *handle,
 168                   const char *subr)
 169 {
 170   no_dynl_error (subr);
 171   return NULL;
 172 }
 173
 174 #endif
 175
 176 scm_t_bits scm_tc16_dynamic_obj;
 177
 178 #define DYNL_FILENAME(x)        (SCM_CELL_OBJECT_1 (x))
 179 #define DYNL_HANDLE(x)          ((void *) SCM_CELL_WORD_2 (x))
 180 #define SET_DYNL_HANDLE(x, v)   (SCM_SET_CELL_WORD_2 ((x), (v)))
 181
 182
 183 static SCM
 184 dynl_obj_mark (SCM ptr)
 185 {
 186   return DYNL_FILENAME (ptr);
 187 }
 188
 189
 190 static int
 191 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 192 {
 193   scm_puts ("#<dynamic-object ", port);
 194   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 195   if (DYNL_HANDLE (exp) == NULL)
 196     scm_puts (" (unlinked)", port);
 197   scm_putc ('>', port);
 198   return 1;
 199 }
 200
 201
 202 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
 203             (SCM filename),
 204             "Open the dynamic library called @var{filename}.  A library\n"
 205             "handle representing the opened library is returned; this handle\n"
 206             "should be used as the @var{dobj} argument to the following\n"
 207             "functions.")
 208 #define FUNC_NAME s_scm_dynamic_link
 209 {
 210   void *handle;
 211
 212   SCM_VALIDATE_STRING (1, filename);
 213   handle = sysdep_dynl_link (SCM_STRING_CHARS (filename), FUNC_NAME);
 214   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
 215 }
 216 #undef FUNC_NAME
 217
 218
 219 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 220             (SCM obj),
 221             "Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}\n"
 222             "otherwise.")
 223 #define FUNC_NAME s_scm_dynamic_object_p
 224 {
 225   return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 226 }
 227 #undef FUNC_NAME
 228
 229
 230 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 231             (SCM dobj),
 232             "Unlink the indicated object file from the application.  The\n"
 233             "argument @var{dobj} must have been obtained by a call to\n"
 234             "@code{dynamic-link}.  After @code{dynamic-unlink} has been\n"
 235             "called on @var{dobj}, its content is no longer accessible.")
 236 #define FUNC_NAME s_scm_dynamic_unlink
 237 {
 238   /*fixme* GC-problem */
 239   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 240   if (DYNL_HANDLE (dobj) == NULL) {
 241     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 242   } else {
 243     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 244     SET_DYNL_HANDLE (dobj, NULL);
 245     return SCM_UNSPECIFIED;
 246   }
 247 }
 248 #undef FUNC_NAME
 249
 250
 251 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 252             (SCM name, SCM dobj),
 253             "Search the dynamic object @var{dobj} for the C function\n"
 254             "indicated by the string @var{name} and return some Scheme\n"
 255             "handle that can later be used with @code{dynamic-call} to\n"
 256             "actually call the function.\n\n"
 257             "Regardless whether your C compiler prepends an underscore @samp{_} to\n"
 258             "the global names in a program, you should @strong{not} include this\n"
 259             "underscore in @var{function}.  Guile knows whether the underscore is\n"
 260             "needed or not and will add it when necessary.")
 261 #define FUNC_NAME s_scm_dynamic_func
 262 {
 263   /* The returned handle is formed by casting the address of the function to a
 264    * long value and converting this to a scheme number
 265    */
 266
 267   void (*func) ();
 268
 269   SCM_VALIDATE_STRING (1, name);
 270   /*fixme* GC-problem */
 271   SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
 272   if (DYNL_HANDLE (dobj) == NULL) {
 273     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 274   } else {
 275     char *chars;
 276
 277     chars = SCM_STRING_CHARS (name);
 278     func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME);
 279     return scm_ulong2num ((unsigned long) func);
 280   }
 281 }
 282 #undef FUNC_NAME
 283
 284
 285 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 286             (SCM func, SCM dobj),
 287             "Call the C function indicated by @var{func} and @var{dobj}.\n"
 288             "The function is passed no arguments and its return value is\n"
 289             "ignored.  When @var{function} is something returned by\n"
 290             "@code{dynamic-func}, call that function and ignore @var{dobj}.\n"
 291             "When @var{func} is a string , look it up in @var{dynobj}; this\n"
 292             "is equivalent to\n"
 293             "@smallexample\n"
 294             "(dynamic-call (dynamic-func @var{func} @var{dobj} #f))\n"
 295             "@end smallexample\n\n")
 296 #define FUNC_NAME s_scm_dynamic_call
 297 {
 298   void (*fptr) ();
 299
 300   if (SCM_STRINGP (func))
 301     func = scm_dynamic_func (func, dobj);
 302   fptr = (void (*) ()) SCM_NUM2ULONG (1, func);
 303   fptr ();
 304   return SCM_UNSPECIFIED;
 305 }
 306 #undef FUNC_NAME
 307
 308 /* return a newly allocated array of char pointers to each of the strings
 309    in args, with a terminating NULL pointer.  */
 310 /* Note: a similar function is defined in posix.c, but we don't necessarily
 311    want to export it.  */
 312 static char **allocate_string_pointers (SCM args, int *num_args_return)
 313 {
 314   char **result;
 315   int n_args = scm_ilength (args);
 316   int i;
 317
 318   SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers");
 319   result = (char **) scm_malloc ((n_args + 1) * sizeof (char *));
 320   result[n_args] = NULL;
 321   for (i = 0; i < n_args; i++)
 322     {
 323       SCM car = SCM_CAR (args);
 324
 325       if (!SCM_STRINGP (car))
 326         {
 327           free (result);
 328           scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car);
 329         }
 330       result[i] = SCM_STRING_CHARS (SCM_CAR (args));
 331       args = SCM_CDR (args);
 332     }
 333   *num_args_return = n_args;
 334   return result;
 335 }
 336
 337 SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
 338             (SCM func, SCM dobj, SCM args),
 339             "Call the C function indicated by @var{func} and @var{dobj},\n"
 340             "just like @code{dynamic-call}, but pass it some arguments and\n"
 341             "return its return value.  The C function is expected to take\n"
 342             "two arguments and return an @code{int}, just like @code{main}:\n"
 343             "@smallexample\n"
 344             "int c_func (int argc, char **argv);\n"
 345             "@end smallexample\n\n"
 346             "The parameter @var{args} must be a list of strings and is\n"
 347             "converted into an array of @code{char *}.  The array is passed\n"
 348             "in @var{argv} and its size in @var{argc}.  The return value is\n"
 349             "converted to a Scheme number and returned from the call to\n"
 350             "@code{dynamic-args-call}.")
 351 #define FUNC_NAME s_scm_dynamic_args_call
 352 {
 353   int (*fptr) (int argc, char **argv);
 354   int result, argc;
 355   char **argv;
 356
 357   if (SCM_STRINGP (func))
 358     func = scm_dynamic_func (func, dobj);
 359
 360   fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func);
 361   argv = allocate_string_pointers (args, &argc);
 362   /* if the procedure mutates its arguments, the original strings will be
 363      changed -- in Guile 1.6 and earlier, this wasn't the case since a
 364      new copy of each string was allocated.  */
 365   result = (*fptr) (argc, argv);
 366   free (argv);
 367
 368   return SCM_MAKINUM (0L + result);
 369 }
 370 #undef FUNC_NAME
 371
 372 void
 373 scm_init_dynamic_linking ()
 374 {
 375   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 376   scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
 377   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 378   sysdep_dynl_init ();
 379 #include "libguile/dynl.x"
 380 }
 381
 382 /*
 383   Local Variables:
 384   c-file-style: "gnu"
 385   End:
 386 */