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