diff options
Diffstat (limited to 'dlperl/dlperl.c')
| -rw-r--r-- | dlperl/dlperl.c | 1037 |
1 files changed, 0 insertions, 1037 deletions
diff --git a/dlperl/dlperl.c b/dlperl/dlperl.c deleted file mode 100644 index 49d48bb197..0000000000 --- a/dlperl/dlperl.c +++ /dev/null @@ -1,1037 +0,0 @@ -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; -} |