libguile/dynl.c

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