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