libguile/dynl.c

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