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