tinyscheme_genesi... 1
tinyscheme_genesi... 2
tinyscheme_genesi... 3
tinyscheme_genesi... 4
tinyscheme_genesi... 5
tinyscheme_genesi... 6 #define _SCHEME_SOURCE
tinyscheme_genesi... 7 #include "dynload.h"
tinyscheme_genesi... 8 #include <string.h>
tinyscheme_genesi... 9 #include <stdio.h>
tinyscheme_genesi... 10 #include <stdlib.h>
tinyscheme_genesi... 11
tinyscheme_genesi... 12 #ifndef MAXPATHLEN
tinyscheme_genesi... 13 # define MAXPATHLEN 1024
tinyscheme_genesi... 14 #endif
tinyscheme_genesi... 15
tinyscheme_genesi... 16 static void make_filename(const char *name, char *filename);
tinyscheme_genesi... 17 static void make_init_fn(const char *name, char *init_fn);
tinyscheme_genesi... 18
tinyscheme_genesi... 19 #ifdef _WIN32
tinyscheme_genesi... 20 # include <windows.h>
tinyscheme_genesi... 21 #else
tinyscheme_genesi... 22 typedef void *HMODULE;
tinyscheme_genesi... 23 typedef void (*FARPROC)();
tinyscheme_genesi... 24 #define SUN_DL
tinyscheme_genesi... 25 #include <dlfcn.h>
tinyscheme_genesi... 26 #endif
tinyscheme_genesi... 27
tinyscheme_genesi... 28 #ifdef _WIN32
tinyscheme_genesi... 29
tinyscheme_genesi... 30 #define PREFIX ""
tinyscheme_genesi... 31 #define SUFFIX ".dll"
tinyscheme_genesi... 32
tinyscheme_genesi... 33 static void display_w32_error_msg(const char *additional_message)
tinyscheme_genesi... 34 {
tinyscheme_genesi... 35 LPVOID msg_buf;
tinyscheme_genesi... 36
tinyscheme_genesi... 37 FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
tinyscheme_genesi... 38 NULL, GetLastError(), 0,
tinyscheme_genesi... 39 (LPTSTR)&msg_buf, 0, NULL);
tinyscheme_genesi... 40 fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf);
tinyscheme_genesi... 41 LocalFree(msg_buf);
tinyscheme_genesi... 42 }
tinyscheme_genesi... 43
tinyscheme_genesi... 44 static HMODULE dl_attach(const char *module) {
tinyscheme_genesi... 45 HMODULE dll = LoadLibrary(module);
tinyscheme_genesi... 46 if (!dll) display_w32_error_msg(module);
tinyscheme_genesi... 47 return dll;
tinyscheme_genesi... 48 }
tinyscheme_genesi... 49
tinyscheme_genesi... 50 static FARPROC dl_proc(HMODULE mo, const char *proc) {
tinyscheme_genesi... 51 FARPROC procedure = GetProcAddress(mo,proc);
tinyscheme_genesi... 52 if (!procedure) display_w32_error_msg(proc);
tinyscheme_genesi... 53 return procedure;
tinyscheme_genesi... 54 }
tinyscheme_genesi... 55
tinyscheme_genesi... 56 static void dl_detach(HMODULE mo) {
tinyscheme_genesi... 57 (void)FreeLibrary(mo);
tinyscheme_genesi... 58 }
tinyscheme_genesi... 59
tinyscheme_genesi... 60 #elif defined(SUN_DL)
tinyscheme_genesi... 61
tinyscheme_genesi... 62 #include <dlfcn.h>
tinyscheme_genesi... 63
tinyscheme_genesi... 64 #define PREFIX "lib"
tinyscheme_genesi... 65 #define SUFFIX ".so"
tinyscheme_genesi... 66
tinyscheme_genesi... 67 static HMODULE dl_attach(const char *module) {
tinyscheme_genesi... 68 HMODULE so=dlopen(module,RTLD_LAZY);
tinyscheme_genesi... 69 if(!so) {
tinyscheme_genesi... 70 fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror());
tinyscheme_genesi... 71 }
tinyscheme_genesi... 72 return so;
tinyscheme_genesi... 73 }
tinyscheme_genesi... 74
tinyscheme_genesi... 75 static FARPROC dl_proc(HMODULE mo, const char *proc) {
tinyscheme_genesi... 76 const char *errmsg;
tinyscheme_genesi... 77 FARPROC fp=(FARPROC)dlsym(mo,proc);
tinyscheme_genesi... 78 if ((errmsg = dlerror()) == 0) {
tinyscheme_genesi... 79 return fp;
tinyscheme_genesi... 80 }
tinyscheme_genesi... 81 fprintf(stderr, "Error initializing scheme module \"%s\": %s\n", proc, errmsg);
tinyscheme_genesi... 82 return 0;
tinyscheme_genesi... 83 }
tinyscheme_genesi... 84
tinyscheme_genesi... 85 static void dl_detach(HMODULE mo) {
tinyscheme_genesi... 86 (void)dlclose(mo);
tinyscheme_genesi... 87 }
tinyscheme_genesi... 88 #endif
tinyscheme_genesi... 89
tinyscheme_genesi... 90 pointer scm_load_ext(scheme *sc, pointer args)
tinyscheme_genesi... 91 {
tinyscheme_genesi... 92 pointer first_arg;
tinyscheme_genesi... 93 pointer retval;
tinyscheme_genesi... 94 char filename[MAXPATHLEN], init_fn[MAXPATHLEN+6];
tinyscheme_genesi... 95 char *name;
tinyscheme_genesi... 96 HMODULE dll_handle;
tinyscheme_genesi... 97 void (*module_init)(scheme *sc);
tinyscheme_genesi... 98
tinyscheme_genesi... 99 if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) {
tinyscheme_genesi... 100 name = string_value(first_arg);
tinyscheme_genesi... 101 make_filename(name,filename);
tinyscheme_genesi... 102 make_init_fn(name,init_fn);
tinyscheme_genesi... 103 dll_handle = dl_attach(filename);
tinyscheme_genesi... 104 if (dll_handle == 0) {
tinyscheme_genesi... 105 retval = sc -> F;
tinyscheme_genesi... 106 }
tinyscheme_genesi... 107 else {
tinyscheme_genesi... 108 module_init = (void(*)(scheme *))dl_proc(dll_handle, init_fn);
tinyscheme_genesi... 109 if (module_init != 0) {
tinyscheme_genesi... 110 (*module_init)(sc);
tinyscheme_genesi... 111 retval = sc -> T;
tinyscheme_genesi... 112 }
tinyscheme_genesi... 113 else {
tinyscheme_genesi... 114 retval = sc->F;
tinyscheme_genesi... 115 }
tinyscheme_genesi... 116 }
tinyscheme_genesi... 117 }
tinyscheme_genesi... 118 else {
tinyscheme_genesi... 119 retval = sc -> F;
tinyscheme_genesi... 120 }
tinyscheme_genesi... 121
tinyscheme_genesi... 122 return(retval);
tinyscheme_genesi... 123 }
tinyscheme_genesi... 124
tinyscheme_genesi... 125 static void make_filename(const char *name, char *filename) {
tinyscheme_genesi... 126 strcpy(filename,name);
tinyscheme_genesi... 127 strcat(filename,SUFFIX);
tinyscheme_genesi... 128 }
tinyscheme_genesi... 129
tinyscheme_genesi... 130 static void make_init_fn(const char *name, char *init_fn) {
tinyscheme_genesi... 131 const char *p=strrchr(name,'/');
tinyscheme_genesi... 132 if(p==0) {
tinyscheme_genesi... 133 p=name;
tinyscheme_genesi... 134 } else {
tinyscheme_genesi... 135 p++;
tinyscheme_genesi... 136 }
tinyscheme_genesi... 137 strcpy(init_fn,"init_");
tinyscheme_genesi... 138 strcat(init_fn,p);
tinyscheme_genesi... 139 }
tinyscheme_genesi... 140
tinyscheme_genesi... 141
tinyscheme_genesi... 142
tinyscheme_genesi... 143 Local variables:
tinyscheme_genesi... 144 c-file-style: "k&r"
tinyscheme_genesi... 145 End:
tinyscheme_genesi... 146 */