From c7d035ae1a729232579a0fe41ed5affa131d3623 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:27 -0800
Subject: Import Upstream version 5d9

---
 dynl.c | 153 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 128 insertions(+), 25 deletions(-)

(limited to 'dynl.c')

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
-- 
cgit v1.2.3