libguile/dynl.c

   1 /* dynl.c - dynamic linking
   2  *
   3  * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000 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 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  45    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  46
  47
  48 /* "dynl.c" dynamically link&load object files.
  49    Author: Aubrey Jaffer
  50    Modified for libguile by Marius Vollmer */
  51
  52 #if 0 /* Disabled until we know for sure that it isn't needed */
  53 /* XXX - This is only here to drag in a definition of __eprintf. This
  54    is needed for proper operation of dynamic linking. The real
  55    solution would probably be a shared libgcc. */
  56
  57 #undef NDEBUG
  58 #include <assert.h>
  59
  60 static void
  61 maybe_drag_in_eprintf ()
  62 {
  63   assert (!maybe_drag_in_eprintf);
  64 }
  65 #endif
  66
  67 #include <stdio.h>
  68 #include <string.h>
  69
  70 #include "libguile/_scm.h"
  71 #include "libguile/dynl.h"
  72 #include "libguile/smob.h"
  73 #include "libguile/keywords.h"
  74 #include "libguile/ports.h"
  75 #include "libguile/strings.h"
  76
  77 #include "libguile/validate.h"
  78
  79 /* Create a new C argv array from a scheme list of strings. */
  80 /* Dirk:FIXME:: A quite similar function is implemented in posix.c */
  81 /* Dirk:FIXME:: In case of assertion errors, we get memory leaks */
  82
  83 /* Converting a list of SCM strings into a argv-style array.  You must
  84    have ints disabled for the whole lifetime of the created argv (from
  85    before MAKE_ARGV_FROM_STRINGLIST until after
  86    MUST_FREE_ARGV). Atleast this is was the documentation for
  87    MAKARGVFROMSTRS says, it isn't really used that way.
  88
  89    This code probably belongs into strings.c
  90    (Dirk: IMO strings.c is not the right place.) */
  91
  92 static char **
  93 scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn)
  94 {
  95   char **argv;
  96   int argc;
  97   int i;
  98
  99   argc = scm_ilength (args);
 100   SCM_ASSERT (argc >= 0, args, argn, subr);
 101   argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr);
 102   for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) {
 103     SCM arg = SCM_CAR (args);
 104     scm_sizet len;
 105     char *dst;
 106     char *src;
 107
 108     SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr);
 109     len = SCM_STRING_LENGTH (arg);
 110     src = SCM_STRING_CHARS (arg);
 111     dst = (char *) scm_must_malloc (len + 1, subr);
 112     memcpy (dst, src, len);
 113     dst[len] = 0;
 114     argv[i] = dst;
 115   }
 116
 117   if (argcp)
 118     *argcp = argc;
 119   argv[argc] = 0;
 120   return argv;
 121 }
 122
 123 static void
 124 scm_must_free_argv(char **argv)
 125 {
 126   char **av = argv;
 127   while (*av)
 128     free (*(av++));
 129   free (argv);
 130 }
 131
 132 /* Module registry
 133  */
 134
 135 /* We can't use SCM objects here. One should be able to call
 136    SCM_REGISTER_MODULE from a C++ constructor for a static
 137    object. This happens before main and thus before libguile is
 138    initialized. */
 139
 140 struct moddata {
 141   struct moddata *link;
 142   char *module_name;
 143   void *init_func;
 144 };
 145
 146 static struct moddata *registered_mods = NULL;
 147
 148 void
 149 scm_register_module_xxx (char *module_name, void *init_func)
 150 {
 151   struct moddata *md;
 152
 153   /* XXX - should we (and can we) DEFER_INTS here? */
 154
 155   for (md = registered_mods; md; md = md->link)
 156     if (!strcmp (md->module_name, module_name))
 157       {
 158         md->init_func = init_func;
 159         return;
 160       }
 161
 162   md = (struct moddata *) malloc (sizeof (struct moddata));
 163   if (md == NULL)
 164     {
 165       fprintf (stderr,
 166                "guile: can't register module (%s): not enough memory",
 167                module_name);
 168       return;
 169     }
 170
 171   md->module_name = module_name;
 172   md->init_func = init_func;
 173   md->link = registered_mods;
 174   registered_mods = md;
 175 }
 176
 177 SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0,
 178             (),
 179             "Return a list of the object code modules that have been imported into\n"
 180             "the current Guile process.  Each element of the list is a pair whose\n"
 181             "car is the name of the module, and whose cdr is the function handle\n"
 182             "for that module's initializer function.  The name is the string that\n"
 183             "has been passed to scm_register_module_xxx.")
 184 #define FUNC_NAME s_scm_registered_modules
 185 {
 186   SCM res;
 187   struct moddata *md;
 188
 189   res = SCM_EOL;
 190   for (md = registered_mods; md; md = md->link)
 191     res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
 192                               scm_ulong2num ((unsigned long) md->init_func)),
 193                     res);
 194   return res;
 195 }
 196 #undef FUNC_NAME
 197
 198 SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
 199             (),
 200             "Destroy the list of modules registered with the current Guile process.\n"
 201             "The return value is unspecified.  @strong{Warning:} this function does\n"
 202             "not actually unlink or deallocate these modules, but only destroys the\n"
 203             "records of which modules have been loaded.  It should therefore be used\n"
 204             "only by module bookkeeping operations.")
 205 #define FUNC_NAME s_scm_clear_registered_modules
 206 {
 207   struct moddata *md1, *md2;
 208
 209   SCM_DEFER_INTS;
 210
 211   for (md1 = registered_mods; md1; md1 = md2)
 212     {
 213       md2 = md1->link;
 214       free (md1);
 215     }
 216   registered_mods = NULL;
 217
 218   SCM_ALLOW_INTS;
 219   return SCM_UNSPECIFIED;
 220 }
 221 #undef FUNC_NAME
 222
 223 /* Dispatch to the system dependent files
 224  *
 225  * They define some static functions.  These functions are called with
 226  * deferred interrupts.  When they want to throw errors, they are
 227  * expected to insert a SCM_ALLOW_INTS before doing the throw.  It
 228  * might work to throw an error while interrupts are deferred (because
 229  * they will be unconditionally allowed the next time a SCM_ALLOW_INTS
 230  * is executed, SCM_DEFER_INTS and SCM_ALLOW_INTS do not nest).
 231  */
 232
 233 #ifdef DYNAMIC_LINKING
 234
 235 #include "libltdl/ltdl.h"
 236
 237 static void *
 238 sysdep_dynl_link (const char *fname, const char *subr)
 239 {
 240   lt_dlhandle handle;
 241   handle = lt_dlopenext (fname);
 242   if (NULL == handle)
 243     {
 244       SCM fn;
 245       SCM msg;
 246
 247       SCM_ALLOW_INTS;
 248       fn = scm_makfrom0str (fname);
 249       msg = scm_makfrom0str (lt_dlerror ());
 250       scm_misc_error (subr, "file: ~S, message: ~S", SCM_LIST2 (fn, msg));
 251     }
 252   return (void *) handle;
 253 }
 254
 255 static void
 256 sysdep_dynl_unlink (void *handle, const char *subr)
 257 {
 258   if (lt_dlclose ((lt_dlhandle) handle))
 259     {
 260       SCM_ALLOW_INTS;
 261       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 262     }
 263 }
 264
 265 static void *
 266 sysdep_dynl_func (const char *symb, void *handle, const char *subr)
 267 {
 268   void *fptr;
 269
 270   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 271   if (!fptr)
 272     {
 273       SCM_ALLOW_INTS;
 274       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 275     }
 276   return fptr;
 277 }
 278
 279 static void
 280 sysdep_dynl_init ()
 281 {
 282   lt_dlinit ();
 283 }
 284
 285 #else
 286
 287 /* no dynamic linking available, throw errors. */
 288
 289 static void
 290 sysdep_dynl_init (void)
 291 {
 292 }
 293
 294 static void
 295 no_dynl_error (const char *subr)
 296 {
 297   SCM_ALLOW_INTS;
 298   scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 299 }
 300
 301 static void *
 302 sysdep_dynl_link (const char *filename, const char *subr)
 303 {
 304   no_dynl_error (subr);
 305   return NULL;
 306 }
 307
 308 static void
 309 sysdep_dynl_unlink (void *handle,
 310                     const char *subr)
 311 {
 312   no_dynl_error (subr);
 313 }
 314
 315 static void *
 316 sysdep_dynl_func (const char *symbol,
 317                   void *handle,
 318                   const char *subr)
 319 {
 320   no_dynl_error (subr);
 321   return NULL;
 322 }
 323
 324 #endif
 325
 326 scm_bits_t scm_tc16_dynamic_obj;
 327
 328 #define DYNL_FILENAME(x)        (SCM_CELL_OBJECT_1 (x))
 329 #define DYNL_HANDLE(x)          ((void *) SCM_CELL_WORD_2 (x))
 330 #define SET_DYNL_HANDLE(x, v)   (SCM_SET_CELL_WORD_2 ((x), (v)))
 331
 332
 333 static SCM
 334 dynl_obj_mark (SCM ptr)
 335 {
 336   return DYNL_FILENAME (ptr);
 337 }
 338
 339
 340 static int
 341 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 342 {
 343   scm_puts ("#<dynamic-object ", port);
 344   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 345   if (DYNL_HANDLE (exp) == NULL)
 346     scm_puts (" (unlinked)", port);
 347   scm_putc ('>', port);
 348   return 1;
 349 }
 350
 351
 352 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
 353             (SCM fname),
 354             "Open the dynamic library @var{library-file}.  A library handle\n"
 355             "representing the opened library is returned; this handle should be used\n"
 356             "as the @var{lib} argument to the following functions.")
 357 #define FUNC_NAME s_scm_dynamic_link
 358 {
 359   void *handle;
 360
 361   SCM_VALIDATE_STRING (1, fname);
 362   SCM_STRING_COERCE_0TERMINATION_X (fname);
 363   handle = sysdep_dynl_link (SCM_STRING_CHARS (fname), FUNC_NAME);
 364   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (fname), handle);
 365 }
 366 #undef FUNC_NAME
 367
 368
 369 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 370             (SCM obj),
 371             "Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}\n"
 372             "otherwise.")
 373 #define FUNC_NAME s_scm_dynamic_object_p
 374 {
 375   return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 376 }
 377 #undef FUNC_NAME
 378
 379
 380 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 381             (SCM dobj),
 382             "Unlink the library represented by @var{library-handle},\n"
 383             "and remove any imported symbols from the address space.\n"
 384             "GJB:FIXME:DOC: 2nd version below:\n"
 385             "Unlink the indicated object file from the application.  The\n"
 386             "argument @var{dynobj} must have been obtained by a call to\n"
 387             "@code{dynamic-link}.  After @code{dynamic-unlink} has been\n"
 388             "called on @var{dynobj}, its content is no longer accessible.")
 389 #define FUNC_NAME s_scm_dynamic_unlink
 390 {
 391   /*fixme* GC-problem */
 392   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 393   if (DYNL_HANDLE (dobj) == NULL) {
 394     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 395   } else {
 396     SCM_DEFER_INTS;
 397     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 398     SET_DYNL_HANDLE (dobj, NULL);
 399     SCM_ALLOW_INTS;
 400     return SCM_UNSPECIFIED;
 401   }
 402 }
 403 #undef FUNC_NAME
 404
 405
 406 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 407             (SCM name, SCM dobj),
 408             "Search the dynamic object @var{dobj} for the C function\n"
 409             "indicated by the string @var{name} and return some Scheme\n"
 410             "handle that can later be used with @code{dynamic-call} to\n"
 411             "actually call the function.\n\n"
 412             "Regardless whether your C compiler prepends an underscore @samp{_} to\n"
 413             "the global names in a program, you should @strong{not} include this\n"
 414             "underscore in @var{function}.  Guile knows whether the underscore is\n"
 415             "needed or not and will add it when necessary.")
 416 #define FUNC_NAME s_scm_dynamic_func
 417 {
 418   /* The returned handle is formed by casting the address of the function to a
 419    * long value and converting this to a scheme number
 420    */
 421
 422   void (*func) ();
 423
 424   SCM_VALIDATE_STRING (1, name);
 425   /*fixme* GC-problem */
 426   SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
 427   if (DYNL_HANDLE (dobj) == NULL) {
 428     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 429   } else {
 430     char *chars;
 431
 432     SCM_DEFER_INTS;
 433     SCM_STRING_COERCE_0TERMINATION_X (name);
 434     chars = SCM_STRING_CHARS (name);
 435     func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME);
 436     SCM_ALLOW_INTS;
 437     return scm_ulong2num ((unsigned long) func);
 438   }
 439 }
 440 #undef FUNC_NAME
 441
 442
 443 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 444             (SCM func, SCM dobj),
 445             "Call @var{lib-thunk}, a procedure of no arguments.  If @var{lib-thunk}\n"
 446             "is a string, it is assumed to be a symbol found in the dynamic library\n"
 447             "@var{lib} and is fetched with @code{dynamic-func}.  Otherwise, it should\n"
 448             "be a function handle returned by a previous call to @code{dynamic-func}.\n"
 449             "The return value is unspecified.\n"
 450             "GJB:FIXME:DOC 2nd version below\n"
 451             "Call the C function indicated by @var{function} and @var{dynobj}.  The\n"
 452             "function is passed no arguments and its return value is ignored.  When\n"
 453             "@var{function} is something returned by @code{dynamic-func}, call that\n"
 454             "function and ignore @var{dynobj}.  When @var{function} is a string (or\n"
 455             "symbol, etc.), look it up in @var{dynobj}; this is equivalent to\n\n"
 456             "@smallexample\n"
 457             "(dynamic-call (dynamic-func @var{function} @var{dynobj} #f))\n"
 458             "@end smallexample\n\n"
 459             "Interrupts are deferred while the C function is executing (with\n"
 460             "@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}).")
 461 #define FUNC_NAME s_scm_dynamic_call
 462 {
 463   void (*fptr) ();
 464
 465   if (SCM_STRINGP (func))
 466     func = scm_dynamic_func (func, dobj);
 467   fptr = (void (*) ()) SCM_NUM2ULONG (1, func);
 468   SCM_DEFER_INTS;
 469   fptr ();
 470   SCM_ALLOW_INTS;
 471   return SCM_UNSPECIFIED;
 472 }
 473 #undef FUNC_NAME
 474
 475 SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
 476             (SCM func, SCM dobj, SCM args),
 477             "Call @var{proc}, a dynamically loaded function, passing it the argument\n"
 478             "list @var{args} (a list of strings).  As with @code{dynamic-call},\n"
 479             "@var{proc} should be either a function handle or a string, in which case\n"
 480             "it is first fetched from @var{lib} with @code{dynamic-func}.\n\n"
 481             "@var{proc} is assumed to return an integer, which is used as the return\n"
 482             "value from @code{dynamic-args-call}.\n\n"
 483             "GJB:FIXME:DOC 2nd version below\n"
 484             "Call the C function indicated by @var{function} and @var{dynobj}, just\n"
 485             "like @code{dynamic-call}, but pass it some arguments and return its\n"
 486             "return value.  The C function is expected to take two arguments and\n"
 487             "return an @code{int}, just like @code{main}:\n\n"
 488             "@smallexample\n"
 489             "int c_func (int argc, char **argv);\n"
 490             "@end smallexample\n\n"
 491             "The parameter @var{args} must be a list of strings and is converted into\n"
 492             "an array of @code{char *}.  The array is passed in @var{argv} and its\n"
 493             "size in @var{argc}.  The return value is converted to a Scheme number\n"
 494             "and returned from the call to @code{dynamic-args-call}.")
 495 #define FUNC_NAME s_scm_dynamic_args_call
 496 {
 497   int (*fptr) (int argc, char **argv);
 498   int result, argc;
 499   char **argv;
 500
 501   if (SCM_STRINGP (func))
 502     func = scm_dynamic_func (func, dobj);
 503
 504   fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func);
 505   SCM_DEFER_INTS;
 506   argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME, SCM_ARG3);
 507   result = (*fptr) (argc, argv);
 508   scm_must_free_argv (argv);
 509   SCM_ALLOW_INTS;
 510
 511   return SCM_MAKINUM (0L + result);
 512 }
 513 #undef FUNC_NAME
 514
 515 void
 516 scm_init_dynamic_linking ()
 517 {
 518   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 519   scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
 520   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 521   sysdep_dynl_init ();
 522 #ifndef SCM_MAGIC_SNARFER
 523 #include "libguile/dynl.x"
 524 #endif
 525 }
 526
 527 /*
 528   Local Variables:
 529   c-file-style: "gnu"
 530   End:
 531 */