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, 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.
  42  */
  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
  63 #include "_scm.h"
  64 #include "dynl.h"
  65 #include "genio.h"
  66 #include "smob.h"
  67
  68 /* Converting a list of SCM strings into a argv-style array.  You must
  69    have ints disabled for the whole lifetime of the created argv (from
  70    before MAKE_ARGV_FROM_STRINGLIST until after
  71    MUST_FREE_ARGV). Atleast this is was the documentation for
  72    MAKARGVFROMSTRS says, it isn't really used that way.
  73
  74    This code probably belongs into strings.c */
  75
  76 static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp,
  77                                                     char *subr, int argn));
  78
  79 static char **
  80 scm_make_argv_from_stringlist (args, argcp, subr, argn)
  81      SCM args;
  82      int *argcp;
  83      char *subr;
  84      int argn;
  85 {
  86     char **argv;
  87     int argc, i;
  88
  89     argc = scm_ilength(args);
  90     argv = (char **) scm_must_malloc ((1L+argc)*sizeof(char *), subr);
  91     for(i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) {
  92         size_t len;
  93         char *dst, *src;
  94         SCM str = SCM_CAR (args);
  95
  96         SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, argn, subr);
  97         len = 1 + SCM_ROLENGTH (str);
  98         dst = (char *) scm_must_malloc ((long)len, subr);
  99         src = SCM_ROCHARS (str);
 100         while (len--)
 101             dst[len] = src[len];
 102         argv[i] = dst;
 103     }
 104
 105     if (argcp)
 106         *argcp = argc;
 107     argv[argc] = 0;
 108     return argv;
 109 }
 110
 111 static void scm_must_free_argv SCM_P ((char **argv));
 112
 113 static void
 114 scm_must_free_argv(argv)
 115      char **argv;
 116 {
 117     char **av = argv;
 118     while(!(*av))
 119         free(*(av++));
 120     free(argv);
 121 }
 122
 123 /* Coerce an arbitrary readonly-string into a zero-terminated string.
 124  */
 125
 126 static SCM scm_coerce_rostring SCM_P ((SCM rostr, char *subr, int argn));
 127
 128 static SCM
 129 scm_coerce_rostring (rostr, subr, argn)
 130      SCM rostr;
 131      char *subr;
 132      int argn;
 133 {
 134     SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr);
 135     if (SCM_SUBSTRP (rostr))
 136         rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0);
 137     return rostr;
 138 }
 139
 140 /* Module registry
 141  */
 142
 143 /* We can't use SCM objects here. One should be able to call
 144    SCM_REGISTER_MODULE from a C++ constructor for a static
 145    object. This happens before main and thus before libguile is
 146    initialized. */
 147
 148 struct moddata {
 149     struct moddata *link;
 150     char *module_name;
 151     void *init_func;
 152 };
 153
 154 static struct moddata *registered_mods = NULL;
 155
 156 void
 157 scm_register_module_xxx (module_name, init_func)
 158      char *module_name;
 159      void *init_func;
 160 {
 161     struct moddata *md;
 162
 163     /* XXX - should we (and can we) DEFER_INTS here? */
 164
 165     for (md = registered_mods; md; md = md->link)
 166         if (!strcmp (md->module_name, module_name)) {
 167             md->init_func = init_func;
 168             return;
 169         }
 170
 171     md = (struct moddata *)malloc (sizeof (struct moddata));
 172     if (md == NULL) {
 173         fprintf (stderr,
 174                  "guile: can't register module (%s): not enough memory",
 175                  module_name);
 176         return;
 177     }
 178
 179     md->module_name = module_name;
 180     md->init_func = init_func;
 181     md->link = registered_mods;
 182     registered_mods = md;
 183 }
 184
 185 SCM_PROC (s_registered_modules, "c-registered-modules", 0, 0, 0, scm_registered_modules);
 186
 187 SCM
 188 scm_registered_modules ()
 189 {
 190     SCM res;
 191     struct moddata *md;
 192
 193     res = SCM_EOL;
 194     for (md = registered_mods; md; md = md->link)
 195         res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
 196                                   scm_ulong2num ((unsigned long) md->init_func)),
 197                         res);
 198     return res;
 199 }
 200
 201 SCM_PROC (s_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, scm_clear_registered_modules);
 202
 203 SCM
 204 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
 220 /* Dispatch to the system dependent files
 221  *
 222  * They define these static functions:
 223  */
 224
 225 static void sysdep_dynl_init SCM_P ((void));
 226 static void *sysdep_dynl_link SCM_P ((char *filename, char *subr));
 227 static void sysdep_dynl_unlink SCM_P ((void *handle, char *subr));
 228 static void *sysdep_dynl_func SCM_P ((char *symbol, void *handle, char *subr));
 229
 230 #ifdef HAVE_LIBDL
 231 #include "dynl-dl.c"
 232 #else
 233 #ifdef HAVE_SHL_LOAD
 234 #include "dynl-shl.c"
 235 #else
 236 #ifdef HAVE_DLD
 237 #include "dynl-dld.c"
 238 #else
 239
 240 /* no dynamic linking available, throw errors. */
 241
 242 static void
 243 sysdep_dynl_init ()
 244 {
 245 }
 246
 247 static void
 248 no_dynl_error (subr)
 249      char *subr;
 250 {
 251     scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 252 }
 253
 254 static void *
 255 sysdep_dynl_link (filename, subr)
 256      char *filename;
 257      char *subr;
 258 {
 259     no_dynl_error (subr);
 260     return NULL;
 261 }
 262
 263 static void
 264 sysdep_dynl_unlink (handle, subr)
 265      void *handle;
 266      char *subr;
 267 {
 268     no_dynl_error (subr);
 269 }
 270
 271 static void *
 272 sysdep_dynl_func (symbol, handle, subr)
 273      char *symbol;
 274      void *handle;
 275      char *subr;
 276 {
 277     no_dynl_error (subr);
 278     return NULL;
 279 }
 280
 281 #endif
 282 #endif
 283 #endif
 284
 285 int scm_tc16_dynamic_obj;
 286
 287 struct dynl_obj {
 288     SCM filename;
 289     void *handle;
 290 };
 291
 292 static SCM mark_dynl_obj SCM_P ((SCM ptr));
 293 static SCM
 294 mark_dynl_obj (ptr)
 295      SCM ptr;
 296 {
 297     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr);
 298     SCM_SETGC8MARK (ptr);
 299     return d->filename;
 300 }
 301
 302 static int print_dynl_obj SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 303 static int
 304 print_dynl_obj (exp, port, pstate)
 305      SCM exp;
 306      SCM port;
 307      scm_print_state *pstate;
 308 {
 309     struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
 310     scm_gen_puts (scm_regular_string, "#<dynamic-object ", port);
 311     scm_iprin1 (d->filename, port, pstate);
 312     scm_gen_putc ('>', port);
 313     return 1;
 314 }
 315
 316 static scm_smobfuns dynl_obj_smob = {
 317     mark_dynl_obj,
 318     scm_free0,
 319     print_dynl_obj
 320 };
 321
 322 SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
 323
 324 SCM
 325 scm_dynamic_link (fname)
 326      SCM fname;
 327 {
 328     SCM z;
 329     struct dynl_obj *d;
 330
 331     fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
 332     d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj),
 333                                             s_dynamic_link);
 334     d->filename = fname;
 335
 336     SCM_DEFER_INTS;
 337     d->handle = sysdep_dynl_link (SCM_CHARS (fname), s_dynamic_link);
 338     SCM_NEWCELL (z);
 339     SCM_SETCHARS (z, d);
 340     SCM_SETCAR (z, scm_tc16_dynamic_obj);
 341     SCM_ALLOW_INTS;
 342
 343     return z;
 344 }
 345
 346 static struct dynl_obj *get_dynl_obj SCM_P ((SCM obj, char *subr, int argn));
 347 static struct dynl_obj *
 348 get_dynl_obj (dobj, subr, argn)
 349      SCM dobj;
 350      char *subr;
 351      int argn;
 352 {
 353     struct dynl_obj *d;
 354     SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
 355                 dobj, argn, subr);
 356     d = (struct dynl_obj *)SCM_CDR (dobj);
 357     SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
 358     return d;
 359 }
 360
 361 SCM_PROC (s_dynamic_object_p, "dynamic-object?", 1, 0, 0, scm_dynamic_object_p);
 362
 363 SCM
 364 scm_dynamic_object_p (SCM obj)
 365 {
 366     return (SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj)?
 367         SCM_BOOL_T : SCM_BOOL_F;
 368 }
 369
 370 SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
 371
 372 SCM
 373 scm_dynamic_unlink (dobj)
 374      SCM dobj;
 375 {
 376     struct dynl_obj *d = get_dynl_obj (dobj, s_dynamic_unlink, SCM_ARG1);
 377     sysdep_dynl_unlink (d->handle, s_dynamic_unlink);
 378     d->handle = NULL;
 379     return SCM_BOOL_T;
 380 }
 381
 382 SCM_PROC (s_dynamic_func, "dynamic-func", 2, 0, 0, scm_dynamic_func);
 383
 384 SCM
 385 scm_dynamic_func (SCM symb, SCM dobj)
 386 {
 387     struct dynl_obj *d;
 388     void (*func) ();
 389
 390     symb = scm_coerce_rostring (symb, s_dynamic_func, SCM_ARG1);
 391     d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
 392
 393     func = sysdep_dynl_func (SCM_CHARS (symb), d->handle, s_dynamic_func);
 394     return scm_ulong2num ((unsigned long)func);
 395 }
 396
 397 SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
 398
 399 SCM
 400 scm_dynamic_call (SCM func, SCM dobj)
 401 {
 402     void (*fptr)();
 403
 404     if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
 405         func = scm_dynamic_func (func, dobj);
 406     fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, s_dynamic_call);
 407     fptr ();
 408     return SCM_BOOL_T;
 409 }
 410
 411 SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
 412
 413 SCM
 414 scm_dynamic_args_call (func, dobj, args)
 415      SCM func, dobj, args;
 416 {
 417     int (*fptr) (int argc, char **argv);
 418     int result, argc;
 419     char **argv;
 420
 421     if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
 422         func = scm_dynamic_func (func, dobj);
 423
 424     fptr = (int (*)(int, char **)) scm_num2ulong (func, (char *)SCM_ARG1,
 425                                                    s_dynamic_args_call);
 426     argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
 427                                           SCM_ARG3);
 428
 429     result = (*fptr) (argc, argv);
 430
 431     scm_must_free_argv (argv);
 432     return SCM_MAKINUM(0L+result);
 433 }
 434
 435 void
 436 scm_init_dynamic_linking ()
 437 {
 438     scm_tc16_dynamic_obj = scm_newsmob (&dynl_obj_smob);
 439     sysdep_dynl_init ();
 440 #include "dynl.x"
 441 }