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