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 /* "dynl.c" dynamically link&load object files.
  45    Author: Aubrey Jaffer
  46    Modified for libguile by Marius Vollmer */
  47
  48 #if 0 /* Disabled until we know for sure that it isn't needed */
  49 /* XXX - This is only here to drag in a definition of __eprintf. This
  50    is needed for proper operation of dynamic linking. The real
  51    solution would probably be a shared libgcc. */
  52
  53 #undef NDEBUG
  54 #include <assert.h>
  55
  56 static void
  57 maybe_drag_in_eprintf ()
  58 {
  59   assert (!maybe_drag_in_eprintf);
  60 }
  61 #endif
  62
  63 #include <stdio.h>
  64 #include "_scm.h"
  65 #include "dynl.h"
  66 #include "genio.h"
  67 #include "smob.h"
  68
  69 /* Converting a list of SCM strings into a argv-style array.  You must
  70    have ints disabled for the whole lifetime of the created argv (from
  71    before MAKE_ARGV_FROM_STRINGLIST until after
  72    MUST_FREE_ARGV). Atleast this is was the documentation for
  73    MAKARGVFROMSTRS says, it isn't really used that way.
  74
  75    This code probably belongs into strings.c */
  76
  77 static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp,
  78                                                     const char *subr, int argn));
  79
  80 static char **
  81 scm_make_argv_from_stringlist (args, argcp, subr, argn)
  82      SCM args;
  83      int *argcp;
  84      const char *subr;
  85      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_NIMP (str) && 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 scm_must_free_argv SCM_P ((char **argv));
 113
 114 static void
 115 scm_must_free_argv(argv)
 116      char **argv;
 117 {
 118     char **av = argv;
 119     while (*av)
 120       free(*(av++));
 121     free(argv);
 122 }
 123
 124 /* Coerce an arbitrary readonly-string into a zero-terminated string.
 125  */
 126
 127 static SCM scm_coerce_rostring SCM_P ((SCM rostr, const char *subr, int argn));
 128
 129 static SCM
 130 scm_coerce_rostring (rostr, subr, argn)
 131      SCM rostr;
 132      const char *subr;
 133      int argn;
 134 {
 135     SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr);
 136     if (SCM_SUBSTRP (rostr))
 137         rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0);
 138     return rostr;
 139 }
 140
 141 /* Module registry
 142  */
 143
 144 /* We can't use SCM objects here. One should be able to call
 145    SCM_REGISTER_MODULE from a C++ constructor for a static
 146    object. This happens before main and thus before libguile is
 147    initialized. */
 148
 149 struct moddata {
 150     struct moddata *link;
 151     char *module_name;
 152     void *init_func;
 153 };
 154
 155 static struct moddata *registered_mods = NULL;
 156
 157 void
 158 scm_register_module_xxx (module_name, init_func)
 159      char *module_name;
 160      void *init_func;
 161 {
 162     struct moddata *md;
 163
 164     /* XXX - should we (and can we) DEFER_INTS here? */
 165
 166     for (md = registered_mods; md; md = md->link)
 167         if (!strcmp (md->module_name, module_name)) {
 168             md->init_func = init_func;
 169             return;
 170         }
 171
 172     md = (struct moddata *)malloc (sizeof (struct moddata));
 173     if (md == NULL) {
 174         fprintf (stderr,
 175                  "guile: can't register module (%s): not enough memory",
 176                  module_name);
 177         return;
 178     }
 179
 180     md->module_name = module_name;
 181     md->init_func = init_func;
 182     md->link = registered_mods;
 183     registered_mods = md;
 184 }
 185
 186 SCM_PROC (s_registered_modules, "c-registered-modules", 0, 0, 0, scm_registered_modules);
 187
 188 SCM
 189 scm_registered_modules ()
 190 {
 191     SCM res;
 192     struct moddata *md;
 193
 194     res = SCM_EOL;
 195     for (md = registered_mods; md; md = md->link)
 196         res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
 197                                   scm_ulong2num ((unsigned long) md->init_func)),
 198                         res);
 199     return res;
 200 }
 201
 202 SCM_PROC (s_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, scm_clear_registered_modules);
 203
 204 SCM
 205 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         md2 = md1->link;
 213         free (md1);
 214     }
 215     registered_mods = NULL;
 216
 217     SCM_ALLOW_INTS;
 218     return SCM_UNSPECIFIED;
 219 }
 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 static void sysdep_dynl_init SCM_P ((void));
 232 static void *sysdep_dynl_link SCM_P ((const char *filename, const char *subr));
 233 static void sysdep_dynl_unlink SCM_P ((void *handle, const char *subr));
 234 static void *sysdep_dynl_func SCM_P ((const char *symbol, void *handle,
 235                                       const char *subr));
 236
 237 #ifdef HAVE_DLOPEN
 238 #include "dynl-dl.c"
 239 #else
 240 #ifdef HAVE_SHL_LOAD
 241 #include "dynl-shl.c"
 242 #else
 243 #ifdef HAVE_LIBDLD
 244 #include "dynl-dld.c"
 245 #else
 246
 247 /* no dynamic linking available, throw errors. */
 248
 249 static void
 250 sysdep_dynl_init ()
 251 {
 252 }
 253
 254 static void
 255 no_dynl_error (const char *subr)
 256 {
 257   SCM_ALLOW_INTS;
 258   scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 259 }
 260
 261 static void *
 262 sysdep_dynl_link (const char *filename,
 263                   const char *subr)
 264 {
 265     no_dynl_error (subr);
 266     return NULL;
 267 }
 268
 269 static void
 270 sysdep_dynl_unlink (void *handle,
 271                     const char *subr)
 272 {
 273     no_dynl_error (subr);
 274 }
 275
 276 static void *
 277 sysdep_dynl_func (const char *symbol,
 278                   void *handle,
 279                   const char *subr)
 280 {
 281     no_dynl_error (subr);
 282     return NULL;
 283 }
 284
 285 #endif
 286 #endif
 287 #endif
 288
 289 int scm_tc16_dynamic_obj;
 290
 291 struct dynl_obj {
 292     SCM filename;
 293     void *handle;
 294 };
 295
 296 static SCM mark_dynl_obj SCM_P ((SCM ptr));
 297 static SCM
 298 mark_dynl_obj (ptr)
 299      SCM ptr;
 300 {
 301     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr);
 302     return d->filename;
 303 }
 304
 305 static scm_sizet free_dynl_obj SCM_P ((SCM ptr));
 306 static scm_sizet
 307 free_dynl_obj (ptr)
 308      SCM ptr;
 309 {
 310   scm_must_free ((char *)SCM_CDR (ptr));
 311   return sizeof (struct dynl_obj);
 312 }
 313
 314 static int print_dynl_obj SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 315 static int
 316 print_dynl_obj (exp, port, pstate)
 317      SCM exp;
 318      SCM port;
 319      scm_print_state *pstate;
 320 {
 321     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
 322     scm_puts ("#<dynamic-object ", port);
 323     scm_iprin1 (d->filename, port, pstate);
 324     if (d->handle == NULL)
 325       scm_puts (" (unlinked)", port);
 326     scm_putc ('>', port);
 327     return 1;
 328 }
 329
 330 static scm_smobfuns dynl_obj_smob = {
 331     mark_dynl_obj,
 332     free_dynl_obj,
 333     print_dynl_obj
 334 };
 335
 336 SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
 337
 338 SCM
 339 scm_dynamic_link (fname)
 340      SCM fname;
 341 {
 342     SCM z;
 343     void *handle;
 344     struct dynl_obj *d;
 345
 346     fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
 347
 348     SCM_DEFER_INTS;
 349     handle = sysdep_dynl_link (SCM_CHARS (fname), s_dynamic_link);
 350
 351     d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj),
 352                                             s_dynamic_link);
 353     d->filename = fname;
 354     d->handle = handle;
 355
 356     SCM_NEWCELL (z);
 357     SCM_SETCHARS (z, d);
 358     SCM_SETCAR (z, scm_tc16_dynamic_obj);
 359     SCM_ALLOW_INTS;
 360
 361     return z;
 362 }
 363
 364 static struct dynl_obj *get_dynl_obj SCM_P ((SCM obj, const char *subr, int argn));
 365 static struct dynl_obj *
 366 get_dynl_obj (dobj, subr, argn)
 367      SCM dobj;
 368      const char *subr;
 369      int argn;
 370 {
 371     struct dynl_obj *d;
 372     SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
 373                 dobj, argn, subr);
 374     d = (struct dynl_obj *)SCM_CDR (dobj);
 375     SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
 376     return d;
 377 }
 378
 379 SCM_PROC (s_dynamic_object_p, "dynamic-object?", 1, 0, 0, scm_dynamic_object_p);
 380
 381 SCM
 382 scm_dynamic_object_p (SCM obj)
 383 {
 384     return (SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj)?
 385         SCM_BOOL_T : SCM_BOOL_F;
 386 }
 387
 388 SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
 389
 390 SCM
 391 scm_dynamic_unlink (dobj)
 392      SCM dobj;
 393 {
 394     struct dynl_obj *d = get_dynl_obj (dobj, s_dynamic_unlink, SCM_ARG1);
 395     SCM_DEFER_INTS;
 396     sysdep_dynl_unlink (d->handle, s_dynamic_unlink);
 397     d->handle = NULL;
 398     SCM_ALLOW_INTS;
 399     return SCM_UNSPECIFIED;
 400 }
 401
 402 SCM_PROC (s_dynamic_func, "dynamic-func", 2, 0, 0, scm_dynamic_func);
 403
 404 SCM
 405 scm_dynamic_func (SCM symb, SCM dobj)
 406 {
 407     struct dynl_obj *d;
 408     void (*func) ();
 409
 410     symb = scm_coerce_rostring (symb, s_dynamic_func, SCM_ARG1);
 411     d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
 412
 413     SCM_DEFER_INTS;
 414     func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), d->handle,
 415                                            s_dynamic_func);
 416     SCM_ALLOW_INTS;
 417
 418     return scm_ulong2num ((unsigned long)func);
 419 }
 420
 421 SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
 422
 423 SCM
 424 scm_dynamic_call (SCM func, SCM dobj)
 425 {
 426     void (*fptr)();
 427
 428     if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
 429         func = scm_dynamic_func (func, dobj);
 430     fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, s_dynamic_call);
 431     SCM_DEFER_INTS;
 432     fptr ();
 433     SCM_ALLOW_INTS;
 434     return SCM_UNSPECIFIED;
 435 }
 436
 437 SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
 438
 439 SCM
 440 scm_dynamic_args_call (func, dobj, args)
 441      SCM func, dobj, args;
 442 {
 443     int (*fptr) (int argc, char **argv);
 444     int result, argc;
 445     char **argv;
 446
 447     if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
 448         func = scm_dynamic_func (func, dobj);
 449
 450     fptr = (int (*)(int, char **)) scm_num2ulong (func, (char *)SCM_ARG1,
 451                                                    s_dynamic_args_call);
 452     SCM_DEFER_INTS;
 453     argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
 454                                           SCM_ARG3);
 455     result = (*fptr) (argc, argv);
 456     scm_must_free_argv (argv);
 457     SCM_ALLOW_INTS;
 458
 459     return SCM_MAKINUM(0L+result);
 460 }
 461
 462 void
 463 scm_init_dynamic_linking ()
 464 {
 465     scm_tc16_dynamic_obj = scm_newsmob (&dynl_obj_smob);
 466     sysdep_dynl_init ();
 467 #include "dynl.x"
 468 }