calleus.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* EUSLISP foreign function interface
00003 /*
00004 /*      c --> lisp
00005 /*      calleus(foreign-symbol,cargv)
00006 /*
00007 /*      lisp --> c
00008 /*      After loading by using load-foreign func,
00009 /*      (call-foreign address param-spec result-spec . args)
00010 /*
00011 /*      Since arguments are pushed on stack interpretedly at 
00012 /*      runtime referring to parameter specification list,
00013 /*      foreign function calls are not very fast.
00014 /*      Euslisp's foreign function interface facility is provided
00015 /*      for the purpose to link a huge library like suncore or sunview
00016 /*      without much modification to those libraries,
00017 /*      and not intending speeding up of execution.  
00018 /*
00019 /*      Copyright 1988, Toshihiro MATSUI, ETL,
00020 /*                hinted and urged by M.INABA, UTOYO.
00021 /*
00022 /*      1987-Sep-24
00023 /*      1988-MAR-12 removed restriction on the number of args and types
00024 /*                  implementation on SUN4
00025 /****************************************************************/
00026 static char *rcsid="@(#)$Id$";
00027 #include "eus.h"
00028 
00029 struct foreignpod {
00030 #if vax || sun4 || news || mips || i386 || alpha || x86_64 || ARM
00031     unsigned mark:1;
00032     unsigned b:1;
00033     unsigned m:1;
00034     unsigned smark:1;
00035     unsigned pmark:1;
00036     unsigned elmtype:3;
00037     unsigned noexpose:1;
00038     unsigned extra:1;
00039     unsigned bix:6;
00040 #endif
00041     short   cix;
00042     pointer speval,
00043             vtype,              /*const,var*/
00044             spefunc,
00045             pname,
00046             plist,
00047             homepkg,
00048             podcode,
00049             paramtypes,
00050             resulttype;};
00051 
00052 cixpair foreignpodcp;
00053 
00054 #define pisforeignpod(p) (foreignpodcp.cix<=((p)->cix) && \
00055                                           ((p)->cix)<=foreignpodcp.sub)
00056 #define isforeignpod(p) (ispointer(p) && pisforeignpod(p))
00057 
00058 #if x86_64
00059 // Linux, x64
00060 /* development version of euscall written by Y.Kakiuchi */
00061 union NUMCONVBUF {
00062   eusfloat_t fval;
00063   eusinteger_t ival;
00064   int i32val;
00065   float f32val;
00066 };
00067 
00068 eusinteger_t
00069 calleus(fsym,cargv)
00070 register pointer fsym;      /*foreign-symbol*/
00071 register eusinteger_t cargv[]; /*arguments vector passed from C function*/
00072 // cargv[0-5] integer, pointer
00073 // cargv[6-13] float, double
00074 // skip cargv[14](stack pointer), cargv[15] (stack alignment)
00075 // cargv[16.. ] integer, pointer, float, double
00076 // using TYPE
00077 // byte, char, short, long, integer, pointer, int32
00078 // float32, float, double,
00079 { register pointer param,resulttype,p,result;
00080   eusfloat_t f;
00081   float f32;
00082   context *ctx;
00083   pointer *argv;
00084   struct foreignpod *fs;
00085   eusinteger_t c;
00086   int argc=0 /* ,j */;
00087   eusinteger_t *iargv = cargv;
00088   eusinteger_t *fargv = &(cargv[6]);
00089   eusinteger_t *vargv = &(cargv[16]);
00090   int icount = 0, fcount = 0, vcount = 0;
00091   //numunion nu;
00092   union NUMCONVBUF nu;
00093   
00094 #if 0
00095   printf("calleus : fsym.cix = %lX (%lX,%lX)\n", fsym->cix, fsym, &(fsym->cix));
00096 #endif    
00097   ctx=euscontexts[thr_self()];
00098   argv=ctx->vsp;
00099   fs=(struct foreignpod *)fsym;
00100 #if 0
00101   printf("calleus : fsym.paramtypes = %lX (%lX,%lX)\n",
00102          fs->paramtypes, (long *)fs, &(fs->paramtypes));
00103   printf("calleus : fsym.resulttype = %lX (%lX,%lX)\n",
00104          fs->resulttype, (long *)fs, &(fs->resulttype)); 
00105 #endif
00106   if (!isforeignpod(fsym)) error(E_USER,(pointer)"not a foreign pod");
00107   param=fs->paramtypes;
00108   resulttype=fs->resulttype;
00109   while (islist(param)) {
00110     p=ccar(param); param=ccdr(param);
00111     if (p==K_INTEGER) {
00112       if(icount < 6)  c = iargv[icount++]; else c = vargv[vcount++];
00113       vpush(makeint(c));
00114 #if 0
00115     } else if (p==K_INT32) {
00116       if(icount < 6)  c = iargv[icount++]; else c = vargv[vcount++];
00117       vpush(makeint(c & 0x00000000FFFFFFFF));
00118 #endif
00119     } else if (p==K_FLOAT) {
00120       if(fcount < 8)  c = fargv[fcount++]; else c = vargv[vcount++];
00121       nu.ival = c;
00122       vpush(makeflt(nu.fval));
00123     } else if (p==K_FLOAT32) {
00124       if(fcount < 8)  c = fargv[fcount++]; else c = vargv[vcount++];
00125       nu.ival = c & 0x00000000FFFFFFFF;
00126       f = nu.f32val;
00127       vpush(makeflt(f));
00128     } else if (islist(p)) {
00129       if (ccar(p)!=K_STRING) error(E_USER,(pointer)":string key expected");
00130       p=ccdr(p);
00131       if (p==NIL) {
00132         if(icount < 6)  c = iargv[icount++]; else c = vargv[vcount++];
00133         vpush(makestring((char *)c,strlen((char *)c)));
00134       } else {
00135         p=ccar(p); //c=ckintval(p);
00136         if(icount < 6)  c = iargv[icount++]; else c = vargv[vcount++];
00137         vpush(makestring((char *)c, ckintval(p)));
00138       }
00139     } else if (p==K_STRING)  {
00140       if(icount < 6)  c = iargv[icount++]; else c = vargv[vcount++];
00141       c -= 2*sizeof(pointer);
00142       vpush((pointer)c);
00143     } else error(E_USER,(pointer)"unknown param type spec");
00144     argc++;
00145   }
00146 #if 0
00147   // check argv
00148   printf("argc = %d\n", argc);
00149   for(int i=0;i<argc;i++) {
00150     printf("argv[%d] = %lX\n", argv[i]);
00151   }
00152 #endif
00153   result=ufuncall(ctx,fsym,fsym,(pointer)argv,NULL,argc);
00154   ctx->vsp = argv;
00155   if (resulttype==K_STRING) return((eusinteger_t)(result->c.str.chars));
00156   else if (resulttype==K_FLOAT) {
00157     f=fltval(result);
00158     nu.fval=f;
00159     printf("calleus float-result=%f\n",f);
00160     return(nu.ival); 
00161   } else if (resulttype==K_FLOAT32) {
00162     f=fltval(result);
00163     f32 = f;
00164     nu.f32val = f32;
00165     return((eusinteger_t)nu.i32val);
00166   } else return(intval(result));
00167 }
00168 #else // #if x86_64
00169 eusinteger_t
00170 calleus(fsym,cargv,a2,a3,a4,a5,a6,a7,a8)
00171 register pointer fsym;  /*foreign-symbol*/
00172 register eusinteger_t cargv[];  /*arguments vector passed from C function*/
00173 { register pointer param,resulttype,p,result;
00174   double *dp;
00175   float f;
00176   context *ctx;
00177   pointer *argv;
00178   struct foreignpod *fs;
00179   eusinteger_t c;
00180   int i=0,argc=0,j;
00181   numunion nu;
00182 
00183   ctx=euscontexts[thr_self()];
00184   argv=ctx->vsp;
00185   fs=(struct foreignpod *)fsym;
00186   if (!isforeignpod(fsym)) error(E_USER,(pointer)"not a foreign pod");
00187   param=fs->paramtypes;
00188   resulttype=fs->resulttype;
00189   while (islist(param)) {
00190     p=ccar(param); param=ccdr(param);
00191     if (p==K_INTEGER) { vpush(makeint(cargv[i])); i++;}
00192     else if (p==K_FLOAT)   {
00193       dp=(double *)&cargv[i];  f= *dp;
00194       vpush(makeflt(f)); i+=2;}
00195     else if (islist(p)) {
00196       if (ccar(p)!=K_STRING) error(E_USER,(pointer)":string key expected");
00197       p=ccdr(p);
00198       if (p==NIL) {
00199         vpush(makestring((char *)cargv[i],strlen((char *)cargv[i]))); i++;} 
00200       else {
00201         p=ccar(p);
00202         c=ckintval(p);
00203         vpush(makestring((char *)cargv[i++],c));} }
00204     else if (p==K_STRING)  {
00205 #if sun3 || (!alpha && system5) || apollo || sanyo
00206         c=cargv[i++]-6;
00207 #else
00208         c=cargv[i++]-2*sizeof(pointer);
00209 #endif
00210         vpush((pointer)c);}
00211     else error(E_USER,(pointer)"unknown param type spec");
00212     argc++;}
00213   result=ufuncall(ctx,fsym,fsym,(pointer)argv,NULL,argc);
00214   ctx->vsp = argv;
00215   if (resulttype==K_STRING) return((eusinteger_t)(result->c.str.chars));
00216   else if (resulttype==K_FLOAT) {
00217     f=fltval(result);
00218     nu.fval=f;
00219     printf("calleus float-result=%f\n",f);
00220     return(nu.ival); }
00221   else return(intval(result)); }
00222 #endif // x86_64
00223 
00224 void foreign(ctx,mod)
00225 register context *ctx;
00226 pointer mod;
00227 { pointer pkgsave;
00228   eusinteger_t i;/* ???? */
00229   pointer FOREIGN,C_FOREIGN;
00230 
00231   pkgsave=Spevalof(PACKAGE);
00232   pointer_update(Spevalof(PACKAGE), lisppkg);
00233   FOREIGN=basicclass("FOREIGN-POD",C_SYMBOL,&foreignpodcp,
00234                      3,"PODCODE","PARAMTYPES","RESULTTYPE");
00235   C_FOREIGN=Spevalof(FOREIGN);
00236   i=(eusinteger_t)calleus;
00237   defvar(ctx,"*CALLEUS*",makeint(i),lisppkg);
00238   pointer_update(Spevalof(PACKAGE), pkgsave);
00239   }


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Sep 3 2015 10:36:19