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