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 #include "keywords.h"
  69
  70 /* Converting a list of SCM strings into a argv-style array.  You must
  71    have ints disabled for the whole lifetime of the created argv (from
  72    before MAKE_ARGV_FROM_STRINGLIST until after
  73    MUST_FREE_ARGV). Atleast this is was the documentation for
  74    MAKARGVFROMSTRS says, it isn't really used that way.
  75
  76    This code probably belongs into strings.c */
  77
  78 static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp,
  79                                                     const char *subr, int argn));
  80
  81 static char **
  82 scm_make_argv_from_stringlist (args, argcp, subr, argn)
  83      SCM args;
  84      int *argcp;
  85      const char *subr;
  86      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_NIMP (str) && 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 scm_must_free_argv SCM_P ((char **argv));
 114
 115 static void
 116 scm_must_free_argv(argv)
 117      char **argv;
 118 {
 119     char **av = argv;
 120     while (*av)
 121       free(*(av++));
 122     free(argv);
 123 }
 124
 125 /* Coerce an arbitrary readonly-string into a zero-terminated string.
 126  */
 127
 128 static SCM scm_coerce_rostring SCM_P ((SCM rostr, const char *subr, int argn));
 129
 130 static SCM
 131 scm_coerce_rostring (rostr, subr, argn)
 132      SCM rostr;
 133      const char *subr;
 134      int argn;
 135 {
 136     SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr);
 137     if (SCM_SUBSTRP (rostr))
 138         rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0);
 139     return rostr;
 140 }
 141
 142 /* Module registry
 143  */
 144
 145 /* We can't use SCM objects here. One should be able to call
 146    SCM_REGISTER_MODULE from a C++ constructor for a static
 147    object. This happens before main and thus before libguile is
 148    initialized. */
 149
 150 struct moddata {
 151     struct moddata *link;
 152     char *module_name;
 153     void *init_func;
 154 };
 155
 156 static struct moddata *registered_mods = NULL;
 157
 158 void
 159 scm_register_module_xxx (module_name, init_func)
 160      char *module_name;
 161      void *init_func;
 162 {
 163     struct moddata *md;
 164
 165     /* XXX - should we (and can we) DEFER_INTS here? */
 166
 167     for (md = registered_mods; md; md = md->link)
 168         if (!strcmp (md->module_name, module_name)) {
 169             md->init_func = init_func;
 170             return;
 171         }
 172
 173     md = (struct moddata *)malloc (sizeof (struct moddata));
 174     if (md == NULL) {
 175         fprintf (stderr,
 176                  "guile: can't register module (%s): not enough memory",
 177                  module_name);
 178         return;
 179     }
 180
 181     md->module_name = module_name;
 182     md->init_func = init_func;
 183     md->link = registered_mods;
 184     registered_mods = md;
 185 }
 186
 187 SCM_PROC (s_registered_modules, "c-registered-modules", 0, 0, 0, scm_registered_modules);
 188
 189 SCM
 190 scm_registered_modules ()
 191 {
 192     SCM res;
 193     struct moddata *md;
 194
 195     res = SCM_EOL;
 196     for (md = registered_mods; md; md = md->link)
 197         res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
 198                                   scm_ulong2num ((unsigned long) md->init_func)),
 199                         res);
 200     return res;
 201 }
 202
 203 SCM_PROC (s_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, scm_clear_registered_modules);
 204
 205 SCM
 206 scm_clear_registered_modules ()
 207 {
 208     struct moddata *md1, *md2;
 209
 210     SCM_DEFER_INTS;
 211
 212     for (md1 = registered_mods; md1; md1 = md2) {
 213         md2 = md1->link;
 214         free (md1);
 215     }
 216     registered_mods = NULL;
 217
 218     SCM_ALLOW_INTS;
 219     return SCM_UNSPECIFIED;
 220 }
 221
 222 /* Dispatch to the system dependent files
 223  *
 224  * They define some static functions.  These functions are called with
 225  * deferred interrupts.  When they want to throw errors, they are
 226  * expected to insert a SCM_ALLOW_INTS before doing the throw.  It
 227  * might work to throw an error while interrupts are deferred (because
 228  * they will be unconditionally allowed the next time a SCM_ALLOW_INTS
 229  * is executed, SCM_DEFER_INTS and SCM_ALLOW_INTS do not nest).
 230  */
 231
 232 #define DYNL_GLOBAL 0x0001
 233
 234 static void sysdep_dynl_init SCM_P ((void));
 235 static void *sysdep_dynl_link SCM_P ((const char *filename, int flags,
 236                                       const char *subr));
 237 static void sysdep_dynl_unlink SCM_P ((void *handle, const char *subr));
 238 static void *sysdep_dynl_func SCM_P ((const char *symbol, void *handle,
 239                                       const char *subr));
 240
 241 #ifdef HAVE_DLOPEN
 242 #include "dynl-dl.c"
 243 #else
 244 #ifdef HAVE_SHL_LOAD
 245 #include "dynl-shl.c"
 246 #else
 247 #ifdef HAVE_LIBDLD
 248 #include "dynl-dld.c"
 249 #else
 250
 251 /* no dynamic linking available, throw errors. */
 252
 253 static void
 254 sysdep_dynl_init ()
 255 {
 256 }
 257
 258 static void
 259 no_dynl_error (const char *subr)
 260 {
 261   SCM_ALLOW_INTS;
 262   scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 263 }
 264
 265 static void *
 266 sysdep_dynl_link (const char *filename,
 267                   int flags,
 268                   const char *subr)
 269 {
 270     no_dynl_error (subr);
 271     return NULL;
 272 }
 273
 274 static void
 275 sysdep_dynl_unlink (void *handle,
 276                     const char *subr)
 277 {
 278     no_dynl_error (subr);
 279 }
 280
 281 static void *
 282 sysdep_dynl_func (const char *symbol,
 283                   void *handle,
 284                   const char *subr)
 285 {
 286     no_dynl_error (subr);
 287     return NULL;
 288 }
 289
 290 #endif
 291 #endif
 292 #endif
 293
 294 int scm_tc16_dynamic_obj;
 295
 296 struct dynl_obj {
 297     SCM filename;
 298     void *handle;
 299 };
 300
 301 static SCM mark_dynl_obj SCM_P ((SCM ptr));
 302 static SCM
 303 mark_dynl_obj (ptr)
 304      SCM ptr;
 305 {
 306     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr);
 307     return d->filename;
 308 }
 309
 310 static scm_sizet free_dynl_obj SCM_P ((SCM ptr));
 311 static scm_sizet
 312 free_dynl_obj (ptr)
 313      SCM ptr;
 314 {
 315   scm_must_free ((char *)SCM_CDR (ptr));
 316   return sizeof (struct dynl_obj);
 317 }
 318
 319 static int print_dynl_obj SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 320 static int
 321 print_dynl_obj (exp, port, pstate)
 322      SCM exp;
 323      SCM port;
 324      scm_print_state *pstate;
 325 {
 326     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
 327     scm_puts ("#<dynamic-object ", port);
 328     scm_iprin1 (d->filename, port, pstate);
 329     if (d->handle == NULL)
 330       scm_puts (" (unlinked)", port);
 331     scm_putc ('>', port);
 332     return 1;
 333 }
 334
 335 static SCM kw_global;
 336 SCM_SYMBOL (sym_global, "-global");
 337
 338 SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 1, scm_dynamic_link);
 339
 340 SCM
 341 scm_dynamic_link (fname, rest)
 342      SCM fname;
 343      SCM rest;
 344 {
 345     SCM z;
 346     void *handle;
 347     struct dynl_obj *d;
 348     int flags = DYNL_GLOBAL;
 349
 350     fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
 351
 352     /* collect flags */
 353     while (SCM_NIMP (rest) && SCM_CONSP (rest))
 354       {
 355         SCM kw, val;
 356
 357         kw = SCM_CAR (rest);
 358         rest = SCM_CDR (rest);
 359
 360         if (!(SCM_NIMP (rest) && SCM_CONSP (rest)))
 361           scm_misc_error (s_dynamic_link, "keyword without value", SCM_EOL);
 362
 363         val = SCM_CAR (rest);
 364         rest = SCM_CDR (rest);
 365
 366         if (kw == kw_global)
 367           {
 368             if (SCM_FALSEP (val))
 369               flags &= ~DYNL_GLOBAL;
 370           }
 371         else
 372           scm_misc_error (s_dynamic_link, "unknown keyword argument: %s",
 373                           scm_cons (kw, SCM_EOL));
 374       }
 375
 376     SCM_DEFER_INTS;
 377     handle = sysdep_dynl_link (SCM_CHARS (fname), flags, s_dynamic_link);
 378
 379     d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj),
 380                                             s_dynamic_link);
 381     d->filename = fname;
 382     d->handle = handle;
 383
 384     SCM_NEWCELL (z);
 385     SCM_SETCHARS (z, d);
 386     SCM_SETCAR (z, scm_tc16_dynamic_obj);
 387     SCM_ALLOW_INTS;
 388
 389     return z;
 390 }
 391
 392 static struct dynl_obj *get_dynl_obj SCM_P ((SCM obj, const char *subr, int argn));
 393 static struct dynl_obj *
 394 get_dynl_obj (dobj, subr, argn)
 395      SCM dobj;
 396      const char *subr;
 397      int argn;
 398 {
 399     struct dynl_obj *d;
 400     SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
 401                 dobj, argn, subr);
 402     d = (struct dynl_obj *)SCM_CDR (dobj);
 403     SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
 404     return d;
 405 }
 406
 407 SCM_PROC (s_dynamic_object_p, "dynamic-object?", 1, 0, 0, scm_dynamic_object_p);
 408
 409 SCM
 410 scm_dynamic_object_p (SCM obj)
 411 {
 412     return (SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj)?
 413         SCM_BOOL_T : SCM_BOOL_F;
 414 }
 415
 416 SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
 417
 418 SCM
 419 scm_dynamic_unlink (dobj)
 420      SCM dobj;
 421 {
 422     struct dynl_obj *d = get_dynl_obj (dobj, s_dynamic_unlink, SCM_ARG1);
 423     SCM_DEFER_INTS;
 424     sysdep_dynl_unlink (d->handle, s_dynamic_unlink);
 425     d->handle = NULL;
 426     SCM_ALLOW_INTS;
 427     return SCM_UNSPECIFIED;
 428 }
 429
 430 SCM_PROC (s_dynamic_func, "dynamic-func", 2, 0, 0, scm_dynamic_func);
 431
 432 SCM
 433 scm_dynamic_func (SCM symb, SCM dobj)
 434 {
 435     struct dynl_obj *d;
 436     void (*func) ();
 437
 438     symb = scm_coerce_rostring (symb, s_dynamic_func, SCM_ARG1);
 439     d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
 440
 441     SCM_DEFER_INTS;
 442     func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), d->handle,
 443                                            s_dynamic_func);
 444     SCM_ALLOW_INTS;
 445
 446     return scm_ulong2num ((unsigned long)func);
 447 }
 448
 449 SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
 450
 451 SCM
 452 scm_dynamic_call (SCM func, SCM dobj)
 453 {
 454     void (*fptr)();
 455
 456     if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
 457         func = scm_dynamic_func (func, dobj);
 458     fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, s_dynamic_call);
 459     SCM_DEFER_INTS;
 460     fptr ();
 461     SCM_ALLOW_INTS;
 462     return SCM_UNSPECIFIED;
 463 }
 464
 465 SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
 466
 467 SCM
 468 scm_dynamic_args_call (func, dobj, args)
 469      SCM func, dobj, args;
 470 {
 471     int (*fptr) (int argc, char **argv);
 472     int result, argc;
 473     char **argv;
 474
 475     if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
 476         func = scm_dynamic_func (func, dobj);
 477
 478     fptr = (int (*)(int, char **)) scm_num2ulong (func, (char *)SCM_ARG1,
 479                                                    s_dynamic_args_call);
 480     SCM_DEFER_INTS;
 481     argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
 482                                           SCM_ARG3);
 483     result = (*fptr) (argc, argv);
 484     scm_must_free_argv (argv);
 485     SCM_ALLOW_INTS;
 486
 487     return SCM_MAKINUM(0L+result);
 488 }
 489
 490 void
 491 scm_init_dynamic_linking ()
 492 {
 493     scm_tc16_dynamic_obj = scm_make_smob_type_mfpe ("dynamic-object", sizeof (struct dynl_obj),
 494                                                    mark_dynl_obj, free_dynl_obj,
 495                                                    print_dynl_obj, NULL);
 496     sysdep_dynl_init ();
 497 #include "dynl.x"
 498     kw_global = scm_make_keyword_from_dash_symbol (sym_global);
 499 }