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. */
7 /* Calling conventions are based on the conventions given in the New S */
14 extern LVAL s_dll_list
;
16 /************************************************************************/
18 /** DLL Handling Functions **/
20 /************************************************************************/
26 LVAL dllhandle
, dll_list
;
30 h1
= LoadLibrary("foo.dll");
31 h2
= LoadLibrary("simplex.dll");
38 dllname
= (char *) getstring(xlgastring());
40 hdll
= LoadLibrary(dllname
);
42 if ((UINT
) hdll
>= 32) {
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
));
50 xlresults
[0] = dllhandle
;
58 xlresults
[1] = cvfixnum((FIXTYPE
) hdll
);
69 hdll
= (HANDLE
) getfixnum(xlgafixnum());
75 if ((UINT
) hdll
>= 32) {
76 for (last
= NIL
, list
= getvalue(s_dll_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
));
98 if (s_dll_list
!= NULL
)
99 for (list
= getvalue(s_dll_list
); consp(list
); list
= cdr(list
))
100 FreeLibrary((HANDLE
) getfixnum(car(list
)));
103 /************************************************************************/
105 /** Allocation and Error Signalling Functions **/
107 /************************************************************************/
109 static LVAL current_allocs
= NULL
;
110 #define fixup_current_allocs \
111 { if (current_allocs == NULL) current_allocs = NIL; }
113 /* allocate space that will be garbage collected after return */
114 static char *xscall_alloc(int n
, int m
)
119 fixup_current_allocs
;
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
);
128 /************************************************************************/
130 /** Lisp to C/FORTRAN Data Conversion **/
132 /************************************************************************/
142 /* convert lisp argument to allocated pointer */
143 static call_arg
lisp2arg(LVAL x
)
151 /* make sure x is a sequence and find its length */
152 if (! seqp(x
)) x
= consa(x
);
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
;
160 else if (ratiop(elem
)) a
.type
= RE
;
162 else if (! integerp(elem
)) xlerror("not a real number", elem
);
165 /* allocate space for the data */
166 a
.addr
= xscall_alloc(a
.size
, (a
.type
== IN
) ? sizeof(int) : sizeof(double));
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
);
179 /* copy allocated pointer back to new lisp list */
180 static LVAL
arg2lisp(call_arg a
)
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
]));
196 /************************************************************************/
198 /** Foreign Function Call Function **/
200 /************************************************************************/
202 typedef void VFUN(XLSXblock
*);
207 LVAL result
, Lfun
, old_allocs
, next
;
208 call_arg
*args
, *pargs
;
215 fixup_current_allocs
;
217 // ### patch this to handle errors properly (reset allocs, etc) -- use dynamic scoping
218 // ### also use allocation with free as in (new) linalg?
221 xlprotect(current_allocs
);
223 old_allocs
= current_allocs
;
224 current_allocs
= NIL
;
226 /* get the routine pointer */
227 hdll
= (HANDLE
) getfixnum(xlgafixnum());
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
);
234 /* convert the arguments to allocated pointers */
236 if (nargs
== 0) xlfail("too few arguments");
237 args
= (call_arg
*) xscall_alloc(nargs
, sizeof(call_arg
));
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
;
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
));
253 current_allocs
= old_allocs
;