libguile/dynl.c

   1 /* dynl.c - dynamic linking
   2  *
   3  * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001 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
  45
  46 /* "dynl.c" dynamically link&load object files.
  47    Author: Aubrey Jaffer
  48    Modified for libguile by Marius Vollmer */
  49
  50 #if 0 /* Disabled until we know for sure that it isn't needed */
  51 /* XXX - This is only here to drag in a definition of __eprintf. This
  52    is needed for proper operation of dynamic linking. The real
  53    solution would probably be a shared libgcc. */
  54
  55 #undef NDEBUG
  56 #include <assert.h>
  57
  58 static void
  59 maybe_drag_in_eprintf ()
  60 {
  61   assert (!maybe_drag_in_eprintf);
  62 }
  63 #endif
  64
  65 #include <stdio.h>
  66 #include <string.h>
  67
  68 #include "libguile/_scm.h"
  69 #include "libguile/dynl.h"
  70 #include "libguile/smob.h"
  71 #include "libguile/keywords.h"
  72 #include "libguile/ports.h"
  73 #include "libguile/strings.h"
  74 #include "libguile/deprecation.h"
  75 #include "libguile/lang.h"
  76 #include "libguile/validate.h"
  77
  78 /* Create a new C argv array from a scheme list of strings. */
  79 /* Dirk:FIXME:: A quite similar function is implemented in posix.c */
  80 /* Dirk:FIXME:: In case of assertion errors, we get memory leaks */
  81
  82 /* Converting a list of SCM strings into a argv-style array.  You must
  83    have ints disabled for the whole lifetime of the created argv (from
  84    before MAKE_ARGV_FROM_STRINGLIST until after
  85    MUST_FREE_ARGV). Atleast this is was the documentation for
  86    MAKARGVFROMSTRS says, it isn't really used that way.
  87
  88    This code probably belongs into strings.c
  89    (Dirk: IMO strings.c is not the right place.) */
  90
  91 static char **
  92 scm_make_argv_from_stringlist (SCM args, int *argcp, const char *subr,
  93                                int argn)
  94 {
  95   char **argv;
  96   int argc;
  97   int i;
  98
  99   argc = scm_ilength (args);
 100   SCM_ASSERT (argc >= 0, args, argn, subr);
 101   argv = (char **) scm_malloc ((argc + 1) * sizeof (char *));
 102   for (i = 0; !SCM_NULL_OR_NIL_P (args); args = SCM_CDR (args), ++i) {
 103     SCM arg = SCM_CAR (args);
 104     size_t len;
 105     char *dst;
 106     char *src;
 107
 108     SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr);
 109     len = SCM_STRING_LENGTH (arg);
 110     src = SCM_STRING_CHARS (arg);
 111     dst = (char *) scm_malloc (len + 1);
 112     memcpy (dst, src, len);
 113     dst[len] = 0;
 114     argv[i] = dst;
 115   }
 116
 117   if (argcp)
 118     *argcp = argc;
 119   argv[argc] = 0;
 120   return argv;
 121 }
 122
 123 static void
 124 scm_free_argv (char **argv)
 125 {
 126   char **av = argv;
 127   while (*av)
 128     free (*(av++));
 129   free (argv);
 130 }
 131
 132 /* Dispatch to the system dependent files
 133  *
 134  * They define some static functions.  These functions are called with
 135  * deferred interrupts.  When they want to throw errors, they are
 136  * expected to insert a SCM_ALLOW_INTS before doing the throw.  It
 137  * might work to throw an error while interrupts are deferred (because
 138  * they will be unconditionally allowed the next time a SCM_ALLOW_INTS
 139  * is executed, SCM_DEFER_INTS and SCM_ALLOW_INTS do not nest).
 140  */
 141
 142 #ifdef DYNAMIC_LINKING
 143
 144 #include "libltdl/ltdl.h"
 145
 146 static void *
 147 sysdep_dynl_link (const char *fname, const char *subr)
 148 {
 149   lt_dlhandle handle;
 150   handle = lt_dlopenext (fname);
 151   if (NULL == handle)
 152     {
 153       SCM fn;
 154       SCM msg;
 155
 156       SCM_ALLOW_INTS;
 157       fn = scm_makfrom0str (fname);
 158       msg = scm_makfrom0str (lt_dlerror ());
 159       scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
 160     }
 161   return (void *) handle;
 162 }
 163
 164 static void
 165 sysdep_dynl_unlink (void *handle, const char *subr)
 166 {
 167   if (lt_dlclose ((lt_dlhandle) handle))
 168     {
 169       SCM_ALLOW_INTS;
 170       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 171     }
 172 }
 173
 174 static void *
 175 sysdep_dynl_func (const char *symb, void *handle, const char *subr)
 176 {
 177   void *fptr;
 178
 179   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 180   if (!fptr)
 181     {
 182       SCM_ALLOW_INTS;
 183       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 184     }
 185   return fptr;
 186 }
 187
 188 static void
 189 sysdep_dynl_init ()
 190 {
 191   lt_dlinit ();
 192 }
 193
 194 #else
 195
 196 /* no dynamic linking available, throw errors. */
 197
 198 static void
 199 sysdep_dynl_init (void)
 200 {
 201 }
 202
 203 static void
 204 no_dynl_error (const char *subr)
 205 {
 206   SCM_ALLOW_INTS;
 207   scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
 208 }
 209
 210 static void *
 211 sysdep_dynl_link (const char *filename, const char *subr)
 212 {
 213   no_dynl_error (subr);
 214   return NULL;
 215 }
 216
 217 static void
 218 sysdep_dynl_unlink (void *handle,
 219                     const char *subr)
 220 {
 221   no_dynl_error (subr);
 222 }
 223
 224 static void *
 225 sysdep_dynl_func (const char *symbol,
 226                   void *handle,
 227                   const char *subr)
 228 {
 229   no_dynl_error (subr);
 230   return NULL;
 231 }
 232
 233 #endif
 234
 235 scm_t_bits scm_tc16_dynamic_obj;
 236
 237 #define DYNL_FILENAME(x)        (SCM_CELL_OBJECT_1 (x))
 238 #define DYNL_HANDLE(x)          ((void *) SCM_CELL_WORD_2 (x))
 239 #define SET_DYNL_HANDLE(x, v)   (SCM_SET_CELL_WORD_2 ((x), (v)))
 240
 241
 242 static SCM
 243 dynl_obj_mark (SCM ptr)
 244 {
 245   return DYNL_FILENAME (ptr);
 246 }
 247
 248
 249 static int
 250 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 251 {
 252   scm_puts ("#<dynamic-object ", port);
 253   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 254   if (DYNL_HANDLE (exp) == NULL)
 255     scm_puts (" (unlinked)", port);
 256   scm_putc ('>', port);
 257   return 1;
 258 }
 259
 260
 261 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
 262             (SCM filename),
 263             "Open the dynamic library called @var{filename}.  A library\n"
 264             "handle representing the opened library is returned; this handle\n"
 265             "should be used as the @var{dobj} argument to the following\n"
 266             "functions.")
 267 #define FUNC_NAME s_scm_dynamic_link
 268 {
 269   void *handle;
 270
 271   SCM_VALIDATE_STRING (1, filename);
 272   handle = sysdep_dynl_link (SCM_STRING_CHARS (filename), FUNC_NAME);
 273   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
 274 }
 275 #undef FUNC_NAME
 276
 277
 278 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 279             (SCM obj),
 280             "Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}\n"
 281             "otherwise.")
 282 #define FUNC_NAME s_scm_dynamic_object_p
 283 {
 284   return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 285 }
 286 #undef FUNC_NAME
 287
 288
 289 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 290             (SCM dobj),
 291             "Unlink the indicated object file from the application.  The\n"
 292             "argument @var{dobj} must have been obtained by a call to\n"
 293             "@code{dynamic-link}.  After @code{dynamic-unlink} has been\n"
 294             "called on @var{dobj}, its content is no longer accessible.")
 295 #define FUNC_NAME s_scm_dynamic_unlink
 296 {
 297   /*fixme* GC-problem */
 298   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 299   if (DYNL_HANDLE (dobj) == NULL) {
 300     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 301   } else {
 302     SCM_DEFER_INTS;
 303     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 304     SET_DYNL_HANDLE (dobj, NULL);
 305     SCM_ALLOW_INTS;
 306     return SCM_UNSPECIFIED;
 307   }
 308 }
 309 #undef FUNC_NAME
 310
 311
 312 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 313             (SCM name, SCM dobj),
 314             "Search the dynamic object @var{dobj} for the C function\n"
 315             "indicated by the string @var{name} and return some Scheme\n"
 316             "handle that can later be used with @code{dynamic-call} to\n"
 317             "actually call the function.\n\n"
 318             "Regardless whether your C compiler prepends an underscore @samp{_} to\n"
 319             "the global names in a program, you should @strong{not} include this\n"
 320             "underscore in @var{function}.  Guile knows whether the underscore is\n"
 321             "needed or not and will add it when necessary.")
 322 #define FUNC_NAME s_scm_dynamic_func
 323 {
 324   /* The returned handle is formed by casting the address of the function to a
 325    * long value and converting this to a scheme number
 326    */
 327
 328   void (*func) ();
 329
 330   SCM_VALIDATE_STRING (1, name);
 331   /*fixme* GC-problem */
 332   SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
 333   if (DYNL_HANDLE (dobj) == NULL) {
 334     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 335   } else {
 336     char *chars;
 337
 338     SCM_DEFER_INTS;
 339     chars = SCM_STRING_CHARS (name);
 340     func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME);
 341     SCM_ALLOW_INTS;
 342     return scm_ulong2num ((unsigned long) func);
 343   }
 344 }
 345 #undef FUNC_NAME
 346
 347
 348 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 349             (SCM func, SCM dobj),
 350             "Call the C function indicated by @var{func} and @var{dobj}.\n"
 351             "The function is passed no arguments and its return value is\n"
 352             "ignored.  When @var{function} is something returned by\n"
 353             "@code{dynamic-func}, call that function and ignore @var{dobj}.\n"
 354             "When @var{func} is a string , look it up in @var{dynobj}; this\n"
 355             "is equivalent to\n"
 356             "@smallexample\n"
 357             "(dynamic-call (dynamic-func @var{func} @var{dobj} #f))\n"
 358             "@end smallexample\n\n"
 359             "Interrupts are deferred while the C function is executing (with\n"
 360             "@code{SCM_DEFER_INTS}/@code{SCM_ALLOW_INTS}).")
 361 #define FUNC_NAME s_scm_dynamic_call
 362 {
 363   void (*fptr) ();
 364
 365   if (SCM_STRINGP (func))
 366     func = scm_dynamic_func (func, dobj);
 367   fptr = (void (*) ()) SCM_NUM2ULONG (1, func);
 368   SCM_DEFER_INTS;
 369   fptr ();
 370   SCM_ALLOW_INTS;
 371   return SCM_UNSPECIFIED;
 372 }
 373 #undef FUNC_NAME
 374
 375 SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
 376             (SCM func, SCM dobj, SCM args),
 377             "Call the C function indicated by @var{func} and @var{dobj},\n"
 378             "just like @code{dynamic-call}, but pass it some arguments and\n"
 379             "return its return value.  The C function is expected to take\n"
 380             "two arguments and return an @code{int}, just like @code{main}:\n"
 381             "@smallexample\n"
 382             "int c_func (int argc, char **argv);\n"
 383             "@end smallexample\n\n"
 384             "The parameter @var{args} must be a list of strings and is\n"
 385             "converted into an array of @code{char *}.  The array is passed\n"
 386             "in @var{argv} and its size in @var{argc}.  The return value is\n"
 387             "converted to a Scheme number and returned from the call to\n"
 388             "@code{dynamic-args-call}.")
 389 #define FUNC_NAME s_scm_dynamic_args_call
 390 {
 391   int (*fptr) (int argc, char **argv);
 392   int result, argc;
 393   char **argv;
 394
 395   if (SCM_STRINGP (func))
 396     func = scm_dynamic_func (func, dobj);
 397
 398   fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func);
 399   SCM_DEFER_INTS;
 400   argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME, SCM_ARG3);
 401   result = (*fptr) (argc, argv);
 402   scm_free_argv (argv);
 403   SCM_ALLOW_INTS;
 404
 405   return SCM_MAKINUM (0L + result);
 406 }
 407 #undef FUNC_NAME
 408
 409 void
 410 scm_init_dynamic_linking ()
 411 {
 412   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 413   scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
 414   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 415   sysdep_dynl_init ();
 416 #ifndef SCM_MAGIC_SNARFER
 417 #include "libguile/dynl.x"
 418 #endif
 419 }
 420
 421 /*
 422   Local Variables:
 423   c-file-style: "gnu"
 424   End:
 425 */