src/c/mswin/mswdynld.c

   1 /* mswdynld - Dynamic loading and C function calling routines.         */
   2 /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
   3 /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
   4 /* You may give out copies of this software; for conditions see the    */
   5 /* file COPYING included with this distribution.                       */
   6
   7 /* Calling conventions are based on the conventions given in the New S */
   8 /* book.                                                               */
   9
  10 #include "xlisp.h"
  11 #include "xlstat.h"
  12 #include "xlsx.h"
  13
  14 extern LVAL s_dll_list;
  15
  16 /************************************************************************/
  17 /**                                                                    **/
  18 /**                      DLL Handling Functions                        **/
  19 /**                                                                    **/
  20 /************************************************************************/
  21
  22 LVAL xsload_dll()
  23 {
  24   char *dllname;
  25   HANDLE hdll;
  26   LVAL dllhandle, dll_list;
  27 #ifdef DODO
  28 {
  29   HANDLE h1,h2;
  30   h1 = LoadLibrary("foo.dll");
  31   h2 = LoadLibrary("simplex.dll");
  32   FreeLibrary(h1);
  33   FreeLibrary(h2);
  34   return(NIL);
  35 }
  36 #endif DODO
  37
  38   dllname = (char *) getstring(xlgastring());
  39   xllastarg();
  40   hdll = LoadLibrary(dllname);
  41
  42   if ((UINT) hdll >= 32) {
  43     xlsave1(dllhandle);
  44     dllhandle = cvfixnum((FIXTYPE) hdll);
  45     dll_list = consp(getvalue(s_dll_list)) ? getvalue(s_dll_list) : NIL;
  46     setvalue(s_dll_list, cons(dllhandle, dll_list));
  47     xlpop();
  48 #ifdef MULVALS
  49     xlnumresults = 1;
  50     xlresults[0] = dllhandle;
  51 #endif
  52     return(dllhandle);
  53   }
  54   else {
  55 #ifdef MULVALS
  56     xlnumresults = 2;
  57     xlresults[0] = NIL;
  58     xlresults[1] = cvfixnum((FIXTYPE) hdll);
  59 #endif
  60     return NIL;
  61   }
  62 }
  63
  64 LVAL xsfree_dll()
  65 {
  66   HANDLE hdll;
  67   LVAL last, list;
  68
  69   hdll = (HANDLE) getfixnum(xlgafixnum());
  70   xllastarg();
  71
  72 //  SysBeep(10);
  73 //  return(NIL);
  74
  75   if ((UINT) hdll >= 32) {
  76     for (last = NIL, list = getvalue(s_dll_list);
  77          consp(list);
  78          last = list, list = cdr(list)) {
  79       //*** because of some bug, on a 386SX20 at least, frees MUST be done
  80       //*** on a last in-first out basis. So only the head of the list
  81       //*** can be freed. Hence the following line:
  82       if (consp(last)) break;
  83       if (hdll == (HANDLE) getfixnum(car(list))) {
  84         if (consp(last)) cdr(last) = cdr(list);
  85         else setvalue(s_dll_list, cdr(list));
  86         FreeLibrary(hdll);
  87         break;
  88       }
  89     }
  90   }
  91   return(NIL);
  92 }
  93
  94 void MSWDLLCleanup()
  95 {
  96   LVAL list;
  97
  98   if (s_dll_list != NULL)
  99     for (list = getvalue(s_dll_list); consp(list); list = cdr(list))
 100       FreeLibrary((HANDLE) getfixnum(car(list)));
 101 }
 102
 103 /************************************************************************/
 104 /**                                                                    **/
 105 /**               Allocation and Error Signalling Functions            **/
 106 /**                                                                    **/
 107 /************************************************************************/
 108
 109 static LVAL current_allocs = NULL;
 110 #define fixup_current_allocs \
 111   { if (current_allocs == NULL) current_allocs = NIL; }
 112
 113 /* allocate space that will be garbage collected after return */
 114 static char *xscall_alloc(int n, int m)
 115 {
 116   LVAL adata;
 117   char *p;
 118
 119   fixup_current_allocs;
 120
 121   adata = newadata(n, m, FALSE);
 122   if (adata == NIL || (p = getadaddr(adata)) == NULL)
 123     xlfail("allocation failed");
 124   current_allocs = cons(adata, current_allocs);
 125   return(p);
 126 }
 127
 128 /************************************************************************/
 129 /**                                                                    **/
 130 /**                Lisp to C/FORTRAN Data Conversion                   **/
 131 /**                                                                    **/
 132 /************************************************************************/
 133
 134 #define IN 0
 135 #define RE 1
 136
 137 typedef struct {
 138   int type, size;
 139   char *addr;
 140 } call_arg;
 141
 142 /* convert lisp argument to allocated pointer */
 143 static call_arg lisp2arg(LVAL x)
 144 {
 145   call_arg a;
 146   LVAL elem, data;
 147   int i;
 148
 149   xlprot1(x);
 150
 151   /* make sure x is a sequence and find its length */
 152   if (! seqp(x)) x = consa(x);
 153   a.size = seqlen(x);
 154
 155   /* determine the mode of the data */
 156   for (i = 0, a.type = IN, data = x; i < a.size; i++) {
 157     elem = getnextelement(&data, i);
 158     if (floatp(elem)) a.type = RE;
 159 #ifdef BIGNUMS
 160     else if (ratiop(elem)) a.type = RE;
 161 #endif
 162     else if (! integerp(elem)) xlerror("not a real number", elem);
 163   }
 164
 165   /* allocate space for the data */
 166   a.addr = xscall_alloc(a.size, (a.type == IN) ? sizeof(int) : sizeof(double));
 167
 168   /* fill the space */
 169   for (i = 0, data = x; i < a.size; i++) {
 170     elem = getnextelement(&data, i);
 171     if (a.type == IN) ((int *) a.addr)[i] = getfixnum(elem);
 172     else ((double *) a.addr)[i] = makefloat(elem);
 173   }
 174
 175   xlpop();
 176   return(a);
 177 }
 178
 179 /* copy allocated pointer back to new lisp list */
 180 static LVAL arg2lisp(call_arg a)
 181 {
 182   LVAL x, next;
 183   int i;
 184
 185   xlsave1(x);
 186   x = mklist(a.size, NIL);
 187   for (i = 0, next = x; i < a.size; i++, next = cdr(next)) {
 188     if (a.type == IN) rplaca(next, cvfixnum((FIXTYPE) ((int *) a.addr)[i]));
 189     else rplaca(next, cvflonum((FLOTYPE) ((double *) a.addr)[i]));
 190   }
 191   xlpop();
 192
 193   return(x);
 194 }
 195
 196 /************************************************************************/
 197 /**                                                                    **/
 198 /**                 Foreign Function Call Function                     **/
 199 /**                                                                    **/
 200 /************************************************************************/
 201
 202 typedef void VFUN(XLSXblock *);
 203 typedef VFUN *VFPTR;
 204
 205 LVAL xscall_cfun()
 206 {
 207   LVAL result, Lfun, old_allocs, next;
 208   call_arg *args, *pargs;
 209   int nargs, i;
 210   VFPTR routine;
 211   HANDLE hdll;
 212   char *name;
 213   XLSXblock params;
 214
 215   fixup_current_allocs;
 216
 217   // ### patch this to handle errors properly (reset allocs, etc) -- use dynamic scoping
 218   // ### also use allocation with free as in (new) linalg?
 219   xlstkcheck(3);
 220   xlsave(old_allocs);
 221   xlprotect(current_allocs);
 222   xlsave(result);
 223   old_allocs = current_allocs;
 224   current_allocs = NIL;
 225
 226   /* get the routine pointer */
 227   hdll = (HANDLE) getfixnum(xlgafixnum());
 228   Lfun = xlgetarg();
 229   if (stringp(Lfun)) name = getstring(Lfun);
 230   else if (fixp(Lfun)) name = (char *) MAKEINTRESOURCE((int) getfixnum(Lfun));
 231   routine = (VFPTR) GetProcAddress(hdll, name);
 232   if (! routine) xlerror("can't find function address", Lfun);
 233
 234   /* convert the arguments to allocated pointers */
 235   nargs = xlargc;
 236   if (nargs == 0) xlfail("too few arguments");
 237   args = (call_arg *) xscall_alloc(nargs, sizeof(call_arg));
 238   params.argc = nargs;
 239   params.argv = (char **) xscall_alloc(nargs, sizeof(char *));
 240   for (i = 0; i < nargs; i++) {
 241     args[i] = lisp2arg(xlgetarg());
 242     params.argv[i] = args[i].addr;
 243   }
 244
 245   /* make the call */
 246   (*routine)(&params);
 247
 248   /* convert the pointers back to lists, grouped in a list */
 249   result = (nargs > 0) ? mklist(nargs, NIL) : NIL;
 250   for (next = result, pargs = args; consp(next); next = cdr(next), pargs++)
 251     rplaca(next, arg2lisp(*pargs));
 252
 253   current_allocs = old_allocs;
 254   xlpopn(3);
 255
 256   return(result);
 257 }