eval.c
Go to the documentation of this file.
00001 /*****************************************************************/
00002 /* eval.c
00003 /       interpreted evaluation of lisp forms
00004 /*      1986-Jun-6
00005 /*      Copyright Toshihiro Matsui, ETL Umezono Sakuramura
00006 /*      0298-54-5459
00007 *****************************************************************/
00008 static char *rcsid="@(#)$Id$";
00009 
00010 #include "eus.h"
00011 #define FALSE 0
00012 #define TRUE 1
00013 
00014 extern pointer ALLOWOTHERKEYS,K_ALLOWOTHERKEYS;
00015 extern pointer OPTIONAL,REST,KEY,AUX,MACRO,LAMBDA,LAMCLOSURE;
00016 extern char *maxmemory;
00017 
00018 #ifdef EVAL_DEBUG
00019 int evaldebug;
00020 #endif
00021 
00022 pointer *getobjv(sym,varvec,obj)
00023 register pointer sym;
00024 pointer  varvec,obj;
00025 { register pointer *vv=varvec->c.vec.v;
00026   register int i=0,n;
00027   n=intval(varvec->c.vec.size);
00028   while (i<n)
00029     if (vv[i]==sym) return(&(obj->c.obj.iv[i]));
00030     else i++;
00031   return(NULL);}
00032 
00033 pointer getval(ctx,sym)
00034 register context *ctx;
00035 register pointer sym;
00036 { register struct bindframe *bf=ctx->bindfp;
00037   register pointer var,val;
00038   pointer  *vaddr;
00039   int vt;
00040   if (sym->c.sym.vtype>=V_SPECIAL) {
00041     vt=intval(sym->c.sym.vtype);
00042     val=ctx->specials->c.vec.v[vt]; /*sym->c.sym.speval;*/
00043     if (val==UNBOUND) {
00044       val=sym->c.sym.speval;
00045       if (val==UNBOUND) error(E_UNBOUND,sym);
00046       else return(val); }
00047     else return(val);}
00048   if (sym->c.sym.vtype==V_CONSTANT) return(sym->c.sym.speval);
00049   GC_POINT;
00050   while (bf!=NULL) {
00051     var=bf->sym;
00052     val=bf->val;
00053     if (sym==var) {             /*found in bind-frame*/
00054       if (val==UNBOUND) goto getspecial;
00055       return(val);}
00056     else if (var->cix==vectorcp.cix) {
00057       vaddr=getobjv(sym,var,val);
00058       if (vaddr) return(*vaddr);}
00059     if (bf==bf->lexblink) break;
00060     bf=bf->lexblink;}
00061   /*get special value from the symbol cell*/
00062   /*if (sym->c.sym.vtype==V_GLOBAL) goto getspecial;*/
00063 getspecial:
00064   val=sym->c.sym.speval;
00065   if (val==UNBOUND) error(E_UNBOUND,sym);
00066   else return(val);}
00067 
00068 pointer setval(ctx,sym,val)
00069 register context *ctx;
00070 register pointer sym,val;
00071 { register struct bindframe *bf=ctx->bindfp;
00072   register pointer var;
00073   pointer  *vaddr;
00074   int vt;
00075   if (sym->c.sym.vtype>=V_SPECIAL) {
00076     vt=intval(sym->c.sym.vtype);
00077     pointer_update(ctx->specials->c.vec.v[vt],val);
00078     return(val);}
00079   while (bf!=NULL) {
00080     var=bf->sym;
00081     if (sym==var) {
00082       if (bf->val==UNBOUND) goto setspecial;
00083       pointer_update(bf->val,val); return(val);}
00084     else if (var->cix==vectorcp.cix) {
00085       vaddr=getobjv(sym,var,bf->val);
00086       if (vaddr) {pointer_update(*vaddr,val); return(val);}}
00087     bf=bf->lexblink; GC_POINT;}
00088   /* no local var found. try global binding */
00089   if (sym->c.sym.vtype==V_CONSTANT) error(E_SETCONST,sym);
00090   if (sym->c.sym.vtype==V_GLOBAL) goto setspecial;
00091   setspecial:
00092   pointer_update(sym->c.sym.speval,val);  /* global val*/
00093   return(val);
00094   }
00095 
00096 
00097 pointer getfunc(ctx,f)
00098 register context *ctx;
00099 register pointer f;     /*must be a symbol*/
00100 { register struct fletframe *ffp=ctx->fletfp;
00101   while (ffp!=NULL) {
00102     if (ffp->name==f) {  return(ffp->fclosure);}
00103     else ffp=ffp->lexlink;}
00104   if (f->c.sym.spefunc==UNBOUND) error(E_UNDEF,f);
00105   else {        /*global function definition is taken, context changes*/
00106     return(f->c.sym.spefunc);}}
00107 
00108 /* called from compiled code*/
00109 pointer get_sym_func(s)
00110 pointer s;
00111 { register pointer f;
00112   if ((f=s->c.sym.spefunc)==UNBOUND) error(E_UNDEF,s);
00113   else return(f);}
00114 
00115 
00116 void setfunc(sym,func)
00117 register pointer sym,func;
00118 { pointer_update(sym->c.sym.spefunc,func);}
00119 
00120 pointer *ovafptr(o,v)
00121 register pointer o,v;
00122 { register pointer c,*vaddr;
00123   if (!ispointer(o)) error(E_NOOBJ,o,v);
00124   c=classof(o);
00125   vaddr=getobjv(v,c->c.cls.vars,o);
00126   if (vaddr) return(vaddr);
00127   else error(E_NOOBJVAR,o,v);}
00128 
00129 /***** special variable binding *****/
00130 
00131 void bindspecial(ctx,sym,newval)
00132 register context *ctx;
00133 pointer sym,newval;
00134 { register struct specialbindframe *sbf=(struct specialbindframe *)(ctx->vsp);
00135   int vt;
00136   GC_POINT;
00137   vt=intval(sym->c.sym.vtype);
00138   ctx->vsp += (sizeof(struct specialbindframe)/sizeof(pointer));
00139   sbf->sblink=ctx->sbindfp;
00140   sbf->sym=sym;
00141 
00142   if (sym->c.sym.vtype==V_GLOBAL){
00143     sbf->oldval=speval(sym); speval(sym)=newval;}
00144   else { sbf->oldval=spevalof(sym,vt);  spevalof(sym,vt)=newval;}
00145 
00146   ctx->sbindfp=sbf;
00147   ctx->special_bind_count++;}
00148 
00149 /* called by compiled code */
00150 void unbindx(ctx,count)
00151 register context *ctx;
00152 register int count;
00153 { register pointer s;
00154   register struct specialbindframe *sbfp=ctx->sbindfp;
00155   if (ctx->special_bind_count<count) error(E_USER,(pointer)"inconsistent special binding");
00156   ctx->special_bind_count -= count;
00157   while (count-- >0) {
00158     s=sbfp->sym;
00159     /***/
00160    if (s->c.sym.vtype==V_GLOBAL) {pointer_update(speval(s),sbfp->oldval);}
00161    else pointer_update(Spevalof(s),sbfp->oldval); 
00162     sbfp=sbfp->sblink;}
00163   ctx->sbindfp=sbfp;}
00164 
00165 void unbindspecial(ctx,limit)
00166 register context *ctx;
00167 register struct specialbindframe *limit;
00168 { register pointer s;
00169   register struct specialbindframe *sbfp=ctx->sbindfp;
00170   if (sbfp) {
00171     while (limit<=sbfp) {       /* < is harmful to unwind in eus.c */
00172       s=sbfp->sym;
00173       /***/
00174       if (s->c.sym.vtype==V_GLOBAL) {pointer_update(speval(s),sbfp->oldval);}
00175       else pointer_update(Spevalof(s),sbfp->oldval);
00176       sbfp=sbfp->sblink;
00177       ctx->special_bind_count--;}
00178     ctx->sbindfp=sbfp;}}
00179 
00180 struct bindframe *fastbind(ctx,var,val,lex)
00181 register context *ctx;
00182 register pointer var,val;
00183 struct bindframe *lex;
00184 { register struct bindframe *bf;
00185   bf=(struct bindframe *)(ctx->vsp);
00186   ctx->vsp += sizeof(struct bindframe)/sizeof(eusinteger_t);
00187   bf->lexblink=lex;
00188   bf->dynblink=ctx->bindfp;
00189   bf->sym=var;
00190   bf->val=val;
00191   ctx->bindfp=bf;       /*update bindfp*/
00192   return(bf);    }
00193 
00194 struct bindframe *vbind(ctx,var,val,lex,declscope)
00195 register context *ctx;
00196 register pointer var,val;
00197 struct bindframe *lex,*declscope;
00198 { register struct bindframe *p;
00199   if (!issymbol(var)) error(E_NOSYMBOL);
00200   if (var->c.sym.vtype==V_CONSTANT) error(E_NOVARIABLE,var);
00201   p=ctx->bindfp;
00202   while (p>declscope) {
00203     if (p->sym==var) 
00204       if (p->val==UNBOUND) { bindspecial(ctx,var,val); return(ctx->bindfp);}
00205       else error(E_MULTIDECL);
00206     if (p==p->lexblink) break;
00207     p=p->lexblink;}
00208   /*not found in declare scope*/
00209   if (var->c.sym.vtype>= /* V_SPECIAL */  V_GLOBAL ) {
00210         /* For defun-c-callable in eusforeign.l to create a foreign-pod,
00211                 global value of SYMBOL must be replaced with FOREIGN-POD
00212                 by let binding.  Since SYMBOL is V_GLOBAL, special binding
00213                 (global binding) must be made for V_GLOBAL.  Proclaiming
00214                 symbol as SPECIAL is no use, since INTERN does not refer
00215                 thread local binding. */                
00216     bindspecial(ctx,var,val);
00217     return(ctx->bindfp);}
00218   return(fastbind(ctx,var,val,lex));}
00219 
00220 struct bindframe *declare(ctx,decllist,env)
00221 register context *ctx;
00222 pointer decllist;
00223 struct bindframe *env;
00224 { register pointer decl,var;
00225 
00226   while (iscons(decllist)) {
00227     decl=ccar(decllist); decllist=ccdr(decllist);
00228     if (!iscons(decl)) error(E_DECLARE);
00229     if (ccar(decl)==QSPECIAL) { /*special binding*/
00230       decl=ccdr(decl);
00231       while (iscons(decl)) {
00232         var=ccar(decl);
00233         if (var->c.sym.vtype < V_SPECIAL) env=vbind(ctx,var,UNBOUND,env,ctx->bindfp);
00234         decl=ccdr(decl); } }  }
00235   return(env);}
00236 
00237 int parsekeyparams(keyvec,actuals,noarg,results,allowotherkeys)
00238  /*for compiled codes*/
00239 register pointer keyvec, *actuals, *results;
00240 int noarg,allowotherkeys;
00241 { register int i=0,n=0,suppliedbits=0,keysize, bitpos;
00242   register pointer akeyvar, *keys;
00243   
00244   if (noarg<=0) return(suppliedbits);
00245   if (noarg & 1) error(E_KEYPARAM);
00246   keysize=vecsize(keyvec);
00247   for (i=0; i<keysize; i++) {
00248 #ifdef SAFETY
00249       take_care(results[i]);
00250 #endif
00251       results[i]=NIL;
00252   }
00253   while (n<noarg) {
00254     akeyvar=actuals[n++];
00255     if (!issymbol(akeyvar)) error(E_KEYPARAM);
00256     if (akeyvar->c.sym.homepkg!=keywordpkg) error(E_KEYPARAM);
00257     i=0;        /*search for keyword*/
00258     keys=keyvec->c.vec.v;
00259     if (akeyvar==K_ALLOWOTHERKEYS) allowotherkeys=(actuals[n]!=NIL);
00260     while (i<keysize && keys[i]!=akeyvar) i++;
00261     if (i<keysize) {    /*keyword found*/
00262       bitpos = 1<<i;
00263       if ((suppliedbits & bitpos) ==0) {        /*already supplied-->ignore*/
00264         pointer_update(results[i],actuals[n]);
00265         suppliedbits |= bitpos;} }
00266     else if (!allowotherkeys) error(E_NOKEYPARAM,akeyvar);
00267     n++;} 
00268   return(suppliedbits);}
00269 
00270 struct bindframe *bindkeyparams(ctx,formal,argp,noarg,env,bf)
00271 register context *ctx;
00272 pointer formal;
00273 pointer *argp;
00274 int noarg;
00275 struct bindframe *env,*bf;
00276 { pointer fvar,initform;
00277   register pointer fkeyvar,akeyvar;
00278   pointer keys[KEYWORDPARAMETERLIMIT],
00279           vars[KEYWORDPARAMETERLIMIT],
00280           inits[KEYWORDPARAMETERLIMIT];
00281   register int nokeys=0,i,n,allowotherkeys=0;
00282 
00283   /*parse lambda list and make keyword tables*/
00284   while (iscons(formal)) {
00285       fkeyvar=ccar(formal); formal=ccdr(formal);
00286       if (iscons(fkeyvar)) {
00287         fvar=ccar(fkeyvar);
00288         initform=ccdr(fkeyvar);
00289         if (iscons(initform)) initform=ccar(initform); else initform=NIL;
00290         if (iscons(fvar)) {
00291           fkeyvar=ccar(fvar); fvar=ccdr(fvar);
00292           if (!iscons(fvar)) error(E_KEYPARAM);
00293           fvar=ccar(fvar);
00294           if (!issymbol(fkeyvar)) error(E_NOSYMBOL);
00295           if (fkeyvar->c.sym.homepkg!=keywordpkg) error(E_KEYPARAM);}
00296         else {
00297           if (!issymbol(fvar)) error(E_NOSYMBOL);
00298           fkeyvar=fvar->c.sym.pname;
00299           fkeyvar=intern(ctx,(char *)fkeyvar->c.str.chars,
00300                                 vecsize(fkeyvar),keywordpkg);}}
00301       else if (fkeyvar==ALLOWOTHERKEYS) {
00302         allowotherkeys=1;
00303         if (islist(formal)) {
00304           fkeyvar=ccar(formal); formal=ccdr(formal);
00305           if (fkeyvar==AUX) break;
00306           else  error(E_USER,(pointer)"something after &allow-other-keys"); }
00307         break;}
00308       else if (fkeyvar==AUX) break;
00309       else {
00310         initform=NIL;
00311         fvar=fkeyvar;
00312         if (!issymbol(fvar)) error(E_NOSYMBOL);
00313         fkeyvar=fvar->c.sym.pname;
00314         fkeyvar=intern(ctx,(char *)fkeyvar->c.str.chars,
00315                                 vecsize(fkeyvar),keywordpkg);}
00316       
00317       keys[nokeys]=fkeyvar;
00318       vars[nokeys]=fvar;
00319       inits[nokeys]=initform;
00320       nokeys++;
00321       if (nokeys>=KEYWORDPARAMETERLIMIT) {
00322         error(E_USER, "Too many keyword parameters >32"); 
00323         }
00324       } 
00325   n=0;
00326   while (n<noarg) {
00327       akeyvar=argp[n++];
00328       if (!issymbol(akeyvar)) error(E_KEYPARAM);
00329       if (akeyvar->c.sym.homepkg!=keywordpkg) error(E_KEYPARAM);
00330       if (akeyvar==K_ALLOWOTHERKEYS) allowotherkeys=(argp[n]!=NIL);
00331       i=0;      /*search for keyword*/
00332       while (i<nokeys && keys[i]!=akeyvar) i++;
00333       if (n>=noarg) error(E_KEYPARAM);  /*not paired*/
00334       if (i<nokeys) {
00335         if (inits[i]!=UNBOUND) {
00336           env=vbind(ctx,vars[i],argp[n],env,bf);
00337           inits[i]=UNBOUND;} }
00338       else if (!allowotherkeys) error(E_NOKEYPARAM,akeyvar);
00339       n++;  }
00340   i=0;
00341   while (i<nokeys) {
00342     if (inits[i]!=UNBOUND) env=vbind(ctx,vars[i],eval(ctx,inits[i]),env,bf);
00343     i++;}
00344   return(env);}
00345 
00346 pointer funlambda(ctx,fn,formal,body,argp,env,noarg)
00347 register context *ctx;
00348 pointer fn,formal,body,*argp;
00349 struct bindframe *env;
00350 int noarg;
00351 { pointer ftype,fvar,result,decl,aval,initform,fkeyvar,akeyvar;
00352   pointer *vspsave= ctx->vsp;
00353   struct specialbindframe *sbfps=ctx->sbindfp;
00354   struct bindframe *bf=ctx->bindfp;
00355   struct blockframe *myblock;
00356   int n=0,keyno=0,i;
00357   jmp_buf funjmp;
00358 
00359     ctx->bindfp=env;   /*****?????*****/
00360 
00361     /*declaration*/
00362     while (iscons(body)) {
00363       decl=ccar(body);
00364       if (!iscons(decl) || (ccar(decl)!=QDECLARE)) break;
00365       env=declare(ctx,ccdr(decl),env);
00366       body=ccdr(body); GC_POINT;}
00367 
00368     /* make a new bind frame */
00369     while (iscons(formal)) {
00370       fvar=ccar(formal); formal=ccdr(formal);
00371       if (fvar==OPTIONAL) goto bindopt;
00372       if (fvar==REST) goto bindrest;
00373       if (fvar==KEY) { keyno=n; goto bindkey;}
00374       if (fvar==AUX) goto bindaux;
00375       if (n>=noarg) error(E_MISMATCHARG);
00376       env=vbind(ctx,fvar,argp[n],env,bf);
00377       n++;}
00378     if (n!=noarg) error(E_MISMATCHARG);
00379     goto evbody;
00380 bindopt:
00381     while (iscons(formal)) {
00382       fvar=ccar(formal); formal=ccdr(formal);   /*take one formal*/
00383       if (fvar==REST) goto bindrest;
00384       if (fvar==KEY) { keyno=n; goto bindkey;}
00385       if (fvar==AUX) goto bindaux;
00386       if (n<noarg) { /*an actual arg is supplied*/
00387         aval=argp[n];
00388         if (iscons(fvar)) fvar=ccar(fvar);}
00389       else if (iscons(fvar)) {
00390         initform=ccdr(fvar);
00391         fvar=ccar(fvar);
00392         if (iscons(initform)) {GC_POINT;aval=eval(ctx,ccar(initform));}
00393         else aval=NIL;}
00394       else aval=NIL;
00395       env=vbind(ctx,fvar,aval,env,bf);
00396       n++;}
00397     if (n<noarg) error(E_MISMATCHARG);
00398     goto evbody;
00399 bindrest:
00400     keyno=n;
00401     fvar=carof(formal,E_PARAMETER);
00402     formal=ccdr(formal);
00403     /*list up all rest arguments*/
00404     result=NIL;
00405     i=noarg;
00406     while (n<i) result=cons(ctx,argp[--i],result);
00407     env=vbind(ctx,fvar,result,env,bf);
00408     n++;
00409     if (!iscons(formal)) goto evbody;
00410     fvar=ccar(formal); formal=ccdr(formal);
00411     if (fvar==KEY) goto bindkey;
00412     else if (fvar==AUX) goto bindaux;
00413     else error(E_PARAMETER);
00414 bindkey:
00415     env=bindkeyparams(ctx,formal,&argp[keyno],noarg-keyno,env,bf);
00416     while (iscons(formal)) {
00417       fvar=ccar(formal);  formal=ccdr(formal);
00418       if (fvar==AUX) goto bindaux;}
00419     goto evbody;
00420 bindaux:
00421     while (iscons(formal)) {
00422       fvar=ccar(formal); formal=ccdr(formal);
00423       if (iscons(fvar)) {
00424         initform=ccdr(fvar);
00425         fvar=ccar(fvar);
00426         if (iscons(initform)) {GC_POINT;aval=eval(ctx,ccar(initform));}
00427         else aval=NIL;}
00428       else aval=NIL;
00429       env=vbind(ctx,fvar,aval,env,bf); }
00430 evbody:
00431     GC_POINT;
00432     /*create block around lambda*/
00433     myblock=(struct blockframe *)makeblock(ctx,BLOCKFRAME,fn,(jmp_buf *)funjmp,NULL);
00434     /*evaluate body*/
00435     if ((result=(pointer)eussetjmp(funjmp))==0) {GC_POINT;result=progn(ctx,body);}
00436     else if (result==(pointer)1) result=makeint(0);
00437     /*end of body evaluation: clean up stack frames*/
00438     ctx->blkfp=myblock->dynklink;
00439     ctx->bindfp=bf;
00440     ctx->vsp=vspsave;
00441 
00442 #ifdef __RETURN_BARRIER
00443     check_return_barrier(ctx);
00444     /* check return barrier */
00445 #endif
00446 /*    unbindspecial(ctx,(struct specialbindframe *)ctx->vsp); */
00447     unbindspecial(ctx,sbfps+1);
00448     return(result);}
00449 
00450 #if IRIX6
00451 
00452 #include <alloca.h>
00453 
00454 extern long   i_call_foreign(eusinteger_t (*)(),int,numunion *);
00455 extern double f_call_foreign(eusinteger_t (*)(),int,numunion *);
00456 
00457 pointer call_foreign(func,code,n,args)
00458 eusinteger_t (*func)();
00459 pointer code;
00460 int n;
00461 pointer args[];
00462 { pointer paramtypes=code->c.fcode.paramtypes;
00463   pointer resulttype=code->c.fcode.resulttype;
00464   pointer p,lisparg;
00465   numunion nu,*cargv;
00466   eusinteger_t i=0;
00467   double f;
00468 
00469   cargv=(numunion *)alloca(n*sizeof(numunion));
00470   while (iscons(paramtypes)) {
00471     p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
00472     lisparg=args[i];
00473     if (p==K_INTEGER)
00474         cargv[i++].ival=isint(lisparg)?intval(lisparg):bigintval(lisparg);
00475     else if (p==K_FLOAT) cargv[i++].fval=ckfltval(lisparg);
00476     else if (p==K_STRING)
00477       if (elmtypeof(lisparg)==ELM_FOREIGN)
00478         cargv[i++].ival=lisparg->c.ivec.iv[0];
00479       else cargv[i++].ival=(eusinteger_t)(lisparg->c.str.chars);
00480     else error(E_USER,(pointer)"unknown type specifier");}
00481   /* &rest arguments?  */
00482   while (i<n) { /* i is the counter for the actual arguments*/
00483     lisparg=args[i];
00484     if (isint(lisparg)) cargv[i++].ival=intval(lisparg);
00485     else if (isflt(lisparg)) cargv[i++].fval=ckfltval(lisparg);
00486     else if (isvector(lisparg)) {
00487       if (elmtypeof(lisparg)==ELM_FOREIGN)
00488         cargv[i++].ival=lisparg->c.ivec.iv[0];
00489       else cargv[i++].ival=(eusinteger_t)(lisparg->c.str.chars);}
00490     else cargv[i++].ival=(eusinteger_t)(lisparg->c.obj.iv);}
00491   
00492   if (resulttype==K_FLOAT) return(makeflt(f_call_foreign(func,n,cargv)));
00493   else {
00494     i=i_call_foreign(func,n,cargv);
00495     if (resulttype==K_INTEGER) return(mkbigint(i));
00496     else if (resulttype==K_STRING) {
00497       p=makepointer(i-2*sizeof(pointer));
00498       if (isvector(p)) return(p);
00499       else error(E_USER,(pointer)"illegal foreign string"); }
00500     else if (iscons(resulttype)) {
00501         /* (:string [10]) (:foreign-string [20]) */
00502       if (ccar(resulttype)==K_STRING) {
00503         resulttype=ccdr(resulttype);
00504         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
00505         else j=strlen((char *)i);
00506         return(makestring((char *)i, j)); }
00507       else if (ccar(resulttype)==K_FOREIGN_STRING) {
00508         resulttype=ccdr(resulttype);
00509         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
00510         else j=strlen((char *)i);
00511         return(make_foreign_string(i, j)); }
00512       error(E_USER,(pointer)"unknown result type"); }
00513     else error(E_USER,(pointer)"result type?"); 
00514     }}
00515 
00516 #else /* IRIX6 */
00517 
00518 #if IRIX
00519 
00520 #include <alloca.h>
00521 
00522 extern int    i_call_foreign(eusinteger_t (*)(),int,int *);
00523 extern double f_call_foreign(eusinteger_t (*)(),int,int *);
00524 
00525 pointer call_foreign(func,code,n,args)
00526 eusinteger_t (*func)();
00527 pointer code;
00528 int n;
00529 pointer args[];
00530 { pointer paramtypes=code->c.fcode.paramtypes;
00531   pointer resulttype=code->c.fcode.resulttype;
00532   pointer p,lisparg;
00533   numunion nu,*cargs;
00534   eusinteger_t i=0;
00535   unsigned int *offset,*isfloat,m=0;
00536   int *cargv;
00537   union {
00538     double d;
00539     struct {
00540       int i1,i2;} i;
00541     } numbox;
00542   double f;
00543 
00544   cargs=(numunion *)alloca(n*sizeof(numunion));
00545   offset=(unsigned int *)alloca(n*sizeof(unsigned int));
00546   isfloat=(unsigned int *)alloca(n*sizeof(unsigned int));
00547   while (iscons(paramtypes)) {
00548     p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
00549     lisparg=args[i];
00550     if (isfloat[i]=(p==K_FLOAT)) {
00551       cargs[i].fval=ckfltval(lisparg);
00552       offset[i]=(m+1)&~1; m=offset[i++]+2;}
00553     else if (p==K_INTEGER) {
00554       cargs[i++].ival=isint(lisparg)?intval(lisparg):bigintval(lisparg);
00555       offset[i++]=m++;}
00556     else if (p==K_STRING) {
00557       if (elmtypeof(lisparg)==ELM_FOREIGN)
00558         cargs[i].ival=lisparg->c.ivec.iv[0];
00559       else cargs[i].ival=(eusinteger_t)(lisparg->c.str.chars);
00560       offset[i++]=m++;}
00561     else error(E_USER,(pointer)"unknown type specifier");}
00562   /* &rest arguments?  */
00563   while (i<n) { /* i is the counter for the actual arguments*/
00564     lisparg=args[i];
00565     if (isfloat[i]=isflt(lisparg)) {
00566       cargs[i].fval=ckfltval(lisparg);
00567       offset[i]=(m+1)&~1; m=offset[i++]+2;}
00568     else if (isint(lisparg)) {
00569       cargs[i].ival=intval(lisparg);
00570       offset[i++]=m++;}
00571     else if (isvector(lisparg)) {
00572       if (elmtypeof(lisparg)==ELM_FOREIGN)
00573         cargs[i].ival=lisparg->c.ivec.iv[0];
00574       else cargs[i].ival=(eusinteger_t)(lisparg->c.str.chars);
00575       offset[i++]=m++;}
00576     else {
00577       cargs[i++].ival=(eusinteger_t)(lisparg->c.obj.iv);
00578       offset[i++]=m++;}}
00579   cargv=(int *)alloca(m*sizeof(int));
00580   for (i=0; i<n; ++i) {
00581     if (isfloat[i]) {
00582       numbox.d=(double)cargs[i].fval;
00583       cargv[offset[i]]=numbox.i.i1; cargv[offset[i]+1]=numbox.i.i2;}
00584     else cargv[offset[i]]=cargs[i].ival;}
00585   
00586   if (resulttype==K_FLOAT) return(makeflt(f_call_foreign(func,m,cargv)));
00587   else {
00588     i=i_call_foreign(func,m,cargv);
00589     if (resulttype==K_INTEGER) return(mkbigint(i));
00590     else if (resulttype==K_STRING) {
00591       p=makepointer(i-2*sizeof(pointer));
00592       if (isvector(p)) return(p);
00593       else error(E_USER,(pointer)"illegal foreign string"); }
00594     else if (iscons(resulttype)) {
00595         /* (:string [10]) (:foreign-string [20]) */
00596       if (ccar(resulttype)=K_STRING) {
00597         resulttype=ccdr(resulttype);
00598         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
00599         else j=strlen((char *)i);
00600         return(makestring((char *)i, j)); }
00601       else if (ccar(resulttype)=K_FOREIGN_STRING) {
00602         resulttype=ccdr(resulttype);
00603         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
00604         else j=strlen((char *)i);
00605         return(make_foreign_string(i, j)); }
00606       error(E_USER,(pointer)"unknown result type"); }
00607     else error(E_USER,(pointer)"result type?"); 
00608     }}
00609 
00610 #else /* IRIX */
00611 
00612 /* not IRIS */
00613 #if (defined(x86_64) || defined(aarch64))
00614 extern long exec_function_i(void (*)(), long *, long *, long, long *);
00615 extern long exec_function_f(void (*)(), long *, long *, long, long *);
00616 
00617 #if x86_64
00618 // func  %rdi
00619 // iargv %rsi
00620 // fargv %rdx
00621 // vargc %rcx
00622 // vargv %r8
00623 __asm__ (".align 8\n"
00624 #if Darwin
00625          "_exec_function_i:\n\t"
00626 #else
00627          "exec_function_i:\n\t"
00628 #endif
00629          "push %rbx\n\t"
00630          "sub  $0x120, %rsp\n\t"
00631          "mov %rdx, %rax\n\t"
00632          "movsd 0x00(%rax), %xmm0\n\t"
00633          "movsd 0x08(%rax), %xmm1\n\t"
00634          "movsd 0x10(%rax), %xmm2\n\t"
00635          "movsd 0x18(%rax), %xmm3\n\t"
00636          "movsd 0x20(%rax), %xmm4\n\t"
00637          "movsd 0x28(%rax), %xmm5\n\t"
00638          "movsd 0x30(%rax), %xmm6\n\t"
00639          "movsd 0x38(%rax), %xmm7\n\t"
00640          "mov %rsp, %rax\n\t"
00641          "mov  $0, %r10\n\t"
00642          "cmpl %ecx, %r10d\n\t"
00643          "jge  .LENDLP\n"
00644          ".LNEXTLP:\n\t"
00645          "mov (%r8), %rbx\n\t"
00646          "mov %rbx, (%rax)\n\t"
00647          "add  $8, %rax\n\t"
00648          "add  $8, %r8\n\t"
00649          "add  $1, %r10d\n\t"
00650          "cmpl %r10d, %ecx\n\t"
00651          "jg   .LNEXTLP\n"
00652          ".LENDLP:\n\t"
00653          "mov %rdi, %rbx\n\t"
00654          "mov %rsi, %rax\n\t"
00655          "mov 0x00(%rax), %rdi\n\t"
00656          "mov 0x08(%rax), %rsi\n\t"
00657          "mov 0x10(%rax), %rdx\n\t"
00658          "mov 0x18(%rax), %rcx\n\t"
00659          "mov 0x20(%rax), %r8\n\t"
00660          "mov 0x28(%rax), %r9\n\t"
00661          "mov $0x00, %eax\n\t"
00662          "call *%rbx\n\t"
00663          "add $0x120, %rsp\n\t"
00664          "pop %rbx\n\t"
00665          "retq"
00666          );
00667 __asm__ (".align 8\n"
00668 #if Darwin
00669          "_exec_function_f:\n\t"
00670 #else
00671          "exec_function_f:\n\t"
00672 #endif
00673          "push %rbx\n\t"
00674          "sub  $0x120, %rsp\n\t"
00675          "mov %rdx, %rax\n\t"
00676          "movsd 0x00(%rax), %xmm0\n\t"
00677          "movsd 0x08(%rax), %xmm1\n\t"
00678          "movsd 0x10(%rax), %xmm2\n\t"
00679          "movsd 0x18(%rax), %xmm3\n\t"
00680          "movsd 0x20(%rax), %xmm4\n\t"
00681          "movsd 0x28(%rax), %xmm5\n\t"
00682          "movsd 0x30(%rax), %xmm6\n\t"
00683          "movsd 0x38(%rax), %xmm7\n\t"
00684          "mov %rsp, %rax\n\t"
00685          "mov  $0, %r10\n\t"
00686          "cmpl %ecx, %r10d\n\t"
00687          "jge  .LENDLPF\n"
00688          ".LNEXTLPF:\n\t"
00689          "mov (%r8), %rbx\n\t"
00690          "mov %rbx, (%rax)\n\t"
00691          "add  $8, %rax\n\t"
00692          "add  $8, %r8\n\t"
00693          "add  $1, %r10d\n\t"
00694          "cmpl %r10d, %ecx\n\t"
00695          "jg   .LNEXTLPF\n"
00696          ".LENDLPF:\n\t"
00697          "mov %rdi, %rbx\n\t"
00698          "mov %rsi, %rax\n\t"
00699          "mov 0x00(%rax), %rdi\n\t"
00700          "mov 0x08(%rax), %rsi\n\t"
00701          "mov 0x10(%rax), %rdx\n\t"
00702          "mov 0x18(%rax), %rcx\n\t"
00703          "mov 0x20(%rax), %r8\n\t"
00704          "mov 0x28(%rax), %r9\n\t"
00705          "mov $0x00, %eax\n\t"
00706          "call *%rbx\n\t"
00707          "movsd %xmm0, (%rsp)\n\t"
00708          "mov   (%rsp), %rax\n\t"
00709          "add $0x120, %rsp\n\t"
00710          "pop %rbx\n\t"
00711          "retq"
00712          );
00713 #endif
00714 
00715 #if aarch64
00716 __asm__ (".align 8\n"
00717          "exec_function_i:\n\t"
00718          "sub   sp, sp, #192\n\t" // 128(8x16) + 64
00719          "stp   x29, x30, [sp, 128]\n\t"
00720          "add   x29, sp, 128\n\t"
00721          "str   x0, [x29, 56]\n\t" // fc
00722          "str   x1, [x29, 48]\n\t" // iargv
00723          "str   x2, [x29, 40]\n\t" // fargv
00724          "str   x3, [x29, 32]\n\t" // vargc
00725          "str   x4, [x29, 24]\n\t" // vargv
00726          // vargv -> stack
00727          "mov   x1, 0\n\t"
00728          "ldr   x2, [x29, 24]\n\t"
00729          "b     .FUNCII_LPCK\n\t"
00730          ".FUNCII_LP:\n\t"
00731          "lsl   x0, x1, 3\n\t"
00732          "add   x3, x2, x0\n\t" // vargv[i]
00733          "add   x4, sp, x0\n\t" // stack[i]
00734          "ldr   x0, [x3]\n\t"
00735          "str   x0, [x4]\n\t" // push stack
00736          "add   x1, x1, 1\n\t"
00737          ".FUNCII_LPCK:\n\t"
00738          "ldr   x5, [x29, 32]\n\t"
00739          "cmp   x1, x5\n\t"
00740          "blt   .FUNCII_LP\n\t"
00741          // fargv -> register
00742          "ldr   x0, [x29, 40]\n\t" // fargv
00743          "ldr   d0, [x0]\n\t"
00744          "add   x0, x0, 8\n\t"
00745          "ldr   d1, [x0]\n\t"
00746          "add   x0, x0, 8\n\t"
00747          "ldr   d2, [x0]\n\t"
00748          "add   x0, x0, 8\n\t"
00749          "ldr   d3, [x0]\n\t"
00750          "add   x0, x0, 8\n\t"
00751          "ldr   d4, [x0]\n\t"
00752          "add   x0, x0, 8\n\t"
00753          "ldr   d5, [x0]\n\t"
00754          "add   x0, x0, 8\n\t"
00755          "ldr   d6, [x0]\n\t"
00756          "add   x0, x0, 8\n\t"
00757          "ldr   d7, [x0]\n\t"
00758          // iargv -> register
00759          "ldr   x0, [x29, 48]\n\t" // iargv
00760          "ldr   x9, [x0]\n\t"
00761          "add   x0, x0, 8\n\t"
00762          "ldr   x1, [x0]\n\t"
00763          "add   x0, x0, 8\n\t"
00764          "ldr   x2, [x0]\n\t"
00765          "add   x0, x0, 8\n\t"
00766          "ldr   x3, [x0]\n\t"
00767          "add   x0, x0, 8\n\t"
00768          "ldr   x4, [x0]\n\t"
00769          "add   x0, x0, 8\n\t"
00770          "ldr   x5, [x0]\n\t"
00771          "add   x0, x0, 8\n\t"
00772          "ldr   x6, [x0]\n\t"
00773          "add   x0, x0, 8\n\t"
00774          "ldr   x7, [x0]\n\t"
00775          // function call
00776          "ldr   x8, [x29, 56]\n\t"
00777          "mov   x0, x9\n\t"
00778          "blr   x8\n\t"
00779          "add   sp, x29, 0\n\t"
00780          "ldp   x29, x30, [sp], 64\n\t"
00781          "ret"
00782          );
00783 
00784 __asm__ (".align 8\n"
00785          "exec_function_f:\n\t"
00786          "sub   sp, sp, #192\n\t" // 128(8x16) + 64
00787          "stp   x29, x30, [sp, 128]\n\t"
00788          "add   x29, sp, 128\n\t"
00789          "str   x0, [x29, 56]\n\t" // fc
00790          "str   x1, [x29, 48]\n\t" // iargv
00791          "str   x2, [x29, 40]\n\t" // fargv
00792          "str   x3, [x29, 32]\n\t" // vargc
00793          "str   x4, [x29, 24]\n\t" // vargv
00794          // vargv -> stack
00795          "mov   x1, 0\n\t"
00796          "ldr   x2, [x29, 24]\n\t"
00797          "b     .FUNCFF_LPCK\n\t"
00798          ".FUNCFF_LP:\n\t"
00799          "lsl   x0, x1, 3\n\t"
00800          "add   x3, x2, x0\n\t" // vargv[i]
00801          "add   x4, sp, x0\n\t" // stack[i]
00802          "ldr   x0, [x3]\n\t"
00803          "str   x0, [x4]\n\t" // push stack
00804          "add   x1, x1, 1\n\t"
00805          ".FUNCFF_LPCK:\n\t"
00806          "ldr   x5, [x29, 32]\n\t"
00807          "cmp   x1, x5\n\t"
00808          "blt   .FUNCFF_LP\n\t"
00809          // fargv -> register
00810          "ldr   x0, [x29, 40]\n\t" // fargv
00811          "ldr   d0, [x0]\n\t"
00812          "add   x0, x0, 8\n\t"
00813          "ldr   d1, [x0]\n\t"
00814          "add   x0, x0, 8\n\t"
00815          "ldr   d2, [x0]\n\t"
00816          "add   x0, x0, 8\n\t"
00817          "ldr   d3, [x0]\n\t"
00818          "add   x0, x0, 8\n\t"
00819          "ldr   d4, [x0]\n\t"
00820          "add   x0, x0, 8\n\t"
00821          "ldr   d5, [x0]\n\t"
00822          "add   x0, x0, 8\n\t"
00823          "ldr   d6, [x0]\n\t"
00824          "add   x0, x0, 8\n\t"
00825          "ldr   d7, [x0]\n\t"
00826          // iargv -> register
00827          "ldr   x0, [x29, 48]\n\t" // iargv
00828          "ldr   x9, [x0]\n\t"
00829          "add   x0, x0, 8\n\t"
00830          "ldr   x1, [x0]\n\t"
00831          "add   x0, x0, 8\n\t"
00832          "ldr   x2, [x0]\n\t"
00833          "add   x0, x0, 8\n\t"
00834          "ldr   x3, [x0]\n\t"
00835          "add   x0, x0, 8\n\t"
00836          "ldr   x4, [x0]\n\t"
00837          "add   x0, x0, 8\n\t"
00838          "ldr   x5, [x0]\n\t"
00839          "add   x0, x0, 8\n\t"
00840          "ldr   x6, [x0]\n\t"
00841          "add   x0, x0, 8\n\t"
00842          "ldr   x7, [x0]\n\t"
00843          // function call
00844          "ldr   x8, [x29, 56]\n\t"
00845          "mov   x0, x9\n\t"
00846          "blr   x8\n\t"
00847          "str   d0, [x29, 56]\n\t"
00848          "ldr   x0, [x29, 56]\n\t"
00849          "add   sp, x29, 0\n\t"
00850          "ldp   x29, x30, [sp], 64\n\t"
00851          "ret"
00852          );
00853 #endif
00854 
00855 #if x86_64
00856 #define NUM_INT_ARGUMENTS 6
00857 #define NUM_FLT_ARGUMENTS 8
00858 #define NUM_EXTRA_ARGUMENTS 16
00859 #elif aarch64
00860 #define NUM_INT_ARGUMENTS 8
00861 #define NUM_FLT_ARGUMENTS 8
00862 #define NUM_EXTRA_ARGUMENTS 16
00863 #endif
00864 
00865 pointer call_foreign(ifunc,code,n,args)
00866 eusinteger_t (*ifunc)(); /* ???? */
00867 pointer code;
00868 int n;
00869 pointer args[];
00870 {   
00871   pointer paramtypes=code->c.fcode.paramtypes;
00872   pointer resulttype=code->c.fcode.resulttype;
00873   pointer p,lisparg;
00874   eusinteger_t iargv[NUM_INT_ARGUMENTS];
00875   eusinteger_t fargv[NUM_FLT_ARGUMENTS];
00876   eusinteger_t vargv[NUM_EXTRA_ARGUMENTS];
00877   int icntr = 0, fcntr = 0, vcntr = 0;
00878 
00879   numunion nu;
00880   eusinteger_t j=0; /*lisp argument counter*//* ???? */
00881   eusinteger_t c=0;
00882   union {
00883     double d;
00884     float f;
00885     long l;
00886     struct {
00887       int i1,i2;} i;
00888     } numbox;
00889   double f;
00890 
00891   if (code->c.fcode.entry2 != NIL) {
00892     ifunc = (((eusinteger_t)ifunc)&0xffffffff00000000) 
00893       | (intval(code->c.fcode.entry2)&0x00000000ffffffff);
00894     /* R.Hanai 090726 */
00895   }
00896   
00897   while (iscons(paramtypes)) {
00898     p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
00899     lisparg=args[j++];
00900     if (p==K_INTEGER) {
00901       c = isint(lisparg)?intval(lisparg):bigintval(lisparg); 
00902       if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
00903     }  else if (p==K_STRING) {
00904       if (elmtypeof(lisparg)==ELM_FOREIGN) c=lisparg->c.ivec.iv[0];
00905       else  c=(eusinteger_t)(lisparg->c.str.chars);
00906       if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
00907     } else if (p==K_FLOAT32) {
00908       numbox.f=(float)ckfltval(lisparg);
00909       c=((eusinteger_t)numbox.i.i1) & 0x00000000FFFFFFFF;
00910       if(fcntr < NUM_FLT_ARGUMENTS) fargv[fcntr++] = c; else vargv[vcntr++] = c;
00911     } else if (p==K_DOUBLE || p==K_FLOAT) {
00912       numbox.d=ckfltval(lisparg);
00913       c=numbox.l;
00914       if(fcntr < NUM_FLT_ARGUMENTS) fargv[fcntr++] = c; else vargv[vcntr++] = c;
00915     } else error(E_USER,(pointer)"unknown type specifier");
00916     if (vcntr >= NUM_EXTRA_ARGUMENTS) {
00917       error(E_USER,(pointer)"too many number of arguments");
00918     }
00919   }
00920   /* &rest arguments?  */
00921   while (j<n) { /* j is the counter for the actual arguments*/
00922     lisparg=args[j++];
00923     if (isint(lisparg)) {
00924       c=intval(lisparg);
00925       if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
00926     } else if (isflt(lisparg)) {
00927       numbox.d=ckfltval(lisparg);       /* i advances independently */
00928       c=numbox.l;
00929       if(fcntr < NUM_FLT_ARGUMENTS) fargv[fcntr++] = c; else vargv[vcntr++] = c;
00930     } else if (isvector(lisparg)) {
00931       if (elmtypeof(lisparg)==ELM_FOREIGN) c=lisparg->c.ivec.iv[0];
00932       else c=(eusinteger_t)(lisparg->c.str.chars); 
00933       if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
00934     } else if (isbignum(lisparg)){
00935       if (bigsize(lisparg)==1){
00936         eusinteger_t *xv = bigvec(lisparg);
00937         c=(eusinteger_t)xv[0];
00938         if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
00939       }else{
00940         fprintf(stderr, "bignum size!=1\n");
00941       }
00942     } else {
00943       c=(eusinteger_t)(lisparg->c.obj.iv);
00944       if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
00945     }
00946     if (vcntr >= NUM_EXTRA_ARGUMENTS) {
00947       error(E_USER,(pointer)"too many number of arguments");
00948     }
00949   }
00950   
00951   if (resulttype==K_FLOAT) {
00952     numbox.l = exec_function_f((void (*)())ifunc, iargv, fargv, vcntr, vargv);
00953     f = numbox.d;
00954     return(makeflt(f));
00955   } else if (resulttype==K_FLOAT32) {
00956     numbox.l = exec_function_f((void (*)())ifunc, iargv, fargv, vcntr, vargv);
00957     f = (double)numbox.f;
00958     return(makeflt(f));
00959   } else {
00960     c = exec_function_i((void (*)())ifunc, iargv, fargv, vcntr, vargv);
00961     if (resulttype==K_INTEGER) {
00962       return(mkbigint(c));
00963     } else if (resulttype==K_STRING) {
00964       p=makepointer(c-2*sizeof(pointer));
00965       if (isvector(p)) return(p);
00966       else error(E_USER,(pointer)"illegal foreign string");
00967     } else if (iscons(resulttype)) {
00968       /* (:string [10]) (:foreign-string [20]) */
00969       if (ccar(resulttype)==K_STRING) { /* R.Hanai 09/07/25 */
00970         resulttype=ccdr(resulttype);
00971         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
00972         else j=strlen((char *)c);
00973         return(makestring((char *)c, j)); 
00974       } else if (ccar(resulttype)==K_FOREIGN_STRING) { /* R.Hanai 09/07/25 */
00975         resulttype=ccdr(resulttype);
00976         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
00977         else j=strlen((char *)c);
00978         return(make_foreign_string(c, j)); }
00979       error(E_USER,(pointer)"unknown result type"); 
00980     } else error(E_USER,(pointer)"result type?"); 
00981   }
00982 }
00983 #else /* not x86_64 */
00984 pointer call_foreign(ifunc,code,n,args)
00985 eusinteger_t (*ifunc)(); /* ???? */
00986 pointer code;
00987 int n;
00988 pointer args[];
00989 { double (*ffunc)();
00990   pointer paramtypes=code->c.fcode.paramtypes;
00991   pointer resulttype=code->c.fcode.resulttype;
00992   pointer p,lisparg;
00993   eusinteger_t cargv[100];
00994   numunion nu;
00995   eusinteger_t i=0; /*C argument counter*//* ???? */
00996   eusinteger_t j=0; /*lisp argument counter*//* ???? */
00997   union {
00998     double d;
00999     float f;
01000     struct {
01001       int i1,i2;} i;
01002     } numbox;
01003   double f;
01004   
01005   if (code->c.fcode.entry2 != NIL) {
01006 #if (WORD_SIZE == 64)
01007     ifunc = (((eusinteger_t)ifunc)&0xffffffff00000000) | (intval(code->c.fcode.entry2)&0x00000000ffffffff);
01008 #else
01009     ifunc = (((int)ifunc)&0xffff0000) | (intval(code->c.fcode.entry2)&0x0000ffff);    /* kanehiro's patch 2000.12.13 */
01010 #endif
01011   }
01012   ffunc=(double (*)())ifunc;
01013   while (iscons(paramtypes)) {
01014     p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
01015     lisparg=args[j++];
01016     if (p==K_INTEGER)
01017       cargv[i++]=isint(lisparg)?intval(lisparg):bigintval(lisparg);
01018     else if (p==K_STRING) {
01019       if (elmtypeof(lisparg)==ELM_FOREIGN) cargv[i++]=lisparg->c.ivec.iv[0];
01020       else  cargv[i++]=(eusinteger_t)(lisparg->c.str.chars);}
01021     else if (p==K_FLOAT32) {
01022       numbox.f=ckfltval(lisparg);
01023       cargv[i++]=(int)numbox.i.i1;}
01024     else if (p==K_DOUBLE || p==K_FLOAT) {
01025       numbox.d=ckfltval(lisparg);
01026       cargv[i++]=numbox.i.i1; cargv[i++]=numbox.i.i2;}
01027     else error(E_USER,(pointer)"unknown type specifier");}
01028   /* &rest arguments?  */
01029   while (j<n) { /* j is the counter for the actual arguments*/
01030     lisparg=args[j++];
01031     if (isint(lisparg)) cargv[i++]=intval(lisparg);
01032     else if (isflt(lisparg)) {
01033       numbox.d=ckfltval(lisparg);       /* i advances independently */
01034       numbox.f=ckfltval(lisparg);
01035       cargv[i++]=numbox.i.i1; cargv[i++]=numbox.i.i2;}
01036     else if (isvector(lisparg)) {
01037       if (elmtypeof(lisparg)==ELM_FOREIGN)
01038         cargv[i++]=lisparg->c.ivec.iv[0];
01039       else cargv[i++]=(eusinteger_t)(lisparg->c.str.chars);}
01040 #if 1    /* begin kanehiro's patch 2000.12.13 */
01041     else if (isbignum(lisparg)){
01042       if (bigsize(lisparg)==1){
01043         eusinteger_t *xv = bigvec(lisparg);
01044         cargv[i++]=(eusinteger_t)xv[0];
01045       }else{
01046         fprintf(stderr, "bignum size!=1\n");
01047       }
01048     }
01049 #endif    /* end of kanehiro's patch 2000.12.13 */
01050     else cargv[i++]=(eusinteger_t)(lisparg->c.obj.iv);}
01051   
01052   if (resulttype==K_FLOAT) {
01053     if (i<=8) 
01054       f=(*ffunc)(cargv[0],cargv[1],cargv[2],cargv[3],
01055                  cargv[4],cargv[5],cargv[6],cargv[7]);
01056     else if (i<=32)
01057       f=(*ffunc)(cargv[0],cargv[1],cargv[2],cargv[3],
01058                  cargv[4],cargv[5],cargv[6],cargv[7],
01059                  cargv[8],cargv[9],cargv[10],cargv[11],
01060                  cargv[12],cargv[13],cargv[14],cargv[15],
01061                  cargv[16],cargv[17],cargv[18],cargv[19],
01062                  cargv[20],cargv[21],cargv[22],cargv[23],
01063                  cargv[24],cargv[25],cargv[26],cargv[27],
01064                  cargv[28],cargv[29],cargv[30],cargv[31]);
01065 #if (sun3 || sun4 || mips || alpha)
01066     else if (i>32) 
01067       f=(*ffunc)(cargv[0],cargv[1],cargv[2],cargv[3],
01068                  cargv[4],cargv[5],cargv[6],cargv[7],
01069                  cargv[8],cargv[9],cargv[10],cargv[11],
01070                  cargv[12],cargv[13],cargv[14],cargv[15],
01071                  cargv[16],cargv[17],cargv[18],cargv[19],
01072                  cargv[20],cargv[21],cargv[22],cargv[23],
01073                  cargv[24],cargv[25],cargv[26],cargv[27],
01074                  cargv[28],cargv[29],cargv[30],cargv[31],
01075                  cargv[32],cargv[33],cargv[34],cargv[35],
01076                  cargv[36],cargv[37],cargv[38],cargv[39],
01077                  cargv[40],cargv[41],cargv[42],cargv[43],
01078                  cargv[44],cargv[45],cargv[46],cargv[47],
01079                  cargv[48],cargv[49],cargv[50],cargv[51],
01080                  cargv[52],cargv[53],cargv[54],cargv[55],
01081                  cargv[56],cargv[57],cargv[58],cargv[59],
01082                  cargv[60],cargv[61],cargv[62],cargv[63],
01083                  cargv[64],cargv[65],cargv[66],cargv[67],
01084                  cargv[68],cargv[69],cargv[70],cargv[71],
01085                  cargv[72],cargv[73],cargv[74],cargv[75],
01086                  cargv[76],cargv[77],cargv[78],cargv[79]);
01087 #endif
01088     return(makeflt(f));}
01089   else {
01090     if (i<8) 
01091       i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
01092                cargv[4],cargv[5],cargv[6],cargv[7]);
01093     else if (i<=32)
01094       i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
01095                  cargv[4],cargv[5],cargv[6],cargv[7],
01096                  cargv[8],cargv[9],cargv[10],cargv[11],
01097                  cargv[12],cargv[13],cargv[14],cargv[15],
01098                  cargv[16],cargv[17],cargv[18],cargv[19],
01099                  cargv[20],cargv[21],cargv[22],cargv[23],
01100                  cargv[24],cargv[25],cargv[26],cargv[27],
01101                  cargv[28],cargv[29],cargv[30],cargv[31]);
01102 #if (sun3 || sun4 || mips || alpha)
01103     else if (i>32) 
01104       i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
01105                  cargv[4],cargv[5],cargv[6],cargv[7],
01106                  cargv[8],cargv[9],cargv[10],cargv[11],
01107                  cargv[12],cargv[13],cargv[14],cargv[15],
01108                  cargv[16],cargv[17],cargv[18],cargv[19],
01109                  cargv[20],cargv[21],cargv[22],cargv[23],
01110                  cargv[24],cargv[25],cargv[26],cargv[27],
01111                  cargv[28],cargv[29],cargv[30],cargv[31],
01112                  cargv[32],cargv[33],cargv[34],cargv[35],
01113                  cargv[36],cargv[37],cargv[38],cargv[39],
01114                  cargv[40],cargv[41],cargv[42],cargv[43],
01115                  cargv[44],cargv[45],cargv[46],cargv[47],
01116                  cargv[48],cargv[49],cargv[50],cargv[51],
01117                  cargv[52],cargv[53],cargv[54],cargv[55],
01118                  cargv[56],cargv[57],cargv[58],cargv[59],
01119                  cargv[60],cargv[61],cargv[62],cargv[63],
01120                  cargv[64],cargv[65],cargv[66],cargv[67],
01121                  cargv[68],cargv[69],cargv[70],cargv[71],
01122                  cargv[72],cargv[73],cargv[74],cargv[75],
01123                  cargv[76],cargv[77],cargv[78],cargv[79]);
01124 #endif
01125     if (resulttype==K_INTEGER) return(mkbigint(i));
01126     else if (resulttype==K_STRING) {
01127       p=makepointer(i-2*sizeof(pointer));
01128       if (isvector(p)) return(p);
01129       else error(E_USER,(pointer)"illegal foreign string"); }
01130     else if (iscons(resulttype)) {
01131         /* (:string [10]) (:foreign-string [20]) */
01132       if (ccar(resulttype)=K_STRING) {
01133         resulttype=ccdr(resulttype);
01134         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
01135         else j=strlen((char *)i);
01136         return(makestring((char *)i, j)); }
01137       else if (ccar(resulttype)=K_FOREIGN_STRING) {
01138         resulttype=ccdr(resulttype);
01139         if (resulttype!=NIL) j=ckintval(ccar(resulttype));
01140         else j=strlen((char *)i);
01141         return(make_foreign_string(i, j)); }
01142       error(E_USER,(pointer)"unknown result type"); }
01143     else error(E_USER,(pointer)"result type?"); 
01144     }}
01145 #endif /* x86_64 */
01146 #endif /* IRIX */
01147 #endif /* IRIX6 */
01148   
01149 pointer funcode(ctx,func,args,noarg)
01150 register context *ctx;
01151 register pointer func,args;
01152 register int noarg;
01153 { register pointer (*subr)();
01154   register pointer *argp=ctx->vsp;
01155   register int n=0;
01156   register eusinteger_t addr;
01157   pointer tmp;
01158   addr=(eusinteger_t)(func->c.code.entry);
01159 #if (defined x86_64) || (defined aarch64)
01160   addr &= ~3L;  /*0xfffffffc; ???? */
01161 #else
01162   addr &= ~3;  /*0xfffffffc; ???? */
01163 #endif
01164 #if ARM
01165   if (func->c.code.entry2 != NIL) {
01166     addr = addr | (intval(func->c.code.entry2)&0x0000ffff);
01167   }
01168 #endif
01169   subr=(pointer (*)())(addr);
01170 #ifdef FUNCODE_DEBUG
01171   printf( "funcode:func = " ); hoge_print( func );
01172   printf( "funcode:args = " ); hoge_print( args );
01173 #endif
01174   GC_POINT;
01175   switch((eusinteger_t)(func->c.code.subrtype)) {       /*func,macro or special form*//* ???? */
01176       case (eusinteger_t)SUBR_FUNCTION:/* ???? */
01177               if (noarg<0) {
01178                 while (piscons(args)) {
01179                   vpush(eval(ctx,ccar(args))); args=ccdr(args); n++; GC_POINT;}
01180                 if (pisfcode(func))     /*foreign function?*/
01181                   return(call_foreign((eusinteger_t (*)())subr,func,n,argp));
01182                 else return((*subr)(ctx,n,argp));}
01183               else if (pisfcode(func))
01184                 return(call_foreign((eusinteger_t (*)())subr,func,noarg,(pointer *)args));
01185               else return((*subr)(ctx,noarg,args,0));
01186               break;
01187       case (eusinteger_t)SUBR_MACRO:/* ???? */
01188               if (noarg>=0) error(E_ILLFUNC);
01189               while (iscons(args)) { vpush(ccar(args)); args=ccdr(args); n++;}
01190           GC_POINT;
01191           tmp = (*subr)(ctx,n,argp);
01192           GC_POINT;
01193               return(eval(ctx,tmp));
01194       case (eusinteger_t)SUBR_SPECIAL: /* ???? */
01195               if (noarg>=0) error(E_ILLFUNC);
01196               else return((*subr)(ctx,args));
01197 /*      case (int)SUBR_ENTRY:
01198               func=(*subr)(func);
01199               return(makeint(func)); */
01200       default: error(E_ILLFUNC); break;}
01201   }
01202 
01203 pointer clofunc;
01204 pointer ufuncall(ctx,form,fn,args,env,noarg)
01205 register context *ctx;
01206 pointer form,fn;
01207 register pointer args;  /*or 'pointer *' */
01208 struct bindframe *env;
01209 int noarg;
01210 { pointer func,formal,aval,ftype,result,*argp,hook;
01211   register struct callframe *vf=(struct callframe *)(ctx->vsp);
01212   struct specialbindframe *sbfps=ctx->sbindfp;
01213   register int n=0,i;
01214   register pointer (*subr)();
01215   struct fletframe *oldfletfp=ctx->fletfp, *fenv;
01216   GC_POINT;
01217   /* evalhook */
01218   if (Spevalof(QEVALHOOK)!=NIL &&  ehbypass==0) {
01219       hook=Spevalof(QEVALHOOK);
01220       bindspecial(ctx,QEVALHOOK,NIL);
01221       if (noarg<0) vpush(cons(ctx,fn,args));
01222       else {
01223         argp=(pointer *)args;
01224         aval=NIL;
01225         i=noarg;
01226         while (--i>=0) aval=cons(ctx,argp[i],aval);
01227         vpush(cons(ctx,fn,aval));}
01228       vpush(env);
01229       GC_POINT;
01230       result=ufuncall(ctx,form,hook,(pointer)(ctx->vsp-2),env,2);       /*apply evalhook function*/
01231       ctx->vsp=(pointer *)vf;
01232       unbindspecial(ctx,sbfps+1);
01233 #ifdef __RETURN_BARRIER
01234       check_return_barrier(ctx);
01235       /* check return barrier */
01236 #endif
01237       return(result);}
01238   else ehbypass=0;
01239 
01240   if (issymbol(fn)) {
01241     func=getfunc(ctx,fn);
01242     }
01243   else {
01244     if (islist(fn)) env=ctx->bindfp;
01245     func=fn;}
01246   if (!ispointer(func)) error(E_ILLFUNC);
01247 
01248   /*make a new stack frame*/
01249   stackck;      /*stack overflow?*/
01250   breakck;      /*signal exists?*/
01251   vf->vlink=ctx->callfp;
01252   vf->form=form; 
01253   ctx->callfp=vf;
01254   ctx->vsp+=sizeof(struct callframe)/(sizeof(pointer));
01255   argp=ctx->vsp;
01256 
01257   if (pisclosure(func)) {
01258     clofunc=func;
01259     fn=func;
01260     if (fn->c.code.subrtype!=SUBR_FUNCTION) error(E_ILLFUNC);
01261     subr=(pointer (*)())((eusinteger_t)(fn->c.code.entry) & ~3 /*0xfffffffc ????*/);
01262 #if ARM
01263     register eusinteger_t addr;
01264     addr = (eusinteger_t)(fn->c.code.entry);
01265 #if (WORD_SIZE == 64)
01266     addr &= ~3L;  /*0xfffffffc; ???? */
01267 #else
01268     addr &= ~3;  /*0xfffffffc; ???? */
01269 #endif
01270     if (fn->c.code.entry2 != NIL) {
01271       addr = addr | (intval(fn->c.code.entry2)&0x0000ffff);
01272     }
01273     subr=(pointer (*)())(addr);
01274 #endif
01275 #if !Solaris2 && !SunOS4_1 && !Linux && !IRIX && !IRIX6 && !alpha && !Cygwin
01276     if ((char *)subr>maxmemory) {
01277         prinx(ctx,clofunc, STDOUT);
01278         error(E_USER,(pointer)"garbage closure, fatal bug!"); }
01279 #endif
01280     if (noarg<0) {
01281         while (iscons(args)) {
01282           vpush(eval(ctx,ccar(args))); args=ccdr(args); n++; GC_POINT;}
01283         result=(*subr)(ctx,n,argp,func);}       /*call func with env*/
01284       else result=(*subr)(ctx,noarg,args,func);
01285     /*recover call frame and stack pointer*/
01286     ctx->vsp=(pointer *)vf;
01287     ctx->callfp= vf->vlink;
01288     ctx->fletfp=oldfletfp;
01289 #ifdef __RETURN_BARRIER
01290     check_return_barrier(ctx);
01291     /* check return barrier */
01292 #endif
01293     return(result);}
01294 
01295   else if (piscode(func)) {     /*call subr*/
01296     GC_POINT;
01297     result=funcode(ctx,func,args,noarg);
01298     ctx->vsp=(pointer *)vf;
01299     ctx->callfp= vf->vlink;
01300     ctx->fletfp=oldfletfp;
01301 #ifdef __RETURN_BARRIER
01302     check_return_barrier(ctx);
01303 #endif
01304     return(result);}
01305   else if (piscons(func)) {
01306     ftype=ccar(func);
01307     func=ccdr(func);
01308     if (!issymbol(ftype)) error(E_LAMBDA);
01309     if (ftype->c.sym.homepkg==keywordpkg) fn=ftype;     /*blockname=selector*/
01310     else if (ftype==LAMCLOSURE) {
01311       fn=ccar(func); func=ccdr(func);
01312       env=(struct bindframe *)intval(ccar(func));
01313       if (env < (struct bindframe *)ctx->stack ||
01314           (struct bindframe *)ctx->stacklimit < env) env=0;
01315       func=ccdr(func);
01316       /* ctx->fletfp=(struct fletframe *)intval(ccar(func)); */
01317       fenv=(struct fletframe *)intval(ccar(func)); 
01318       func=ccdr(func);}
01319     else if (ftype!=LAMBDA && ftype!=MACRO) error(E_LAMBDA);
01320     else env=NULL /*0 ????*/; 
01321     formal=carof(func,E_LAMBDA);
01322     func=ccdr(func);
01323     if (noarg<0) {      /*spread args on stack*/
01324       noarg=0;
01325       while (iscons(args)) {
01326         aval=ccar(args);
01327         args=ccdr(args);
01328         if (ftype!=MACRO) {GC_POINT;aval=eval(ctx,aval);}
01329         vpush(aval); noarg++;}}
01330     else {
01331       argp=(pointer *)args;
01332       if (ftype==MACRO) error(E_ILLFUNC);}
01333     GC_POINT;
01334     if (ftype==LAMCLOSURE) { ctx->fletfp=fenv; }
01335     result=funlambda(ctx,fn,formal,func,argp,env,noarg);
01336     ctx->vsp=(pointer *)vf;
01337     ctx->callfp=vf->vlink;
01338     GC_POINT;
01339     if (ftype==MACRO) result=eval(ctx,result);
01340     ctx->fletfp=oldfletfp;
01341 #ifdef __RETURN_BARRIER
01342     check_return_barrier(ctx);
01343     /* check return barrier */
01344 #endif
01345     return(result);}
01346   else error(E_ILLFUNC);
01347   }
01348 
01349 pointer eval(ctx,form)
01350 register context *ctx;
01351 register pointer form;
01352 { register pointer c;
01353   register pointer p;
01354 #if defined(DEBUG_COUNT) || defined(EVAL_DEBUG)
01355   static int count=0;
01356   int save_count;
01357 
01358   count++;
01359   save_count = count;
01360 #endif
01361 #ifdef EVAL_DEBUG
01362   if( evaldebug ) {
01363       printf( "%d:", count );
01364       hoge_print(form);
01365   }
01366 #endif
01367   GC_POINT;
01368   if (isnum(form)) p = form;
01369   else if (pissymbol(form)) p = getval(ctx,form);
01370   else if (!piscons(form)) p = form;
01371   else {
01372     c=ccdr(form);
01373     if (c!=NIL && issymbol(c)) p = (*ovafptr(eval(ctx,ccar(form)),c));
01374     else {
01375       p = ufuncall(ctx,form,ccar(form),c,NULL,-1);
01376 #ifdef SAFETY
01377       take_care(p);
01378 #endif
01379     }
01380   }
01381 
01382 #ifdef EVAL_DEBUG
01383   if( evaldebug ) {
01384       printf( "%d:--- ", save_count );
01385       hoge_print(p);
01386   }
01387 #endif
01388   return(p);
01389   }
01390 
01391 pointer eval2(ctx,form,env)
01392 register context *ctx;
01393 register pointer form;
01394 pointer env;
01395 { register pointer c;
01396   GC_POINT;
01397   if (isnum(form)) return(form);
01398   else if (pissymbol(form)) return(getval(ctx,form));
01399   else if (!piscons(form)) return(form);
01400   else {
01401     c=ccdr(form);
01402     if (c!=NIL && issymbol(c)) return(*ovafptr(eval(ctx,ccar(form)),c));
01403     else return(ufuncall(ctx,form,ccar(form),(pointer)c,(struct bindframe *)env,-1));}
01404   }
01405 
01406 pointer progn(ctx,forms)
01407 register context *ctx;
01408 register pointer forms;
01409 { register pointer result=NIL;
01410   while (iscons(forms)) {
01411     GC_POINT;
01412     result=eval(ctx,ccar(forms)); forms=ccdr(forms);}
01413   return(result);}
01414 
01415 
01416 /* csend(ctx,object,selector,argc,arg1,arg2,....) */
01417 #ifdef USE_STDARG
01418 
01419 pointer csend(context *ctx, ...)
01420 {
01421   va_list ap;
01422 
01423   pointer rec,sel;
01424   int cnt;
01425   pointer res,*spsave;
01426   int i=0;
01427 
01428   va_start(ap, ctx);
01429 
01430   rec = va_arg(ap,pointer);
01431   sel = va_arg(ap,pointer);
01432   cnt = va_arg(ap,int);
01433   spsave=ctx->vsp;
01434   vpush(rec); vpush(sel);
01435   while (i++ < cnt) vpush(va_arg(ap,pointer));
01436   GC_POINT;
01437   res=(pointer)SEND(ctx,cnt+2, spsave);
01438   ctx->vsp=spsave;
01439   return(res);}
01440 
01441 #else
01442 pointer csend(va_alist)
01443 va_dcl
01444 { va_list ap;
01445   pointer rec,sel;
01446   int cnt;
01447   pointer res,*spsave;
01448   int i=0;
01449   register context *ctx;
01450 
01451   va_start(ap);
01452   ctx = va_arg(ap,context *);
01453   rec = va_arg(ap,pointer);
01454   sel = va_arg(ap,pointer);
01455   cnt = va_arg(ap,int);
01456   spsave=ctx->vsp;
01457   vpush(rec); vpush(sel);
01458   while (i++ < cnt) vpush(va_arg(ap,pointer));
01459   GC_POINT;
01460   res=(pointer)SEND(ctx,cnt+2, spsave);
01461   ctx->vsp=spsave;
01462 #ifdef SAFETY
01463   take_care(res);
01464 #endif
01465   return(res);}
01466 #endif
01467 


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Mar 9 2017 04:57:49