/* xsdynload - Dynamic loading and C function calling routines. */
/* XLISP-STAT 2.1 Copyright (c) 1990, 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. */
/* Calling conventions are based on the conventions given in the New S */
/* book. Calling conventions for dyn-load are based on a combination */
/* KCL's si:faslink conventions and Bill Dunlap's dyn.load2 for New S. */
/* */
/* The dynamic loading code is based on the KCL faslink function and */
/* Bill Dunlap's dynamic loader for New S. */
#include "xlisp.h"
#ifdef FOREIGNCALL
#include "xlstat.h"
extern char *progname;
extern LVAL k_fortran, k_libflags, s_cfun_table;
typedef int (*pfi_t)(); /* pointer to function returning integer. */
typedef LVAL (*pfl_t)(); /* pointer to function returning LVAL. */
#define HASHSIZE 397
static int verbose;
static char lbuf[100];
#include "foreign.h"
#ifdef MEMPROT
#include <sys/mman.h>
#endif
/* forward declarations */
LOCAL char *get_caddress _((char *name));
#ifndef SHLIB_DYNLOAD
#ifdef STATIC_LOAD_ONLY
LOCAL link_and_load _((char *fname, char *libs, int fort));
#else
#ifndef HAS_OWN_DYNLOAD
LOCAL VOID link_and_load _((char *fname, char *libs, int fort));
LOCAL int code_size _((char *tmpfname, char *code_start));
LOCAL VOID read_code _((char *tmpfname, char *addr));
LOCAL VOID enter_symbols _((char *tmpfname));
#endif /* HAS_OWN_DYNLOAD */
#endif /* STATIC_LOAD_ONLY */
#endif /* SHLIB_DYNLOAD */
/************************************************************************/
/** **/
/** Public Allocation and Error Signalling Functions **/
/** **/
/************************************************************************/
static LVAL current_allocs = NULL;
#define fixup_current_allocs \
{ if (current_allocs == NULL) current_allocs = NIL; }
/* allocate space that will be garbage collected after return */
char *xscall_alloc(n, m)
int n, m;
{
LVAL adata;
char *p = NULL;
fixup_current_allocs;
adata = newadata(n, m, FALSE);
if (adata == NIL || (p = getadaddr(adata)) == NULL)
xlfail("allocation failed");
current_allocs = cons(adata, current_allocs);
return(p);
}
/* error routint for use within C functions */
VOID xscall_fail(s) char *s; { xlfail(s); }
/************************************************************************/
/** **/
/** Lisp to C/FORTRAN Data Conversion **/
/** **/
/************************************************************************/
#define IN 0
#define RE 1
#define MAXARGS 15
typedef struct {
int type, size;
char *addr;
} call_arg;
/* convert lisp argument to allocated pointer */
LOCAL call_arg lisp2arg(x)
LVAL x;
{
call_arg a;
LVAL elem, data;
int i;
xlprot1(x);
/* make sure x is a sequence and find its length */
if (! seqp(x)) x = consa(x);
a.size = seqlen(x);
/* determine the mode of the data */
for (i = 0, a.type = IN, data = x; i < a.size; i++) {
elem = getnextelement(&data, i);
if (floatp(elem)) a.type = RE;
#ifdef BIGNUMS
else if (ratiop(elem)) a.type = RE;
#endif
else if (! integerp(elem)) xlerror("not a real number", elem);
}
/* allocate space for the data */
a.addr = xscall_alloc(a.size, (a.type == IN) ? sizeof(int) : sizeof(double));
/* fill the space */
for (i = 0, data = x; i < a.size; i++) {
elem = getnextelement(&data, i);
if (a.type == IN) ((int *) a.addr)[i] = getfixnum(elem);
#if !(defined(ibm032) && defined(__HIGHC__))
else ((double *) a.addr)[i] = makefloat(elem);
#else /* avoid bug in hc 2.1n C compiler on IBM RT running AOS 4.3 */
else {
double *dbl = &((double *)a.addr)[i] ;
*dbl = makefloat(elem) ;
}
#endif
}
xlpop();
return(a);
}
/* copy allocated pointer back to new lisp list */
LOCAL LVAL arg2lisp(a)
call_arg a;
{
LVAL x, next;
int i;
xlsave1(x);
x = mklist(a.size, NIL);
for (i = 0, next = x; i < a.size; i++, next = cdr(next)) {
if (a.type == IN) rplaca(next, cvfixnum((FIXTYPE) ((int *) a.addr)[i]));
else rplaca(next, cvflonum((FLOTYPE) ((double *) a.addr)[i]));
}
xlpop();
return(x);
}
/************************************************************************/
/** **/
/** Foreign Function Call Functions **/
/** **/
/************************************************************************/
LOCAL LVAL call_foreign(which)
int which;
{
LVAL result, name, old_allocs, next;
call_arg args[MAXARGS], *pargs;
int nargs;
int (*routine)();
char *get_caddress();
char *pattern;
fixup_current_allocs;
xlstkcheck(3);
xlsave(old_allocs);
xlprotect(current_allocs);
xlsave(result);
old_allocs = current_allocs;
current_allocs = NIL;
/* get the routine pointer */
name = xlgastring();
pattern = (which == 'C') ? INTERNAL_CNAME_PATTERN : INTERNAL_FNAME_PATTERN;
sprintf(lbuf, pattern, getstring(name));
routine = (pfi_t) get_caddress(lbuf);
if (! routine) xlerror("can't find internal symbol by this name", name);
/* convert the arguments to allocated pointers */
for (nargs = 0; moreargs(); nargs++) {
if (nargs >= MAXARGS) xlfail("too many arguments");
args[nargs] = lisp2arg(xlgetarg());
}
/* make the call -- there must be a better way to do this */
switch (nargs) {
case 0: routine(); break;
case 1: routine(args[0].addr); break;
case 2: routine(args[0].addr, args[1].addr); break;
case 3: routine(args[0].addr, args[1].addr, args[2].addr); break;
case 4:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr);
break;
case 5:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr);
break;
case 6:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr);
break;
case 7:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr);
break;
case 8:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr);
break;
case 9:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr,
args[8].addr);
break;
case 10:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr,
args[8].addr, args[9].addr);
break;
case 11:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr,
args[8].addr, args[9].addr, args[10].addr);
break;
case 12:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr,
args[8].addr, args[9].addr, args[10].addr, args[11].addr);
break;
case 13:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr,
args[8].addr, args[9].addr, args[10].addr, args[11].addr,
args[12].addr);
break;
case 14:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr,
args[8].addr, args[9].addr, args[10].addr, args[11].addr,
args[12].addr, args[13].addr);
break;
case 15:
routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
args[4].addr, args[5].addr, args[6].addr, args[7].addr,
args[8].addr, args[9].addr, args[10].addr, args[11].addr,
args[12].addr, args[13].addr, args[14].addr);
break;
}
/* convert the pointers back to lists, grouped in a list */
result = (nargs > 0) ? mklist(nargs, NIL) : NIL;
for (next = result, pargs = args; consp(next); next = cdr(next), pargs++)
rplaca(next, arg2lisp(*pargs));
current_allocs = old_allocs;
xlpopn(3);
return(result);
}
/* CALL-CFUN */
LVAL xscall_cfun() { return(call_foreign('C')); }
/* CALL-FSUB */
LVAL xscall_fsub() { return(call_foreign('F')); }
/* CALL-LFUN */
LVAL xscall_lfun()
{
LVAL name, old_allocs, result;
LVAL (*routine)();
char *get_caddress();
fixup_current_allocs;
xlstkcheck(2);
xlsave(old_allocs);
xlprotect(current_allocs);
old_allocs = current_allocs;
current_allocs = NIL;
name = xlgastring();
sprintf(lbuf, INTERNAL_CNAME_PATTERN, getstring(name));
routine = (pfl_t) get_caddress(lbuf);
if (! routine) xlerror("can't find internal symbol by this name", name);
result = routine();
current_allocs = old_allocs;
xlpopn(2);
return(result);
}
/************************************************************************/
/** **/
/** Fake COFF ldfcn's for BSD **/
/** **/
/************************************************************************/
#ifdef STDBSD
#define LDFILE FILE
#define SYMENT struct nlist
#define SUCCESS TRUE
#define FAILURE FALSE
#define LDNAMELIMIT 100
#define AOUTHDR struct exec
#define SCNHDR AOUTHDR
#define FREAD fread
static struct exec header;
static char ldnamebuf[LDNAMELIMIT];
LOCAL LDFILE *ldopen(name, dummy)
char *name, *dummy;
{
LDFILE *fp;
if ((fp = fopen(name, "r")) == NULL) xlfail("cannot open ld file");
if (fread((char *) &header, sizeof(header), 1, fp) != 1 ||
feof(fp) || ferror(fp)) {
fclose(fp);
fp = NULL;
}
return(fp);
}
LOCAL ldtbread(fp, i, psym)
LDFILE *fp;
int i;
SYMENT *psym;
{
if (i < 0 || i >= header.a_syms / sizeof(SYMENT)) return(FAILURE);
if (fseek(fp, N_SYMOFF(header) + i * sizeof(SYMENT), 0) < 0) return(FAILURE);
if (fread((char *) psym, sizeof(SYMENT), 1, fp) != 1 ||
feof(fp) || ferror(fp)) return(FAILURE);
return(SUCCESS);
}
LOCAL char *ldgetname(fp, psym)
LDFILE *fp;
SYMENT *psym;
{
char *bp = ldnamebuf;
long which = psym->n_un.n_strx;
int i = 0;
*bp = '\0';
if (which) {
ok_fseek(fp, N_STROFF(header) + which, 0);
while ((*bp++ = getc(fp)) != '\0')
if (++i >= LDNAMELIMIT) xlfail("name too long for ld buffer");
}
return(ldnamebuf);
}
LOCAL ldohseek(fp)
LDFILE *fp;
{
if (fseek(fp, 0, 0) < 0) return(FAILURE);
else return(SUCCESS);
}
LOCAL ldclose(fp)
LDFILE *fp;
{
fclose(fp);
return(SUCCESS);
}
#endif /* STDBSD */
/************************************************************************/
/** **/
/** Dynamic Loading Functions **/
/** **/
/************************************************************************/
#ifndef SHLIB_DYNLOAD
#define round_up(a, d) ((long)(a)%(d) ? (d)*((long)(a)/(d) + 1) : (long)(a))
#ifdef STDBSD
#define SYMVALUE(sym) ((char *) ((sym).n_value))
#ifndef SYM_IS_GLOBAL_FUNCTION
#define SYM_IS_GLOBAL_FUNCTION(ldptr,symbol) \
(((symbol).n_type & N_TYPE) == N_TEXT && ((symbol).n_type & N_EXT))
#endif /* SYM_IS_GLOBAL_FUNCTION */
#endif /* STDBSD */
#endif /* SHLIB_DYNLOAD */
/* DYN-LOAD function */
LVAL xsdynload()
{
char *name, *libs;
LVAL flag, arg;
int fort;
name = (char *) getstring(xlgastring());
if (! xlgetkeyarg(k_verbose, &flag)) flag = (VERBDFLT) ? s_true : NIL;
verbose = flag != NIL;
if (! xlgetkeyarg(k_fortran, &flag)) flag = NIL;
fort = flag != NIL;
if (xlgetkeyarg(k_libflags, &arg) && stringp(arg))
libs = (char *) getstring(arg);
else libs = "";
link_and_load(name, libs, fort);
return(s_true);
}
#ifndef SHLIB_DYNLOAD
LOCAL VOID enter_csymbol(name, addr)
char *name, *addr;
{
LVAL table, list, entry;
int i;
static initialized = FALSE;
if (! initialized) {
setvalue(s_cfun_table, newvector(HASHSIZE));
initialized = TRUE;
}
table = getvalue(s_cfun_table);
if (vectorp(table)) {
i = hash(name, getsize(table));
/* see if name is already in the table; replace its value if it is */
for (list = getelement(table, i); consp(list); list = cdr(list)) {
entry = car(list);
if (stringp(car(entry)) && strcmp(name, getstring(car(entry))) == 0) {
rplacd(entry, cvfixnum((FIXTYPE) addr));
return;
}
}
/* otherwise (not returned yet) make a new entry */
entry = cons(NIL, NIL);
setelement(table, i, cons(entry, getelement(table, i)));
rplaca(entry, cvstring(name));
rplacd(entry, cvfixnum((FIXTYPE) addr));
}
}
LOCAL char *find_hash_entry(name)
char *name;
{
LVAL table, entry, list;
int i;
if (! symbolp(s_cfun_table)) return(NULL);
table = getvalue(s_cfun_table);
if (vectorp(table)) {
i = hash(name, getsize(table));
for (list = getelement(table, i); consp(list); list = cdr(list)) {
entry = car(list);
if (stringp(car(entry)) && strcmp(name, getstring(car(entry))) == 0)
return((fixp(cdr(entry))) ? (char *) getfixnum(cdr(entry)) : NULL);
}
}
return (NULL);
}
LOCAL char *get_caddress(name)
char *name;
{
struct nlist nl[2];
char *addr;
if ((addr = find_hash_entry(name)) != NULL) return(addr);
else {
#ifdef COFF_FORMAT
nl[0].n_name = name;
nl[1].n_name = "";
#else
nl[0].n_un.n_name = name;
nl[1].n_un.n_name = "";
#endif
if (nlist(progname, nl) == -1)
xlfail("file not found or invalid name list");
if((addr = (char *) nl[0].n_value) != NULL) {
enter_csymbol(name, addr);
return(addr);
}
else return (NULL);
}
}
#ifdef STATIC_LOAD_ONLY
LOCAL link_and_load(fname, libs, fort)
char *fname, *libs;
int fort;
{
xlfail("dynamic loading not available on this system");
}
#else
#ifndef HAS_OWN_DYNLOAD
LOCAL VOID link_and_load(fname, libs, fort)
char *fname, *libs;
int fort;
{
char tmpfname[TMPNAMESIZE];
char *code_start, *addr, *syslibs;
int size, size_guess;
/* make the libstring, the tempfile name and the initial code space */
syslibs = (fort) ? FLIBS : CLIBS;
sprintf(tmpfname, TMPPATTERN, getpid());
size_guess = MIN_ALLOC;
addr = calloc(1, size_guess);
if (addr == NULL) xlfail("can't make initial code allocation");
code_start = (char *) round_up(addr, PAGE_SIZE);
size_guess -= (long) (code_start - addr);
#ifdef MEMPROT
mprotect(code_start, size_guess,(PROT_READ|PROT_WRITE|PROT_EXEC));
#endif
/* do an incremental load of the file and libs against xlisp */
sprintf(buf, LDPATTERN,
progname, (char *) code_start, fname, libs, syslibs, tmpfname);
if (verbose) printf("first ld pass\n%s\n", buf);
if (system(buf) != 0) {
free(addr);
xlfail("link failed");
}
/* check the code size and redo the load if needed */
size = code_size(tmpfname, code_start);
if (size_guess < size) {
free(addr);
addr = calloc(1, size + PAGE_SIZE);
if (addr == NULL) xlfail("can't make code allocation");
code_start = (char *) round_up(addr, PAGE_SIZE);
#ifdef MEMPROT
mprotect(code_start, size, (PROT_READ|PROT_WRITE|PROT_EXEC));
#endif
sprintf(buf, LDPATTERN,
progname, (char *) code_start, fname, libs, syslibs, tmpfname);
if (verbose) printf("second ld pass\n%s\n", buf);
if (system(buf) != 0) {
free(addr);
xlfail("link failed");
}
if (size < code_size(tmpfname, code_start)) {
free(addr);
xlfail("can't figure out tempfile size");
}
}
/* read in the object file */
if (verbose) printf("reading in the code ..."); fflush(stdout);
read_code(tmpfname, code_start);
if (verbose) printf("done\n");
/* enter the external symbols into the hash table */
if (verbose) printf("entering symbols..."); fflush(stdout);
enter_symbols(tmpfname);
if (verbose) printf("done\n");
/* unlink the tempfile */
unlink(tmpfname);
}
LOCAL int code_size(tmpfname, code_start)
char *tmpfname, *code_start;
{
LDFILE *fp;
AOUTHDR header;
SCNHDR scnheader;
int size;
if ((fp = ldopen(tmpfname, NULL)) == NULL)
xlfail("cannot open temporary ld file");
if (ldohseek(fp) == FAILURE) xlfail("could not seek to a.out header");
if (FREAD((char *) &header, sizeof(header), 1, fp) < 1)
xlfail("could not read a.out header");
#ifdef COFF_FORMAT
/* read last section header and measure size from code start */
/* section numbers begin with one! */
if (ldshread(fp, (unsigned short) N_SECTIONS(fp), &scnheader)==FAILURE)
xlfail("cannot read object file section");
size = SCN_ADDR(fp, scnheader) + SCN_LENGTH(fp, scnheader)
- (long) code_start;
#else
size = header.a_text + header.a_data + header.a_bss;
#endif /* COFF_FORMAT */
if (ldclose(fp) == FAILURE) xlfail("cannot close tempfile");
return(size);
}
LOCAL VOID read_code(tmpfname, addr)
char *tmpfname, *addr;
{
LDFILE *fp;
AOUTHDR header;
SCNHDR scnheader;
int size, i;
if ((fp = ldopen(tmpfname, NULL)) == NULL)
xlfail("cannot open temporary ld file");
if (ldohseek(fp) == FAILURE) xlfail("could not seek to a.out header");
if (FREAD((char *) &header, sizeof(header), 1, fp) < 1)
xlfail("could not read a.out header");
#ifdef COFF_FORMAT
/* read in code and data sections, zero out bss sections */
/* zeroing should not be needed since space came from */
/* calloc, but it can't hurt. */
/* section numbers begin with one! */
for (i = 1 ; i <= N_SECTIONS(fp) ; i++) {
if (ldshread(fp, (unsigned short) i, &scnheader)==FAILURE)
xlfail("cannot read object file section");
if (SCN_IS_BSS(fp, scnheader))
bzero((char *) SCN_ADDR(fp, scnheader),
(int) SCN_LENGTH(fp, scnheader));
else {
if (FSEEK(fp, SCN_FILE_LOC(fp, scnheader), 0) == -1)
xlfail("could not seek to object file section");
if (FREAD((char *) SCN_ADDR(fp, scnheader), 1,
(int) SCN_LENGTH(fp, scnheader), fp)
< SCN_LENGTH(fp, scnheader))
xlfail("could not read object file section");
}
}
#else
ok_fseek(fp, (long) N_TXTOFF(header), 0);
size = header.a_text + header.a_data;
ok_fread((char *) addr, 1, size, fp);
#endif
if (ldclose(fp) == FAILURE) xlfail("cannot close tempfile");
}
LOCAL VOID enter_symbols(tmpfname)
char *tmpfname;
{
LDFILE *input;
SYMENT symbol;
char *symname, *symaddr;
int i;
/* open the file */
if ((input = ldopen(tmpfname, NULL)) == NULL)
xlfail("cannot open tempfile for symbol reading");
/* process symbols while they last */
i = 0;
while (ldtbread(input, i, &symbol) == SUCCESS) {
i++;
if (SYM_IS_GLOBAL_FUNCTION(input, symbol)) {
symname = ldgetname(input, &symbol);
symaddr = SYMVALUE(symbol);
enter_csymbol(symname, symaddr);
}
}
if (ldclose(input) == FAILURE) xlfail("cannot close tempfile");
}
/************************************************************************/
/** **/
/** Utility Functions **/
/** **/
/************************************************************************/
LOCAL VOID ok_fread(ptr, size, nitems, stream)
char *ptr;
int size, nitems;
FILE *stream;
{
if (fread(ptr, size, nitems, stream) != nitems ||
feof(stream) || ferror(stream))
xlfail("error while reading disk file");
}
LOCAL VOID ok_fseek(stream, offset, ptrname)
FILE *stream;
long offset;
int ptrname;
{
if (fseek(stream, offset, ptrname) < 0)
xlfail("error while seeking on disk file");
}
#endif /* HAS_OWN_DYNLOAD */
#endif /* STATIC_LOAD_ONLY */
#endif /* SHLIB_DYNLOAD */
#endif /* FOREIGNCALL */
syntax highlighted by Code2HTML, v. 0.9.1