Re: extension paths

[Thien-Thi Nguyen]

() Mike Gran <address@hidden>
() Thu, 26 Jan 2017 22:41:23 +0000 (UTC)

   In ancient days, there were discussions of wrapping
   lt_dladdsearchdir directly, which would provide that
   functionality.  It was actually something that you
   could do in TTN's version of Guile 1.4.

Yeah, that's what ‘lt_dladdsearchdir’ is for.  Here's the code:

/* dynl.c --- dynamic linking */

/* Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009, 2012 Thien-Thi Nguyen
 * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997,
 *   1998, 1999, 2000, 2002 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 * Boston, MA 02110-1301, USA.
 */

#include "libguile/_scm.h"
#include <limits.h>                     /* for PATH_MAX */
#include <stdio.h>                      /* for snprintf */
#include <string.h>                     /* for strncmp */
#include <stdbool.h>
#include "libguile/smob.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libltdl/ltdl.h"


typedef void (*cthunk_t) (void);
typedef int (*mainish_func_t) (int argc, char **argv);

static int tc;

#define DYNL_FILENAME(x)        (SCM_CELL_OBJECT_1 (x))
#define DYNL_HANDLE(x)          ((lt_dlhandle) SCM_CELL_WORD_2 (x))
#define SET_DYNL_HANDLE(x, v)   (SCM_SET_CELL_WORD_2 ((x), (v)))

static lt_dlhandle
validate_live_dobj (const char * const FUNC_NAME, int pos, SCM obj)
{
  SMOBV (tc, (pos), (obj));
  if (! DYNL_HANDLE (obj))
    SCM_MISC_ERROR ("Already unlinked: ~S", SCM_LIST1 (obj));
  return DYNL_HANDLE (obj);
}

#define VALIDATE_LIVE_DOBJ_COPY(pos, obj, cvar)         \
  cvar = validate_live_dobj (FUNC_NAME, pos, obj)

static SCM
mark_dynl_obj (SCM ptr)
{
  return DYNL_FILENAME (ptr);
}

static int
print_dynl_obj (SCM exp, SCM port, PSTATE_SNUBBED pstate)
{
  char buf[32 + PATH_MAX];
  SCM filename = DYNL_FILENAME (exp);

  scm_lfwrite (buf, snprintf (buf, sizeof (buf),
                              "#<dynamic-object %s%s>",
                              (SCM_ROSTRINGP (filename)
                               ? SCM_ROCHARS (filename)
                               : ""),
                              (DYNL_HANDLE (exp)
                               ? ""
                               : " (unlinked)")),
               port);
  return 1;
}

/* These functions are called with deferred interrupts.  When they want
   to throw errors, they are expected to insert a enable interrupts before
   doing the throw.  It might work to throw an error while interrupts
   are deferred (because they will be unconditionally allowed the next
   time INTSOK is executed, NOINTS and INTSOK do not nest).  */
static void
hopefully (const char * const FUNC_NAME, bool result)
{
  if (!result)
    {
      INTSOK ();
      SCM_MISC_ERROR (lt_dlerror (), SCM_EOL);
    }
}

#define HOPEFULLY(expression)   hopefully (FUNC_NAME, (expression))
#define ZHOPEFULLY(expression)  HOPEFULLY (! (expression))

DSOPRIVATE void *
scm_i_lt_dlsym (SCM dobj, const char *name)
{
#define FUNC_NAME __func__
  lt_dlhandle handle;

  VALIDATE_LIVE_DOBJ_COPY (1, dobj, handle);
  return lt_dlsym (handle, name);
#undef FUNC_NAME
}

SCM_DEFINE
(scm_dynamic_link, "dynamic-link", 1, 0, 0,
 (SCM name),
 doc: /***********
Open the dynamic library file @var{name} and return
its @dfn{library handle}, suitable for passing to the
following functions.
As a special case, if @var{name} is @code{#f},
the returned handle is for the Guile executable itself.  */)
{
#define FUNC_NAME s_scm_dynamic_link
  const char *fname = NULL;
  lt_dladvise advise;
  lt_dlhandle handle;

  if (SCM_NFALSEP (name))
    {
      SCM_COERCE_SUBSTR (name);
      SCM_VALIDATE_ROSTRING_COPY (1, name, fname);
    }

  NOINTS ();

  ZHOPEFULLY (lt_dladvise_init (&advise));
  ZHOPEFULLY (lt_dladvise_global (&advise));

  if (!fname || '/' != fname[0])
    ZHOPEFULLY (lt_dladvise_ext (&advise));

  handle = lt_dlopenadvise (fname, advise);
  lt_dladvise_destroy (&advise);

  HOPEFULLY (handle);

  INTSOK ();
  SCM_RETURN_NEWSMOB2 (tc, SCM_UNPACK (name), handle);
#undef FUNC_NAME
}

SCM_DEFINE
(scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 (SCM obj),
 doc: /***********
Return @code{#t} iff @var{obj} is a dynamic library handle.  */)
{
  return SCM_BOOL (SCM_SMOB_PREDICATE (tc, obj));
}

SCM_DEFINE
(scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 (SCM h),
 doc: /***********
Unlink the library represented by dynamic library handle
@var{h} and remove any imported symbols from the address space.  */)
{
#define FUNC_NAME s_scm_dynamic_unlink
  lt_dlhandle dh;

  /* FIXME: GC-problem.  */
  VALIDATE_LIVE_DOBJ_COPY (1, h, dh);
  NOINTS ();
  ZHOPEFULLY (lt_dlclose (dh));
  SET_DYNL_HANDLE (h, NULL);
  INTSOK ();
  return SCM_UNSPECIFIED;
#undef FUNC_NAME
}

SCM_DEFINE
(scm_dynamic_func, "dynamic-func", 2, 0, 0,
 (SCM name, SCM dobj),
 doc: /***********
Import the function @var{name} from @var{h}, a dynamic library
handle, and return a @dfn{dynamic function handle}.
At the moment, the dynamic function handle
is formed by casting the address of @var{name}
to C type @code{long} and converting this number to its
Scheme representation.

Regardless whether your C compiler prepends an underscore
@samp{_} to the global names in a program, you should
@strong{not} include this underscore in @var{function}.
Guile knows whether the underscore is
needed or not and will add it when necessary.

-sig: (name h)  */)
{
#define FUNC_NAME s_scm_dynamic_func
  const char *cname;
  lt_dlhandle dh;
  lt_ptr fptr;

  SCM_COERCE_SUBSTR (name);
  SCM_VALIDATE_ROSTRING_COPY (1, name, cname);
  /* FIXME: GC-problem.  */
  VALIDATE_LIVE_DOBJ_COPY (2, dobj, dh);
  NOINTS ();
  HOPEFULLY (fptr = lt_dlsym (dh, cname));
  INTSOK ();
  return scm_ulong2num ((unsigned long) fptr);
#undef FUNC_NAME
}

SCM_DEFINE
(scm_dynamic_call, "dynamic-call", 2, 0, 0,
 (SCM func, SCM dobj),
 doc: /***********
Call @var{lib-thunk}, a procedure of no arguments.
If @var{lib-thunk} is a string, it is assumed to be a symbol
found in the dynamic library @var{h} and is fetched
with @code{dynamic-func}.  Otherwise, it should be a function
handle returned by a previous call to @code{dynamic-func}.

Interrupts are deferred while the C function is executing.

-sig: (lib-thunk h)  */)
{
#define FUNC_NAME s_scm_dynamic_call
  cthunk_t fptr;

  if (SCM_ROSTRINGP (func))
    func = scm_dynamic_func (func, dobj);
  fptr = (cthunk_t) SCM_NUM2ULONG (1, func);
  NOINTS ();
  fptr ();
  INTSOK ();
  return SCM_UNSPECIFIED;
#undef FUNC_NAME
}

SCM_DEFINE
(scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
 (SCM func, SCM dobj, SCM args),
 doc: /***********
Call @var{proc}, a dynamically loaded function,
passing it @var{args} (a list of strings)
in the standard @code{(int argc, char **argv)} manner.
As with @code{dynamic-call}, @var{proc} should be
either a function handle or a string, in which case
it is first fetched from @var{h} with @code{dynamic-func}.

@var{proc} should return an integer, which is used as the
return value from @code{dynamic-args-call}.

-sig: (proc h args)  */)
{
#define FUNC_NAME s_scm_dynamic_args_call
  mainish_func_t fptr;
  int result, argc;
  SCM argv;

  SCM_VALIDATE_LIST_COPYLEN (3, args, argc);
  if (SCM_ROSTRINGP (func))
    func = scm_dynamic_func (func, dobj);

  fptr = (mainish_func_t) SCM_NUM2ULONG (1, func);
  NOINTS ();
  argv = scm_optimal_argv (FUNC_NAME, argc, 3, args, 0);
  result = (*fptr) (argc, (char **) SCM_CHARS (argv));
  INTSOK ();

  return scm_return_first (SCM_MAKINUM (result), argv);
#undef FUNC_NAME
}

SCM_DEFINE
(scm_percent_percent_ltdl, "%%ltdl", 1, 1, 0,
 (SCM command, SCM arg),
 doc: /***********
Dispatch @var{command} given @var{args}, where
@var{command} is one of @code{add-search-dir!},
@code{set-search-path!}, or @code{get-search-path}
(a symbol).

@strong{This interface is highly experimental.}  */)
{
#define FUNC_NAME s_scm_percent_percent_ltdl
  const char *s;
  size_t len;

  SCM_VALIDATE_SYMBOL (1, command);
  s = SCM_ROCHARS (command);
  len = SCM_ROLENGTH (command);

  /* Poor man's hash wannabe (usage is low-frequency enough that it's
     not worth declaring, initializing and comparing against, a symbol).  */
#define COMMAND_IS(kstr)  (! strncmp (kstr, s, len))

  if (COMMAND_IS ("add-search-dir!"))
    {
      ZHOPEFULLY (lt_dladdsearchdir (SCM_ROCHARS (arg)));
      return SCM_UNSPECIFIED;
    }

  if (COMMAND_IS ("set-search-path!"))
    return SCM_NEGATE_BOOL (lt_dlsetsearchpath (SCM_ROCHARS (arg)));

  if (COMMAND_IS ("get-search-path"))
    return scm_makfrom0str (lt_dlgetsearchpath ());

#undef COMMAND_IS

  SCM_MISC_ERROR ("bad command", SCM_EOL);
#undef FUNC_NAME
}


DSOPRIVATE void
scm_init_dynamic_linking (void)
{
  tc = scm_make_smob_type_mfpe
    ("dynamic-object", 0, mark_dynl_obj, NULL, print_dynl_obj, NULL);
  lt_dlinit ();
#include "libguile/dynl.x"
}

/* dynl.c ends here */

Now that i'm (slowly) returning to Official Guile hacking, this
is one of the features it would be nice to port "forward".  I'm
not emotionally attached to doing that myself (i know i'm slow)
however, so if anyone else beats me to it, cool!  (Just do it.)

-- 
Thien-Thi Nguyen -----------------------------------------------
 (defun responsep (query)
   (pcase (context query)
     (`(technical ,ml) (correctp ml))
     ...))                              748E A0E8 1CB8 A748 9BFA
--------------------------------------- 6CE4 6703 2224 4C80 7502

signature.asc
Description: PGP signature