diff options
Diffstat (limited to 'dlperl/dlperl.c')
| -rw-r--r-- | dlperl/dlperl.c | 1037 |
1 files changed, 1037 insertions, 0 deletions
diff --git a/dlperl/dlperl.c b/dlperl/dlperl.c new file mode 100644 index 0000000000..49d48bb197 --- /dev/null +++ b/dlperl/dlperl.c @@ -0,0 +1,1037 @@ +static char sccsid[] = "@(#)dlperl.c 1.2 10/12/92 (DLPERL)"; + +/* + * name: dlperl.c + * synopsis: dlperl - perl interface to dynamically linked usubs + * sccsid: @(#)dlperl.c 1.2 10/12/92 + */ + +/* + * NOTE: this code is *not* portable + * - uses SPARC assembler with gcc asm extensions + * - is SPARC ABI specific + * - uses SunOS 4.x dlopen + * + * NOTE: not all types are currently implemented + * - multiple indirections (pointers to pointers, etc.) + * - structures + * - quad-precison (long double) + */ + +#include <dlfcn.h> +#include <alloca.h> +#include <ctype.h> + +/* perl */ +#include "EXTERN.h" +#include "perl.h" + +/* globals */ +int Dl_warn = 1; +int Dl_errno; +#define DL_ERRSTR_SIZ 256 +char Dl_errstr[DL_ERRSTR_SIZ]; +#define WORD_SIZE (sizeof(int)) + +static int userval(); +static int userset(); +static int usersub(); + + +/* + * glue perl subroutines and variables to dlperl functions + */ +enum usersubs { + US_dl_open, + US_dl_sym, + US_dl_call, + US_dl_close, +}; + +enum uservars { + UV_DL_VERSION, + UV_DL_WARN, + UV_dl_errno, + UV_dl_errstr, +}; + + +int +dlperl_init() +{ + struct ufuncs uf; + char *file = "dlperl.c"; + + uf.uf_val = userval; + uf.uf_set = userset; + +#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf) + + /* subroutines */ + make_usub("dl_open", US_dl_open, usersub, file); + make_usub("dl_sym", US_dl_sym, usersub, file); + make_usub("dl_call", US_dl_call, usersub, file); + make_usub("dl_close", US_dl_close, usersub, file); + + /* variables */ + MAGICVAR("DL_VERSION", (int) UV_DL_VERSION); + MAGICVAR("DL_WARN", (int) UV_DL_WARN); + MAGICVAR("dl_errno", (int) UV_dl_errno); + MAGICVAR("dl_errstr", (int) UV_dl_errstr); + + return 0; +} + + +/* + * USERVAL AND USERSET + */ + +/* + * assign dlperl variables to perl variables + */ +/*ARGSUSED*/ +static int +userval(ix, str) +int ix; +STR *str; +{ + switch(ix) { + case UV_DL_VERSION: + str_set(str, sccsid); + break; + case UV_DL_WARN: + str_numset(str, (double) Dl_warn); + break; + case UV_dl_errno: + str_numset(str, (double) Dl_errno); + break; + case UV_dl_errstr: + str_set(str, Dl_errstr); + break; + default: + fatal("dlperl: unimplemented userval"); + break; + } + return 0; +} + +/* + * assign perl variables to dlperl variables + */ +static int +userset(ix, str) +int ix; +STR *str; +{ + switch(ix) { + case UV_DL_WARN: + Dl_warn = (int) str_gnum(str); + break; + default: + fatal("dlperl: unimplemented userset"); + break; + } + return 0; +} + + +/* + * USERSUBS + */ +static int +usersub(ix, sp, items) +int ix; +register int sp; +register int items; +{ + int oldsp = sp; + STR **st = stack->ary_array + sp; + register STR *Str; /* used in str_get and str_gnum macros */ + + Dl_errno = 0; + *Dl_errstr = '\0'; + + switch(ix) { + case US_dl_open: + { + char *file; + void *dl_so; + + if(items != 1) { + fatal("Usage: $dl_so = &dl_open($file)"); + return oldsp; + } + + file = str_get(st[1]); + dl_so = dlopen(file, 1); + + --sp; + if(dl_so == NULL) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, "&dl_open: %s", dlerror()); + if(Dl_warn) warn(Dl_errstr); + + astore(stack, ++sp, str_mortal(&str_undef)); + } else { + astore(stack, ++sp, str_2mortal(str_make( + (char *) &dl_so, sizeof(void *)))); + } + break; + } + case US_dl_sym: + { + void *dl_so; + char *symbol; + void *dl_func; + + if(items != 2) { + fatal("Usage: $dl_func = &dl_sym($dl_so, $symbol)"); + return oldsp; + } + + dl_so = *(void **) str_get(st[1]); + symbol = str_get(st[2]); + dl_func = dlsym(dl_so, symbol); + + --sp; + if(dl_func == NULL) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, "&dl_sym: %s", dlerror()); + if(Dl_warn) warn(Dl_errstr); + + astore(stack, ++sp, str_mortal(&str_undef)); + } else { + astore(stack, ++sp, str_2mortal(str_make( + (char *) &dl_func, sizeof(void *)))); + } + break; + } + case US_dl_call: + { + void *dl_func; + char *parms_desc, *return_desc; + int nstack, nparm, narr, nlen, nrep; + int f_indirect, f_no_parm, f_result; + char c, *c_p; int c_pn = 0; + unsigned char C, *C_p; int C_pn = 0; + short s, *s_p; int s_pn = 0; + unsigned short S, *S_p; int S_pn = 0; + int i, *i_p; int i_pn = 0; + unsigned int I, *I_p; int I_pn = 0; + long l, *l_p; int l_pn = 0; + unsigned long L, *L_p; int L_pn = 0; + float f, *f_p; int f_pn = 0; + double d, *d_p; int d_pn = 0; + char *a, **a_p; int a_pn = 0; + char *p, **p_p; int p_pn = 0; + unsigned int *stack_base, *stack_p; + unsigned int *xp; + void (*func)(); + unsigned int ret_o; + double ret_fd; + float ret_f; + char *c1; + int n1, n2; + + if(items < 3) { +fatal("Usage: @vals = &dl_call($dl_func, $parms_desc, $return_desc, @parms)"); + return oldsp; + } + dl_func = *(void **) str_get(st[1]); + parms_desc = str_get(st[2]); + return_desc = str_get(st[3]); + + /* determine size of stack and temporaries */ +# define CNT_STK_TMP(PN, SN) \ + n2 = 0; do { \ + if(f_indirect) { \ + PN += narr; \ + ++nstack; \ + if(!f_no_parm) \ + nparm += narr; \ + } else { \ + nstack += SN; \ + if(!f_no_parm) \ + ++nparm; \ + } \ + } while(++n2 < nrep); \ + f_indirect = f_no_parm = narr = nrep = 0; + + nstack = 0; + nparm = 0; + f_indirect = f_no_parm = narr = nrep = 0; + for(c1 = parms_desc;*c1;++c1) { + switch(*c1) { + case ' ': + case '\t': + break; + + case 'c': /* signed char */ + CNT_STK_TMP(c_pn, 1); + break; + case 'C': /* unsigned char */ + CNT_STK_TMP(C_pn, 1); + break; + case 's': /* signed short */ + CNT_STK_TMP(s_pn, 1); + break; + case 'S': /* unsigned short */ + CNT_STK_TMP(S_pn, 1); + break; + case 'i': /* signed int */ + CNT_STK_TMP(i_pn, 1); + break; + case 'I': /* unsigned int */ + CNT_STK_TMP(I_pn, 1); + break; + case 'l': /* signed long */ + CNT_STK_TMP(l_pn, 1); + break; + case 'L': /* unsigned long */ + CNT_STK_TMP(L_pn, 1); + break; + case 'f': /* float */ + CNT_STK_TMP(f_pn, 1); + break; + case 'd': /* double */ + CNT_STK_TMP(d_pn, 2); + break; + case 'a': /* ascii (null-terminated) string */ + CNT_STK_TMP(a_pn, 1); + break; + case 'p': /* pointer to <nlen> buffer */ + CNT_STK_TMP(p_pn, 1); + break; + + case '&': /* pointer = [1] */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: too many indirections, with char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + narr = 1; + break; + case '[': /* array */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: too many indirections, with char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) { + narr = narr * 10 + (*c1 - '0'); + ++c1; + } + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != ']') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c, expected ]", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + case '<': /* length */ + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != '>') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c, expected >", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + case '+': + break; + case '-': + f_no_parm = 1; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if(nrep) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: too many repeats"); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + while(isdigit(*c1)) { + nrep = nrep * 10 + (*c1 - '0'); + ++c1; + } + --c1; + break; + default: + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + } + /* trailing &[]<>+-0-9 is ignored */ + if(nparm != items - 3) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: bad parameter count %d, expected %d", + items - 3, nparm); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + nparm = 4; + + /* allocate temporaries */ + if((c_pn && (c_p = (char *) + alloca(c_pn * sizeof(char))) == NULL) || + (C_pn && (C_p = (unsigned char *) + alloca(C_pn * sizeof(unsigned char))) == NULL) || + (s_pn && (s_p = (short *) + alloca(s_pn * sizeof(short))) == NULL) || + (S_pn && (S_p = (unsigned short *) + alloca(S_pn * sizeof(unsigned short))) == NULL) || + (i_pn && (i_p = (int *) + alloca(i_pn * sizeof(int))) == NULL) || + (I_pn && (I_p = (unsigned int *) + alloca(I_pn * sizeof(unsigned int))) == NULL) || + (l_pn && (l_p = (long *) + alloca(l_pn * sizeof(long))) == NULL) || + (L_pn && (L_p = (unsigned long *) + alloca(L_pn * sizeof(unsigned long))) == NULL) || + (f_pn && (f_p = (float *) + alloca(f_pn * sizeof(float))) == NULL) || + (d_pn && (d_p = (double *) + alloca(d_pn * sizeof(double))) == NULL) || + (a_pn && (a_p = (char **) + alloca(a_pn * sizeof(char *))) == NULL) || + (p_pn && (p_p = (char **) + alloca(p_pn * sizeof(char *))) == NULL)) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, "&dl_call: bad alloca"); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + + /* grow stack - maintains stack alignment (double word) */ + /* NOTE: no functions should be called otherwise the stack */ + /* that is being built will be corrupted */ + /* NOTE: some of the stack is pre-allocated, but is not */ + /* reused here */ + if(alloca(nstack * WORD_SIZE) == NULL) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, "&dl_call: bad alloca"); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + + /* stack base */ +#if !defined(lint) + asm("add %%sp,68,%%o0;st %%o0,%0" : + "=g" (stack_base) : /* input */ : "%%o0"); +#else + stack_base = 0; +#endif + stack_p = stack_base; + + /* layout stack */ +# define LAY_STK_NUM(T, P, PN) \ + n2 = 0; do { \ + if(f_indirect) { \ + *stack_p++ = (unsigned int) &P[PN]; \ + if(f_no_parm) { \ + PN += narr; \ + } else { \ + for(n1 = 0;n1 < narr;++n1) { \ + P[PN++] = (T) \ + str_gnum(st[nparm++]); \ + } \ + } \ + } else { \ + if(f_no_parm) { \ + ++stack_p; \ + } else { \ + *stack_p++ = (T) \ + str_gnum(st[nparm++]); \ + } \ + } \ + } while(++n2 < nrep); \ + f_indirect = f_no_parm = narr = nrep = 0; + +# define LAY_STK_DOUBLE(T, P, PN) \ + n2 = 0; do { \ + if(f_indirect) { \ + *stack_p++ = (unsigned int) &P[PN]; \ + if(f_no_parm) { \ + PN += narr; \ + } else { \ + for(n1 = 0;n1 < narr;++n1) { \ + P[PN++] = (T) \ + str_gnum(st[nparm++]); \ + } \ + } \ + } else { \ + if(f_no_parm) { \ + stack_p += 2; \ + } else { \ + d = (T) str_gnum(st[nparm++]); \ + xp = (unsigned int *) &d; \ + *stack_p++ = *xp++; \ + *stack_p++ = *xp; \ + } \ + } \ + } while(++n2 < nrep); \ + f_indirect = f_no_parm = narr = nrep = 0; + +# define LAY_STK_STR(P, PN) \ + n2 = 0; do { \ + if(f_indirect) { \ + *stack_p++ = (unsigned int) &P[PN]; \ + if(f_no_parm) { \ + PN += narr; \ + } else { \ + for(n1 = 0;n1 < narr;++n1) { \ + P[PN++] = \ + str_get(st[nparm++]); \ + } \ + } \ + } else { \ + if(f_no_parm) { \ + ++stack_p; \ + } else { \ + *stack_p++ = (unsigned int) \ + str_get(st[nparm++]); \ + } \ + } \ + } while(++n2 < nrep); \ + f_indirect = f_no_parm = narr = nrep = 0; + + c_pn = C_pn = s_pn = S_pn = i_pn = I_pn = l_pn = L_pn = 0; + f_pn = d_pn = a_pn = p_pn = 0; + f_indirect = f_no_parm = narr = nrep = 0; + for(c1 = parms_desc;*c1;++c1) { + switch(*c1) { + case ' ': + case '\t': + break; + + case 'c': /* signed char */ + LAY_STK_NUM(char, c_p, c_pn); + break; + case 'C': /* unsigned char */ + LAY_STK_NUM(unsigned char, C_p, C_pn); + break; + case 's': /* signed short */ + LAY_STK_NUM(short, s_p, s_pn); + break; + case 'S': /* unsigned short */ + LAY_STK_NUM(unsigned short, S_p, S_pn); + break; + case 'i': /* signed int */ + LAY_STK_NUM(int, i_p, i_pn); + break; + case 'I': /* unsigned int */ + LAY_STK_NUM(unsigned int, I_p, I_pn); + break; + case 'l': /* signed long */ + LAY_STK_NUM(long, l_p, l_pn); + break; + case 'L': /* unsigned long */ + LAY_STK_NUM(unsigned long, L_p, L_pn); + break; + case 'f': /* float */ + LAY_STK_NUM(float, f_p, f_pn); + break; + case 'd': /* double */ + LAY_STK_DOUBLE(double, d_p, d_pn); + break; + case 'a': /* ascii (null-terminated) string */ + LAY_STK_STR(a_p, a_pn); + break; + case 'p': /* pointer to <nlen> buffer */ + LAY_STK_STR(p_p, p_pn); + break; + + case '&': /* pointer = [1] */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: too many indirections, with char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + narr = 1; + break; + case '[': /* array */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: too many indirections, with char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) { + narr = narr * 10 + (*c1 - '0'); + ++c1; + } + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != ']') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c, expected ]", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + case '<': /* length */ + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != '>') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c, expected >", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + case '+': + break; + case '-': + f_no_parm = 1; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if(nrep) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: too many repeats"); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + while(isdigit(*c1)) { + nrep = nrep * 10 + (*c1 - '0'); + ++c1; + } + --c1; + break; + default: + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + } + /* trailing &[]<>+-0-9 is ignored */ + + /* call function */ + /* NOTE: the first 6 words are passed in registers %o0 - %o5 */ + /* %sp+68 to %sp+92 are vacant, but allocated */ + /* and shadow %o0 - %o5 */ + /* above stack_base starts at %sp+68 and the function */ + /* call below sets up %o0 - %o5 from stack_base */ + func = (void (*)()) dl_func; + (*func)(stack_base[0], stack_base[1], stack_base[2], + stack_base[3], stack_base[4], stack_base[5]); + + /* save return value */ + /* NOTE: return values are either in %o0 or %f0 */ +#if !defined(lint) + asm("st %%o0,%0" : "=g" (ret_o) : /* input */); + asm("std %%f0,%0" : "=g" (ret_fd) : /* input */); + asm("st %%f0,%0" : "=g" (ret_f) : /* input */); +#else + ret_o = 0; ret_fd = 0.0; ret_f = 0.0; +#endif + + /* parameter results */ +# define RES_NUM(P, PN, SN) \ + n2 = 0; do { \ + if(f_indirect) { \ + ++nstack; \ + if(f_result) { \ + for(n1 = 0;n1 < narr;++n1) { \ + astore(stack, ++sp, str_2mortal( \ + str_nmake((double) P[PN++]))); \ + } \ + } else { \ + PN += narr; \ + } \ + } else { \ + nstack += SN; \ + if(f_result) { \ + astore(stack, ++sp, \ + str_mortal(&str_undef));\ + } \ + } \ + } while(++n2 < nrep); \ + f_indirect = f_result = narr = nlen = nrep = 0; + +# define RES_STR(P, PN, L, SN) \ + n2 = 0; do { \ + if(f_indirect) { \ + ++nstack; \ + if(f_result) { \ + for(n1 = 0;n1 < narr;++n1) { \ + astore(stack, ++sp, str_2mortal( \ + str_make(P[PN++], L))); \ + } \ + } else { \ + PN += narr; \ + } \ + } else { \ + if(f_result) { \ + astore(stack, ++sp, str_2mortal(\ + str_make((char *) \ + stack_base[nstack], L))); \ + } \ + nstack += SN; \ + } \ + } while(++n2 < nrep); \ + f_indirect = f_result = narr = nlen = nrep = 0; + + --sp; + nstack = 0; + c_pn = C_pn = s_pn = S_pn = i_pn = I_pn = l_pn = L_pn = 0; + f_pn = d_pn = a_pn = p_pn = 0; + f_indirect = f_result = narr = nlen = nrep = 0; + for(c1 = parms_desc;*c1;++c1) { + switch(*c1) { + case ' ': + case '\t': + break; + + case 'c': /* signed char */ + RES_NUM(c_p, c_pn, 1); + break; + case 'C': /* unsigned char */ + RES_NUM(C_p, C_pn, 1); + break; + case 's': /* signed short */ + RES_NUM(s_p, s_pn, 1); + break; + case 'S': /* unsigned short */ + RES_NUM(S_p, S_pn, 1); + break; + case 'i': /* signed int */ + RES_NUM(i_p, i_pn, 1); + break; + case 'I': /* unsigned int */ + RES_NUM(I_p, I_pn, 1); + break; + case 'l': /* signed long */ + RES_NUM(l_p, l_pn, 1); + break; + case 'L': /* unsigned long */ + RES_NUM(L_p, L_pn, 1); + break; + case 'f': /* float */ + RES_NUM(f_p, f_pn, 1); + break; + case 'd': /* double */ + RES_NUM(d_p, d_pn, 2); + break; + case 'a': /* ascii (null-terminated) string */ + RES_STR(a_p, a_pn, 0, 1); + break; + case 'p': /* pointer to <nlen> buffer */ + RES_STR(p_p, p_pn, nlen, 1); + break; + + case '&': /* pointer = [1] */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: too many indirections, with char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + narr = 1; + break; + case '[': /* array */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: too many indirections, with char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) { + narr = narr * 10 + (*c1 - '0'); + ++c1; + } + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != ']') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c, expected ]", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + case '<': /* length */ + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) { + nlen = nlen * 10 + (*c1 - '0'); + ++c1; + } + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != '>') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c, expected >", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + case '+': + f_result = 1; + break; + case '-': + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if(nrep) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: too many repeats"); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + while(isdigit(*c1)) { + nrep = nrep * 10 + (*c1 - '0'); + ++c1; + } + --c1; + break; + default: + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: parms_desc %s: bad char %c", + parms_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + } + /* trailing &[]<>+-0-9 is ignored */ + + /* return value */ +# define RET_NUM(T, S, P, R) \ + if(f_indirect) { \ + P = (T *) ret_o; \ + for(n1 = 0;n1 < narr;++n1) { \ + S = *P++; \ + astore(stack, ++sp, str_2mortal( \ + str_nmake((double) S))); \ + } \ + } else { \ + S = (T) R; \ + astore(stack, ++sp, str_2mortal( \ + str_nmake((double) S))); \ + } + +# define RET_STR(S, P, L) \ + if(f_indirect) { \ + P = (char **) ret_o; \ + for(n1 = 0;n1 < narr;++n1) { \ + S = *P++; \ + astore(stack, ++sp, str_2mortal( \ + str_make((char *) S, L))); \ + } \ + } else { \ + S = (char *) ret_o; \ + astore(stack, ++sp, str_2mortal( \ + str_make((char *) S, L))); \ + } + + f_indirect = nlen = narr = 0; + for(c1 = return_desc;*c1;++c1) { + switch(*c1) { + case ' ': + case '\t': + break; + + case 'c': /* signed char */ + RET_NUM(char, c, c_p, ret_o); + goto ret_exit; + case 'C': /* unsigned char */ + RET_NUM(unsigned char, C, C_p, ret_o); + goto ret_exit; + case 's': /* signed short */ + RET_NUM(short, s, s_p, ret_o); + goto ret_exit; + case 'S': /* unsigned short */ + RET_NUM(unsigned short, S, S_p, ret_o); + goto ret_exit; + case 'i': /* signed int */ + RET_NUM(int, i, i_p, ret_o); + goto ret_exit; + case 'I': /* unsigned int */ + RET_NUM(unsigned int, I, I_p, ret_o); + goto ret_exit; + case 'l': /* signed long */ + RET_NUM(long, l, l_p, ret_o); + goto ret_exit; + case 'L': /* unsigned long */ + RET_NUM(unsigned long, L, L_p, ret_o); + goto ret_exit; + case 'f': /* float */ + RET_NUM(float, f, f_p, ret_f); + break; + case 'd': /* double */ + RET_NUM(double, d, d_p, ret_fd); + goto ret_exit; + case 'a': /* ascii (null-terminated) string */ + RET_STR(a, a_p, 0); + goto ret_exit; + case 'p': /* pointer to <nlen> buffer */ + RET_STR(p, p_p, nlen); + goto ret_exit; + + case '&': /* pointer = [1] */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: return_desc %s: too many indirections, with char %c", + return_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + narr = 1; + break; + case '[': /* array */ + if(f_indirect) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: return_desc %s: too many indirections, with char %c", + return_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + f_indirect = 1; + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) { + narr = narr * 10 + (*c1 - '0'); + ++c1; + } + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != ']') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: return_desc %s: bad char %c, expected ]", + return_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + case '<': /* length */ + ++c1; + while(*c1 == ' ' && *c1 == '\t') + ++c1; + while(isdigit(*c1)) { + nlen = nlen * 10 + (*c1 - '0'); + ++c1; + } + while(*c1 == ' ' && *c1 == '\t') + ++c1; + if(*c1 != '>') { + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: return_desc %s: bad char %c, expected >", + return_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + break; + default: + Dl_errno = 1; + (void) sprintf(Dl_errstr, + "&dl_call: return_desc %s: bad char %c", + return_desc, *c1); + if(Dl_warn) warn(Dl_errstr); + return oldsp; + } + } +ret_exit: /* anything beyond first [cCsSiIlLdfap] is ignored */ + break; + } + case US_dl_close: + { + void *dl_so; + int dl_err; + + if(items != 1) { + fatal("Usage: $dl_err = &dl_close($dl_so)"); + return oldsp; + } + + dl_so = *(void **) str_get(st[1]); + dl_err = dlclose(dl_so); + + --sp; + if(dl_err) { + Dl_errno = 1; + (void) sprintf(Dl_errstr, "&dl_close: %s", dlerror()); + if(Dl_warn) warn(Dl_errstr); + } + astore(stack, ++sp, str_2mortal(str_nmake((double) dl_err))); + break; + } + default: + fatal("dlperl: unimplemented usersub"); + break; + } + return sp; +} |