1 /* -*- tab-width:4; -*- */
2 /*
3 * Dynamic loading and ffi
4 */
5
6 #include "s.h"
7 #include <dlfcn.h>
8 #include <avcall.h>
9
10 /*-- FFI type marker
11 *
12 * Note: keywords passed for types: don't need to be gc protected
13 * because all keywords are referenced in the keyword hash. They never
14 * move or will be removed.
15 */
16
17 static SOBJ
18 EXT_KEYW_ANY,
19 EXT_KEYW_VOID,
20 EXT_KEYW_CHAR,
21 EXT_KEYW_SHORT,
22 EXT_KEYW_USHORT,
23 EXT_KEYW_INT,
24 EXT_KEYW_UINT,
25 EXT_KEYW_LONG,
26 EXT_KEYW_ULONG,
27 EXT_KEYW_FLOAT,
28 EXT_KEYW_DOUBLE,
29 EXT_KEYW_STATIC_PTR,
30 EXT_KEYW_ITEM, /* alias for static-pointer */
31 EXT_KEYW_DYNAMIC_PTR,
32 EXT_KEYW_STRING,
33 EXT_KEYW_BOOLEAN;
34
35 /* This value is stored in the ExtFunc structure. Conversion between
36 keyword and type is performed in the make_ext_func */
37
38 enum ExtTypes {
39 EXT_T_VOID = -1,
40 EXT_T_CHAR = -2,
41 EXT_T_SHORT = -3,
42 EXT_T_USHORT = -4,
43 EXT_T_INT = -5,
44 EXT_T_UINT = -6,
45 EXT_T_LONG = -7,
46 EXT_T_ULONG = -8,
47 EXT_T_FLOAT = -9,
48 EXT_T_DOUBLE = -10,
49 EXT_T_STATIC_PTR = -11,
50 EXT_T_DYNAMIC_PTR = -12,
51 EXT_T_STRING = -13,
52 EXT_T_BOOLEAN = -14,
53 EXT_T_ERROR = -20,
54 EXT_T_ANY = -21,
55 EXT_T_MAX
56 };
57
58 /* table used to convert keyword to type */
59
60 struct ExtKeywType {
61 SOBJ *atom;
62 short type;
63 };
64
65 static struct ExtKeywType keyw2type_ref[] = {
66 { &EXT_KEYW_ANY, EXT_T_ANY},
67 { &EXT_KEYW_VOID, EXT_T_VOID},
68 { &EXT_KEYW_CHAR, EXT_T_CHAR},
69 { &EXT_KEYW_SHORT, EXT_T_SHORT},
70 { &EXT_KEYW_USHORT, EXT_T_USHORT},
71 { &EXT_KEYW_INT, EXT_T_INT},
72 { &EXT_KEYW_UINT, EXT_T_UINT},
73 { &EXT_KEYW_LONG, EXT_T_LONG},
74 { &EXT_KEYW_ULONG, EXT_T_ULONG},
75 { &EXT_KEYW_FLOAT, EXT_T_FLOAT},
76 { &EXT_KEYW_DOUBLE, EXT_T_DOUBLE},
77 { &EXT_KEYW_STATIC_PTR, EXT_T_STATIC_PTR},
78 { &EXT_KEYW_ITEM, EXT_T_STATIC_PTR},
79 { &EXT_KEYW_DYNAMIC_PTR, EXT_T_DYNAMIC_PTR},
80 { &EXT_KEYW_STRING, EXT_T_STRING},
81 { &EXT_KEYW_BOOLEAN, EXT_T_BOOLEAN},
82 { NULL },
83 };
84
85 /*-- convert the keyword to an external type */
keyword_to_ext_type(SOBJ keyw)86 static int keyword_to_ext_type(SOBJ keyw)
87 {
88 int i;
89 struct ExtKeywType *k = keyw2type_ref;
90 char *keywstr;
91
92 while(k->atom) {
93 if (*k->atom == SCM_KEYW_NAME(keyw))
94 return(k->type);
95 k++;
96 }
97
98 keywstr = SCM_ATOM_NAME(SCM_KEYW_NAME(keyw));
99 for (i = 0; i < scm_type_next_descr; i++) {
100 if (streq(keywstr, scm_type_hook[i].name)) return(i);
101 }
102
103 return(EXT_T_ERROR);
104 }
105
106 #define DLFLAGS (RTLD_LAZY|RTLD_GLOBAL)
107
108 static SOBJ scm_dl_list;
109
scm_find_extsym(char * path,char * sym_name,int must)110 void *scm_find_extsym(char *path, char *sym_name, int must)
111 {
112 void *handle, *sym;
113 SOBJ l, str;
114
115 str = scm_mkstring(path);
116
117 if (scm_dl_list == NULL) SCM_ERR("dl_list not initialized", NULL);
118 if ((l = scm_member(str, scm_dl_list)) != scm_false) {
119 handle = SCM_POINTER(SCM_CAR(SCM_CDR(l)));
120 } else {
121 if ((handle=dlopen(path, DLFLAGS)) == NULL) SCM_ERR(dlerror(), str);
122 scm_dl_list = scm_cons(str,
123 scm_cons(scm_mk_static_pointer(handle),
124 scm_dl_list));
125 }
126 sym = dlsym(handle, sym_name);
127
128 if (must && sym == NULL) {
129 SCM_ERR("find-func: error: ", scm_mkstring(dlerror()));
130 }
131 return(sym);
132 }
133
load_and_call(char * path,char * sym_name)134 static void load_and_call(char *path, char *sym_name)
135 {
136 void (*init_func)();
137 SOBJ str = scm_mkstring(path);
138
139 if ((init_func = scm_find_extsym("", sym_name, FALSE)) != NULL) {
140 scm_puts("; load-and-call: module '"); scm_cdisplay(str);
141 scm_puts("' already (statically) loaded\n");
142 }
143 if (scm_member(str, scm_dl_list) != scm_false) {
144 scm_puts("; load-and-call: module '"); scm_cdisplay(str);
145 scm_puts("' already (dynamically) loaded\n");
146 }
147
148 init_func = scm_find_extsym(path, sym_name, TRUE);
149 (*init_func)();
150 }
151
152 #define INIT_FUNC_PREFIX "scm_init_"
153 #define INIT_FUNC_PREFIX_LEN strlen(INIT_FUNC_PREFIX)
154
155 #define INIT_SYM_NAME_MAX 64
156
157
load_library(char * path)158 static void load_library(char *path)
159 {
160 char init_sym_name[INIT_SYM_NAME_MAX];
161 char *p, *q;
162 int len;
163
164 p = strrchr(path, '/');
165 if (p == NULL) /* no / => current path */
166 p = path;
167 else
168 p++;
169
170 q = strchr(p, '.'); /* search for possible suffix */
171 if (q == NULL) /* no suffix ? set q to end of string */
172 q = p + strlen(p);
173
174 len = INIT_FUNC_PREFIX_LEN + q-p;
175 if (len >= (INIT_SYM_NAME_MAX-1))
176 SCM_ERR("load-library: init symbol too long", NULL);
177
178 strcpy(init_sym_name, INIT_FUNC_PREFIX);
179 strncpy(init_sym_name + INIT_FUNC_PREFIX_LEN, p, q-p);
180 init_sym_name[len] = 0;
181 load_and_call(path, init_sym_name);
182 }
183
scm_mk_static_pointer(void * p)184 SOBJ scm_mk_static_pointer(void *p)
185 {
186 SOBJ new = scm_mkpointer(p);
187 return(new);
188 }
189
scm_mk_dynamic_pointer(void * p)190 SOBJ scm_mk_dynamic_pointer(void *p)
191 {
192 SOBJ new = scm_mkpointer(p);
193 SCM_POINTER_ATTRIB(new) = SCM_POINTER_FLAG_ALLOCED;
194 return(new);
195 }
196
197 /*E* (load-library NAME) => #t */
198 /*D* Load a dynamic library and link it to the current scheme
199 interpreter. Functions and variables of this library can be accessed
200 with 'make-extfunc' and 'make-extvar' */
201
scm_load_library(SOBJ x)202 SOBJ scm_load_library(SOBJ x)
203 {
204 if (!SCM_STRINGP(x)) SCM_ERR("load-library: bad string", x);
205 load_library(SCM_STR_VALUE(x));
206 return(scm_true);
207 }
208
209 /****************************************************************
210 * FFI
211 ****************************************************************/
212
213 /*-- gc function for the extfunc */
214
scm_extfunc_mark(SOBJ extfunc)215 void scm_extfunc_mark(SOBJ extfunc)
216 {
217 }
218
scm_extfunc_sweep(SOBJ extfunc)219 void scm_extfunc_sweep(SOBJ extfunc)
220 {
221 if (SCM_EXTFUNC(extfunc)) {
222 scm_free(SCM_EXTFUNC(extfunc));
223 }
224 SCM_EXTFUNC(extfunc) = NULL;
225 }
226
scm_mkextfunc(SCM_ExtFunc * f)227 SOBJ scm_mkextfunc(SCM_ExtFunc *f)
228 {
229 SOBJ obj = scm_newcell(SOBJ_T_EXTFUNC);
230 SCM_EXTFUNC(obj) = f;
231 return(obj);
232 }
233
scm_extfunc_print(SOBJ x,PORT * p)234 void scm_extfunc_print(SOBJ x, PORT *p)
235 {
236 port_puts(p, "#<extfunc>");
237 }
238
scm_extfunc_write(SOBJ x,PORT * p)239 void scm_extfunc_write(SOBJ x, PORT *p)
240 {
241 char buf[128];
242 sprintf(buf, "#<extfunc %p: ret=%d func=%p nargs=%d optargs=%d>",
243 x,
244 SCM_EXTFUNC(x)->return_t,
245 SCM_EXTFUNC(x)->func,
246 SCM_EXTFUNC(x)->argc,
247 SCM_EXTFUNC(x)->vararg);
248 port_puts(p, buf);
249 }
250
251
scm_new_extfunc()252 static SCM_ExtFunc *scm_new_extfunc()
253 {
254 return(scm_must_alloc(sizeof(SCM_ExtFunc)));
255 }
256
257 /*-- create an external function object.
258 *
259 * Syntax: (make-external-func <lib> <ret-type> <name> <arglist> )
260 * Example: (make-external-function "" 0 'printf '(:string . :any))
261 */
errext(char * string,SOBJ x)262 static void errext(char *string, SOBJ x)
263 {
264 char buf[128];
265 sprintf(buf, "make-external-function: %s", string);
266 SCM_ERR(buf, x);
267 }
268
errcall(char * string,SOBJ x)269 static void errcall(char *string, SOBJ x)
270 {
271 char buf[128];
272 sprintf(buf, "call-external-function: %s", string);
273 SCM_ERR(buf, x);
274 }
275
276 /*E* (make-extfunc LIB RET NAME '(ARG...)) => EXTFUNC */
277 /*D* Create a new external function that can be called just like if
278 it's a native scheme procedure. RET and ARG are keyword reprenting
279 the type of return and argument. NAME is the name of the function as
280 defined in the symbol table of the dynamic library LIB. */
281
282 /*X* (define printf (make-extfunc "" :int "printf" '(:string . :any))) */
283
scm_make_extfunc(SOBJ lib,SOBJ ret,SOBJ name,SOBJ argl)284 SOBJ scm_make_extfunc(SOBJ lib, SOBJ ret, SOBJ name, SOBJ argl)
285 {
286 SCM_ExtFunc *f;
287 void *func;
288 int iret = 0, itype = 0;
289
290 if (!SCM_STRINGP(lib)) errext("bad library name", lib);
291 if (!SCM_STRINGP(name)) errext("bad function name", name);
292 if (!SCM_KEYWORDP(ret) ||
293 (iret = keyword_to_ext_type(ret)) == EXT_T_ERROR)
294 errext("bad return type", ret);
295
296 if (iret >= 0) { /* check if internal type has converters */
297 if (scm_type_hook[iret].ext2obj == NULL ||
298 scm_type_hook[iret].obj2ext == NULL) {
299 errext("internal type has no caster", ret);
300 }
301 }
302
303 func = scm_find_extsym(SCM_STR_VALUE(lib), SCM_STR_VALUE(name), FALSE);
304 if (func == NULL) errext("function not found", scm_cons(lib, name));
305
306 f = scm_new_extfunc();
307 f->func = func;
308 f->return_t = iret;
309 f->argc = 0;
310
311 while(argl) {
312 if (!SCM_PAIRP(argl)) {
313 f->vararg = 1;
314 break;
315 }
316 if (!SCM_KEYWORDP(SCM_CAR(argl)) ||
317 (itype = keyword_to_ext_type(SCM_CAR(argl))) == EXT_T_ERROR)
318 errext("bad argument type", SCM_CAR(argl));
319
320 if (itype >= 0) { /* check if internal type has converters */
321 if (scm_type_hook[itype].ext2obj == NULL ||
322 scm_type_hook[itype].obj2ext == NULL) {
323 errext("internal type has no caster", SCM_CAR(argl));
324 }
325 }
326
327 f->arg_t[f->argc++] = itype;
328 argl = SCM_CDR(argl);
329 }
330 return(scm_mkextfunc(f));
331 }
332
pushargs(av_alist * al,SCM_ExtFunc * f,int nargs,SOBJ * arg)333 static void pushargs(av_alist *al, SCM_ExtFunc *f, int nargs, SOBJ *arg)
334 {
335 int i, type;
336 SOBJ obj;
337
338 if (f->vararg) {
339 if (nargs < f->argc) errcall("not enough args", NULL);
340 } else {
341 if (nargs != f->argc) errcall("bad number of args", NULL);
342 }
343
344 for (i = 0; i < f->argc; i++) {
345 obj = arg[i];
346 type = f->arg_t[i];
347 switch(type) {
348 case EXT_T_VOID: errcall("void argument not allowed", NULL);
349 case EXT_T_CHAR:
350 case EXT_T_SHORT: case EXT_T_USHORT:
351 case EXT_T_INT: case EXT_T_UINT:
352 case EXT_T_LONG: case EXT_T_ULONG:
353 if (SCM_CHARP(obj)) { av_long(*al, SCM_CHAR(obj)); break;}
354 if (SCM_NUMBERP(obj)){ av_long(*al, scm_number2long(obj)); break;}
355 if (SCM_BOOLEANP(obj)){av_long(*al, obj!=scm_false); break;}
356 errcall("bad integer", obj);
357
358 case EXT_T_FLOAT:
359 if (SCM_NUMBERP(obj)){ av_float(*al, scm_number2double(obj)); break;}
360 errcall("bad float", obj);
361
362 case EXT_T_DOUBLE:
363 if (SCM_NUMBERP(obj)){ av_double(*al, scm_number2double(obj)); break;}
364 errcall("bad double", obj);
365
366 case EXT_T_STATIC_PTR: case EXT_T_DYNAMIC_PTR: case EXT_T_STRING:
367 if (obj == NULL) { av_ptr(*al,void*,obj); break;}
368 if (SCM_POINTERP(obj)) { av_ptr(*al,void*,SCM_POINTER(obj)); break;}
369 if (SCM_STRINGP(obj)) { av_ptr(*al,void*,SCM_STR_VALUE(obj)); break;}
370 errcall("bad pointer", obj);
371
372 case EXT_T_BOOLEAN:
373 av_long(*al, obj != scm_false);
374 break;
375
376 default:
377 if (type < 0)
378 errcall("bad argument type", SCM_MKINUM(type));
379
380 if (scm_type_hook[type].obj2ext == NULL)
381 errcall("can't convert", scm_mkstring(scm_type_hook[type].name));
382
383 av_ptr(*al,void*,(*scm_type_hook[type].obj2ext)(obj));
384
385 }
386 }
387
388 /* for variable arguments, try to guess type */
389 while(i < nargs) {
390 obj = arg[i];
391 type = SCM_OBJTYPE(obj);
392 switch(type) {
393 case SOBJ_T_INUM:
394 case SOBJ_T_BNUM: av_long(*al, scm_number2long(obj)); break;
395 case SOBJ_T_FNUM: av_double(*al, scm_number2double(obj)); break;
396 case SOBJ_T_CHAR: av_char(*al, SCM_CHAR(obj)); break;
397 case SOBJ_T_STRING: av_ptr(*al, void*, SCM_STR_VALUE(obj)); break;
398 case SOBJ_T_SYMBOL: av_ptr(*al, void*, SCM_SYM_NAME(obj)); break;
399 case SOBJ_T_POINTER:av_ptr(*al, void*, SCM_POINTER(obj)); break;
400 default:
401 if (obj == NULL) {
402 av_ptr(*al, void*, NULL);
403 } else if (scm_type_hook[type].obj2ext != NULL) {
404 av_ptr(*al, void*, (*scm_type_hook[type].obj2ext)(obj));
405 } else {
406 errcall("don't know how to convert", obj);
407 }
408 }
409 i++;
410 }
411 }
412
413
scm_extfunc_call(SOBJ proc,int nargs,SOBJ * arg)414 SOBJ scm_extfunc_call(SOBJ proc, int nargs, SOBJ *arg)
415 {
416 av_alist alist;
417 SCM_ExtFunc *f = SCM_EXTFUNC(proc);
418 int type;
419
420 type = f->return_t;
421
422 switch(type) {
423 case EXT_T_VOID:
424 av_start_void(alist, f->func);
425 pushargs(&alist, f, nargs, arg);
426 av_call(alist);
427 return(scm_undefined);
428
429 case EXT_T_CHAR:
430 {
431 char result;
432 av_start_char(alist, f->func, &result);
433 pushargs(&alist, f, nargs, arg);
434 av_call(alist);
435 return(scm_int2num(result));
436 }
437 case EXT_T_SHORT:
438 {
439 short result;
440 av_start_short(alist, f->func, &result);
441 pushargs(&alist, f, nargs, arg);
442 av_call(alist);
443 return(scm_int2num(result));
444 }
445 case EXT_T_INT:
446 {
447 int result;
448 av_start_int(alist, f->func, &result);
449 pushargs(&alist, f, nargs, arg);
450 av_call(alist);
451 return(scm_int2num(result));
452 }
453 case EXT_T_LONG:
454 {
455 long result;
456 av_start_long(alist, f->func, &result);
457 pushargs(&alist, f, nargs, arg);
458 av_call(alist);
459 return(scm_int2num(result));
460 }
461 case EXT_T_DOUBLE:
462 {
463 double result;
464 av_start_double(alist, f->func, &result);
465 pushargs(&alist, f, nargs, arg);
466 av_call(alist);
467 return(scm_mkfnum(result));
468 }
469 case EXT_T_STATIC_PTR: case EXT_T_DYNAMIC_PTR:
470 {
471 void *p;
472
473 av_start_ptr(alist, f->func, void *, &p);
474 pushargs(&alist, f, nargs, arg);
475 av_call(alist);
476 return( type == EXT_T_STATIC_PTR ?
477 scm_mk_static_pointer(p) :
478 scm_mk_dynamic_pointer(p) );
479 }
480
481 case EXT_T_STRING:
482 {
483 void *p;
484 av_start_ptr(alist, f->func, void *, &p);
485 pushargs(&alist, f, nargs, arg);
486 av_call(alist);
487 return((p != NULL) ? scm_mkstring(p) : NULL);
488 }
489
490 case EXT_T_BOOLEAN:
491 {
492 int result;
493 av_start_int(alist, f->func, &result);
494 pushargs(&alist, f, nargs, arg);
495 av_call(alist);
496 return(SCM_MKBOOL(result));
497 }
498
499 default:
500 {
501 void *p;
502
503 if (type < 0) /* ext type */
504 errcall("return type not supported", SCM_MKINUM(type));
505
506 if (scm_type_hook[type].ext2obj == NULL)
507 errcall("return cannot be converted",
508 scm_mkstring(scm_type_hook[type].name));
509
510 av_start_ptr(alist, f->func, void *, &p);
511 pushargs(&alist, f, nargs, arg);
512 av_call(alist);
513 return( (*scm_type_hook[type].ext2obj)(type, p) );
514 }
515 }
516 return(NULL);
517 }
518
519
520 /*E* (external-exists? LIB NAME) => BOOLEAN */
521 /*D* Return #t if symbol NAME is defined in the dynamic library LIB. */
scm_external_existsp(SOBJ lib,SOBJ entry)522 SOBJ scm_external_existsp(SOBJ lib, SOBJ entry)
523 {
524 if (!SCM_STRINGP(entry)) SCM_ERR("external-exists?: bad string", entry);
525 if (!SCM_STRINGP(lib)) SCM_ERR("external-exists?: bad string", lib);
526
527 return(SCM_MKBOOL(scm_find_extsym(SCM_STR_VALUE(lib),
528 SCM_STR_VALUE(entry), FALSE)));
529 }
530
531
push_arg(av_alist * al,int type,SOBJ arg)532 static void push_arg(av_alist *al, int type, SOBJ arg)
533 {
534 switch(type) {
535 case EXT_T_VOID: SCM_ERR("external-call: cannot push void arg", arg);
536
537 case EXT_T_CHAR:
538 case EXT_T_SHORT: case EXT_T_USHORT:
539 case EXT_T_INT: case EXT_T_UINT:
540 case EXT_T_LONG: case EXT_T_ULONG:
541 if (SCM_CHARP(arg)) { av_long(*al, SCM_CHAR(arg)); break; }
542 if (SCM_NUMBERP(arg)) { av_long(*al, scm_number2long(arg)); break; }
543 SCM_ERR("external-call: bad integer", arg);
544
545 case EXT_T_FLOAT:
546 if (SCM_CHARP(arg)) { av_float(*al, SCM_CHAR(arg)); break; }
547 if (SCM_NUMBERP(arg)) { av_float(*al, scm_number2double(arg)); break; }
548 SCM_ERR("external-call: bad float", arg);
549
550 case EXT_T_DOUBLE:
551 if (SCM_CHARP(arg)) { av_double(*al,SCM_CHAR(arg)); break; }
552 if (SCM_NUMBERP(arg)) { av_double(*al,scm_number2double(arg)); break; }
553 SCM_ERR("external-call: bad double", arg);
554
555 case EXT_T_STATIC_PTR: case EXT_T_DYNAMIC_PTR: case EXT_T_STRING:
556 if (SCM_POINTERP(arg)) { av_ptr(*al, void*, SCM_POINTER(arg)); break;}
557 if (SCM_STRINGP(arg)) { av_ptr(*al, void*, SCM_STR_VALUE(arg));break;}
558 SCM_ERR("external-call: bad pointer", arg);
559
560 case EXT_T_BOOLEAN:
561 if (SCM_BOOLEANP(arg)) { av_long(*al, (arg != scm_false)); break; }
562 if (SCM_NUMBERP(arg)) { av_long(*al, scm_number2long(arg)); break; }
563 SCM_ERR("external-call: bad boolean", arg);
564 default:
565 SCM_ERR("external-call: bad argument type", arg);
566 }
567 }
568
push_list(av_alist * al,SOBJ list)569 static void push_list(av_alist *al, SOBJ list)
570 {
571 SOBJ arg;
572 while(list) {
573 arg = SCM_CAR(list);
574 switch(SCM_OBJTYPE(arg)) {
575 case SOBJ_T_INUM:
576 case SOBJ_T_BNUM: av_long(*al, scm_number2long(arg)); break;
577 case SOBJ_T_FNUM: av_double(*al, scm_number2double(arg)); break;
578 case SOBJ_T_CHAR: av_char(*al, SCM_CHAR(arg)); break;
579 case SOBJ_T_STRING: av_ptr(*al, void*, SCM_STR_VALUE(arg)); break;
580 case SOBJ_T_SYMBOL: av_ptr(*al, void*, SCM_SYM_NAME(arg)); break;
581 case SOBJ_T_POINTER: av_ptr(*al, void*, SCM_POINTER(arg)); break;
582 default:
583 SCM_ERR("push_list: don't know how to convert", arg);
584 }
585 list = SCM_CDR(list);
586 }
587 }
588
push_args(av_alist * al,SOBJ argtype,SOBJ argval)589 static void push_args(av_alist *al, SOBJ argtype, SOBJ argval)
590 {
591 /* prepare arguments */
592 while(argtype) {
593 if (!SCM_PAIRP(argtype)) { /* have a rest */
594 push_list(al, argval);
595 break;
596 }
597 if (argval == NULL) SCM_ERR("call-external: not enough arguments", argtype);
598
599 if (!SCM_INUMP(SCM_CAR(argtype)))
600 SCM_ERR("call-external: argtype is not a number", SCM_CAR(argtype));
601
602 push_arg(al, SCM_INUM(SCM_CAR(argtype)), SCM_CAR(argval));
603 argtype = SCM_CDR(argtype);
604 argval = SCM_CDR(argval);
605 }
606
607 }
608
609 /*E* (call-external LIB RET NAME '(TYPE ...) (ARG ...)) */
610 /*D* Directly call a library function. Argument are converted
611 according to type and the value returned is converted to scheme
612 value as specified by the RET keyword */
613
scm_external_call(SOBJ lib,SOBJ ret,SOBJ entry,SOBJ argtype,SOBJ argval)614 SOBJ scm_external_call(SOBJ lib, SOBJ ret, SOBJ entry,
615 SOBJ argtype, SOBJ argval)
616 {
617 av_alist alist;
618 void *func;
619
620 /*-- type checking */
621 if (!SCM_STRINGP(lib)) SCM_ERR("external-call: bad library name", lib);
622 if (!SCM_STRINGP(entry)) SCM_ERR("external-call: bad entry name", entry);
623 if (!SCM_INUMP(ret)) SCM_ERR("external-call: bad return type", ret);
624
625 func = scm_find_extsym(SCM_STR_VALUE(lib), SCM_STR_VALUE(entry), FALSE);
626 if (func == NULL)
627 SCM_ERR("external-call: cannot find func", scm_cons(lib, entry));
628
629 switch(SCM_INUM(ret)) {
630 case EXT_T_VOID:
631 av_start_void(alist, func);
632 push_args(&alist, argtype, argval);
633 av_call(alist);
634 return(scm_undefined);
635
636 case EXT_T_INT:
637 {
638 int result;
639 av_start_int(alist, func, &result);
640 push_args(&alist, argtype, argval);
641 av_call(alist);
642 return(scm_int2num(result));
643 }
644
645 case EXT_T_DOUBLE:
646 {
647 double result;
648 av_start_double(alist, func, &result);
649 push_args(&alist, argtype, argval);
650 av_call(alist);
651 return(scm_mkfnum(result));
652 }
653
654 default:
655 SCM_ERR("external-call: unsupported return type", ret);
656 }
657 return(scm_undefined);
658 }
659
660 /*E* (make-external-pointer LIB NAME) => POINTER */
661
scm_make_extptr(SOBJ lib,SOBJ name)662 SOBJ scm_make_extptr(SOBJ lib, SOBJ name)
663 {
664 if (!SCM_STRINGP(lib)) errext("bad library name", lib);
665 if (!SCM_STRINGP(name)) errext("bad symbol name", name);
666
667 return(scm_mkpointer(scm_find_extsym(SCM_STR_VALUE(lib),
668 SCM_STR_VALUE(name),
669 FALSE)));
670 }
671
672 /*-- initialize this module */
673
scm_init_dyn()674 void scm_init_dyn()
675 {
676 void *handle = dlopen(NULL, DLFLAGS);
677 if (handle == NULL) SCM_ERR("dyn: cannot init", scm_mkstring(dlerror()));
678
679 scm_dl_list = SCM_LIST2(scm_mkstring(""), scm_mk_static_pointer(handle));
680 scm_add_cvar("library-list", &scm_dl_list);
681
682 EXT_KEYW_ANY = scm_mkatom("any");
683 EXT_KEYW_VOID = scm_mkatom("void");
684 EXT_KEYW_CHAR = scm_mkatom("char");
685 EXT_KEYW_SHORT = scm_mkatom("short");
686 EXT_KEYW_USHORT = scm_mkatom("ushort");
687 EXT_KEYW_INT = scm_mkatom("int");
688 EXT_KEYW_UINT = scm_mkatom("uint");
689 EXT_KEYW_LONG = scm_mkatom("long");
690 EXT_KEYW_ULONG = scm_mkatom("ulong");
691 EXT_KEYW_FLOAT = scm_mkatom("float");
692 EXT_KEYW_DOUBLE = scm_mkatom("double");
693 EXT_KEYW_STATIC_PTR = scm_mkatom("pointer");
694 EXT_KEYW_ITEM = scm_mkatom("item");
695 EXT_KEYW_DYNAMIC_PTR = scm_mkatom("dynamic-ptr");
696 EXT_KEYW_STRING = scm_mkatom("string");
697 EXT_KEYW_BOOLEAN = scm_mkatom("boolean");
698
699 scm_add_cprim("make-extfunc", scm_make_extfunc, 4);
700 scm_add_cprim("load-library", scm_load_library, 1);
701 scm_add_cprim("external-exists?", scm_external_existsp, 2);
702 scm_add_cprim("external-call", scm_external_call, 5);
703 scm_add_cprim("make-external-pointer", scm_make_extptr, 2);
704 }
705
706