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 /* Dispatch to the system dependent files
  79  *
  80  * They define some static functions.  These functions are called with
  81  * deferred interrupts.  When they want to throw errors, they are
  82  * expected to insert a SCM_ALLOW_INTS before doing the throw.  It
  83  * might work to throw an error while interrupts are deferred (because
  84  * they will be unconditionally allowed the next time a SCM_ALLOW_INTS
  85  * is executed, SCM_DEFER_INTS and SCM_ALLOW_INTS do not nest).
  86  */
  87
  88 #ifdef DYNAMIC_LINKING
  89
  90 #include "libltdl/ltdl.h"
  91
  92 static void *
  93 sysdep_dynl_link (const char *fname, const char *subr)
  94 {
  95   lt_dlhandle handle;
  96   handle = lt_dlopenext (fname);
  97   if (NULL == handle)
  98     {
  99       SCM fn;
 100       SCM msg;
 101
 102       SCM_ALLOW_INTS;
 103       fn = scm_makfrom0str (fname);
 104       msg = scm_makfrom0str (lt_dlerror ());
 105       scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
 106     }
 107   return (void *) handle;
 108 }
 109
 110 static void
 111 sysdep_dynl_unlink (void *handle, const char *subr)
 112 {
 113   if (lt_dlclose ((lt_dlhandle) handle))
 114     {
 115       SCM_ALLOW_INTS;
 116       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 117     }
 118 }
 119
 120 static void *
 121 sysdep_dynl_func (const char *symb, void *handle, const char *subr)
 122 {
 123   void *fptr;
 124
 125   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 126   if (!fptr)
 127     {
 128       SCM_ALLOW_INTS;
 129       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 130     }
 131   return fptr;
 132 }
 133
 134 static void
 135 sysdep_dynl_init ()
 136 {
 137   lt_dlinit ();
 138 }
 139
 140 #else
 141
 142 /* no dynamic linking available, throw errors. */
 143
 144 static void
 145 sysdep_dynl_init (void)
 146 {
 147 }
 148
 149 static void
 150 no_dynl_error (const char *subr)
 151 {
 152   SCM_ALLOW_INTS;
 153   scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 154 }
 155
 156 static void *
 157 sysdep_dynl_link (const char *filename, const char *subr)
 158 {
 159   no_dynl_error (subr);
 160   return NULL;
 161 }
 162
 163 static void
 164 sysdep_dynl_unlink (void *handle,
 165                     const char *subr)
 166 {
 167   no_dynl_error (subr);
 168 }
 169
 170 static void *
 171 sysdep_dynl_func (const char *symbol,
 172                   void *handle,
 173                   const char *subr)
 174 {
 175   no_dynl_error (subr);
 176   return NULL;
 177 }
 178
 179 #endif
 180
 181 scm_t_bits scm_tc16_dynamic_obj;
 182
 183 #define DYNL_FILENAME(x)        (SCM_CELL_OBJECT_1 (x))
 184 #define DYNL_HANDLE(x)          ((void *) SCM_CELL_WORD_2 (x))
 185 #define SET_DYNL_HANDLE(x, v)   (SCM_SET_CELL_WORD_2 ((x), (v)))
 186
 187
 188 static SCM
 189 dynl_obj_mark (SCM ptr)
 190 {
 191   return DYNL_FILENAME (ptr);
 192 }
 193
 194
 195 static int
 196 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 197 {
 198   scm_puts ("#<dynamic-object ", port);
 199   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 200   if (DYNL_HANDLE (exp) == NULL)
 201     scm_puts (" (unlinked)", port);
 202   scm_putc ('>', port);
 203   return 1;
 204 }
 205
 206
 207 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
 208             (SCM filename),
 209             "Open the dynamic library called @var{filename}.  A library\n"
 210             "handle representing the opened library is returned; this handle\n"
 211             "should be used as the @var{dobj} argument to the following\n"
 212             "functions.")
 213 #define FUNC_NAME s_scm_dynamic_link
 214 {
 215   void *handle;
 216
 217   SCM_VALIDATE_STRING (1, filename);
 218   handle = sysdep_dynl_link (SCM_STRING_CHARS (filename), FUNC_NAME);
 219   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
 220 }
 221 #undef FUNC_NAME
 222
 223
 224 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 225             (SCM obj),
 226             "Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}\n"
 227             "otherwise.")
 228 #define FUNC_NAME s_scm_dynamic_object_p
 229 {
 230   return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 231 }
 232 #undef FUNC_NAME
 233
 234
 235 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 236             (SCM dobj),
 237             "Unlink the indicated object file from the application.  The\n"
 238             "argument @var{dobj} must have been obtained by a call to\n"
 239             "@code{dynamic-link}.  After @code{dynamic-unlink} has been\n"
 240             "called on @var{dobj}, its content is no longer accessible.")
 241 #define FUNC_NAME s_scm_dynamic_unlink
 242 {
 243   /*fixme* GC-problem */
 244   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 245   if (DYNL_HANDLE (dobj) == NULL) {
 246     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 247   } else {
 248     SCM_DEFER_INTS;
 249     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 250     SET_DYNL_HANDLE (dobj, NULL);
 251     SCM_ALLOW_INTS;
 252     return SCM_UNSPECIFIED;
 253   }
 254 }
 255 #undef FUNC_NAME
 256
 257
 258 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 259             (SCM name, SCM dobj),
 260             "Search the dynamic object @var{dobj} for the C function\n"
 261             "indicated by the string @var{name} and return some Scheme\n"
 262             "handle that can later be used with @code{dynamic-call} to\n"
 263             "actually call the function.\n\n"
 264             "Regardless whether your C compiler prepends an underscore @samp{_} to\n"
 265             "the global names in a program, you should @strong{not} include this\n"
 266             "underscore in @var{function}.  Guile knows whether the underscore is\n"
 267             "needed or not and will add it when necessary.")
 268 #define FUNC_NAME s_scm_dynamic_func
 269 {
 270   /* The returned handle is formed by casting the address of the function to a
 271    * long value and converting this to a scheme number
 272    */
 273
 274   void (*func) ();
 275
 276   SCM_VALIDATE_STRING (1, name);
 277   /*fixme* GC-problem */
 278   SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
 279   if (DYNL_HANDLE (dobj) == NULL) {
 280     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 281   } else {
 282     char *chars;
 283
 284     SCM_DEFER_INTS;
 285     chars = SCM_STRING_CHARS (name);
 286     func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME);
 287     SCM_ALLOW_INTS;
 288     return scm_ulong2num ((unsigned long) func);
 289   }
 290 }
 291 #undef FUNC_NAME
 292
 293
 294 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 295             (SCM func, SCM dobj),
 296             "Call the C function indicated by @var{func} and @var{dobj}.\n"
 297             "The function is passed no arguments and its return value is\n"
 298             "ignored.  When @var{function} is something returned by\n"
 299             "@code{dynamic-func}, call that function and ignore @var{dobj}.\n"
 300             "When @var{func} is a string , look it up in @var{dynobj}; this\n"
 301             "is equivalent to\n"
 302             "@smallexample\n"
 303             "(dynamic-call (dynamic-func @var{func} @var{dobj} #f))\n"
 304             "@end smallexample\n\n"
 305             "Interrupts are deferred while the C function is executing (with\n"
 306             "@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}).")
 307 #define FUNC_NAME s_scm_dynamic_call
 308 {
 309   void (*fptr) ();
 310
 311   if (SCM_STRINGP (func))
 312     func = scm_dynamic_func (func, dobj);
 313   fptr = (void (*) ()) SCM_NUM2ULONG (1, func);
 314   SCM_DEFER_INTS;
 315   fptr ();
 316   SCM_ALLOW_INTS;
 317   return SCM_UNSPECIFIED;
 318 }
 319 #undef FUNC_NAME
 320
 321 /* return a newly allocated array of char pointers to each of the strings
 322    in args, with a terminating NULL pointer.  */
 323 /* Note: a similar function is defined in posix.c, but we don't necessarily
 324    want to export it.  */
 325 static char **allocate_string_pointers (SCM args, int *num_args_return)
 326 {
 327   char **result;
 328   int n_args = scm_ilength (args);
 329   int i;
 330
 331   SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers");
 332   result = (char **) scm_malloc ((n_args + 1) * sizeof (char *));
 333   result[n_args] = NULL;
 334   for (i = 0; i < n_args; i++)
 335     {
 336       SCM car = SCM_CAR (args);
 337
 338       if (!SCM_STRINGP (car))
 339         {
 340           free (result);
 341           scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car);
 342         }
 343       result[i] = SCM_STRING_CHARS (SCM_CAR (args));
 344       args = SCM_CDR (args);
 345     }
 346   *num_args_return = n_args;
 347   return result;
 348 }
 349
 350 SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
 351             (SCM func, SCM dobj, SCM args),
 352             "Call the C function indicated by @var{func} and @var{dobj},\n"
 353             "just like @code{dynamic-call}, but pass it some arguments and\n"
 354             "return its return value.  The C function is expected to take\n"
 355             "two arguments and return an @code{int}, just like @code{main}:\n"
 356             "@smallexample\n"
 357             "int c_func (int argc, char **argv);\n"
 358             "@end smallexample\n\n"
 359             "The parameter @var{args} must be a list of strings and is\n"
 360             "converted into an array of @code{char *}.  The array is passed\n"
 361             "in @var{argv} and its size in @var{argc}.  The return value is\n"
 362             "converted to a Scheme number and returned from the call to\n"
 363             "@code{dynamic-args-call}.")
 364 #define FUNC_NAME s_scm_dynamic_args_call
 365 {
 366   int (*fptr) (int argc, char **argv);
 367   int result, argc;
 368   char **argv;
 369
 370   if (SCM_STRINGP (func))
 371     func = scm_dynamic_func (func, dobj);
 372
 373   fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func);
 374   SCM_DEFER_INTS;
 375   argv = allocate_string_pointers (args, &argc);
 376   /* if the procedure mutates its arguments, the original strings will be
 377      changed -- in Guile 1.6 and earlier, this wasn't the case since a
 378      new copy of each string was allocated.  */
 379   result = (*fptr) (argc, argv);
 380   free (argv);
 381   SCM_ALLOW_INTS;
 382
 383   return SCM_MAKINUM (0L + result);
 384 }
 385 #undef FUNC_NAME
 386
 387 void
 388 scm_init_dynamic_linking ()
 389 {
 390   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 391   scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
 392   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 393   sysdep_dynl_init ();
 394 #include "libguile/dynl.x"
 395 }
 396
 397 /*
 398   Local Variables:
 399   c-file-style: "gnu"
 400   End:
 401 */