calleus.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* EUSLISP foreign function interface
3 /*
4 /* c --> lisp
5 /* calleus(foreign-symbol,cargv)
6 /*
7 /* lisp --> c
8 /* After loading by using load-foreign func,
9 /* (call-foreign address param-spec result-spec . args)
10 /*
11 /* Since arguments are pushed on stack interpretedly at
12 /* runtime referring to parameter specification list,
13 /* foreign function calls are not very fast.
14 /* Euslisp's foreign function interface facility is provided
15 /* for the purpose to link a huge library like suncore or sunview
16 /* without much modification to those libraries,
17 /* and not intending speeding up of execution.
18 /*
19 /* Copyright 1988, Toshihiro MATSUI, ETL,
20 /* hinted and urged by M.INABA, UTOYO.
21 /*
22 /* 1987-Sep-24
23 /* 1988-MAR-12 removed restriction on the number of args and types
24 /* implementation on SUN4
25 /****************************************************************/
26 static char *rcsid="@(#)$Id$";
27 #include "eus.h"
28 
29 struct foreignpod {
30 #if vax || sun4 || news || mips || alpha || Linux
31  unsigned mark:1;
32  unsigned b:1;
33  unsigned m:1;
34  unsigned smark:1;
35  unsigned pmark:1;
36  unsigned elmtype:3;
37  unsigned noexpose:1;
38  unsigned extra:1;
39  unsigned bix:6;
40 #endif
41  short cix;
43  vtype, /*const,var*/
51 
53 
54 #define pisforeignpod(p) (foreignpodcp.cix<=((p)->cix) && \
55  ((p)->cix)<=foreignpodcp.sub)
56 #define isforeignpod(p) (ispointer(p) && pisforeignpod(p))
57 
58 #if (defined x86_64) || (defined aarch64)
59 // Linux, x64
60 /* development version of euscall written by Y.Kakiuchi */
61 union NUMCONVBUF {
64  int i32val;
65  float f32val;
66 };
67 
69 calleus(fsym,cargv)
70 register pointer fsym; /*foreign-symbol*/
71 register eusinteger_t cargv[]; /*arguments vector passed from C function*/
72 // cargv[0-5] integer, pointer
73 // cargv[6-13] float, double
74 // skip cargv[14](stack pointer), cargv[15] (stack alignment)
75 // cargv[16.. ] integer, pointer, float, double
76 // using TYPE
77 // byte, char, short, long, integer, pointer, int32
78 // float32, float, double,
79 { register pointer param,resulttype,p,result;
80  eusfloat_t f;
81  float f32;
82  context *ctx;
83  pointer *argv;
84  struct foreignpod *fs;
85  eusinteger_t c;
86  int argc=0 /* ,j */;
87  eusinteger_t *iargv = cargv;
88  eusinteger_t *fargv = &(cargv[6]);
89  eusinteger_t *vargv = &(cargv[16]);
90  int icount = 0, fcount = 0, vcount = 0;
91  //numunion nu;
92  union NUMCONVBUF nu;
93 
94 #if 0
95  printf("calleus : fsym.cix = %lX (%lX,%lX)\n", fsym->cix, fsym, &(fsym->cix));
96 #endif
97  ctx=euscontexts[thr_self()];
98  argv=ctx->vsp;
99  fs=(struct foreignpod *)fsym;
100 #if 0
101  printf("calleus : fsym.paramtypes = %lX (%lX,%lX)\n",
102  fs->paramtypes, (long *)fs, &(fs->paramtypes));
103  printf("calleus : fsym.resulttype = %lX (%lX,%lX)\n",
104  fs->resulttype, (long *)fs, &(fs->resulttype));
105 #endif
106  if (!isforeignpod(fsym)) error(E_USER,(pointer)"not a foreign pod");
107  param=fs->paramtypes;
108  resulttype=fs->resulttype;
109  while (islist(param)) {
110  p=ccar(param); param=ccdr(param);
111  if (p==K_INTEGER) {
112  if(icount < 6) c = iargv[icount++]; else c = vargv[vcount++];
113  vpush(makeint(c));
114 #if 0
115  } else if (p==K_INT32) {
116  if(icount < 6) c = iargv[icount++]; else c = vargv[vcount++];
117  vpush(makeint(c & 0x00000000FFFFFFFF));
118 #endif
119  } else if (p==K_FLOAT) {
120  if(fcount < 8) c = fargv[fcount++]; else c = vargv[vcount++];
121  nu.ival = c;
122  vpush(makeflt(nu.fval));
123  } else if (p==K_FLOAT32) {
124  if(fcount < 8) c = fargv[fcount++]; else c = vargv[vcount++];
125  nu.ival = c & 0x00000000FFFFFFFF;
126  f = nu.f32val;
127  vpush(makeflt(f));
128  } else if (islist(p)) {
129  if (ccar(p)!=K_STRING) error(E_USER,(pointer)":string key expected");
130  p=ccdr(p);
131  if (p==NIL) {
132  if(icount < 6) c = iargv[icount++]; else c = vargv[vcount++];
133  vpush(makestring((char *)c,strlen((char *)c)));
134  } else {
135  p=ccar(p); //c=ckintval(p);
136  if(icount < 6) c = iargv[icount++]; else c = vargv[vcount++];
137  vpush(makestring((char *)c, ckintval(p)));
138  }
139  } else if (p==K_STRING) {
140  if(icount < 6) c = iargv[icount++]; else c = vargv[vcount++];
141  c -= 2*sizeof(pointer);
142  vpush((pointer)c);
143  } else error(E_USER,(pointer)"unknown param type spec");
144  argc++;
145  }
146 #if 0
147  // check argv
148  printf("argc = %d\n", argc);
149  for(int i=0;i<argc;i++) {
150  printf("argv[%d] = %lX\n", argv[i]);
151  }
152 #endif
153  result=ufuncall(ctx,fsym,fsym,(pointer)argv,NULL,argc);
154  ctx->vsp = argv;
155  if (resulttype==K_STRING) return((eusinteger_t)(result->c.str.chars));
156  else if (resulttype==K_FLOAT) {
157  f=fltval(result);
158  nu.fval=f;
159  printf("calleus float-result=%f\n",f);
160  return(nu.ival);
161  } else if (resulttype==K_FLOAT32) {
162  f=fltval(result);
163  f32 = f;
164  nu.f32val = f32;
165  return((eusinteger_t)nu.i32val);
166  } else return(intval(result));
167 }
168 #else // #if x86_64
170 calleus(fsym,cargv,a2,a3,a4,a5,a6,a7,a8)
171 register pointer fsym; /*foreign-symbol*/
172 register eusinteger_t cargv[]; /*arguments vector passed from C function*/
173 register int a2, a3, a4, a5, a6, a7, a8;
174 { register pointer param,resulttype,p,result;
175  double *dp;
176  float f;
177  context *ctx;
178  pointer *argv;
179  struct foreignpod *fs;
180  eusinteger_t c;
181  int i=0,argc=0,j;
182  numunion nu;
183 
184  ctx=euscontexts[thr_self()];
185  argv=ctx->vsp;
186  fs=(struct foreignpod *)fsym;
187  if (!isforeignpod(fsym)) error(E_USER,(pointer)"not a foreign pod");
188  param=fs->paramtypes;
190  while (islist(param)) {
191  p=ccar(param); param=ccdr(param);
192  if (p==K_INTEGER) { vpush(makeint(cargv[i])); i++;}
193  else if (p==K_FLOAT) {
194  dp=(double *)&cargv[i]; f= *dp;
195  vpush(makeflt(f)); i+=2;}
196  else if (islist(p)) {
197  if (ccar(p)!=K_STRING) error(E_USER,(pointer)":string key expected");
198  p=ccdr(p);
199  if (p==NIL) {
200  vpush(makestring((char *)cargv[i],strlen((char *)cargv[i]))); i++;}
201  else {
202  p=ccar(p);
203  c=ckintval(p);
204  vpush(makestring((char *)cargv[i++],c));} }
205  else if (p==K_STRING) {
206 #if sun3 || (!alpha && system5) || apollo || sanyo
207  c=cargv[i++]-6;
208 #else
209  c=cargv[i++]-2*sizeof(pointer);
210 #endif
211  vpush((pointer)c);}
212  else error(E_USER,(pointer)"unknown param type spec");
213  argc++;}
214  result=ufuncall(ctx,fsym,fsym,(pointer)argv,NULL,argc);
215  ctx->vsp = argv;
216  if (resulttype==K_STRING) return((eusinteger_t)(result->c.str.chars));
217  else if (resulttype==K_FLOAT) {
218  f=fltval(result);
219  nu.fval=f;
220  printf("calleus float-result=%f\n",f);
221  return(nu.ival); }
222  else return(intval(result)); }
223 #endif // x86_64
224 
225 void foreign(ctx,mod)
226 register context *ctx;
227 pointer mod;
228 { pointer pkgsave;
229  eusinteger_t i;/* ???? */
230  pointer FOREIGN,C_FOREIGN;
231 
232  pkgsave=Spevalof(PACKAGE);
233  pointer_update(Spevalof(PACKAGE), lisppkg);
234  FOREIGN=basicclass("FOREIGN-POD",C_SYMBOL,&foreignpodcp,
235  3,"PODCODE","PARAMTYPES","RESULTTYPE");
236  C_FOREIGN=Spevalof(FOREIGN);
238  defvar(ctx,"*CALLEUS*",makeint(i),lisppkg);
239  pointer_update(Spevalof(PACKAGE), pkgsave);
240  }
NUMCONVBUF::i32val
int i32val
Definition: calleus.c:64
foreignpod::extra
unsigned extra
Definition: calleus.c:38
numunion
Definition: eus.h:428
NIL
pointer NIL
Definition: eus.c:110
foreignpod::mark
unsigned mark
Definition: calleus.c:31
foreignpod::speval
pointer speval
Definition: calleus.c:42
foreignpod::b
unsigned b
Definition: calleus.c:32
foreignpod::m
unsigned m
Definition: calleus.c:33
makeint
#define makeint(v)
Definition: sfttest.c:2
context
Definition: eus.h:524
foreignpod::pname
pointer pname
Definition: calleus.c:45
PACKAGE
pointer PACKAGE
Definition: eus.c:110
foreignpod::elmtype
unsigned elmtype
Definition: calleus.c:36
calleus
eusinteger_t calleus(pointer fsym, cargv)
Definition: calleus.c:69
numunion::ival
eusinteger_t ival
Definition: eus.h:431
intval
#define intval(p)
Definition: sfttest.c:1
foreignpod::paramtypes
pointer paramtypes
Definition: calleus.c:49
numunion::fval
eusfloat_t fval
Definition: eus.h:430
pointer
struct cell * pointer
Definition: eus.h:165
foreign
void foreign(context *ctx, pointer mod)
Definition: calleus.c:225
eus.h
makestring
pointer makestring(char *, int)
Definition: makes.c:147
foreignpod::resulttype
pointer resulttype
Definition: calleus.c:50
rcsid
static char * rcsid
Definition: calleus.c:26
string::chars
byte chars[1]
Definition: eus.h:212
eusfloat_t
double eusfloat_t
Definition: eus.h:21
cell::c
union cell::cellunion c
K_STRING
pointer K_STRING
Definition: eus.c:131
NUMCONVBUF::fval
eusfloat_t fval
Definition: calleus.c:62
defvar
pointer defvar(context *, char *, pointer, pointer)
Definition: makes.c:704
foreignpod::podcode
pointer podcode
Definition: calleus.c:48
foreignpod::bix
unsigned bix
Definition: calleus.c:39
foreignpod::smark
unsigned smark
Definition: calleus.c:34
foreignpod::cix
short cix
Definition: calleus.c:41
cell::cix
short cix
Definition: eus.h:398
NUMCONVBUF::ival
eusinteger_t ival
Definition: calleus.c:63
NULL
#define NULL
Definition: transargv.c:8
foreignpod::vtype
pointer vtype
Definition: calleus.c:43
fltval
float fltval()
foreignpod::pmark
unsigned pmark
Definition: calleus.c:35
foreignpod::plist
pointer plist
Definition: calleus.c:46
euscontexts
context * euscontexts[MAXTHREAD]
Definition: eus.c:105
foreignpod::noexpose
unsigned noexpose
Definition: calleus.c:37
basicclass
pointer basicclass(char *name,...) pointer basicclass(va_alist) va_dcl
Definition: eus.c:405
K_INTEGER
pointer K_INTEGER
Definition: eus.c:132
C_SYMBOL
pointer C_SYMBOL
Definition: eus.c:142
iargv
static int * iargv
Definition: transargv.c:58
lisppkg
pointer lisppkg
Definition: eus.c:109
makeflt
pointer makeflt()
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
foreignpod::spefunc
pointer spefunc
Definition: calleus.c:44
f
f
argc
static int argc
Definition: transargv.c:56
cell
Definition: eus.h:381
eusinteger_t
long eusinteger_t
Definition: eus.h:19
K_FLOAT32
pointer K_FLOAT32
Definition: eus.c:133
context::vsp
pointer * vsp
Definition: eus.h:525
cixpair
Definition: eus.h:452
E_USER
@ E_USER
Definition: eus.h:1006
ufuncall
pointer ufuncall(context *, pointer, pointer, pointer, struct bindframe *, int)
Definition: eval.c:1469
NUMCONVBUF
Definition: calleus.c:61
foreignpodcp
cixpair foreignpodcp
Definition: calleus.c:52
K_FLOAT
pointer K_FLOAT
Definition: eus.c:133
NUMCONVBUF::f32val
float f32val
Definition: calleus.c:65
cell::cellunion::str
struct string str
Definition: eus.h:402
foreignpod
Definition: calleus.c:29
fargv
static float * fargv
Definition: transargv.c:57
thr_self
unsigned int thr_self()
Definition: eus.c:25
foreignpod::homepkg
pointer homepkg
Definition: calleus.c:47


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 15 2023 02:06:43