aboutsummaryrefslogtreecommitdiffstats
path: root/dynl.c
diff options
context:
space:
mode:
Diffstat (limited to 'dynl.c')
-rw-r--r--dynl.c153
1 files changed, 128 insertions, 25 deletions
diff --git a/dynl.c b/dynl.c
index d965840..a1a0c37 100644
--- a/dynl.c
+++ b/dynl.c
@@ -73,7 +73,7 @@ SCM l_dyn_link(fname)
SCM fname;
{
int status;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
DEFER_INTS;
status = dld_link(CHARS(fname));
ALLOW_INTS;
@@ -89,7 +89,7 @@ SCM l_dyn_call(symb, shl)
int i;
void (*func)() = 0;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
DEFER_INTS;
if ((i = dld_function_executable_p(CHARS(symb))))
func = (void (*) ()) dld_get_func(CHARS(symb));
@@ -113,7 +113,7 @@ SCM l_dyn_main_call(symb, shl, args)
int (*func)(int argc, char **argv) = 0;
char **argv;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
DEFER_INTS;
argv = makargvfrmstrs(args, s_main_call);
if ((i = dld_function_executable_p(CHARS(symb))))
@@ -141,7 +141,7 @@ SCM l_dyn_unlink(fname)
SCM fname;
{
int status;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_unlink);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_unlink);
DEFER_INTS;
status = dld_unlink_by_file(CHARS(fname), 1);
ALLOW_INTS;
@@ -194,7 +194,7 @@ SCM l_dyn_link(fname)
{
SCM z;
shl_t shl;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
shl = shl_load(CHARS(fname), BIND_DEFERRED , 0L);
@@ -214,8 +214,8 @@ SCM l_dyn_call(symb, shl)
void (*func)() = 0;
int i;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
if ((i = shl_findsym(P_SHL(shl),
CHARS(symb),
@@ -238,8 +238,8 @@ SCM l_dyn_main_call(symb, shl, args)
int (*func)P((int argc, char **argv)) = 0;
char **argv;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
if ((i = shl_findsym(P_SHL(shl),
CHARS(symb),
@@ -263,7 +263,7 @@ SCM l_dyn_unlink(shl)
SCM shl;
{
int status;
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
status = shl_unload(SHL(shl));
ALLOW_INTS;
@@ -318,9 +318,9 @@ SCM dynl(dir, symbol, fname)
struct dsc$descriptor fnamed, symbold, dird;
void (*fcn)();
long retval;
- ASSERT(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl);
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl);
- ASSERT(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl);
+ ASRTER(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl);
+ ASRTER(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl);
descriptorize(&fnamed, fname);
descriptorize(&symbold, symbol);
DEFER_INTS;
@@ -393,7 +393,7 @@ SCM l_dyn_link(fname)
SCM z;
void *handle;
if FALSEP(fname) return fname;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
handle = dlopen(CHARS(fname), DLOPEN_MODE);
@@ -421,8 +421,8 @@ SCM l_dyn_call(symb, shl)
{
void (*func)() = 0;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
@@ -450,8 +450,8 @@ SCM l_dyn_main_call(symb, shl, args)
int (*func)P((int argc, char **argv)) = 0;
char **argv;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
@@ -481,7 +481,7 @@ SCM l_dyn_unlink(shl)
SCM shl;
{
int status;
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
status = dlclose(SHL(shl));
SETCHARS(shl, NULL);
@@ -549,7 +549,7 @@ SCM l_dyn_link(fname)
Str255 errMessage;
if FALSEP(fname) return fname;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
strcpy((char *)libName, CHARS(fname));
@@ -577,8 +577,8 @@ SCM l_dyn_call(symb, shl)
Str255 symName;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
strcpy((char *)symName, CHARS(symb));
@@ -609,8 +609,8 @@ SCM l_dyn_main_call(symb, shl, args)
Str255 symName;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
strcpy((char *)symName, CHARS(symb));
c2pstr((char *)symName);
@@ -640,7 +640,7 @@ SCM l_dyn_unlink(shl)
OSErr status;
CFragConnectionID connID;
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
connID = (CFragConnectionID)SHL(shl);
status = CloseConnection(&connID);
@@ -665,3 +665,106 @@ void init_dynl()
}
}
#endif /* MACOS */
+
+#ifdef _WIN32
+# include <windows.h>
+# define SHL(obj) ((HINSTANCE)(CDR(obj)))
+int prinshl(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ lputs("#<shl ", port);
+ intprint(CDR(exp), 16, port);
+ lputc('>', port);
+ return 1;
+}
+
+int tc16_shl;
+static smobfuns shlsmob = {mark0, free0, prinshl};
+
+static char s_link[] = "dyn:link";
+SCM scm_dyn_link(fname)
+ SCM fname;
+{
+ SCM z, shl = BOOL_F;
+ HINSTANCE hshl;
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ NEWCELL(z);
+ DEFER_INTS;
+ hshl = LoadLibrary(CHARS(fname));
+ if (hshl) {
+ SETCHARS(z, hshl);
+ CAR(z) = tc16_shl;
+ shl = z;
+ }
+ ALLOW_INTS;
+ return shl;
+}
+
+static char s_unlink[] = "dyn:unlink";
+SCM scm_dyn_unlink(shl)
+ SCM shl;
+{
+ BOOL status;
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ DEFER_INTS;
+ status = FreeLibrary(SHL(shl));
+ ALLOW_INTS;
+ return status ? BOOL_T : BOOL_F;
+}
+
+static char s_call[] = "dyn:call";
+SCM scm_dyn_call(symb, shl)
+ SCM symb, shl;
+{
+ FARPROC func;
+ int i;
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ DEFER_INTS;
+ func = GetProcAddress(SHL(shl), CHARS(symb));
+ ALLOW_INTS;
+ if (!func) return BOOL_F;
+ (*func) ();
+ return BOOL_T;
+}
+
+static char s_main_call[] = "dyn:main-call";
+SCM scm_dyn_main_call(symb, shl, args)
+ SCM symb, shl, args;
+{
+ int i;
+ FARPROC func;
+ char **argv;
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+ DEFER_INTS;
+ func = GetProcAddress(SHL(shl), CHARS(symb));
+ if (!func) {
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ argv = makargvfrmstrs(args, s_main_call);
+ ALLOW_INTS;
+ i = (*func) ((int)ilength(args), argv);
+ DEFER_INTS;
+ must_free_argv(argv);
+ ALLOW_INTS;
+ return MAKINUM(0L+i);
+}
+
+static iproc subr1s[] = {
+ {s_link, scm_dyn_link},
+ {s_unlink, scm_dyn_unlink},
+ {0, 0}};
+
+void init_dynl()
+{
+ if (!dumped) {
+ tc16_shl = newsmob(&shlsmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_call, tc7_subr_2, scm_dyn_call);
+ make_subr(s_main_call, tc7_lsubr_2, scm_dyn_main_call);
+ add_feature("win32-dl");
+ }
+}
+#endif
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 13:58:26 +0000