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 HAVE_DLOPEN
 234 #include "dynl-dl.c"
 235 #else
 236 #ifdef HAVE_SHL_LOAD
 237 #include "dynl-shl.c"
 238 #else
 239 #ifdef HAVE_LIBDLD
 240 #include "dynl-dld.c"
 241 #else
 242
 243 /* no dynamic linking available, throw errors. */
 244
 245 static void
 246 sysdep_dynl_init (void)
 247 {
 248 }
 249
 250 static void
 251 no_dynl_error (const char *subr)
 252 {
 253   SCM_ALLOW_INTS;
 254   scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 255 }
 256
 257 static void *
 258 sysdep_dynl_link (const char *filename,
 259                   int flags,
 260                   const char *subr)
 261 {
 262     no_dynl_error (subr);
 263     return NULL;
 264 }
 265
 266 static void
 267 sysdep_dynl_unlink (void *handle,
 268                     const char *subr)
 269 {
 270     no_dynl_error (subr);
 271 }
 272
 273 static void *
 274 sysdep_dynl_func (const char *symbol,
 275                   void *handle,
 276                   const char *subr)
 277 {
 278     no_dynl_error (subr);
 279     return NULL;
 280 }
 281
 282 #endif
 283 #endif
 284 #endif
 285
 286 int scm_tc16_dynamic_obj;
 287
 288 struct dynl_obj {
 289     SCM filename;
 290     void *handle;
 291 };
 292
 293 static SCM
 294 mark_dynl_obj (SCM ptr)
 295 {
 296     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr);
 297     return d->filename;
 298 }
 299
 300 static scm_sizet
 301 free_dynl_obj (SCM ptr)
 302 {
 303   scm_must_free ((char *)SCM_CDR (ptr));
 304   return sizeof (struct dynl_obj);
 305 }
 306
 307 static int
 308 print_dynl_obj (SCM exp,SCM port,scm_print_state *pstate)
 309 {
 310     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
 311     scm_puts ("#<dynamic-object ", port);
 312     scm_iprin1 (d->filename, port, pstate);
 313     if (d->handle == NULL)
 314       scm_puts (" (unlinked)", port);
 315     scm_putc ('>', port);
 316     return 1;
 317 }
 318
 319 static SCM kw_global;
 320 SCM_SYMBOL (sym_global, "-global");
 321
 322 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 1,
 323             (SCM fname, SCM rest),
 324 "Open the dynamic library @var{library-file}.  A library handle
 325 representing the opened library is returned; this handle should be used
 326 as the @var{lib} argument to the following functions.")
 327 #define FUNC_NAME s_scm_dynamic_link
 328 {
 329     SCM z;
 330     void *handle;
 331     struct dynl_obj *d;
 332     int flags = DYNL_GLOBAL;
 333
 334     fname = scm_coerce_rostring (fname, FUNC_NAME, SCM_ARG1);
 335
 336     /* collect flags */
 337     while (SCM_CONSP (rest))
 338       {
 339         SCM kw, val;
 340
 341         kw = SCM_CAR (rest);
 342         rest = SCM_CDR (rest);
 343
 344         if (!SCM_CONSP (rest))
 345           scm_misc_error (FUNC_NAME, "keyword without value", SCM_EOL);
 346
 347         val = SCM_CAR (rest);
 348         rest = SCM_CDR (rest);
 349
 350         if (kw == kw_global)
 351           {
 352             if (SCM_FALSEP (val))
 353               flags &= ~DYNL_GLOBAL;
 354           }
 355         else
 356           scm_misc_error (FUNC_NAME, "unknown keyword argument: %s",
 357                           scm_cons (kw, SCM_EOL));
 358       }
 359
 360     SCM_DEFER_INTS;
 361     handle = sysdep_dynl_link (SCM_CHARS (fname), flags, FUNC_NAME);
 362
 363     d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj),
 364                                             FUNC_NAME);
 365     d->filename = fname;
 366     d->handle = handle;
 367
 368     SCM_NEWCELL (z);
 369     SCM_SETCHARS (z, d);
 370     SCM_SETCAR (z, scm_tc16_dynamic_obj);
 371     SCM_ALLOW_INTS;
 372
 373     return z;
 374 }
 375 #undef FUNC_NAME
 376
 377 static struct dynl_obj *
 378 get_dynl_obj (SCM dobj,const char *subr,int argn)
 379 {
 380     struct dynl_obj *d;
 381     SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
 382                 dobj, argn, subr);
 383     d = (struct dynl_obj *)SCM_CDR (dobj);
 384     SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
 385     return d;
 386 }
 387
 388 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 389             (SCM obj),
 390 "Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}
 391 otherwise.")
 392 #define FUNC_NAME s_scm_dynamic_object_p
 393 {
 394     return SCM_BOOL(SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj);
 395 }
 396 #undef FUNC_NAME
 397
 398 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 399             (SCM dobj),
 400 "Unlink the library represented by @var{library-handle}, and remove any
 401 imported symbols from the address space.
 402 GJB:FIXME:DOC: 2nd version below:
 403 Unlink the indicated object file from the application.  The argument
 404 @var{dynobj} should be one of the values returned by
 405 @code{dynamic-link}.  When @code{dynamic-unlink} has been called on
 406 @var{dynobj}, it is no longer usable as an argument to the functions
 407 below and you will get type mismatch errors when you try to.
 408 ")
 409 #define FUNC_NAME s_scm_dynamic_unlink
 410 {
 411     struct dynl_obj *d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG1);
 412     SCM_DEFER_INTS;
 413     sysdep_dynl_unlink (d->handle, FUNC_NAME);
 414     d->handle = NULL;
 415     SCM_ALLOW_INTS;
 416     return SCM_UNSPECIFIED;
 417 }
 418 #undef FUNC_NAME
 419
 420 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 421             (SCM symb, SCM dobj),
 422 "Import the symbol @var{func} from @var{lib} (a dynamic library handle).
 423 A @dfn{function handle} representing the imported function is returned.
 424 GJB:FIXME:DOC: 2nd version below
 425 Search the C function indicated by @var{function} (a string or symbol)
 426 in @var{dynobj} and return some Scheme object that can later be used
 427 with @code{dynamic-call} to actually call this function.  Right now,
 428 these Scheme objects are formed by casting the address of the function
 429 to @code{long} and converting this number to its Scheme representation.
 430
 431 Regardless whether your C compiler prepends an underscore @samp{_} to
 432 the global names in a program, you should @strong{not} include this
 433 underscore in @var{function}.  Guile knows whether the underscore is
 434 needed or not and will add it when necessary.
 435
 436 ")
 437 #define FUNC_NAME s_scm_dynamic_func
 438 {
 439     struct dynl_obj *d;
 440     void (*func) ();
 441
 442     symb = scm_coerce_rostring (symb, FUNC_NAME, SCM_ARG1);
 443     d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG2);
 444
 445     SCM_DEFER_INTS;
 446     func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), d->handle,
 447                                            FUNC_NAME);
 448     SCM_ALLOW_INTS;
 449
 450     return scm_ulong2num ((unsigned long)func);
 451 }
 452 #undef FUNC_NAME
 453
 454 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 455             (SCM func, SCM dobj),
 456 "Call @var{lib-thunk}, a procedure of no arguments.  If @var{lib-thunk}
 457 is a string, it is assumed to be a symbol found in the dynamic library
 458 @var{lib} and is fetched with @code{dynamic-func}.  Otherwise, it should
 459 be a function handle returned by a previous call to @code{dynamic-func}.
 460 The return value is unspecified.
 461 GJB:FIXME:DOC 2nd version below
 462 Call the C function indicated by @var{function} and @var{dynobj}.  The
 463 function is passed no arguments and its return value is ignored.  When
 464 @var{function} is something returned by @code{dynamic-func}, call that
 465 function and ignore @var{dynobj}.  When @var{function} is a string (or
 466 symbol, etc.), look it up in @var{dynobj}; this is equivalent to
 467
 468 @smallexample
 469 (dynamic-call (dynamic-func @var{function} @var{dynobj} #f))
 470 @end smallexample
 471
 472 Interrupts are deferred while the C function is executing (with
 473 @code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}).
 474 ")
 475 #define FUNC_NAME s_scm_dynamic_call
 476 {
 477     void (*fptr)();
 478
 479     if (SCM_ROSTRINGP (func))
 480         func = scm_dynamic_func (func, dobj);
 481     fptr = (void (*)()) SCM_NUM2ULONG (1, func);
 482     SCM_DEFER_INTS;
 483     fptr ();
 484     SCM_ALLOW_INTS;
 485     return SCM_UNSPECIFIED;
 486 }
 487 #undef FUNC_NAME
 488
 489 SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
 490             (SCM func, SCM dobj, SCM args),
 491 "Call @var{proc}, a dynamically loaded function, passing it the argument
 492 list @var{args} (a list of strings).  As with @code{dynamic-call},
 493 @var{proc} should be either a function handle or a string, in which case
 494 it is first fetched from @var{lib} with @code{dynamic-func}.
 495
 496 @var{proc} is assumed to return an integer, which is used as the return
 497 value from @code{dynamic-args-call}.
 498
 499 GJB:FIXME:DOC 2nd version below
 500 Call the C function indicated by @var{function} and @var{dynobj}, just
 501 like @code{dynamic-call}, but pass it some arguments and return its
 502 return value.  The C function is expected to take two arguments and
 503 return an @code{int}, just like @code{main}:
 504
 505 @smallexample
 506 int c_func (int argc, char **argv);
 507 @end smallexample
 508
 509 The parameter @var{args} must be a list of strings and is converted into
 510 an array of @code{char *}.  The array is passed in @var{argv} and its
 511 size in @var{argc}.  The return value is converted to a Scheme number
 512 and returned from the call to @code{dynamic-args-call}.
 513
 514
 515 ")
 516 #define FUNC_NAME s_scm_dynamic_args_call
 517 {
 518     int (*fptr) (int argc, char **argv);
 519     int result, argc;
 520     char **argv;
 521
 522     if (SCM_ROSTRINGP (func))
 523         func = scm_dynamic_func (func, dobj);
 524
 525     fptr = (int (*)(int, char **)) SCM_NUM2ULONG (1,func);
 526     SCM_DEFER_INTS;
 527     argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME,
 528                                           SCM_ARG3);
 529     result = (*fptr) (argc, argv);
 530     scm_must_free_argv (argv);
 531     SCM_ALLOW_INTS;
 532
 533     return SCM_MAKINUM(0L+result);
 534 }
 535 #undef FUNC_NAME
 536
 537 void
 538 scm_init_dynamic_linking ()
 539 {
 540     scm_tc16_dynamic_obj = scm_make_smob_type_mfpe ("dynamic-object", sizeof (struct dynl_obj),
 541                                                    mark_dynl_obj, free_dynl_obj,
 542                                                    print_dynl_obj, NULL);
 543     sysdep_dynl_init ();
 544 #include "dynl.x"
 545     kw_global = scm_make_keyword_from_dash_symbol (sym_global);
 546 }