/* xlshlib - Shared library support functions. */
/* XLISP-STAT 2.1 Copyright (c) 1990-1997, by Luke Tierney */
/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */
/* You may give out copies of this software; for conditions see the */
/* file COPYING included with this distribution. */
#include "xlisp.h"
#ifdef SHAREDLIBS
#include <dlfcn.h>
#define cvvoidptr(x) newnatptr(x, NIL)
#define setsubr(x,v) getsubr(x)=(v)
#define setoffset(x,v) getoffset(x)=(v)
#define xlgasubr() (testarg(typearg(subrp)))
static void shlib_error()
{
char *str = dlerror();
xlfail(str != NULL ? str : "unknown shared library error");
}
/* SHLIB-OPEN path */
LVAL xshlibopen()
{
char *name;
void *handle;
name = getstring(xlgastring());
xllastarg();
if ((handle = dlopen(name, RTLD_NOW)) == NULL)
shlib_error();
return newnatptr(handle, NIL);
}
/* SHLIB-SYMADDR lib name &optional error */
LVAL xshlibsymaddr()
{
void *val;
LVAL lib = xlganatptr();
void *handle = getnpaddr(lib);
char *name = getstring(xlgastring());
int err = moreargs() ? null(xlgetarg()) : TRUE;
xllastarg();
if ((val = dlsym(handle, name)) == NULL) {
if (err)
shlib_error();
else
return NIL;
}
return newnatptr(val, lib);
}
/* SHLIB-CLOSE lib */
LVAL xshlibclose()
{
void *lib = getnpaddr(xlganatptr());
xllastarg();
if (dlclose(lib) == -1)
shlib_error();
return NIL;
}
#define MAX_CALLADDR_ARGS 16
/* CALL-BY-ADDRESS &rest args */
LVAL xshlibcalladdr()
{
void *(*f)() = (void *(*)()) getnpaddr(xlganatptr());
void *a[MAX_CALLADDR_ARGS];
int n, i;
if (xlargc > MAX_CALLADDR_ARGS)
xltoomany();
for (n = xlargc, i = 0; i < n; i++) {
LVAL arg = xlgetarg();
if (fixp(arg))
a[i] = (void *) getfixnum(arg);
else if (natptrp(arg))
a[i] = getnpaddr(arg);
else
xlbadtype(arg);
}
switch (n) {
case 0: return cvvoidptr(f());
case 1: return cvvoidptr(f(a[0]));
case 2: return cvvoidptr(f(a[0],a[1]));
case 3: return cvvoidptr(f(a[0],a[1],a[2]));
case 4: return cvvoidptr(f(a[0],a[1],a[2],a[3]));
case 5: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4]));
case 6: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5]));
case 7: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6]));
case 8: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]));
case 9: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]));
case 10: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9]));
case 11: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10]));
case 12: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11]));
case 13: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12]));
case 14: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12],a[13]));
case 15: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12],a[13],a[14]));
case 16: return cvvoidptr(f(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],
a[9],a[10],a[11],a[12],a[13],a[14],a[15]));
default: xlfail("too many arguments"); return NIL;
}
}
#ifdef _Windows
typedef void * __stdcall (*stdfun0)(void);
typedef void * __stdcall (*stdfun1)(void *);
typedef void * __stdcall (*stdfun2)(void *, void *);
typedef void * __stdcall (*stdfun3)(void *, void *, void *);
typedef void * __stdcall (*stdfun4)(void *, void *, void *, void *);
typedef void * __stdcall (*stdfun5)(void *, void *, void *, void *, \
void *);
typedef void * __stdcall (*stdfun6)(void *, void *, void *, void *, \
void *, void *);
typedef void * __stdcall (*stdfun7)(void *, void *, void *, void *, \
void *, void *, void *);
typedef void * __stdcall (*stdfun8)(void *, void *, void *, void *, \
void *, void *, void *, void *);
typedef void * __stdcall (*stdfun9)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun10)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun11)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun12)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *, void *, void *, void *);
typedef void * __stdcall (*stdfun13)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *, void *, void *, void *, \
void *);
typedef void * __stdcall (*stdfun14)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *, void *, void *, void *, \
void *, void *);
typedef void * __stdcall (*stdfun15)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *, void *, void *, void *, \
void *, void *, void *);
typedef void * __stdcall (*stdfun16)(void *, void *, void *, void *, \
void *, void *, void *, void *, void *, void *, void *, void *, \
void *, void *, void *, void *);
LVAL xshlibstdcalladdr()
{
void *f = getnpaddr(xlganatptr());
void *a[MAX_CALLADDR_ARGS];
int n, i;
if (xlargc > MAX_CALLADDR_ARGS)
xltoomany();
for (n = xlargc, i = 0; i < n; i++) {
LVAL arg = xlgetarg();
if (fixp(arg))
a[i] = (void *) getfixnum(arg);
else if (natptrp(arg))
a[i] = getnpaddr(arg);
else
xlbadtype(arg);
}
switch (n) {
case 0: return cvvoidptr(((stdfun0) f)());
case 1: return cvvoidptr(((stdfun1) f)(a[0]));
case 2: return cvvoidptr(((stdfun2) f)(a[0],a[1]));
case 3: return cvvoidptr(((stdfun3) f)(a[0],a[1],a[2]));
case 4: return cvvoidptr(((stdfun4) f)(a[0],a[1],a[2],a[3]));
case 5: return cvvoidptr(((stdfun5) f)(a[0],a[1],a[2],a[3],
a[4]));
case 6: return cvvoidptr(((stdfun6) f)(a[0],a[1],a[2],a[3],
a[4], a[5]));
case 7: return cvvoidptr(((stdfun7) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6]));
case 8: return cvvoidptr(((stdfun8) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7]));
case 9: return cvvoidptr(((stdfun9) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8]));
case 10: return cvvoidptr(((stdfun10) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8],a[9]));
case 11: return cvvoidptr(((stdfun11) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8],a[9],a[10]));
case 12: return cvvoidptr(((stdfun12) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8],a[9],a[10],a[11]));
case 13: return cvvoidptr(((stdfun13) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8],a[9],a[10],a[11],
a[12]));
case 14: return cvvoidptr(((stdfun14) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8],a[9],a[10],a[11],
a[12],a[13]));
case 15: return cvvoidptr(((stdfun15) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8],a[9],a[10],a[11],
a[12],a[13],a[14]));
case 16: return cvvoidptr(((stdfun16) f)(a[0],a[1],a[2],a[3],
a[4],a[5],a[6],a[7],
a[8],a[9],a[10],a[11],
a[12],a[13],a[14],a[15]));
default: xlfail("too many arguments"); return NIL;
}
}
#endif
/* ARRAY-DATA-ADDRESS array */
LVAL xarraydata_addr()
{
LVAL x = xlgetarg();
xllastarg();
switch (ntype(x)) {
case DARRAY: x = getdarraydata(x); /* and drop through */
case VECTOR:
case STRING:
case TVEC: return newnatptr(gettvecdata(x), x);
default: return xlbadtype(x);
}
}
/* MAKE-SUBR addr &optional mulvalp */
LVAL xmakesubr()
{
LVAL val;
LVAL (*fun)(void) = (LVAL (*)(void)) getnpaddr(xlganatptr());
int mv = moreargs() ? (null(xlgetarg()) ? FALSE : TRUE) : FALSE;
xllastarg();
val = cvsubr(fun, SUBR, 0);
setmulvalp(val, mv);
return val;
}
LOCAL LVAL errsubr() { xlfail("SUBR not available"); return NIL; }
/* CLEAR-SUBR subr */
LVAL xclearsubr()
{
LVAL x = xlgasubr();
xllastarg();
setsubr(x, errsubr);
setoffset(x, 0);
setmulvalp(x, FALSE);
return NIL;
}
#define MAKEVERSION(major,minor) ((1L<<16) * major + minor)
#define XLSHLIB_SYSVERSION {MAKEVERSION(0,1),MAKEVERSION(0,0)}
#define XLSHLIB_VERSION_INFO(maj_cur,min_cur,maj_old,min_old) \
XLSHLIB_SYSVERSION, \
{MAKEVERSION(maj_cur,min_cur),MAKEVERSION(maj_old,min_old)}
struct version_info { long current, oldest; };
typedef struct { char *name; FIXTYPE val; } FIXCONSTDEF;
typedef struct { char *name; FLOTYPE val; } FLOCONSTDEF;
typedef struct { char *name; char *val; } STRCONSTDEF;
typedef struct { char *name; unsigned long val; } ULONGCONSTDEF;
typedef struct {
struct version_info sysversion;
struct version_info modversion;
FUNDEF *funs;
FIXCONSTDEF *fixconsts;
FLOCONSTDEF *floconsts;
STRCONSTDEF *strconsts;
ULONGCONSTDEF *ulongconsts;
} xlshlib_modinfo_t;
static struct version_info defsysversion = XLSHLIB_SYSVERSION;
static int check_version(struct version_info *req, struct version_info *imp)
{
if (req->current == imp->current)
return TRUE;
else if (req->current > imp->current)
return imp->current >= req->oldest ? TRUE : FALSE;
else
return req->current >= imp->oldest ? TRUE : FALSE;
}
/* SHLIB-INIT funtab &optional (version -1) (oldest version) */
LVAL xshlibinit()
{
LVAL subr, val, sym;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
struct version_info defversion;
defversion.current = moreargs()?getfixnum(xlgafixnum()):-1;
defversion.oldest = moreargs()?getfixnum(xlgafixnum()):defversion.current;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
if (defversion.current >= 0 &&
! check_version(&defversion, &(info->modversion)))
xlfail("module not compatible with requested version");
xlsave1(val);
val = NIL;
if (p != NULL)
for (val = NIL; (p->fd_subr) != (LVAL(*)(void)) NULL; p++) {
subr = cvsubr(p->fd_subr, p->fd_type & TYPEFIELD, 0);
setmulvalp(subr, (p->fd_type & (TYPEFIELD + 1)) ? TRUE : FALSE);
val = cons(subr, val);
if (p->fd_name != NULL) {
sym = xlenter(p->fd_name);
setfunction(sym, subr);
}
}
if (pfix != NULL)
for (; pfix->name != NULL; pfix++) {
sym = xlenter(pfix->name);
defconstant(sym, cvfixnum(pfix->val));
}
if (pflo != NULL)
for (; pflo->name != NULL; pflo++) {
sym = xlenter(pflo->name);
defconstant(sym, cvflonum(pflo->val));
}
if (pstr != NULL)
for (; pstr->name != NULL; pstr++) {
sym = xlenter(pstr->name);
defconstant(sym, cvstring(pstr->val));
}
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
if (pulong != NULL)
for (; pulong->name != NULL; pulong++) {
sym = xlenter(pulong->name);
defconstant(sym, ulong2lisp(pulong->val));
}
}
xlpop();
return xlnreverse(val);
}
/* SHLIB-INFO funtab */
LVAL xshlibinfo()
{
LVAL val;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
xlsave1(val);
val = cons(cvfixnum((FIXTYPE) info->modversion.current), NIL);
val = cons(cvfixnum((FIXTYPE) info->modversion.oldest), val);
val = cons(NIL, val);
if (p != NULL) {
for (; (p->fd_subr) != (LVAL(*)(void)) NULL; p++)
rplaca(val, cons(cvstring(p->fd_name), car(val)));
rplaca(val, xlnreverse(car(val)));
}
val = cons(NIL, val);
if (pfix != NULL)
for (; pfix->name != NULL; pfix++)
rplaca(val, cons(cvstring(pfix->name), car(val)));
if (pflo != NULL)
for (; pflo->name != NULL; pflo++)
rplaca(val, cons(cvstring(pflo->name), car(val)));
if (pstr != NULL)
for (; pstr->name != NULL; pstr++)
rplaca(val, cons(cvstring(pstr->name), car(val)));
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
for (; pulong->name != NULL; pulong++)
rplaca(val, cons(cvstring(pulong->name), car(val)));
}
rplaca(val, xlnreverse(car(val)));
xlpop();
return xlnreverse(val);
}
#endif /* SHAREDLIBS */
syntax highlighted by Code2HTML, v. 0.9.1