Back to index

plt-scheme  4.2.1
dynext.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2002 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   Thanks to Patrick Barta for the WINDOWS_DYNAMIC_LOAD code.
00022   Thanks to William Ng for the CODEFRAGMENT_DYNAMIC_LOAD code.
00023 */
00024 
00025 /* Some copilers don't like re-def of GC_malloc in schemef.h: */
00026 #ifndef MZ_PRECISE_GC
00027 # define SCHEME_NO_GC_PROTO
00028 #endif
00029 
00030 #include "schpriv.h"
00031 #include "schvers.h"
00032 #include "schgc.h"
00033 
00034 #ifdef UNIX_DYNAMIC_LOAD
00035 # ifdef OS_X_NO_DLFCN
00036 #  include "dlcompat.inc"
00037 # else
00038 #  include <dlfcn.h>
00039 # endif
00040 #endif
00041 #if defined(WINDOWS_DYNAMIC_LOAD)
00042 # include <windows.h>
00043 #endif
00044 #if defined(CODEFRAGMENT_DYNAMIC_LOAD)
00045 # include <CodeFragments.h>
00046 static Boolean get_ext_file_spec(FSSpec *spec, const char *filename );
00047 static Boolean load_ext_file_spec(FSSpec *spec, CFragConnectionID *connID);
00048 #endif
00049 
00050 #if defined(RTLD_NOW)
00051 # define DLOPEN_MODE (RTLD_NOW)
00052 #elif defined(RTLD_LAZY)
00053 # define DLOPEN_MODE (RTLD_LAZY)
00054 #else
00055 # define DLOPEN_MODE (1)
00056 #endif
00057 
00058 #ifdef SHL_DYNAMIC_LOAD
00059 #include <dl.h>
00060 #include <errno.h>
00061 #define dlopen(file, flag) ((void *)shl_load(file, BIND_IMMEDIATE, 0L))
00062 #define dlclose(dl) (shl_unload((shl_t)dl))
00063 void *dlsym(void *_handle, const char *name)
00064 {
00065   void *result;
00066   shl_t handle = (shl_t)_handle;
00067 
00068   if (!shl_findsym(&handle, name, TYPE_PROCEDURE, (void *)&result))
00069     return result;
00070   else
00071     return NULL;
00072 }
00073 static char *dlerror(void) {
00074   static char errbuf[20];
00075   sprintf(errbuf, "%d", errno);
00076   return errbuf;
00077 }
00078 #define UNIX_DYNAMIC_LOAD
00079 #endif
00080 
00081 #ifdef LINK_EXTENSIONS_BY_TABLE
00082 # undef SCHEME_NO_GC_PROTO
00083 # include "schemex.h"
00084 #endif
00085 
00086 static Scheme_Object *load_extension(int argc, Scheme_Object **argv);
00087 static Scheme_Object *current_load_extension(int argc, Scheme_Object *argv[]);
00088 
00089 #ifdef LINK_EXTENSIONS_BY_TABLE
00090 Scheme_Extension_Table *scheme_extension_table;
00091 
00092 #define SSI_ARG_TYPES Scheme_Extension_Table *
00093 #define SSI_ARGS scheme_extension_table
00094 #else
00095 #define SSI_ARG_TYPES
00096 #define SSI_ARGS
00097 #endif
00098 
00099 #ifndef UNIX_DYNAMIC_LOAD
00100 # ifndef WINDOWS_DYNAMIC_LOAD
00101 #  ifndef CODEFRAGMENT_DYNAMIC_LOAD
00102 #   define NO_DYNAMIC_LOAD
00103 #  endif
00104 # endif
00105 #endif
00106 
00107 #ifndef NO_DYNAMIC_LOAD
00108 static Scheme_Hash_Table *loaded_extensions; /* hash on scheme_initialize pointer */
00109 static Scheme_Hash_Table *fullpath_loaded_extensions; /* hash on full path name */
00110 #endif
00111 
00112 #ifdef MZ_PRECISE_GC 
00113 # define VERSION_AND_VARIANT MZSCHEME_VERSION "@3m"
00114 #else
00115 # define VERSION_AND_VARIANT MZSCHEME_VERSION
00116 #endif
00117 
00118 /* For precise GC, make a proc ptr look like a fixnum: */
00119 #define mzPROC_TO_HASH_OBJ(f) ((Scheme_Object *)(((long)f) | 0x1))
00120 
00121 void scheme_init_dynamic_extension(Scheme_Env *env)
00122 {
00123   if (scheme_starting_up) {
00124 #ifndef NO_DYNAMIC_LOAD
00125     REGISTER_SO(loaded_extensions);
00126     REGISTER_SO(fullpath_loaded_extensions);
00127     loaded_extensions = scheme_make_hash_table(SCHEME_hash_ptr);
00128     fullpath_loaded_extensions = scheme_make_hash_table(SCHEME_hash_string);
00129 #endif
00130 
00131 #ifdef LINK_EXTENSIONS_BY_TABLE
00132     REGISTER_SO(scheme_extension_table);
00133     
00134     scheme_extension_table = 
00135       (Scheme_Extension_Table *)scheme_malloc_atomic(sizeof(Scheme_Extension_Table));
00136 #include "schemex.inc"
00137 #endif
00138   }
00139 
00140   scheme_add_global_constant("load-extension", 
00141                           scheme_make_prim_w_arity2(load_extension, 
00142                                                  "load-extension",
00143                                                  1, 1,
00144                                                  0, -1), 
00145                           env);
00146 
00147   scheme_add_global_constant("current-load-extension", 
00148                           scheme_register_parameter(current_load_extension, 
00149                                                  "current-load-extension",
00150                                                  MZCONFIG_LOAD_EXTENSION_HANDLER), 
00151                           env);
00152 }
00153 
00154 static Scheme_Object *
00155 current_load_extension(int argc, Scheme_Object *argv[])
00156 {
00157   return scheme_param_config("current-load-extension", 
00158                           scheme_make_integer(MZCONFIG_LOAD_EXTENSION_HANDLER),
00159                           argc, argv,
00160                           2, NULL, NULL, 0);
00161 }
00162 
00163 #ifndef NO_DYNAMIC_LOAD
00164 
00165 typedef Scheme_Object *(*Init_Procedure)(Scheme_Env *);
00166 typedef Scheme_Object *(*Reload_Procedure)(Scheme_Env *);
00167 typedef Scheme_Object *(*Modname_Procedure)(void);
00168 
00169 typedef struct {
00170   void *handle;
00171   Init_Procedure init_f;
00172   Reload_Procedure reload_f;
00173   Modname_Procedure modname_f;
00174 } ExtensionData;
00175 
00176 #endif
00177 
00178 static char *copy_vers(char *vers)
00179 {
00180   if (vers) {
00181     int len = strlen(vers);
00182     char *vcopy;
00183     vcopy = (char *)scheme_malloc_atomic(len + 1);
00184     memcpy(vcopy, vers, len + 1);
00185     return vcopy;
00186   } else
00187     return NULL;
00188 }
00189 
00190 typedef char *(*Setup_Procedure)(SSI_ARG_TYPES);
00191 
00192 static Scheme_Object *do_load_extension(const char *filename,
00193                                    Scheme_Object *expected_module, Scheme_Env *env)
00194 {
00195 #ifndef NO_DYNAMIC_LOAD
00196   Init_Procedure init_f; /* set by platform-specific code */
00197   Reload_Procedure reload_f; /* set by platform-specific code */
00198   Modname_Procedure modname_f; /* set by platform-specific code */
00199   ExtensionData *ed;
00200   void *handle;
00201   int comppath;
00202 
00203   comppath = scheme_is_complete_path(filename, strlen(filename), SCHEME_PLATFORM_PATH_KIND);
00204 
00205   reload_f = NULL;
00206   modname_f = NULL;
00207   handle = NULL;
00208 
00209   if (comppath)
00210     init_f = (Init_Procedure)scheme_hash_get(fullpath_loaded_extensions, (Scheme_Object *)filename);
00211   else
00212     init_f = NULL;
00213 
00214   if (!init_f) {
00215 #endif
00216 
00217 #ifdef UNIX_DYNAMIC_LOAD
00218     void *dl;
00219     Setup_Procedure f;
00220     char *vers;
00221     
00222     /* Make sure that filename is not a pathless filename.
00223        Some Unix systems don't search as a relative path
00224        otherwise. */
00225     if (filename[0] != '/') {
00226       int l = strlen(filename);
00227       char *s;
00228       s = (char *)scheme_malloc_atomic(l + 3);
00229       s[0] = '.';
00230       s[1] = '/';
00231       memcpy(s + 2, filename, l + 1);
00232       filename = s;
00233     }
00234     
00235     dl = dlopen((char *)filename, DLOPEN_MODE);
00236     if (!dl)
00237       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00238                      "load-extension: couldn't open \"%s\" (%s)",
00239                      filename, dlerror());
00240 
00241     handle = dl;
00242     
00243 #ifdef UNDERSCORE_DYNLOAD_SYMBOL_PREFIX
00244 # define SO_SYMBOL_PREFIX "_"
00245 #else
00246 # define SO_SYMBOL_PREFIX
00247 #endif
00248 
00249     f = (Setup_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_initialize_internal");
00250 
00251     if (!f) {
00252       const char *err;
00253       err = dlerror();
00254       dlclose(dl);
00255       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00256                      "load-extension: \"%s\" is not an extension (%s)", 
00257                      filename, err);
00258     }
00259 
00260     vers = f(SSI_ARGS);
00261     if (!vers || strcmp(vers, VERSION_AND_VARIANT)) {
00262       /* Copy, because we're going to unload the extension: */
00263       vers = copy_vers(vers);
00264       dlclose(dl);
00265       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_VERSION,
00266                      "load-extension: bad version %s (not %s) from \"%s\"",
00267                      vers, VERSION_AND_VARIANT, filename);
00268     }
00269 
00270     init_f = (Init_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_initialize");
00271     if (init_f) {
00272       reload_f = (Reload_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_reload");
00273       if (reload_f)
00274        modname_f = (Modname_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_module_name");
00275     }
00276 
00277     if (!init_f || !reload_f || !modname_f) {
00278       const char *err;
00279       err = dlerror();
00280       dlclose(dl);
00281       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00282                      "load-extension: no %s in \"%s\" (%s)",
00283                      (init_f 
00284                      ? (reload_f
00285                         ? "scheme_module_name"
00286                         : "scheme_reload")
00287                      : "scheme_initialize"),
00288                      filename, err);
00289     }
00290 #endif
00291 #if defined(WINDOWS_DYNAMIC_LOAD)
00292     HINSTANCE dl;
00293     Setup_Procedure f;
00294     char *vers;
00295   
00296     dl = LoadLibraryW(WIDE_PATH(filename));
00297     if (!dl) {
00298       long err;
00299       err = GetLastError();
00300       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00301                      "load-extension: could not load \"%s\" (%E)",
00302                      filename, err);
00303     }
00304     
00305     handle = (void *)dl;
00306     
00307     f = (Setup_Procedure)GetProcAddress(dl, "scheme_initialize_internal");
00308     
00309     if (!f) {
00310       long err;
00311       err = GetLastError();
00312       FreeLibrary(dl);
00313       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00314                      "load-extension: \"%s\" is not an extension (%E)",
00315                      filename, err);
00316     }
00317     
00318     vers = f(SSI_ARGS);
00319     if (!vers || strcmp(vers, VERSION_AND_VARIANT)) {
00320       /* Copy, because we're going to unload the extension: */
00321       vers = copy_vers(vers);
00322       FreeLibrary(dl);
00323       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_VERSION,
00324                      "load-extension: bad version %s (not %s) from \"%s\"",
00325                      vers, VERSION_AND_VARIANT, filename);
00326     }
00327     
00328     init_f = (Init_Procedure)GetProcAddress(dl,"scheme_initialize");
00329     if (init_f) {
00330       reload_f = (Reload_Procedure)GetProcAddress(dl,"scheme_reload");
00331       if (reload_f)
00332        modname_f = (Modname_Procedure)GetProcAddress(dl,"scheme_module_name");
00333     }
00334     
00335     if (!init_f || !reload_f || !modname_f) {
00336       FreeLibrary(dl);
00337       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00338                      "load-extension: no %s in \"%s\"", 
00339                      (init_f 
00340                      ? (reload_f
00341                         ? "scheme_module_name"
00342                         : "scheme_reload")
00343                      : "scheme_initialize"),
00344                      filename);
00345     }
00346 #endif
00347 #if defined(CODEFRAGMENT_DYNAMIC_LOAD)
00348     FSSpec spec;
00349     Setup_Procedure f;
00350     char *vers;
00351     CFragConnectionID connID;
00352 
00353     if (get_ext_file_spec( &spec, filename ) && load_ext_file_spec( &spec, &connID ) )
00354       {
00355        OSErr err;
00356        handle = (void *)connID;
00357        
00358        err = FindSymbol( connID, "\pscheme_initialize_internal", ( Ptr * )&f, 0 );
00359        if ( err != noErr )
00360          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00361                         "load-extension: \"%s\" is not an extension",
00362                         filename);
00363        
00364        vers = f(SSI_ARGS);
00365        
00366        if (!vers || strcmp(vers, VERSION_AND_VARIANT))
00367          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_VERSION,
00368                         "load-extension: bad version %s (not %s) from \"%s\"",
00369                         vers, VERSION_AND_VARIANT, filename);
00370        
00371        err = FindSymbol( connID, "\pscheme_initialize", ( Ptr * )&init_f, 0 );
00372        if ( err != noErr )
00373          init_f = NULL;
00374        else {
00375          err = FindSymbol( connID, "\pscheme_reload", ( Ptr * )&reload_f, 0 );
00376          if ( err != noErr )
00377            reload_f = NULL;
00378          else {
00379            err = FindSymbol( connID, "\pscheme_module_name", ( Ptr * )&modname_f, 0 );
00380            if ( err != noErr )
00381              modname_f = NULL;
00382          }
00383        }
00384 
00385        if ( err != noErr )
00386          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00387                         "load-extension: no %s in \"%s\"", 
00388                         (init_f 
00389                          ? (reload_f
00390                             ? "scheme_module_name"
00391                             : "scheme_reload")
00392                          : "scheme_initialize"),
00393                         filename);
00394        
00395 
00396       }
00397     else
00398       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00399                      "load-extension: could not load extension: \"%s\"",
00400                      filename);
00401 #endif
00402 #ifdef NO_DYNAMIC_LOAD
00403     scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
00404                    "load-extension: not supported on this platform");
00405     return NULL;
00406 #else
00407 
00408     if (comppath)
00409       scheme_hash_set(fullpath_loaded_extensions, (Scheme_Object *)filename, mzPROC_TO_HASH_OBJ(init_f));
00410   }
00411 #endif
00412 
00413 #ifndef NO_DYNAMIC_LOAD
00414   ed = (ExtensionData *)scheme_hash_get(loaded_extensions, mzPROC_TO_HASH_OBJ(init_f));
00415 
00416   if (ed) {
00417     init_f = ed->reload_f;
00418     modname_f = ed->modname_f;
00419   } else {
00420     ed = MALLOC_ONE_ATOMIC(ExtensionData);
00421     ed->handle = handle;
00422     ed->init_f = init_f;
00423     ed->reload_f = reload_f;
00424     ed->modname_f = modname_f;
00425     scheme_hash_set(loaded_extensions, mzPROC_TO_HASH_OBJ(init_f), (Scheme_Object *)ed);
00426   }
00427 
00428   if (SCHEME_SYMBOLP(expected_module)) {
00429     Scheme_Object *n;
00430     n = modname_f();
00431     if (!SAME_OBJ(expected_module, n)) {
00432       Scheme_Object *other;
00433 
00434       if (n && SCHEME_SYMBOLP(n)) {
00435        char *s, *t;
00436        long len, slen;
00437        
00438        t = "module `";
00439        len = strlen(t);
00440        slen = SCHEME_SYM_LEN(n);
00441        
00442        s = (char *)scheme_malloc_atomic(len + slen + 2);
00443        memcpy(s, t, len);
00444        memcpy(s + len, SCHEME_SYM_VAL(n), slen);
00445        s[len + slen] = '\'';
00446        s[len + slen + 1]= 0;
00447        
00448        other = scheme_make_sized_byte_string(s, len + slen + 1, 0);
00449       } else
00450        other = scheme_make_byte_string("non-module");
00451 
00452       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00453                      "load-extension: expected module `%S', but found %T in: %s", 
00454                      expected_module,
00455                      other,
00456                      filename);
00457 
00458       return NULL;
00459     }
00460   }
00461 
00462   return init_f(env);
00463 #endif
00464 }
00465 
00466 #ifdef MZ_XFORM
00467 START_XFORM_SKIP;
00468 #endif
00469 
00470 void scheme_register_extension_global(void *ptr, long size)
00471 {
00472   GC_add_roots((char *)ptr, (char *)(((char *)ptr) + size + 1));
00473 }
00474 
00475 #ifdef MZ_XFORM
00476 END_XFORM_SKIP;
00477 #endif
00478 
00479 static Scheme_Object *load_extension(int argc, Scheme_Object **argv)
00480 {
00481   return scheme_load_with_clrd(argc, argv, "load-extension", MZCONFIG_LOAD_EXTENSION_HANDLER);
00482 }
00483 
00484 Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv)
00485 {
00486   char *filename;
00487   Scheme_Object *expected_module;
00488 
00489   if (!SCHEME_PATH_STRINGP(argv[0]))
00490     scheme_wrong_type("default-load-extension-handler", SCHEME_PATH_STRING_STR, 0, argc, argv);
00491   expected_module = argv[1];
00492   if (!SCHEME_FALSEP(expected_module) && !SCHEME_SYMBOLP(expected_module))
00493     scheme_wrong_type("default-load-extension-handler", "symbol or #f", 1, argc, argv);
00494 
00495   filename = scheme_expand_string_filename(argv[0],
00496                                       "default-load-extension-handler",
00497                                       NULL,
00498                                       SCHEME_GUARD_FILE_EXECUTE);
00499 
00500   return scheme_force_value(do_load_extension(filename, expected_module, scheme_get_env(NULL)));
00501 }
00502 
00503 Scheme_Object *scheme_load_extension(const char *filename, Scheme_Env *env)
00504 {
00505   Scheme_Object *a[1];
00506 
00507   a[0] = scheme_make_byte_string(filename);
00508   return load_extension(1, a);
00509 }
00510 
00511 void scheme_free_dynamic_extensions()
00512 {
00513   if (loaded_extensions) {
00514     int i;
00515     ExtensionData *ed;
00516     for (i = 0; i < loaded_extensions->size; i++) {
00517       if (loaded_extensions->vals[i]) {
00518         ed = (ExtensionData *)loaded_extensions->vals[i];
00519 #       ifdef UNIX_DYNAMIC_LOAD
00520         dlclose(ed->handle);
00521 #       endif
00522 #       ifdef WINDOWS_DYNAMIC_LOAD
00523         FreeLibrary(ed->handle);
00524 #       endif
00525       }
00526     }
00527   }
00528 }
00529 
00530 #if defined(CODEFRAGMENT_DYNAMIC_LOAD)
00531 
00532 static Boolean get_ext_file_spec(FSSpec *spec, const char *filename)
00533 {
00534 #ifndef EXTENSIONS_WITHOUT_PATH
00535        return scheme_mac_path_to_spec(filename, spec);
00536 #else
00537        /* William Ng's code for always finding an extension in a particular place. */
00538        /* This is a very Mac-like idea, but not MzScheme-like. */
00539     ProcessSerialNumber currentPSN;
00540     ProcessInfoRec info;
00541        Boolean ret = false;
00542     currentPSN.highLongOfPSN = 0;
00543     currentPSN.lowLongOfPSN = kCurrentProcess;
00544     info.processInfoLength = sizeof(ProcessInfoRec);
00545     info.processName = NULL;
00546     info.processAppSpec = spec;
00547     
00548        if ( GetProcessInformation(&currentPSN, &info)==noErr )
00549        {
00550 #ifdef EXTENSION_IN_SEPARATE_FOLDER
00551               /* call PBGetCatInfoSync to get the folder par id */
00552               #define EXTENSION_FOLDER_NAME "\pextensions"
00553               HFileInfo file_info = {0};
00554               CInfoPBPtr    myCPBPtr;           /* for the PBGetCatInfo call */
00555               myCPBPtr = (CInfoPBRec*)&file_info;
00556        
00557               myCPBPtr->hFileInfo.ioNamePtr      = EXTENSION_FOLDER_NAME;
00558               myCPBPtr->hFileInfo.ioVRefNum      = spec->vRefNum;
00559               myCPBPtr->hFileInfo.ioFDirIndex    = 0;
00560               myCPBPtr->hFileInfo.ioDirID        = spec->parID;
00561               
00562               if (PBGetCatInfoSync(myCPBPtr) == noErr) 
00563               {
00564                      if ((myCPBPtr->hFileInfo.ioFlAttrib & ioDirMask) != 0) 
00565                      {   /* we have a directory */
00566                             spec->parID   = myCPBPtr->hFileInfo.ioDirID;
00567                             c2pstrcpy(spec->name,filename);
00568                             ret = true;
00569                      }
00570               }
00571 #else
00572               /* copy the extension filename to the FSSpec */
00573               c2pstrcpy(spec->name,filename);
00574               ret = true;
00575 
00576 #endif
00577        }
00578                      
00579        return ret;
00580 #endif
00581 }
00582 
00583 static Boolean load_ext_file_spec(FSSpec *spec, CFragConnectionID *connID)
00584 {
00585        OSErr err = GetDiskFragment(spec, 0, 0, 0, kPrivateCFragCopy, connID, 0, NULL);
00586        return err==noErr;
00587 }
00588 
00589 #endif
00590