Back to index

plt-scheme  4.2.1
Defines | Typedefs | Functions
dynext.c File Reference
#include "schpriv.h"
#include "schvers.h"
#include "schgc.h"

Go to the source code of this file.

Defines

#define SCHEME_NO_GC_PROTO
#define DLOPEN_MODE   (1)
#define SSI_ARG_TYPES
#define SSI_ARGS
#define NO_DYNAMIC_LOAD
#define VERSION_AND_VARIANT   MZSCHEME_VERSION
#define mzPROC_TO_HASH_OBJ(f)   ((Scheme_Object *)(((long)f) | 0x1))

Typedefs

typedef char *(* Setup_Procedure )(SSI_ARG_TYPES)

Functions

static Scheme_Objectload_extension (int argc, Scheme_Object **argv)
static Scheme_Objectcurrent_load_extension (int argc, Scheme_Object *argv[])
void scheme_init_dynamic_extension (Scheme_Env *env)
static char * copy_vers (char *vers)
static Scheme_Objectdo_load_extension (const char *filename, Scheme_Object *expected_module, Scheme_Env *env)
void scheme_register_extension_global (void *ptr, long size)
Scheme_Objectscheme_default_load_extension (int argc, Scheme_Object **argv)
Scheme_Objectscheme_load_extension (const char *filename, Scheme_Env *env)
void scheme_free_dynamic_extensions ()

Define Documentation

#define DLOPEN_MODE   (1)

Definition at line 55 of file dynext.c.

#define mzPROC_TO_HASH_OBJ (   f)    ((Scheme_Object *)(((long)f) | 0x1))

Definition at line 119 of file dynext.c.

#define NO_DYNAMIC_LOAD

Definition at line 102 of file dynext.c.

Definition at line 27 of file dynext.c.

#define SSI_ARG_TYPES

Definition at line 95 of file dynext.c.

#define SSI_ARGS

Definition at line 96 of file dynext.c.

Definition at line 115 of file dynext.c.


Typedef Documentation

typedef char*(* Setup_Procedure)(SSI_ARG_TYPES)

Definition at line 190 of file dynext.c.


Function Documentation

static char* copy_vers ( char *  vers) [static]

Definition at line 178 of file dynext.c.

{
  if (vers) {
    int len = strlen(vers);
    char *vcopy;
    vcopy = (char *)scheme_malloc_atomic(len + 1);
    memcpy(vcopy, vers, len + 1);
    return vcopy;
  } else
    return NULL;
}

Here is the caller graph for this function:

static Scheme_Object * current_load_extension ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 155 of file dynext.c.

{
  return scheme_param_config("current-load-extension", 
                          scheme_make_integer(MZCONFIG_LOAD_EXTENSION_HANDLER),
                          argc, argv,
                          2, NULL, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_load_extension ( const char *  filename,
Scheme_Object expected_module,
Scheme_Env env 
) [static]

Definition at line 192 of file dynext.c.

{
#ifndef NO_DYNAMIC_LOAD
  Init_Procedure init_f; /* set by platform-specific code */
  Reload_Procedure reload_f; /* set by platform-specific code */
  Modname_Procedure modname_f; /* set by platform-specific code */
  ExtensionData *ed;
  void *handle;
  int comppath;

  comppath = scheme_is_complete_path(filename, strlen(filename), SCHEME_PLATFORM_PATH_KIND);

  reload_f = NULL;
  modname_f = NULL;
  handle = NULL;

  if (comppath)
    init_f = (Init_Procedure)scheme_hash_get(fullpath_loaded_extensions, (Scheme_Object *)filename);
  else
    init_f = NULL;

  if (!init_f) {
#endif

#ifdef UNIX_DYNAMIC_LOAD
    void *dl;
    Setup_Procedure f;
    char *vers;
    
    /* Make sure that filename is not a pathless filename.
       Some Unix systems don't search as a relative path
       otherwise. */
    if (filename[0] != '/') {
      int l = strlen(filename);
      char *s;
      s = (char *)scheme_malloc_atomic(l + 3);
      s[0] = '.';
      s[1] = '/';
      memcpy(s + 2, filename, l + 1);
      filename = s;
    }
    
    dl = dlopen((char *)filename, DLOPEN_MODE);
    if (!dl)
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: couldn't open \"%s\" (%s)",
                     filename, dlerror());

    handle = dl;
    
#ifdef UNDERSCORE_DYNLOAD_SYMBOL_PREFIX
# define SO_SYMBOL_PREFIX "_"
#else
# define SO_SYMBOL_PREFIX
#endif

    f = (Setup_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_initialize_internal");

    if (!f) {
      const char *err;
      err = dlerror();
      dlclose(dl);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: \"%s\" is not an extension (%s)", 
                     filename, err);
    }

    vers = f(SSI_ARGS);
    if (!vers || strcmp(vers, VERSION_AND_VARIANT)) {
      /* Copy, because we're going to unload the extension: */
      vers = copy_vers(vers);
      dlclose(dl);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_VERSION,
                     "load-extension: bad version %s (not %s) from \"%s\"",
                     vers, VERSION_AND_VARIANT, filename);
    }

    init_f = (Init_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_initialize");
    if (init_f) {
      reload_f = (Reload_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_reload");
      if (reload_f)
       modname_f = (Modname_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_module_name");
    }

    if (!init_f || !reload_f || !modname_f) {
      const char *err;
      err = dlerror();
      dlclose(dl);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: no %s in \"%s\" (%s)",
                     (init_f 
                     ? (reload_f
                        ? "scheme_module_name"
                        : "scheme_reload")
                     : "scheme_initialize"),
                     filename, err);
    }
#endif
#if defined(WINDOWS_DYNAMIC_LOAD)
    HINSTANCE dl;
    Setup_Procedure f;
    char *vers;
  
    dl = LoadLibraryW(WIDE_PATH(filename));
    if (!dl) {
      long err;
      err = GetLastError();
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: could not load \"%s\" (%E)",
                     filename, err);
    }
    
    handle = (void *)dl;
    
    f = (Setup_Procedure)GetProcAddress(dl, "scheme_initialize_internal");
    
    if (!f) {
      long err;
      err = GetLastError();
      FreeLibrary(dl);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: \"%s\" is not an extension (%E)",
                     filename, err);
    }
    
    vers = f(SSI_ARGS);
    if (!vers || strcmp(vers, VERSION_AND_VARIANT)) {
      /* Copy, because we're going to unload the extension: */
      vers = copy_vers(vers);
      FreeLibrary(dl);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_VERSION,
                     "load-extension: bad version %s (not %s) from \"%s\"",
                     vers, VERSION_AND_VARIANT, filename);
    }
    
    init_f = (Init_Procedure)GetProcAddress(dl,"scheme_initialize");
    if (init_f) {
      reload_f = (Reload_Procedure)GetProcAddress(dl,"scheme_reload");
      if (reload_f)
       modname_f = (Modname_Procedure)GetProcAddress(dl,"scheme_module_name");
    }
    
    if (!init_f || !reload_f || !modname_f) {
      FreeLibrary(dl);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: no %s in \"%s\"", 
                     (init_f 
                     ? (reload_f
                        ? "scheme_module_name"
                        : "scheme_reload")
                     : "scheme_initialize"),
                     filename);
    }
#endif
#if defined(CODEFRAGMENT_DYNAMIC_LOAD)
    FSSpec spec;
    Setup_Procedure f;
    char *vers;
    CFragConnectionID connID;

    if (get_ext_file_spec( &spec, filename ) && load_ext_file_spec( &spec, &connID ) )
      {
       OSErr err;
       handle = (void *)connID;
       
       err = FindSymbol( connID, "\pscheme_initialize_internal", ( Ptr * )&f, 0 );
       if ( err != noErr )
         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                        "load-extension: \"%s\" is not an extension",
                        filename);
       
       vers = f(SSI_ARGS);
       
       if (!vers || strcmp(vers, VERSION_AND_VARIANT))
         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_VERSION,
                        "load-extension: bad version %s (not %s) from \"%s\"",
                        vers, VERSION_AND_VARIANT, filename);
       
       err = FindSymbol( connID, "\pscheme_initialize", ( Ptr * )&init_f, 0 );
       if ( err != noErr )
         init_f = NULL;
       else {
         err = FindSymbol( connID, "\pscheme_reload", ( Ptr * )&reload_f, 0 );
         if ( err != noErr )
           reload_f = NULL;
         else {
           err = FindSymbol( connID, "\pscheme_module_name", ( Ptr * )&modname_f, 0 );
           if ( err != noErr )
             modname_f = NULL;
         }
       }

       if ( err != noErr )
         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                        "load-extension: no %s in \"%s\"", 
                        (init_f 
                         ? (reload_f
                            ? "scheme_module_name"
                            : "scheme_reload")
                         : "scheme_initialize"),
                        filename);
       

      }
    else
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: could not load extension: \"%s\"",
                     filename);
#endif
#ifdef NO_DYNAMIC_LOAD
    scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                   "load-extension: not supported on this platform");
    return NULL;
#else

    if (comppath)
      scheme_hash_set(fullpath_loaded_extensions, (Scheme_Object *)filename, mzPROC_TO_HASH_OBJ(init_f));
  }
#endif

#ifndef NO_DYNAMIC_LOAD
  ed = (ExtensionData *)scheme_hash_get(loaded_extensions, mzPROC_TO_HASH_OBJ(init_f));

  if (ed) {
    init_f = ed->reload_f;
    modname_f = ed->modname_f;
  } else {
    ed = MALLOC_ONE_ATOMIC(ExtensionData);
    ed->handle = handle;
    ed->init_f = init_f;
    ed->reload_f = reload_f;
    ed->modname_f = modname_f;
    scheme_hash_set(loaded_extensions, mzPROC_TO_HASH_OBJ(init_f), (Scheme_Object *)ed);
  }

  if (SCHEME_SYMBOLP(expected_module)) {
    Scheme_Object *n;
    n = modname_f();
    if (!SAME_OBJ(expected_module, n)) {
      Scheme_Object *other;

      if (n && SCHEME_SYMBOLP(n)) {
       char *s, *t;
       long len, slen;
       
       t = "module `";
       len = strlen(t);
       slen = SCHEME_SYM_LEN(n);
       
       s = (char *)scheme_malloc_atomic(len + slen + 2);
       memcpy(s, t, len);
       memcpy(s + len, SCHEME_SYM_VAL(n), slen);
       s[len + slen] = '\'';
       s[len + slen + 1]= 0;
       
       other = scheme_make_sized_byte_string(s, len + slen + 1, 0);
      } else
       other = scheme_make_byte_string("non-module");

      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "load-extension: expected module `%S', but found %T in: %s", 
                     expected_module,
                     other,
                     filename);

      return NULL;
    }
  }

  return init_f(env);
#endif
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * load_extension ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 479 of file dynext.c.

{
  return scheme_load_with_clrd(argc, argv, "load-extension", MZCONFIG_LOAD_EXTENSION_HANDLER);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 484 of file dynext.c.

{
  char *filename;
  Scheme_Object *expected_module;

  if (!SCHEME_PATH_STRINGP(argv[0]))
    scheme_wrong_type("default-load-extension-handler", SCHEME_PATH_STRING_STR, 0, argc, argv);
  expected_module = argv[1];
  if (!SCHEME_FALSEP(expected_module) && !SCHEME_SYMBOLP(expected_module))
    scheme_wrong_type("default-load-extension-handler", "symbol or #f", 1, argc, argv);

  filename = scheme_expand_string_filename(argv[0],
                                      "default-load-extension-handler",
                                      NULL,
                                      SCHEME_GUARD_FILE_EXECUTE);

  return scheme_force_value(do_load_extension(filename, expected_module, scheme_get_env(NULL)));
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 511 of file dynext.c.

{
  if (loaded_extensions) {
    int i;
    ExtensionData *ed;
    for (i = 0; i < loaded_extensions->size; i++) {
      if (loaded_extensions->vals[i]) {
        ed = (ExtensionData *)loaded_extensions->vals[i];
#       ifdef UNIX_DYNAMIC_LOAD
        dlclose(ed->handle);
#       endif
#       ifdef WINDOWS_DYNAMIC_LOAD
        FreeLibrary(ed->handle);
#       endif
      }
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 121 of file dynext.c.

{
  if (scheme_starting_up) {
#ifndef NO_DYNAMIC_LOAD
    REGISTER_SO(loaded_extensions);
    REGISTER_SO(fullpath_loaded_extensions);
    loaded_extensions = scheme_make_hash_table(SCHEME_hash_ptr);
    fullpath_loaded_extensions = scheme_make_hash_table(SCHEME_hash_string);
#endif

#ifdef LINK_EXTENSIONS_BY_TABLE
    REGISTER_SO(scheme_extension_table);
    
    scheme_extension_table = 
      (Scheme_Extension_Table *)scheme_malloc_atomic(sizeof(Scheme_Extension_Table));
#include "schemex.inc"
#endif
  }

  scheme_add_global_constant("load-extension", 
                          scheme_make_prim_w_arity2(load_extension, 
                                                 "load-extension",
                                                 1, 1,
                                                 0, -1), 
                          env);

  scheme_add_global_constant("current-load-extension", 
                          scheme_register_parameter(current_load_extension, 
                                                 "current-load-extension",
                                                 MZCONFIG_LOAD_EXTENSION_HANDLER), 
                          env);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_load_extension ( const char *  filename,
Scheme_Env env 
)

Definition at line 503 of file dynext.c.

Here is the call graph for this function:

void scheme_register_extension_global ( void ptr,
long  size 
)

Definition at line 470 of file dynext.c.

{
  GC_add_roots((char *)ptr, (char *)(((char *)ptr) + size + 1));
}

Here is the call graph for this function: