eval.c
Go to the documentation of this file.
1 /*****************************************************************/
2 /* eval.c
3 / interpreted evaluation of lisp forms
4 /* 1986-Jun-6
5 /* Copyright Toshihiro Matsui, ETL Umezono Sakuramura
6 /* 0298-54-5459
7 *****************************************************************/
8 static char *rcsid="@(#)$Id$";
9 
10 #include "eus.h"
11 #define FALSE 0
12 #define TRUE 1
13 
14 extern pointer ALLOWOTHERKEYS,K_ALLOWOTHERKEYS;
15 extern pointer OPTIONAL,REST,KEY,AUX,MACRO,LAMBDA,LAMCLOSURE;
16 extern char *maxmemory;
17 
18 #ifdef EVAL_DEBUG
19 int evaldebug;
20 #endif
21 
22 pointer *getobjv(sym,varvec,obj)
23 register pointer sym;
24 pointer varvec,obj;
25 { register pointer *vv=varvec->c.vec.v;
26  register int i=0,n;
27  n=intval(varvec->c.vec.size);
28  while (i<n)
29  if (vv[i]==sym) return(&(obj->c.obj.iv[i]));
30  else i++;
31  return(NULL);}
32 
33 pointer getval(ctx,sym)
34 register context *ctx;
35 register pointer sym;
36 { register struct bindframe *bf=ctx->bindfp;
37  register pointer var,val;
38  pointer *vaddr;
39  int vt;
40  if (sym->c.sym.vtype>=V_SPECIAL) {
41  vt=intval(sym->c.sym.vtype);
42  val=ctx->specials->c.vec.v[vt]; /*sym->c.sym.speval;*/
43  if (val==UNBOUND) {
44  val=sym->c.sym.speval;
45  if (val==UNBOUND) error(E_UNBOUND,sym);
46  else return(val); }
47  else return(val);}
48  if (sym->c.sym.vtype==V_CONSTANT) return(sym->c.sym.speval);
49  GC_POINT;
50  while (bf!=NULL) {
51  var=bf->sym;
52  val=bf->val;
53  if (sym==var) { /*found in bind-frame*/
54  if (val==UNBOUND) goto getspecial;
55  return(val);}
56  else if (var->cix==vectorcp.cix) {
57  vaddr=getobjv(sym,var,val);
58  if (vaddr) return(*vaddr);}
59  if (bf==bf->lexblink) break;
60  bf=bf->lexblink;}
61  /*get special value from the symbol cell*/
62  /*if (sym->c.sym.vtype==V_GLOBAL) goto getspecial;*/
63 getspecial:
64  val=sym->c.sym.speval;
65  if (val==UNBOUND) error(E_UNBOUND,sym);
66  else return(val);}
67 
68 pointer setval(ctx,sym,val)
69 register context *ctx;
70 register pointer sym,val;
71 { register struct bindframe *bf=ctx->bindfp;
72  register pointer var;
73  pointer *vaddr;
74  int vt;
75  if (sym->c.sym.vtype>=V_SPECIAL) {
76  vt=intval(sym->c.sym.vtype);
77  pointer_update(ctx->specials->c.vec.v[vt],val);
78  return(val);}
79  while (bf!=NULL) {
80  var=bf->sym;
81  if (sym==var) {
82  if (bf->val==UNBOUND) goto setspecial;
83  pointer_update(bf->val,val); return(val);}
84  else if (var->cix==vectorcp.cix) {
85  vaddr=getobjv(sym,var,bf->val);
86  if (vaddr) {pointer_update(*vaddr,val); return(val);}}
87  bf=bf->lexblink; GC_POINT;}
88  /* no local var found. try global binding */
89  if (sym->c.sym.vtype==V_CONSTANT) error(E_SETCONST,sym);
90  if (sym->c.sym.vtype==V_GLOBAL) goto setspecial;
91  setspecial:
92  pointer_update(sym->c.sym.speval,val); /* global val*/
93  return(val);
94  }
95 
96 
97 pointer getfunc(ctx,f)
98 register context *ctx;
99 register pointer f; /*must be a symbol*/
100 { register struct fletframe *ffp=ctx->fletfp;
101  while (ffp!=NULL) {
102  if (ffp->name==f) { return(ffp->fclosure);}
103  else ffp=ffp->lexlink;}
104  if (f->c.sym.spefunc==UNBOUND) error(E_UNDEF,f);
105  else { /*global function definition is taken, context changes*/
106  return(f->c.sym.spefunc);}}
107 
108 /* called from compiled code*/
109 pointer get_sym_func(s)
110 pointer s;
111 { register pointer f;
112  if ((f=s->c.sym.spefunc)==UNBOUND) error(E_UNDEF,s);
113  else return(f);}
114 
115 
116 void setfunc(sym,func)
117 register pointer sym,func;
118 { pointer_update(sym->c.sym.spefunc,func);}
119 
120 pointer *ovafptr(o,v)
121 register pointer o,v;
122 { register pointer c,*vaddr;
123  if (!ispointer(o)) error(E_NOOBJ,o,v);
124  c=classof(o);
125  vaddr=getobjv(v,c->c.cls.vars,o);
126  if (vaddr) return(vaddr);
127  else error(E_NOOBJVAR,o,v);}
128 
129 /***** special variable binding *****/
130 
131 void bindspecial(ctx,sym,newval)
132 register context *ctx;
133 pointer sym,newval;
134 { register struct specialbindframe *sbf=(struct specialbindframe *)(ctx->vsp);
135  int vt;
136  GC_POINT;
137  vt=intval(sym->c.sym.vtype);
138  ctx->vsp += (sizeof(struct specialbindframe)/sizeof(pointer));
139  sbf->sblink=ctx->sbindfp;
140  sbf->sym=sym;
141 
142  if (sym->c.sym.vtype==V_GLOBAL){
143  sbf->oldval=speval(sym); speval(sym)=newval;}
144  else { sbf->oldval=spevalof(sym,vt); spevalof(sym,vt)=newval;}
145 
146  ctx->sbindfp=sbf;
147  ctx->special_bind_count++;}
148 
149 /* called by compiled code */
150 void unbindx(ctx,count)
151 register context *ctx;
152 register int count;
153 { register pointer s;
154  register struct specialbindframe *sbfp=ctx->sbindfp;
155  if (ctx->special_bind_count<count) error(E_USER,(pointer)"inconsistent special binding");
156  ctx->special_bind_count -= count;
157  while (count-- >0) {
158  s=sbfp->sym;
159  /***/
160  if (s->c.sym.vtype==V_GLOBAL) {pointer_update(speval(s),sbfp->oldval);}
161  else pointer_update(Spevalof(s),sbfp->oldval);
162  sbfp=sbfp->sblink;}
163  ctx->sbindfp=sbfp;}
164 
165 void unbindspecial(ctx,limit)
166 register context *ctx;
167 register struct specialbindframe *limit;
168 { register pointer s;
169  register struct specialbindframe *sbfp=ctx->sbindfp;
170  if (sbfp) {
171  while (limit<=sbfp) { /* < is harmful to unwind in eus.c */
172  s=sbfp->sym;
173  /***/
174  if (s->c.sym.vtype==V_GLOBAL) {pointer_update(speval(s),sbfp->oldval);}
175  else pointer_update(Spevalof(s),sbfp->oldval);
176  sbfp=sbfp->sblink;
177  ctx->special_bind_count--;}
178  ctx->sbindfp=sbfp;}}
179 
180 struct bindframe *fastbind(ctx,var,val,lex)
181 register context *ctx;
182 register pointer var,val;
183 struct bindframe *lex;
184 { register struct bindframe *bf;
185  bf=(struct bindframe *)(ctx->vsp);
186  ctx->vsp += sizeof(struct bindframe)/sizeof(eusinteger_t);
187  bf->lexblink=lex;
188  bf->dynblink=ctx->bindfp;
189  bf->sym=var;
190  bf->val=val;
191  ctx->bindfp=bf; /*update bindfp*/
192  return(bf); }
193 
194 struct bindframe *vbind(ctx,var,val,lex,declscope)
195 register context *ctx;
196 register pointer var,val;
197 struct bindframe *lex,*declscope;
198 { register struct bindframe *p;
199  if (!issymbol(var)) error(E_NOSYMBOL);
200  if (var->c.sym.vtype==V_CONSTANT) error(E_NOVARIABLE,var);
201  p=ctx->bindfp;
202  while (p>declscope) {
203  if (p->sym==var)
204  if (p->val==UNBOUND) { bindspecial(ctx,var,val); return(ctx->bindfp);}
205  else error(E_MULTIDECL);
206  if (p==p->lexblink) break;
207  p=p->lexblink;}
208  /*not found in declare scope*/
209  if (var->c.sym.vtype>= /* V_SPECIAL */ V_GLOBAL ) {
210  /* For defun-c-callable in eusforeign.l to create a foreign-pod,
211  global value of SYMBOL must be replaced with FOREIGN-POD
212  by let binding. Since SYMBOL is V_GLOBAL, special binding
213  (global binding) must be made for V_GLOBAL. Proclaiming
214  symbol as SPECIAL is no use, since INTERN does not refer
215  thread local binding. */
216  bindspecial(ctx,var,val);
217  return(ctx->bindfp);}
218  return(fastbind(ctx,var,val,lex));}
219 
220 struct bindframe *declare(ctx,decllist,env)
221 register context *ctx;
222 pointer decllist;
223 struct bindframe *env;
224 { register pointer decl,var;
225 
226  while (iscons(decllist)) {
227  decl=ccar(decllist); decllist=ccdr(decllist);
228  if (!iscons(decl)) error(E_DECLARE);
229  if (ccar(decl)==QSPECIAL) { /*special binding*/
230  decl=ccdr(decl);
231  while (iscons(decl)) {
232  var=ccar(decl);
233  if (var->c.sym.vtype < V_SPECIAL) env=vbind(ctx,var,UNBOUND,env,ctx->bindfp);
234  decl=ccdr(decl); } } }
235  return(env);}
236 
237 int parsekeyparams(keyvec,actuals,noarg,results,allowotherkeys)
238  /*for compiled codes*/
239 register pointer keyvec, *actuals, *results;
240 int noarg,allowotherkeys;
241 { register int i=0,n=0,suppliedbits=0,keysize, bitpos;
242  register pointer akeyvar, *keys;
243 
244  if (noarg<=0) return(suppliedbits);
245  if (noarg & 1) error(E_KEYPARAM);
246  keysize=vecsize(keyvec);
247  for (i=0; i<keysize; i++) {
248 #ifdef SAFETY
249  take_care(results[i]);
250 #endif
251  results[i]=NIL;
252  }
253  while (n<noarg) {
254  akeyvar=actuals[n++];
255  if (!issymbol(akeyvar)) error(E_KEYPARAM);
256  if (akeyvar->c.sym.homepkg!=keywordpkg) error(E_KEYPARAM);
257  i=0; /*search for keyword*/
258  keys=keyvec->c.vec.v;
259  if (akeyvar==K_ALLOWOTHERKEYS) allowotherkeys=(actuals[n]!=NIL);
260  while (i<keysize && keys[i]!=akeyvar) i++;
261  if (i<keysize) { /*keyword found*/
262  bitpos = 1<<i;
263  if ((suppliedbits & bitpos) ==0) { /*already supplied-->ignore*/
264  pointer_update(results[i],actuals[n]);
265  suppliedbits |= bitpos;} }
266  else if (!allowotherkeys) error(E_NOKEYPARAM,akeyvar);
267  n++;}
268  return(suppliedbits);}
269 
270 struct bindframe *bindkeyparams(ctx,formal,argp,noarg,env,bf)
271 register context *ctx;
272 pointer formal;
273 pointer *argp;
274 int noarg;
275 struct bindframe *env,*bf;
276 { pointer fvar,initform;
277  register pointer fkeyvar,akeyvar;
278  pointer keys[KEYWORDPARAMETERLIMIT],
279  vars[KEYWORDPARAMETERLIMIT],
280  inits[KEYWORDPARAMETERLIMIT];
281  register int nokeys=0,i,n,allowotherkeys=0;
282 
283  /*parse lambda list and make keyword tables*/
284  while (iscons(formal)) {
285  fkeyvar=ccar(formal); formal=ccdr(formal);
286  if (iscons(fkeyvar)) {
287  fvar=ccar(fkeyvar);
288  initform=ccdr(fkeyvar);
289  if (iscons(initform)) initform=ccar(initform); else initform=NIL;
290  if (iscons(fvar)) {
291  fkeyvar=ccar(fvar); fvar=ccdr(fvar);
292  if (!iscons(fvar)) error(E_KEYPARAM);
293  fvar=ccar(fvar);
294  if (!issymbol(fkeyvar)) error(E_NOSYMBOL);
295  if (fkeyvar->c.sym.homepkg!=keywordpkg) error(E_KEYPARAM);}
296  else {
297  if (!issymbol(fvar)) error(E_NOSYMBOL);
298  fkeyvar=fvar->c.sym.pname;
299  fkeyvar=intern(ctx,(char *)fkeyvar->c.str.chars,
300  vecsize(fkeyvar),keywordpkg);}}
301  else if (fkeyvar==ALLOWOTHERKEYS) {
302  allowotherkeys=1;
303  if (islist(formal)) {
304  fkeyvar=ccar(formal); formal=ccdr(formal);
305  if (fkeyvar==AUX) break;
306  else error(E_USER,(pointer)"something after &allow-other-keys"); }
307  break;}
308  else if (fkeyvar==AUX) break;
309  else {
310  initform=NIL;
311  fvar=fkeyvar;
312  if (!issymbol(fvar)) error(E_NOSYMBOL);
313  fkeyvar=fvar->c.sym.pname;
314  fkeyvar=intern(ctx,(char *)fkeyvar->c.str.chars,
315  vecsize(fkeyvar),keywordpkg);}
316 
317  keys[nokeys]=fkeyvar;
318  vars[nokeys]=fvar;
319  inits[nokeys]=initform;
320  nokeys++;
321  if (nokeys>=KEYWORDPARAMETERLIMIT) {
322  error(E_USER, "Too many keyword parameters >%d",KEYWORDPARAMETERLIMIT);
323  }
324  }
325  n=0;
326  while (n<noarg) {
327  akeyvar=argp[n++];
328  if (!issymbol(akeyvar)) error(E_KEYPARAM);
329  if (akeyvar->c.sym.homepkg!=keywordpkg) error(E_KEYPARAM);
330  if (akeyvar==K_ALLOWOTHERKEYS) allowotherkeys=(argp[n]!=NIL);
331  i=0; /*search for keyword*/
332  while (i<nokeys && keys[i]!=akeyvar) i++;
333  if (n>=noarg) error(E_KEYPARAM); /*not paired*/
334  if (i<nokeys) {
335  if (inits[i]!=UNBOUND) {
336  env=vbind(ctx,vars[i],argp[n],env,bf);
337  inits[i]=UNBOUND;} }
338  else if (!allowotherkeys) error(E_NOKEYPARAM,akeyvar);
339  n++; }
340  i=0;
341  while (i<nokeys) {
342  if (inits[i]!=UNBOUND) env=vbind(ctx,vars[i],eval(ctx,inits[i]),env,bf);
343  i++;}
344  return(env);}
345 
346 pointer funlambda(ctx,fn,formal,body,argp,env,noarg)
347 register context *ctx;
348 pointer fn,formal,body,*argp;
349 struct bindframe *env;
350 int noarg;
351 { pointer ftype,fvar,result,decl,aval,initform,fkeyvar,akeyvar;
352  pointer *vspsave= ctx->vsp;
353  struct specialbindframe *sbfps=ctx->sbindfp;
354  struct bindframe *bf=ctx->bindfp;
355  struct blockframe *myblock;
356  int n=0,keyno=0,i;
357  jmp_buf funjmp;
358 
359  ctx->bindfp=env; /*****?????*****/
360 
361  /*declaration*/
362  while (iscons(body)) {
363  decl=ccar(body);
364  if (!iscons(decl) || (ccar(decl)!=QDECLARE)) break;
365  env=declare(ctx,ccdr(decl),env);
366  body=ccdr(body); GC_POINT;}
367 
368  /* make a new bind frame */
369  while (iscons(formal)) {
370  fvar=ccar(formal); formal=ccdr(formal);
371  if (fvar==OPTIONAL) goto bindopt;
372  if (fvar==REST) goto bindrest;
373  if (fvar==KEY) { keyno=n; goto bindkey;}
374  if (fvar==AUX) goto bindaux;
375  if (n>=noarg) error(E_MISMATCHARG);
376  env=vbind(ctx,fvar,argp[n],env,bf);
377  n++;}
378  if (n!=noarg) error(E_MISMATCHARG);
379  goto evbody;
380 bindopt:
381  while (iscons(formal)) {
382  fvar=ccar(formal); formal=ccdr(formal); /*take one formal*/
383  if (fvar==REST) goto bindrest;
384  if (fvar==KEY) { keyno=n; goto bindkey;}
385  if (fvar==AUX) goto bindaux;
386  if (n<noarg) { /*an actual arg is supplied*/
387  aval=argp[n];
388  if (iscons(fvar)) fvar=ccar(fvar);}
389  else if (iscons(fvar)) {
390  initform=ccdr(fvar);
391  fvar=ccar(fvar);
392  if (iscons(initform)) {GC_POINT;aval=eval(ctx,ccar(initform));}
393  else aval=NIL;}
394  else aval=NIL;
395  env=vbind(ctx,fvar,aval,env,bf);
396  n++;}
397  if (n<noarg) error(E_MISMATCHARG);
398  goto evbody;
399 bindrest:
400  keyno=n;
401  fvar=carof(formal,E_PARAMETER);
402  formal=ccdr(formal);
403  /*list up all rest arguments*/
404  result=NIL;
405  i=noarg;
406  while (n<i) result=cons(ctx,argp[--i],result);
407  env=vbind(ctx,fvar,result,env,bf);
408  n++;
409  if (!iscons(formal)) goto evbody;
410  fvar=ccar(formal); formal=ccdr(formal);
411  if (fvar==KEY) goto bindkey;
412  else if (fvar==AUX) goto bindaux;
413  else error(E_PARAMETER);
414 bindkey:
415  env=bindkeyparams(ctx,formal,&argp[keyno],noarg-keyno,env,bf);
416  while (iscons(formal)) {
417  fvar=ccar(formal); formal=ccdr(formal);
418  if (fvar==AUX) goto bindaux;}
419  goto evbody;
420 bindaux:
421  while (iscons(formal)) {
422  fvar=ccar(formal); formal=ccdr(formal);
423  if (iscons(fvar)) {
424  initform=ccdr(fvar);
425  fvar=ccar(fvar);
426  if (iscons(initform)) {GC_POINT;aval=eval(ctx,ccar(initform));}
427  else aval=NIL;}
428  else aval=NIL;
429  env=vbind(ctx,fvar,aval,env,bf); }
430 evbody:
431  GC_POINT;
432  /*create block around lambda*/
433  myblock=(struct blockframe *)makeblock(ctx,BLOCKFRAME,fn,&funjmp,NULL);
434  /*evaluate body*/
435  if ((result=(pointer)eussetjmp(funjmp))==0) {GC_POINT;result=progn(ctx,body);}
436  else if (result==(pointer)1) result=makeint(0);
437  /*end of body evaluation: clean up stack frames*/
438  ctx->blkfp=myblock->dynklink;
439  ctx->bindfp=bf;
440  ctx->vsp=vspsave;
441 
442 #ifdef __RETURN_BARRIER
443  check_return_barrier(ctx);
444  /* check return barrier */
445 #endif
446 /* unbindspecial(ctx,(struct specialbindframe *)ctx->vsp); */
447  unbindspecial(ctx,sbfps+1);
448  return(result);}
449 
450 #if IRIX6
451 
452 #include <alloca.h>
453 
454 extern long i_call_foreign(eusinteger_t (*)(),int,numunion *);
455 extern double f_call_foreign(eusinteger_t (*)(),int,numunion *);
456 
457 pointer call_foreign(func,code,n,args)
458 eusinteger_t (*func)();
459 pointer code;
460 int n;
461 pointer args[];
462 { pointer paramtypes=code->c.fcode.paramtypes;
463  pointer resulttype=code->c.fcode.resulttype;
464  pointer p,lisparg;
465  numunion nu,*cargv;
466  eusinteger_t i=0;
467  double f;
468 
469  cargv=(numunion *)alloca(n*sizeof(numunion));
470  while (iscons(paramtypes)) {
471  p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
472  lisparg=args[i];
473  if (p==K_INTEGER)
474  cargv[i++].ival=isint(lisparg)?intval(lisparg):bigintval(lisparg);
475  else if (p==K_FLOAT) cargv[i++].fval=ckfltval(lisparg);
476  else if (p==K_STRING)
477  if (elmtypeof(lisparg)==ELM_FOREIGN)
478  cargv[i++].ival=lisparg->c.ivec.iv[0];
479  else cargv[i++].ival=(eusinteger_t)(lisparg->c.str.chars);
480  else error(E_USER,(pointer)"unknown type specifier");}
481  /* &rest arguments? */
482  while (i<n) { /* i is the counter for the actual arguments*/
483  lisparg=args[i];
484  if (isint(lisparg)) cargv[i++].ival=intval(lisparg);
485  else if (isflt(lisparg)) cargv[i++].fval=ckfltval(lisparg);
486  else if (isvector(lisparg)) {
487  if (elmtypeof(lisparg)==ELM_FOREIGN)
488  cargv[i++].ival=lisparg->c.ivec.iv[0];
489  else cargv[i++].ival=(eusinteger_t)(lisparg->c.str.chars);}
490  else cargv[i++].ival=(eusinteger_t)(lisparg->c.obj.iv);}
491 
492  if (resulttype==K_FLOAT) return(makeflt(f_call_foreign(func,n,cargv)));
493  else {
494  i=i_call_foreign(func,n,cargv);
495  if (resulttype==K_INTEGER) return(mkbigint(i));
496  else if (resulttype==K_STRING) {
497  p=makepointer(i-2*sizeof(pointer));
498  if (isvector(p)) return(p);
499  else error(E_USER,(pointer)"illegal foreign string"); }
500  else if (iscons(resulttype)) {
501  /* (:string [10]) (:foreign-string [20]) */
502  if (ccar(resulttype)==K_STRING) {
503  resulttype=ccdr(resulttype);
504  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
505  else j=strlen((char *)i);
506  return(makestring((char *)i, j)); }
507  else if (ccar(resulttype)==K_FOREIGN_STRING) {
508  resulttype=ccdr(resulttype);
509  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
510  else j=strlen((char *)i);
511  return(make_foreign_string(i, j)); }
512  error(E_USER,(pointer)"unknown result type"); }
513  else error(E_USER,(pointer)"result type?");
514  }}
515 
516 #else /* IRIX6 */
517 
518 #if IRIX
519 
520 #include <alloca.h>
521 
522 extern int i_call_foreign(eusinteger_t (*)(),int,int *);
523 extern double f_call_foreign(eusinteger_t (*)(),int,int *);
524 
525 pointer call_foreign(func,code,n,args)
526 eusinteger_t (*func)();
527 pointer code;
528 int n;
529 pointer args[];
530 { pointer paramtypes=code->c.fcode.paramtypes;
531  pointer resulttype=code->c.fcode.resulttype;
532  pointer p,lisparg;
533  numunion nu,*cargs;
534  eusinteger_t i=0;
535  unsigned int *offset,*isfloat,m=0;
536  int *cargv;
537  union {
538  double d;
539  struct {
540  int i1,i2;} i;
541  } numbox;
542  double f;
543 
544  cargs=(numunion *)alloca(n*sizeof(numunion));
545  offset=(unsigned int *)alloca(n*sizeof(unsigned int));
546  isfloat=(unsigned int *)alloca(n*sizeof(unsigned int));
547  while (iscons(paramtypes)) {
548  p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
549  lisparg=args[i];
550  if (isfloat[i]=(p==K_FLOAT)) {
551  cargs[i].fval=ckfltval(lisparg);
552  offset[i]=(m+1)&~1; m=offset[i++]+2;}
553  else if (p==K_INTEGER) {
554  cargs[i++].ival=isint(lisparg)?intval(lisparg):bigintval(lisparg);
555  offset[i++]=m++;}
556  else if (p==K_STRING) {
557  if (elmtypeof(lisparg)==ELM_FOREIGN)
558  cargs[i].ival=lisparg->c.ivec.iv[0];
559  else cargs[i].ival=(eusinteger_t)(lisparg->c.str.chars);
560  offset[i++]=m++;}
561  else error(E_USER,(pointer)"unknown type specifier");}
562  /* &rest arguments? */
563  while (i<n) { /* i is the counter for the actual arguments*/
564  lisparg=args[i];
565  if (isfloat[i]=isflt(lisparg)) {
566  cargs[i].fval=ckfltval(lisparg);
567  offset[i]=(m+1)&~1; m=offset[i++]+2;}
568  else if (isint(lisparg)) {
569  cargs[i].ival=intval(lisparg);
570  offset[i++]=m++;}
571  else if (isvector(lisparg)) {
572  if (elmtypeof(lisparg)==ELM_FOREIGN)
573  cargs[i].ival=lisparg->c.ivec.iv[0];
574  else cargs[i].ival=(eusinteger_t)(lisparg->c.str.chars);
575  offset[i++]=m++;}
576  else {
577  cargs[i++].ival=(eusinteger_t)(lisparg->c.obj.iv);
578  offset[i++]=m++;}}
579  cargv=(int *)alloca(m*sizeof(int));
580  for (i=0; i<n; ++i) {
581  if (isfloat[i]) {
582  numbox.d=(double)cargs[i].fval;
583  cargv[offset[i]]=numbox.i.i1; cargv[offset[i]+1]=numbox.i.i2;}
584  else cargv[offset[i]]=cargs[i].ival;}
585 
586  if (resulttype==K_FLOAT) return(makeflt(f_call_foreign(func,m,cargv)));
587  else {
588  i=i_call_foreign(func,m,cargv);
589  if (resulttype==K_INTEGER) return(mkbigint(i));
590  else if (resulttype==K_STRING) {
591  p=makepointer(i-2*sizeof(pointer));
592  if (isvector(p)) return(p);
593  else error(E_USER,(pointer)"illegal foreign string"); }
594  else if (iscons(resulttype)) {
595  /* (:string [10]) (:foreign-string [20]) */
596  if (ccar(resulttype)=K_STRING) {
597  resulttype=ccdr(resulttype);
598  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
599  else j=strlen((char *)i);
600  return(makestring((char *)i, j)); }
601  else if (ccar(resulttype)=K_FOREIGN_STRING) {
602  resulttype=ccdr(resulttype);
603  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
604  else j=strlen((char *)i);
605  return(make_foreign_string(i, j)); }
606  error(E_USER,(pointer)"unknown result type"); }
607  else error(E_USER,(pointer)"result type?");
608  }}
609 
610 #else /* IRIX */
611 
612 /* not IRIS */
613 #if (defined(x86_64) || defined(aarch64))
614 extern long exec_function_i(void (*)(), long *, long *, long, long *);
615 extern long exec_function_f(void (*)(), long *, long *, long, long *);
616 
617 #if x86_64
618 // func %rdi
619 // iargv %rsi
620 // fargv %rdx
621 // vargc %rcx
622 // vargv %r8
623 __asm__ (".align 8\n"
624 #if Darwin
625  "_exec_function_i:\n\t"
626 #else
627  "exec_function_i:\n\t"
628 #endif
629  "push %rbx\n\t"
630  "sub $0x120, %rsp\n\t"
631  "mov %rdx, %rax\n\t"
632  "movsd 0x00(%rax), %xmm0\n\t"
633  "movsd 0x08(%rax), %xmm1\n\t"
634  "movsd 0x10(%rax), %xmm2\n\t"
635  "movsd 0x18(%rax), %xmm3\n\t"
636  "movsd 0x20(%rax), %xmm4\n\t"
637  "movsd 0x28(%rax), %xmm5\n\t"
638  "movsd 0x30(%rax), %xmm6\n\t"
639  "movsd 0x38(%rax), %xmm7\n\t"
640  "mov %rsp, %rax\n\t"
641  "mov $0, %r10\n\t"
642  "cmpl %ecx, %r10d\n\t"
643  "jge .LENDLP\n"
644  ".LNEXTLP:\n\t"
645  "mov (%r8), %rbx\n\t"
646  "mov %rbx, (%rax)\n\t"
647  "add $8, %rax\n\t"
648  "add $8, %r8\n\t"
649  "add $1, %r10d\n\t"
650  "cmpl %r10d, %ecx\n\t"
651  "jg .LNEXTLP\n"
652  ".LENDLP:\n\t"
653  "mov %rdi, %rbx\n\t"
654  "mov %rsi, %rax\n\t"
655  "mov 0x00(%rax), %rdi\n\t"
656  "mov 0x08(%rax), %rsi\n\t"
657  "mov 0x10(%rax), %rdx\n\t"
658  "mov 0x18(%rax), %rcx\n\t"
659  "mov 0x20(%rax), %r8\n\t"
660  "mov 0x28(%rax), %r9\n\t"
661  "mov $0x00, %eax\n\t"
662  "call *%rbx\n\t"
663  "add $0x120, %rsp\n\t"
664  "pop %rbx\n\t"
665  "retq"
666  );
667 __asm__ (".align 8\n"
668 #if Darwin
669  "_exec_function_f:\n\t"
670 #else
671  "exec_function_f:\n\t"
672 #endif
673  "push %rbx\n\t"
674  "sub $0x120, %rsp\n\t"
675  "mov %rdx, %rax\n\t"
676  "movsd 0x00(%rax), %xmm0\n\t"
677  "movsd 0x08(%rax), %xmm1\n\t"
678  "movsd 0x10(%rax), %xmm2\n\t"
679  "movsd 0x18(%rax), %xmm3\n\t"
680  "movsd 0x20(%rax), %xmm4\n\t"
681  "movsd 0x28(%rax), %xmm5\n\t"
682  "movsd 0x30(%rax), %xmm6\n\t"
683  "movsd 0x38(%rax), %xmm7\n\t"
684  "mov %rsp, %rax\n\t"
685  "mov $0, %r10\n\t"
686  "cmpl %ecx, %r10d\n\t"
687  "jge .LENDLPF\n"
688  ".LNEXTLPF:\n\t"
689  "mov (%r8), %rbx\n\t"
690  "mov %rbx, (%rax)\n\t"
691  "add $8, %rax\n\t"
692  "add $8, %r8\n\t"
693  "add $1, %r10d\n\t"
694  "cmpl %r10d, %ecx\n\t"
695  "jg .LNEXTLPF\n"
696  ".LENDLPF:\n\t"
697  "mov %rdi, %rbx\n\t"
698  "mov %rsi, %rax\n\t"
699  "mov 0x00(%rax), %rdi\n\t"
700  "mov 0x08(%rax), %rsi\n\t"
701  "mov 0x10(%rax), %rdx\n\t"
702  "mov 0x18(%rax), %rcx\n\t"
703  "mov 0x20(%rax), %r8\n\t"
704  "mov 0x28(%rax), %r9\n\t"
705  "mov $0x00, %eax\n\t"
706  "call *%rbx\n\t"
707  "movsd %xmm0, (%rsp)\n\t"
708  "mov (%rsp), %rax\n\t"
709  "add $0x120, %rsp\n\t"
710  "pop %rbx\n\t"
711  "retq"
712  );
713 #endif
714 
715 #if aarch64
716 __asm__ (".align 8\n"
717  "exec_function_i:\n\t"
718  "sub sp, sp, #192\n\t" // 128(8x16) + 64
719  "stp x29, x30, [sp, 128]\n\t"
720  "add x29, sp, 128\n\t"
721  "str x0, [x29, 56]\n\t" // fc
722  "str x1, [x29, 48]\n\t" // iargv
723  "str x2, [x29, 40]\n\t" // fargv
724  "str x3, [x29, 32]\n\t" // vargc
725  "str x4, [x29, 24]\n\t" // vargv
726  // vargv -> stack
727  "mov x1, 0\n\t"
728  "ldr x2, [x29, 24]\n\t"
729  "b .FUNCII_LPCK\n\t"
730  ".FUNCII_LP:\n\t"
731  "lsl x0, x1, 3\n\t"
732  "add x3, x2, x0\n\t" // vargv[i]
733  "add x4, sp, x0\n\t" // stack[i]
734  "ldr x0, [x3]\n\t"
735  "str x0, [x4]\n\t" // push stack
736  "add x1, x1, 1\n\t"
737  ".FUNCII_LPCK:\n\t"
738  "ldr x5, [x29, 32]\n\t"
739  "cmp x1, x5\n\t"
740  "blt .FUNCII_LP\n\t"
741  // fargv -> register
742  "ldr x0, [x29, 40]\n\t" // fargv
743  "ldr d0, [x0]\n\t"
744  "add x0, x0, 8\n\t"
745  "ldr d1, [x0]\n\t"
746  "add x0, x0, 8\n\t"
747  "ldr d2, [x0]\n\t"
748  "add x0, x0, 8\n\t"
749  "ldr d3, [x0]\n\t"
750  "add x0, x0, 8\n\t"
751  "ldr d4, [x0]\n\t"
752  "add x0, x0, 8\n\t"
753  "ldr d5, [x0]\n\t"
754  "add x0, x0, 8\n\t"
755  "ldr d6, [x0]\n\t"
756  "add x0, x0, 8\n\t"
757  "ldr d7, [x0]\n\t"
758  // iargv -> register
759  "ldr x0, [x29, 48]\n\t" // iargv
760  "ldr x9, [x0]\n\t"
761  "add x0, x0, 8\n\t"
762  "ldr x1, [x0]\n\t"
763  "add x0, x0, 8\n\t"
764  "ldr x2, [x0]\n\t"
765  "add x0, x0, 8\n\t"
766  "ldr x3, [x0]\n\t"
767  "add x0, x0, 8\n\t"
768  "ldr x4, [x0]\n\t"
769  "add x0, x0, 8\n\t"
770  "ldr x5, [x0]\n\t"
771  "add x0, x0, 8\n\t"
772  "ldr x6, [x0]\n\t"
773  "add x0, x0, 8\n\t"
774  "ldr x7, [x0]\n\t"
775  // function call
776  "ldr x8, [x29, 56]\n\t"
777  "mov x0, x9\n\t"
778  "blr x8\n\t"
779  "add sp, x29, 0\n\t"
780  "ldp x29, x30, [sp], 64\n\t"
781  "ret"
782  );
783 
784 __asm__ (".align 8\n"
785  "exec_function_f:\n\t"
786  "sub sp, sp, #192\n\t" // 128(8x16) + 64
787  "stp x29, x30, [sp, 128]\n\t"
788  "add x29, sp, 128\n\t"
789  "str x0, [x29, 56]\n\t" // fc
790  "str x1, [x29, 48]\n\t" // iargv
791  "str x2, [x29, 40]\n\t" // fargv
792  "str x3, [x29, 32]\n\t" // vargc
793  "str x4, [x29, 24]\n\t" // vargv
794  // vargv -> stack
795  "mov x1, 0\n\t"
796  "ldr x2, [x29, 24]\n\t"
797  "b .FUNCFF_LPCK\n\t"
798  ".FUNCFF_LP:\n\t"
799  "lsl x0, x1, 3\n\t"
800  "add x3, x2, x0\n\t" // vargv[i]
801  "add x4, sp, x0\n\t" // stack[i]
802  "ldr x0, [x3]\n\t"
803  "str x0, [x4]\n\t" // push stack
804  "add x1, x1, 1\n\t"
805  ".FUNCFF_LPCK:\n\t"
806  "ldr x5, [x29, 32]\n\t"
807  "cmp x1, x5\n\t"
808  "blt .FUNCFF_LP\n\t"
809  // fargv -> register
810  "ldr x0, [x29, 40]\n\t" // fargv
811  "ldr d0, [x0]\n\t"
812  "add x0, x0, 8\n\t"
813  "ldr d1, [x0]\n\t"
814  "add x0, x0, 8\n\t"
815  "ldr d2, [x0]\n\t"
816  "add x0, x0, 8\n\t"
817  "ldr d3, [x0]\n\t"
818  "add x0, x0, 8\n\t"
819  "ldr d4, [x0]\n\t"
820  "add x0, x0, 8\n\t"
821  "ldr d5, [x0]\n\t"
822  "add x0, x0, 8\n\t"
823  "ldr d6, [x0]\n\t"
824  "add x0, x0, 8\n\t"
825  "ldr d7, [x0]\n\t"
826  // iargv -> register
827  "ldr x0, [x29, 48]\n\t" // iargv
828  "ldr x9, [x0]\n\t"
829  "add x0, x0, 8\n\t"
830  "ldr x1, [x0]\n\t"
831  "add x0, x0, 8\n\t"
832  "ldr x2, [x0]\n\t"
833  "add x0, x0, 8\n\t"
834  "ldr x3, [x0]\n\t"
835  "add x0, x0, 8\n\t"
836  "ldr x4, [x0]\n\t"
837  "add x0, x0, 8\n\t"
838  "ldr x5, [x0]\n\t"
839  "add x0, x0, 8\n\t"
840  "ldr x6, [x0]\n\t"
841  "add x0, x0, 8\n\t"
842  "ldr x7, [x0]\n\t"
843  // function call
844  "ldr x8, [x29, 56]\n\t"
845  "mov x0, x9\n\t"
846  "blr x8\n\t"
847  "str d0, [x29, 56]\n\t"
848  "ldr x0, [x29, 56]\n\t"
849  "add sp, x29, 0\n\t"
850  "ldp x29, x30, [sp], 64\n\t"
851  "ret"
852  );
853 #endif
854 
855 #if x86_64
856 #define NUM_INT_ARGUMENTS 6
857 #define NUM_FLT_ARGUMENTS 8
858 #define NUM_EXTRA_ARGUMENTS 16
859 #elif aarch64
860 #define NUM_INT_ARGUMENTS 8
861 #define NUM_FLT_ARGUMENTS 8
862 #define NUM_EXTRA_ARGUMENTS 16
863 #endif
864 
865 pointer call_foreign(ifunc,code,n,args)
866 eusinteger_t (*ifunc)(); /* ???? */
867 pointer code;
868 int n;
869 pointer args[];
870 {
871  pointer paramtypes=code->c.fcode.paramtypes;
872  pointer resulttype=code->c.fcode.resulttype;
873  pointer p,lisparg;
874  eusinteger_t iargv[NUM_INT_ARGUMENTS];
875  eusinteger_t fargv[NUM_FLT_ARGUMENTS];
876  eusinteger_t vargv[NUM_EXTRA_ARGUMENTS];
877  int icntr = 0, fcntr = 0, vcntr = 0;
878 
879  numunion nu;
880  eusinteger_t j=0; /*lisp argument counter*//* ???? */
881  eusinteger_t c=0;
882  union {
883  double d;
884  float f;
885  long l;
886  struct {
887  int i1,i2;} i;
888  } numbox;
889  double f;
890 
891  if (code->c.fcode.entry2 != NIL) {
892  ifunc = (eusinteger_t (*)())((((eusinteger_t)ifunc)&0xffffffff00000000)
893  | (intval(code->c.fcode.entry2)&0x00000000ffffffff));
894  /* R.Hanai 090726 */
895  }
896 
897  while (iscons(paramtypes)) {
898  p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
899  lisparg=args[j++];
900  if (p==K_INTEGER) {
901  c = isint(lisparg)?intval(lisparg):bigintval(lisparg);
902  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
903  } else if (p==K_STRING) {
904  if (elmtypeof(lisparg)==ELM_FOREIGN) c=lisparg->c.ivec.iv[0];
905  else c=(eusinteger_t)(lisparg->c.str.chars);
906  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
907  } else if (p==K_FLOAT32) {
908  numbox.f=(float)ckfltval(lisparg);
909  c=((eusinteger_t)numbox.i.i1) & 0x00000000FFFFFFFF;
910  if(fcntr < NUM_FLT_ARGUMENTS) fargv[fcntr++] = c; else vargv[vcntr++] = c;
911  } else if (p==K_DOUBLE || p==K_FLOAT) {
912  numbox.d=ckfltval(lisparg);
913  c=numbox.l;
914  if(fcntr < NUM_FLT_ARGUMENTS) fargv[fcntr++] = c; else vargv[vcntr++] = c;
915  } else error(E_USER,(pointer)"unknown type specifier");
916  if (vcntr >= NUM_EXTRA_ARGUMENTS) {
917  error(E_USER,(pointer)"too many number of arguments");
918  }
919  }
920  /* &rest arguments? */
921  while (j<n) { /* j is the counter for the actual arguments*/
922  lisparg=args[j++];
923  if (isint(lisparg)) {
924  c=intval(lisparg);
925  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
926  } else if (isflt(lisparg)) {
927  numbox.d=ckfltval(lisparg); /* i advances independently */
928  c=numbox.l;
929  if(fcntr < NUM_FLT_ARGUMENTS) fargv[fcntr++] = c; else vargv[vcntr++] = c;
930  } else if (isvector(lisparg)) {
931  if (elmtypeof(lisparg)==ELM_FOREIGN) c=lisparg->c.ivec.iv[0];
932  else c=(eusinteger_t)(lisparg->c.str.chars);
933  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
934  } else if (isbignum(lisparg)){
935  if (bigsize(lisparg)==1){
936  eusinteger_t *xv = bigvec(lisparg);
937  c=(eusinteger_t)xv[0];
938  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
939  }else{
940  fprintf(stderr, "bignum size!=1\n");
941  }
942  } else {
943  c=(eusinteger_t)(lisparg->c.obj.iv);
944  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
945  }
946  if (vcntr >= NUM_EXTRA_ARGUMENTS) {
947  error(E_USER,(pointer)"too many number of arguments");
948  }
949  }
950 
951  if (resulttype==K_FLOAT) {
952  numbox.l = exec_function_f((void (*)())ifunc, iargv, fargv, vcntr, vargv);
953  f = numbox.d;
954  return(makeflt(f));
955  } else if (resulttype==K_FLOAT32) {
956  numbox.l = exec_function_f((void (*)())ifunc, iargv, fargv, vcntr, vargv);
957  f = (double)numbox.f;
958  return(makeflt(f));
959  } else {
960  c = exec_function_i((void (*)())ifunc, iargv, fargv, vcntr, vargv);
961  if (resulttype==K_INTEGER) {
962  return(mkbigint(c));
963  } else if (resulttype==K_STRING) {
964  p=makepointer(c-2*sizeof(pointer));
965  if (isvector(p)) return(p);
966  else error(E_USER,(pointer)"illegal foreign string");
967  } else if (iscons(resulttype)) {
968  /* (:string [10]) (:foreign-string [20]) */
969  if (ccar(resulttype)==K_STRING) { /* R.Hanai 09/07/25 */
970  resulttype=ccdr(resulttype);
971  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
972  else j=strlen((char *)c);
973  return(makestring((char *)c, j));
974  } else if (ccar(resulttype)==K_FOREIGN_STRING) { /* R.Hanai 09/07/25 */
975  resulttype=ccdr(resulttype);
976  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
977  else j=strlen((char *)c);
978  return(make_foreign_string(c, j)); }
979  error(E_USER,(pointer)"unknown result type");
980  } else error(E_USER,(pointer)"result type?");
981  }
982 }
983 
984 #elif defined(ARM) && defined(__ARM_ARCH_7A__) /* not (defined(x86_64) || defined(aarch64)) */
985 
986 extern int exec_function_i(void (*)(), int *, int *, int, int *);
987 extern int exec_function_f(void (*)(), int *, int *, int, int *);
988 
989 #define exec_function_asm(FUNC) \
990  /* vargv -> stack */ \
991  "movs r3, #0\n\t" \
992  "str r3, [r7, #60]\n\t" \
993  "b ."FUNC"_LPCK\n\t" \
994  "."FUNC"_LP:\n\t" \
995  "ldr r3, [r7, #60]\n\t" /* i */ \
996  /* https://community.arm.com/developer/ip-products/processors/b/processors-ip-blog/posts/function-parameters-on-32-bit-arm */ \
997  "lsl r4, r3, #2\n\t" /* r4 = i * 2 */ \
998  "ldr r1, [r7, #80]\n\t" /* vargv[0] */ \
999  "add r1, r1, r4\n\t" /* vargv[i] */ \
1000  "add r2, sp, r4\n\t" /* stack[i] */ \
1001  "ldr r0, [r1]\n\t" \
1002  "str r0, [r2]\n\t" /* push stack */ \
1003  "adds r3, r3, #1\n\t" /* i++ */ \
1004  "str r3, [r7, #60]\n\t" \
1005  "."FUNC"_LPCK:\n\t" \
1006  "ldr r2, [r7, #60]\n\t" \
1007  "ldr r3, [r7]\n\t" \
1008  "cmp r2, r3\n\t" \
1009  "blt ."FUNC"_LP\n\t" \
1010  /* fargv -> register */ \
1011  "ldr r0, [r7,#4]\n\t" \
1012  "vldr.32 s0, [r0]\n\t" \
1013  "vldr.32 s1, [r0,#4]\n\t" \
1014  "vldr.32 s2, [r0,#8]\n\t" \
1015  "vldr.32 s3, [r0,#12]\n\t" \
1016  "vldr.32 s4, [r0,#16]\n\t" \
1017  "vldr.32 s5, [r0,#20]\n\t" \
1018  "vldr.32 s6, [r0,#24]\n\t" \
1019  "vldr.32 s7, [r0,#28]\n\t" \
1020  "vldr.32 s8, [r0,#32]\n\t" \
1021  "vldr.32 s9, [r0,#36]\n\t" \
1022  "vldr.32 s10, [r0,#40]\n\t" \
1023  "vldr.32 s11, [r0,#44]\n\t" \
1024  "vldr.32 s12, [r0,#48]\n\t" \
1025  "vldr.32 s13, [r0,#52]\n\t" \
1026  "vldr.32 s14, [r0,#56]\n\t" \
1027  "vldr.32 s15, [r0,#60]\n\t" \
1028  /* iargv -> register */ \
1029  "ldr r0, [r7,#8]\n\t" \
1030  "ldr r0, [r0]\n\t" \
1031  "ldr r1, [r7,#8]\n\t" \
1032  "ldr r1, [r1,#4]\n\t" \
1033  "ldr r2, [r7,#8]\n\t" \
1034  "ldr r2, [r2,#8]\n\t" \
1035  "ldr r3, [r7,#8]\n\t" \
1036  "ldr r3, [r3,#12]\n\t" \
1037  /* funcall */ \
1038  "ldr r6, [r7, #12]\n\t" \
1039  "blx r6\n\t"
1040 
1041 __asm__ (".align 4\n"
1042  ".global exec_function_i\n\t"
1043  ".type exec_function_i, %function\n"
1044  "exec_function_i:\n\t"
1045  "push {r7, lr}\n\t"
1046  "sub sp, sp, #136\n\t"
1047  "add r7, sp, #64\n\t"
1048  "str r0, [r7, #12]\n\t" // fc
1049  "str r1, [r7, #8]\n\t" // iargv
1050  "str r2, [r7, #4]\n\t" // fargv
1051  "str r3, [r7]\n\t" // vcntr
1052  exec_function_asm("FUNCI")
1053  // retval
1054  "adds r7, r7, #72\n\t"
1055  "mov sp, r7\n\t"
1056  "@ sp needed @\n\t"
1057  "pop {r7, pc}\n\t"
1058  ".size exec_function_i, .-exec_function_i\n\t"
1059  );
1060 
1061 __asm__ (".align 4\n"
1062  ".global exec_function_f\n\t"
1063  ".type exec_function_f, %function\n"
1064  "exec_function_f:\n\t"
1065  "push {r7, lr}\n\t"
1066  "sub sp, sp, #136\n\t"
1067  "add r7, sp, #64\n\t"
1068  "str r0, [r7, #12]\n\t" // fc
1069  "str r1, [r7, #8]\n\t" // iargv
1070  "str r2, [r7, #4]\n\t" // fargv
1071  "str r3, [r7]\n\t" // vcntr
1072  exec_function_asm("FUNCF")
1073  // retval
1074  "vmov r0, s0 @ <retval>\n\t"
1075  "vmov r1, s1 @ <retval>\n\t"
1076  "adds r7, r7, #72\n\t"
1077  "mov sp, r7\n\t"
1078  "@ sp needed @\n\t"
1079  "pop {r7, pc}\n\t"
1080  ".size exec_function_f, .-exec_function_f\n\t"
1081  );
1082 
1083 #define NUM_INT_ARGUMENTS 4
1084 #define NUM_FLT_ARGUMENTS 16
1085 #define NUM_EXTRA_ARGUMENTS 16
1086 
1087 pointer call_foreign(ifunc,code,n,args)
1088 eusinteger_t (*ifunc)(); /* ???? */
1089 pointer code;
1090 int n;
1091 pointer args[];
1092 {
1093  pointer paramtypes=code->c.fcode.paramtypes;
1094  pointer resulttype=code->c.fcode.resulttype;
1095  pointer p,lisparg;
1096  eusinteger_t iargv[NUM_INT_ARGUMENTS];
1097  eusinteger_t fargv[NUM_FLT_ARGUMENTS];
1098  eusinteger_t vargv[NUM_EXTRA_ARGUMENTS];
1099  int icntr = 0, fcntr_d = 0, fcntr_f = 0, vcntr_8 = 0, vcntr_16 = 0;
1100 
1101  numunion nu;
1102  eusinteger_t j=0; /*lisp argument counter*//* ???? */
1103  eusinteger_t c=0;
1104  union {
1105  double d;
1106  float f;
1107  long l;
1108  struct {
1109  int i1,i2;} i;
1110  } numbox;
1111  double f;
1112 
1113  if (code->c.fcode.entry2 != NIL) {
1114  ifunc = (eusinteger_t (*)())((((eusinteger_t)ifunc)&0xffffffff00000000)
1115  | (intval(code->c.fcode.entry2)&0x00000000ffffffff));
1116  /* R.Hanai 090726 */
1117  }
1118  while (iscons(paramtypes)) {
1119  p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
1120  lisparg=args[j++];
1121  if (p==K_INTEGER) {
1122  c = isint(lisparg)?intval(lisparg):bigintval(lisparg);
1123  if(icntr < NUM_INT_ARGUMENTS) {
1124  iargv[icntr++] = c;
1125  } else {
1126  vargv[vcntr_8++] = c;
1127  if ( vcntr_8 % 2 == 1 ) vcntr_16 += 2;
1128  if ( vcntr_8 % 2 == 0 ) vcntr_8 = vcntr_16;
1129  }
1130  } else if (p==K_STRING) {
1131  if (elmtypeof(lisparg)==ELM_FOREIGN) c=lisparg->c.ivec.iv[0];
1132  else c=(eusinteger_t)(lisparg->c.str.chars);
1133  if(icntr < NUM_INT_ARGUMENTS) {
1134  iargv[icntr++] = c;
1135  } else {
1136  vargv[vcntr_8++] = c;
1137  if ( vcntr_8 % 2 == 1 ) vcntr_16 += 2;
1138  if ( vcntr_8 % 2 == 0 ) vcntr_8 = vcntr_16;
1139  }
1140  } else if (p==K_FLOAT32 || p==K_FLOAT) {
1141  numbox.f=(float)ckfltval(lisparg);
1142  c=((eusinteger_t)numbox.i.i1) & 0x00000000FFFFFFFF;
1143  // | s0 | s1 | s2 | s3 | s4 | s5 |
1144  // | d0 | d1 | d2 |
1145  if(fcntr_f < NUM_FLT_ARGUMENTS) {
1146  fargv[fcntr_f++] = c;
1147  if ( fcntr_f % 2 == 1 ) fcntr_d += 2; // if *fcntr_f = s1, use d1
1148  if ( fcntr_f % 2 == 0 ) fcntr_f = fcntr_d;
1149  } else {
1150  vargv[vcntr_8++] = c;
1151  if ( vcntr_8 % 2 == 1 ) vcntr_16 += 2;
1152  if ( vcntr_8 % 2 == 0 ) vcntr_8 = vcntr_16;
1153  }
1154  } else if (p==K_DOUBLE) {
1155  numbox.d=(double)ckfltval(lisparg);
1156  if(fcntr_d < NUM_FLT_ARGUMENTS-1) {
1157  fargv[fcntr_d++] = numbox.i.i1; fargv[fcntr_d++] = numbox.i.i2;
1158  if ( fcntr_f % 2 == 0 ) fcntr_f = fcntr_d; // if *fcntr_f = s2, use d1
1159  if(fcntr_d >= NUM_FLT_ARGUMENTS) fcntr_f = fcntr_d;
1160  } else {
1161  vargv[vcntr_16++] = numbox.i.i1; vargv[vcntr_16++] = numbox.i.i2;
1162  if ( vcntr_8 % 2 == 0 ) vcntr_8 = vcntr_16;
1163  }
1164  } else error(E_USER,(pointer)"unknown type specifier");
1165  if (max(vcntr_8, vcntr_16) >= NUM_EXTRA_ARGUMENTS) {
1166  error(E_USER,(pointer)"too many number of arguments");
1167  }
1168  }
1169  int vcntr = max(vcntr_8, vcntr_16);
1170  /* &rest arguments? */
1171  while (j<n) { /* j is the counter for the actual arguments*/
1172  lisparg=args[j++];
1173  if (isint(lisparg)) {
1174  c=intval(lisparg);
1175  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
1176  } else if (isflt(lisparg)) {
1177  numbox.d=ckfltval(lisparg); /* i advances independently */
1178  c=numbox.l;
1179  if(fcntr_f < NUM_FLT_ARGUMENTS) fargv[fcntr_f++] = c; else vargv[vcntr++] = c;
1180  } else if (isvector(lisparg)) {
1181  if (elmtypeof(lisparg)==ELM_FOREIGN) c=lisparg->c.ivec.iv[0];
1182  else c=(eusinteger_t)(lisparg->c.str.chars);
1183  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
1184  } else if (isbignum(lisparg)){
1185  if (bigsize(lisparg)==1){
1186  eusinteger_t *xv = bigvec(lisparg);
1187  c=(eusinteger_t)xv[0];
1188  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
1189  }else{
1190  fprintf(stderr, "bignum size!=1\n");
1191  }
1192  } else {
1193  c=(eusinteger_t)(lisparg->c.obj.iv);
1194  if(icntr < NUM_INT_ARGUMENTS) iargv[icntr++] = c; else vargv[vcntr++] = c;
1195  }
1196  if (vcntr >= NUM_EXTRA_ARGUMENTS) {
1197  error(E_USER,(pointer)"too many number of arguments");
1198  }
1199  }
1200 
1201  if (resulttype==K_FLOAT || resulttype==K_FLOAT32) {
1202  numbox.l = exec_function_f((void (*)())ifunc, iargv, fargv, vcntr, vargv);
1203  f = (double)numbox.f;
1204  return(makeflt(f));
1205  } else {
1206  c = exec_function_i((void (*)())ifunc, iargv, fargv, vcntr, vargv);
1207  if (resulttype==K_INTEGER) {
1208  return(mkbigint(c));
1209  } else if (resulttype==K_STRING) {
1210  p=makepointer(c-2*sizeof(pointer));
1211  if (isvector(p)) return(p);
1212  else error(E_USER,(pointer)"illegal foreign string");
1213  } else if (iscons(resulttype)) {
1214  /* (:string [10]) (:foreign-string [20]) */
1215  if (ccar(resulttype)==K_STRING) { /* R.Hanai 09/07/25 */
1216  resulttype=ccdr(resulttype);
1217  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
1218  else j=strlen((char *)c);
1219  return(makestring((char *)c, j));
1220  } else if (ccar(resulttype)==K_FOREIGN_STRING) { /* R.Hanai 09/07/25 */
1221  resulttype=ccdr(resulttype);
1222  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
1223  else j=strlen((char *)c);
1224  return(make_foreign_string(c, j)); }
1225  error(E_USER,(pointer)"unknown result type");
1226  } else error(E_USER,(pointer)"result type?");
1227  }
1228 }
1229 
1230 #else /* not ARM nor (defined(x86_64) || defined(aarch64)) */
1231 
1232 pointer call_foreign(ifunc,code,n,args)
1233 eusinteger_t (*ifunc)(); /* ???? */
1234 pointer code;
1235 int n;
1236 pointer args[];
1237 { pointer paramtypes=code->c.fcode.paramtypes;
1238  pointer resulttype=code->c.fcode.resulttype;
1239  pointer p,lisparg;
1240  eusinteger_t cargv[100];
1241  numunion nu;
1242  eusinteger_t i=0; /*C argument counter*//* ???? */
1243  eusinteger_t j=0; /*lisp argument counter*//* ???? */
1244  union {
1245  double d;
1246  float f;
1247  struct {
1248  int i1,i2;} i;
1249  } numbox;
1250  double f;
1251 
1252  if (code->c.fcode.entry2 != NIL) {
1253 #if (WORD_SIZE == 64)
1254  ifunc = (((eusinteger_t)ifunc)&0xffffffff00000000) | (intval(code->c.fcode.entry2)&0x00000000ffffffff);
1255 #else
1256  ifunc = (eusinteger_t (*)())((((int)ifunc)&0xffff0000) | (intval(code->c.fcode.entry2)&0x0000ffff)); /* kanehiro's patch 2000.12.13 */
1257 #endif
1258  }
1259  while (iscons(paramtypes)) {
1260  p=ccar(paramtypes); paramtypes=ccdr(paramtypes);
1261  lisparg=args[j++];
1262  if (p==K_INTEGER)
1263  cargv[i++]=isint(lisparg)?intval(lisparg):bigintval(lisparg);
1264  else if (p==K_STRING) {
1265  if (elmtypeof(lisparg)==ELM_FOREIGN) cargv[i++]=lisparg->c.ivec.iv[0];
1266  else cargv[i++]=(eusinteger_t)(lisparg->c.str.chars);}
1267  else if (p==K_FLOAT32 || (WORD_SIZE==32 && p==K_FLOAT)) {
1268  numbox.f=ckfltval(lisparg);
1269  cargv[i++]=(int)numbox.i.i1;}
1270  else if (p==K_DOUBLE || (WORD_SIZE==64 && p==K_FLOAT)) {
1271  numbox.d=ckfltval(lisparg);
1272  cargv[i++]=numbox.i.i1; cargv[i++]=numbox.i.i2;}
1273  else error(E_USER,(pointer)"unknown type specifier");}
1274  /* &rest arguments? */
1275  while (j<n) { /* j is the counter for the actual arguments*/
1276  lisparg=args[j++];
1277  if (isint(lisparg)) cargv[i++]=intval(lisparg);
1278  else if (isflt(lisparg)) {
1279  numbox.d=ckfltval(lisparg); /* i advances independently */
1280  numbox.f=ckfltval(lisparg);
1281  cargv[i++]=numbox.i.i1; cargv[i++]=numbox.i.i2;}
1282  else if (isvector(lisparg)) {
1283  if (elmtypeof(lisparg)==ELM_FOREIGN)
1284  cargv[i++]=lisparg->c.ivec.iv[0];
1285  else cargv[i++]=(eusinteger_t)(lisparg->c.str.chars);}
1286 #if 1 /* begin kanehiro's patch 2000.12.13 */
1287  else if (isbignum(lisparg)){
1288  if (bigsize(lisparg)==1){
1289  eusinteger_t *xv = bigvec(lisparg);
1290  cargv[i++]=(eusinteger_t)xv[0];
1291  }else{
1292  fprintf(stderr, "bignum size!=1\n");
1293  }
1294  }
1295 #endif /* end of kanehiro's patch 2000.12.13 */
1296  else cargv[i++]=(eusinteger_t)(lisparg->c.obj.iv);}
1297 
1298  if (resulttype==K_FLOAT || resulttype==K_FLOAT32) {
1299  union {
1300  eusfloat_t f;
1301 #if __ARM_ARCH==4
1302  eusinteger_t i; // ARM 32bit armel
1303 #else
1304  eusfloat_t i; // Intel 32bit x86
1305 #endif
1306  } n;
1307 #if __ARM_ARCH==4
1308 #else
1309  eusinteger_t (*tmp_ifunc)() = ifunc;
1310  double (*ifunc)();
1311  ifunc=(double (*)())tmp_ifunc;
1312 #endif
1313  if (i<=8)
1314  n.i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
1315  cargv[4],cargv[5],cargv[6],cargv[7]);
1316  else if (i<=32)
1317  n.i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
1318  cargv[4],cargv[5],cargv[6],cargv[7],
1319  cargv[8],cargv[9],cargv[10],cargv[11],
1320  cargv[12],cargv[13],cargv[14],cargv[15],
1321  cargv[16],cargv[17],cargv[18],cargv[19],
1322  cargv[20],cargv[21],cargv[22],cargv[23],
1323  cargv[24],cargv[25],cargv[26],cargv[27],
1324  cargv[28],cargv[29],cargv[30],cargv[31]);
1325 #if (sun3 || sun4 || mips || alpha)
1326  else if (i>32)
1327  n.i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
1328  cargv[4],cargv[5],cargv[6],cargv[7],
1329  cargv[8],cargv[9],cargv[10],cargv[11],
1330  cargv[12],cargv[13],cargv[14],cargv[15],
1331  cargv[16],cargv[17],cargv[18],cargv[19],
1332  cargv[20],cargv[21],cargv[22],cargv[23],
1333  cargv[24],cargv[25],cargv[26],cargv[27],
1334  cargv[28],cargv[29],cargv[30],cargv[31],
1335  cargv[32],cargv[33],cargv[34],cargv[35],
1336  cargv[36],cargv[37],cargv[38],cargv[39],
1337  cargv[40],cargv[41],cargv[42],cargv[43],
1338  cargv[44],cargv[45],cargv[46],cargv[47],
1339  cargv[48],cargv[49],cargv[50],cargv[51],
1340  cargv[52],cargv[53],cargv[54],cargv[55],
1341  cargv[56],cargv[57],cargv[58],cargv[59],
1342  cargv[60],cargv[61],cargv[62],cargv[63],
1343  cargv[64],cargv[65],cargv[66],cargv[67],
1344  cargv[68],cargv[69],cargv[70],cargv[71],
1345  cargv[72],cargv[73],cargv[74],cargv[75],
1346  cargv[76],cargv[77],cargv[78],cargv[79]);
1347 #endif
1348  fprintf(stderr, "%d %f\n", n.i, n.f);
1349  return(makeflt(n.f));}
1350  else {
1351  if (i<8)
1352  i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
1353  cargv[4],cargv[5],cargv[6],cargv[7]);
1354  else if (i<=32)
1355  i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
1356  cargv[4],cargv[5],cargv[6],cargv[7],
1357  cargv[8],cargv[9],cargv[10],cargv[11],
1358  cargv[12],cargv[13],cargv[14],cargv[15],
1359  cargv[16],cargv[17],cargv[18],cargv[19],
1360  cargv[20],cargv[21],cargv[22],cargv[23],
1361  cargv[24],cargv[25],cargv[26],cargv[27],
1362  cargv[28],cargv[29],cargv[30],cargv[31]);
1363 #if (sun3 || sun4 || mips || alpha)
1364  else if (i>32)
1365  i=(*ifunc)(cargv[0],cargv[1],cargv[2],cargv[3],
1366  cargv[4],cargv[5],cargv[6],cargv[7],
1367  cargv[8],cargv[9],cargv[10],cargv[11],
1368  cargv[12],cargv[13],cargv[14],cargv[15],
1369  cargv[16],cargv[17],cargv[18],cargv[19],
1370  cargv[20],cargv[21],cargv[22],cargv[23],
1371  cargv[24],cargv[25],cargv[26],cargv[27],
1372  cargv[28],cargv[29],cargv[30],cargv[31],
1373  cargv[32],cargv[33],cargv[34],cargv[35],
1374  cargv[36],cargv[37],cargv[38],cargv[39],
1375  cargv[40],cargv[41],cargv[42],cargv[43],
1376  cargv[44],cargv[45],cargv[46],cargv[47],
1377  cargv[48],cargv[49],cargv[50],cargv[51],
1378  cargv[52],cargv[53],cargv[54],cargv[55],
1379  cargv[56],cargv[57],cargv[58],cargv[59],
1380  cargv[60],cargv[61],cargv[62],cargv[63],
1381  cargv[64],cargv[65],cargv[66],cargv[67],
1382  cargv[68],cargv[69],cargv[70],cargv[71],
1383  cargv[72],cargv[73],cargv[74],cargv[75],
1384  cargv[76],cargv[77],cargv[78],cargv[79]);
1385 #endif
1386  if (resulttype==K_INTEGER) return(mkbigint(i));
1387  else if (resulttype==K_STRING) {
1388  p=makepointer(i-2*sizeof(pointer));
1389  if (isvector(p)) return(p);
1390  else error(E_USER,(pointer)"illegal foreign string"); }
1391  else if (iscons(resulttype)) {
1392  /* (:string [10]) (:foreign-string [20]) */
1393  if (ccar(resulttype)=K_STRING) {
1394  resulttype=ccdr(resulttype);
1395  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
1396  else j=strlen((char *)i);
1397  return(makestring((char *)i, j)); }
1398  else if (ccar(resulttype)=K_FOREIGN_STRING) {
1399  resulttype=ccdr(resulttype);
1400  if (resulttype!=NIL) j=ckintval(ccar(resulttype));
1401  else j=strlen((char *)i);
1402  return(make_foreign_string(i, j)); }
1403  error(E_USER,(pointer)"unknown result type"); }
1404  else error(E_USER,(pointer)"result type?");
1405  }}
1406 #endif /* x86_64 */
1407 #endif /* IRIX */
1408 #endif /* IRIX6 */
1409 
1410 pointer funcode(ctx,func,args,noarg)
1411 register context *ctx;
1412 register pointer func,args;
1413 register int noarg;
1414 { register pointer (*subr)();
1415  register pointer *argp=ctx->vsp;
1416  register int n=0;
1417  register eusinteger_t addr;
1418  pointer tmp;
1419  addr=(eusinteger_t)(func->c.code.entry);
1420 #if (WORD_SIZE == 64)
1421  addr &= ~3L; /*0xfffffffffffffffc; ???? */
1422 #else
1423  addr &= ~3; /*0xfffffffc; ???? */
1424 #endif
1425 #if ARM
1426  if (func->c.code.entry2 != NIL) {
1427 #if (WORD_SIZE == 64)
1428  addr = addr | (intval(func->c.code.entry2)&0x00000000ffffffff);
1429 #else
1430  addr = addr | (intval(func->c.code.entry2)&0x0000ffff);
1431 #endif
1432  }
1433 #endif
1434  subr=(pointer (*)())(addr);
1435 #ifdef FUNCODE_DEBUG
1436  printf( "funcode:func = " ); hoge_print( func );
1437  printf( "funcode:args = " ); hoge_print( args );
1438 #endif
1439  GC_POINT;
1440  switch((eusinteger_t)(func->c.code.subrtype)) { /*func,macro or special form*//* ???? */
1441  case (eusinteger_t)SUBR_FUNCTION:/* ???? */
1442  if (noarg<0) {
1443  while (piscons(args)) {
1444  vpush(eval(ctx,ccar(args))); args=ccdr(args); n++; GC_POINT;}
1445  if (pisfcode(func)) /*foreign function?*/
1446  return(call_foreign((eusinteger_t (*)())subr,func,n,argp));
1447  else return((*subr)(ctx,n,argp));}
1448  else if (pisfcode(func))
1449  return(call_foreign((eusinteger_t (*)())subr,func,noarg,(pointer *)args));
1450  else return((*subr)(ctx,noarg,args,0));
1451  break;
1452  case (eusinteger_t)SUBR_MACRO:/* ???? */
1453  if (noarg>=0) error(E_ILLFUNC);
1454  while (iscons(args)) { vpush(ccar(args)); args=ccdr(args); n++;}
1455  GC_POINT;
1456  tmp = (*subr)(ctx,n,argp);
1457  GC_POINT;
1458  return(eval(ctx,tmp));
1459  case (eusinteger_t)SUBR_SPECIAL: /* ???? */
1460  if (noarg>=0) error(E_ILLFUNC);
1461  else return((*subr)(ctx,args));
1462 /* case (int)SUBR_ENTRY:
1463  func=(*subr)(func);
1464  return(makeint(func)); */
1465  default: error(E_ILLFUNC); break;}
1466  }
1467 
1468 pointer clofunc;
1469 pointer ufuncall(ctx,form,fn,args,env,noarg)
1470 register context *ctx;
1471 pointer form,fn;
1472 register pointer args; /*or 'pointer *' */
1473 struct bindframe *env;
1474 int noarg;
1475 { pointer func,formal,aval,ftype,result,*argp,hook;
1476  register struct callframe *vf=(struct callframe *)(ctx->vsp);
1477  struct specialbindframe *sbfps=ctx->sbindfp;
1478  register int n=0,i;
1479  register pointer (*subr)();
1480  struct fletframe *oldfletfp=ctx->fletfp, *fenv;
1481  GC_POINT;
1482  /* evalhook */
1483  if (Spevalof(QEVALHOOK)!=NIL && ehbypass==0) {
1484  hook=Spevalof(QEVALHOOK);
1485  bindspecial(ctx,QEVALHOOK,NIL);
1486  if (noarg<0) vpush(cons(ctx,fn,args));
1487  else {
1488  argp=(pointer *)args;
1489  aval=NIL;
1490  i=noarg;
1491  while (--i>=0) aval=cons(ctx,argp[i],aval);
1492  vpush(cons(ctx,fn,aval));}
1493  vpush(env);
1494  GC_POINT;
1495  result=ufuncall(ctx,form,hook,(pointer)(ctx->vsp-2),env,2); /*apply evalhook function*/
1496  ctx->vsp=(pointer *)vf;
1497  unbindspecial(ctx,sbfps+1);
1498 #ifdef __RETURN_BARRIER
1499  check_return_barrier(ctx);
1500  /* check return barrier */
1501 #endif
1502  return(result);}
1503  else ehbypass=0;
1504 
1505  if (issymbol(fn)) {
1506  func=getfunc(ctx,fn);
1507  }
1508  else {
1509  if (islist(fn)) env=ctx->bindfp;
1510  func=fn;}
1511  if (!ispointer(func)) error(E_ILLFUNC);
1512 
1513  /*make a new stack frame*/
1514  stackck; /*stack overflow?*/
1515  breakck; /*signal exists?*/
1516  vf->vlink=ctx->callfp;
1517  vf->form=form;
1518  ctx->callfp=vf;
1519  ctx->vsp+=sizeof(struct callframe)/(sizeof(pointer));
1520  argp=ctx->vsp;
1521 
1522  if (pisclosure(func)) {
1523  clofunc=func;
1524  fn=func;
1525  if (fn->c.code.subrtype!=SUBR_FUNCTION) error(E_ILLFUNC);
1526 #if (WORD_SIZE == 64)
1527  subr=(pointer (*)())((eusinteger_t)(fn->c.code.entry) & ~3L /*0xfffffffc ????*/);
1528 #else
1529  subr=(pointer (*)())((eusinteger_t)(fn->c.code.entry) & ~3 /*0xfffffffc ????*/);
1530 #endif
1531 #if ARM
1532  register eusinteger_t addr;
1533  addr = (eusinteger_t)(fn->c.code.entry);
1534 #if (WORD_SIZE == 64)
1535  addr &= ~3L; /*0xfffffffc; ???? */
1536 #else
1537  addr &= ~3; /*0xfffffffc; ???? */
1538 #endif
1539  if (fn->c.code.entry2 != NIL) {
1540 #if (WORD_SIZE == 64)
1541  addr = addr | (intval(fn->c.code.entry2)&0x00000000ffffffff);
1542 #else
1543  addr = addr | (intval(fn->c.code.entry2)&0x0000ffff);
1544 #endif
1545  }
1546  subr=(pointer (*)())(addr);
1547 #endif
1548 #if !Solaris2 && !SunOS4_1 && !Linux && !IRIX && !IRIX6 && !alpha && !Cygwin
1549  if ((char *)subr>maxmemory) {
1550  prinx(ctx,clofunc, STDOUT);
1551  error(E_USER,(pointer)"garbage closure, fatal bug!"); }
1552 #endif
1553  if (noarg<0) {
1554  while (iscons(args)) {
1555  vpush(eval(ctx,ccar(args))); args=ccdr(args); n++; GC_POINT;}
1556  result=(*subr)(ctx,n,argp,func);} /*call func with env*/
1557  else result=(*subr)(ctx,noarg,args,func);
1558  /*recover call frame and stack pointer*/
1559  ctx->vsp=(pointer *)vf;
1560  ctx->callfp= vf->vlink;
1561  ctx->fletfp=oldfletfp;
1562 #ifdef __RETURN_BARRIER
1563  check_return_barrier(ctx);
1564  /* check return barrier */
1565 #endif
1566  return(result);}
1567 
1568  else if (piscode(func)) { /*call subr*/
1569  GC_POINT;
1570  result=funcode(ctx,func,args,noarg);
1571  ctx->vsp=(pointer *)vf;
1572  ctx->callfp= vf->vlink;
1573  ctx->fletfp=oldfletfp;
1574 #ifdef __RETURN_BARRIER
1575  check_return_barrier(ctx);
1576 #endif
1577  return(result);}
1578  else if (piscons(func)) {
1579  ftype=ccar(func);
1580  func=ccdr(func);
1581  if (!issymbol(ftype)) error(E_LAMBDA);
1582  if (ftype->c.sym.homepkg==keywordpkg) fn=ftype; /*blockname=selector*/
1583  else if (ftype==LAMCLOSURE) {
1584  fn=ccar(func); func=ccdr(func);
1585  env=(struct bindframe *)intval(ccar(func));
1586  if (env < (struct bindframe *)ctx->stack ||
1587  (struct bindframe *)ctx->stacklimit < env) env=0;
1588  func=ccdr(func);
1589  /* ctx->fletfp=(struct fletframe *)intval(ccar(func)); */
1590  fenv=(struct fletframe *)intval(ccar(func));
1591  func=ccdr(func);}
1592  else if (ftype!=LAMBDA && ftype!=MACRO) error(E_LAMBDA);
1593  else env=NULL /*0 ????*/;
1594  formal=carof(func,E_LAMBDA);
1595  func=ccdr(func);
1596  if (noarg<0) { /*spread args on stack*/
1597  noarg=0;
1598  while (iscons(args)) {
1599  aval=ccar(args);
1600  args=ccdr(args);
1601  if (ftype!=MACRO) {GC_POINT;aval=eval(ctx,aval);}
1602  vpush(aval); noarg++;}}
1603  else {
1604  argp=(pointer *)args;
1605  if (ftype==MACRO) error(E_ILLFUNC);}
1606  GC_POINT;
1607  if (ftype==LAMCLOSURE) { ctx->fletfp=fenv; }
1608  result=funlambda(ctx,fn,formal,func,argp,env,noarg);
1609  ctx->vsp=(pointer *)vf;
1610  ctx->callfp=vf->vlink;
1611  GC_POINT;
1612  if (ftype==MACRO) result=eval(ctx,result);
1613  ctx->fletfp=oldfletfp;
1614 #ifdef __RETURN_BARRIER
1615  check_return_barrier(ctx);
1616  /* check return barrier */
1617 #endif
1618  return(result);}
1619  else error(E_ILLFUNC);
1620  }
1621 
1622 pointer eval(ctx,form)
1623 register context *ctx;
1624 register pointer form;
1625 { register pointer c;
1626  register pointer p;
1627 #if defined(DEBUG_COUNT) || defined(EVAL_DEBUG)
1628  static int count=0;
1629  int save_count;
1630 
1631  count++;
1632  save_count = count;
1633 #endif
1634 #ifdef EVAL_DEBUG
1635  if( evaldebug ) {
1636  printf( "%d:", count );
1637  hoge_print(form);
1638  }
1639 #endif
1640  GC_POINT;
1641  if (isnum(form)) p = form;
1642  else if (pissymbol(form)) p = getval(ctx,form);
1643  else if (!piscons(form)) p = form;
1644  else {
1645  c=ccdr(form);
1646  if (c!=NIL && issymbol(c)) p = (*ovafptr(eval(ctx,ccar(form)),c));
1647  else {
1648  p = ufuncall(ctx,form,ccar(form),c,NULL,-1);
1649 #ifdef SAFETY
1650  take_care(p);
1651 #endif
1652  }
1653  }
1654 
1655 #ifdef EVAL_DEBUG
1656  if( evaldebug ) {
1657  printf( "%d:--- ", save_count );
1658  hoge_print(p);
1659  }
1660 #endif
1661  return(p);
1662  }
1663 
1664 pointer eval2(ctx,form,env)
1665 register context *ctx;
1666 register pointer form;
1667 pointer env;
1668 { register pointer c;
1669  GC_POINT;
1670  if (isnum(form)) return(form);
1671  else if (pissymbol(form)) return(getval(ctx,form));
1672  else if (!piscons(form)) return(form);
1673  else {
1674  c=ccdr(form);
1675  if (c!=NIL && issymbol(c)) return(*ovafptr(eval(ctx,ccar(form)),c));
1676  else return(ufuncall(ctx,form,ccar(form),(pointer)c,(struct bindframe *)env,-1));}
1677  }
1678 
1679 pointer progn(ctx,forms)
1680 register context *ctx;
1681 register pointer forms;
1682 { register pointer result=NIL;
1683  while (iscons(forms)) {
1684  GC_POINT;
1685  result=eval(ctx,ccar(forms)); forms=ccdr(forms);}
1686  return(result);}
1687 
1688 
1689 /* csend(ctx,object,selector,argc,arg1,arg2,....) */
1690 #ifdef USE_STDARG
1691 
1692 pointer csend(context *ctx, ...)
1693 {
1694  va_list ap;
1695 
1696  pointer rec,sel;
1697  int cnt;
1698  pointer res,*spsave;
1699  int i=0;
1700 
1701  va_start(ap, ctx);
1702 
1703  rec = va_arg(ap,pointer);
1704  sel = va_arg(ap,pointer);
1705  cnt = va_arg(ap,int);
1706  spsave=ctx->vsp;
1707  vpush(rec); vpush(sel);
1708  while (i++ < cnt) vpush(va_arg(ap,pointer));
1709  GC_POINT;
1710  res=(pointer)SEND(ctx,cnt+2, spsave);
1711  ctx->vsp=spsave;
1712  return(res);}
1713 
1714 #else
1715 pointer csend(va_alist)
1716 va_dcl
1717 { va_list ap;
1718  pointer rec,sel;
1719  int cnt;
1720  pointer res,*spsave;
1721  int i=0;
1722  register context *ctx;
1723 
1724  va_start(ap);
1725  ctx = va_arg(ap,context *);
1726  rec = va_arg(ap,pointer);
1727  sel = va_arg(ap,pointer);
1728  cnt = va_arg(ap,int);
1729  spsave=ctx->vsp;
1730  vpush(rec); vpush(sel);
1731  while (i++ < cnt) vpush(va_arg(ap,pointer));
1732  GC_POINT;
1733  res=(pointer)SEND(ctx,cnt+2, spsave);
1734  ctx->vsp=spsave;
1735 #ifdef SAFETY
1736  take_care(res);
1737 #endif
1738  return(res);}
1739 #endif
1740 
intvector::iv
eusinteger_t iv[1]
Definition: eus.h:305
prinx
pointer prinx(context *, pointer, pointer)
Definition: printer.c:611
d
d
ovafptr
pointer * ovafptr(pointer o, pointer v)
Definition: eval.c:120
symbol::speval
pointer speval
Definition: eus.h:203
f
f
E_NOOBJ
Definition: eus.h:975
intern
pointer intern(context *, char *, int, pointer)
Definition: intern.c:105
vectorcp
cixpair vectorcp
Definition: eus.c:88
cell::cellunion::vec
struct vector vec
Definition: eus.h:414
rcsid
static char * rcsid
Definition: eval.c:8
cell::cellunion::cls
struct _class cls
Definition: eus.h:418
makeblock
struct blockframe * makeblock(context *, pointer, pointer, jmp_buf *, struct blockframe *)
Definition: makes.c:766
makeint
#define makeint(v)
Definition: sfttest.c:2
pointer
struct cell * pointer
Definition: eus.h:165
setfunc
void setfunc(pointer sym, pointer func)
Definition: eval.c:116
context
Definition: eus.h:524
STDOUT
pointer STDOUT
Definition: eus.c:119
cons
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
getval
pointer getval(context *ctx, pointer sym)
Definition: eval.c:33
cell::cellunion::str
struct string str
Definition: eus.h:402
_class::vars
pointer vars
Definition: eus.h:328
numunion::fval
eusfloat_t fval
Definition: eus.h:430
code::entry2
pointer entry2
Definition: eus.h:236
string::chars
byte chars[1]
Definition: eus.h:212
getobjv
pointer * getobjv(pointer sym, pointer varvec, pointer obj)
Definition: eval.c:22
context::vsp
pointer * vsp
Definition: eus.h:525
OPTIONAL
pointer OPTIONAL
Definition: eus.c:170
bindframe::val
pointer val
Definition: eus.h:482
maxmemory
char * maxmemory
Definition: memory.c:50
vbind
struct bindframe * vbind(context *ctx, pointer var, pointer val, struct bindframe *lex, struct bindframe *declscope)
Definition: eval.c:194
n
GLfloat n[6][3]
Definition: cube.c:15
body
static GLfloat body[][2]
Definition: dinoshade.c:75
K_ALLOWOTHERKEYS
pointer K_ALLOWOTHERKEYS
Definition: eus.c:169
cell::cellunion::code
struct code code
Definition: eus.h:408
intval
#define intval(p)
Definition: sfttest.c:1
declare
struct bindframe * declare(context *ctx, pointer decllist, struct bindframe *env)
Definition: eval.c:220
MACRO
pointer MACRO
Definition: eus.c:170
fargv
static float * fargv
Definition: transargv.c:57
call_foreign
pointer call_foreign(eusinteger_t(*ifunc)(), pointer code, int n, args)
Definition: eval.c:1232
iargv
static int * iargv
Definition: transargv.c:58
E_LAMBDA
Definition: eus.h:950
fletframe::name
pointer name
Definition: eus.h:510
E_USER
Definition: eus.h:1006
K_STRING
pointer K_STRING
Definition: eus.c:131
REST
pointer REST
Definition: eus.c:170
code::entry
pointer entry
Definition: eus.h:234
blockframe::dynklink
struct blockframe * dynklink
Definition: eus.h:491
E_ILLFUNC
Definition: eus.h:943
LAMBDA
pointer LAMBDA
Definition: eus.c:170
cell::cellunion::sym
struct symbol sym
Definition: eus.h:401
ckfltval
float ckfltval()
K_FLOAT32
pointer K_FLOAT32
Definition: eus.c:133
ALLOWOTHERKEYS
pointer ALLOWOTHERKEYS
Definition: eus.c:169
specialbindframe::oldval
pointer oldval
Definition: eus.h:487
QDECLARE
pointer QDECLARE
Definition: eus.c:112
clofunc
pointer clofunc
Definition: eval.c:1468
cell::cellunion::ivec
struct intvector ivec
Definition: eus.h:416
parsekeyparams
int parsekeyparams(pointer keyvec, pointer *actuals, int noarg, pointer *results, int allowotherkeys)
Definition: eval.c:237
cell::c
union cell::cellunion c
object::iv
pointer iv[2]
Definition: eus.h:321
callframe
Definition: eus.h:474
bindframe
Definition: eus.h:479
bindspecial
void bindspecial(context *ctx, pointer sym, pointer newval)
Definition: eval.c:131
numunion
Definition: eus.h:428
bindframe::sym
pointer sym
Definition: eus.h:481
l
long l
Definition: structsize.c:3
symbol::homepkg
pointer homepkg
Definition: eus.h:203
bindkeyparams
struct bindframe * bindkeyparams(context *ctx, pointer formal, pointer *argp, int noarg, struct bindframe *env, struct bindframe *bf)
Definition: eval.c:270
eval2
pointer eval2(context *ctx, pointer form, pointer env)
Definition: eval.c:1664
E_DECLARE
Definition: eus.h:986
callframe::vlink
struct callframe * vlink
Definition: eus.h:475
cell
Definition: eus.h:381
setval
pointer setval(context *ctx, pointer sym, pointer val)
Definition: eval.c:68
K_FOREIGN_STRING
pointer K_FOREIGN_STRING
Definition: eus.c:133
unbindx
void unbindx(context *ctx, int count)
Definition: eval.c:150
callframe::form
pointer form
Definition: eus.h:476
QEVALHOOK
pointer QEVALHOOK
Definition: eus.c:121
QSPECIAL
pointer QSPECIAL
Definition: eus.c:112
bindframe::lexblink
struct bindframe * lexblink
Definition: eus.h:480
fletframe::fclosure
pointer fclosure
Definition: eus.h:511
s
short s
Definition: structsize.c:2
vector::size
pointer size
Definition: eus.h:300
progn
pointer progn(context *ctx, pointer forms)
Definition: eval.c:1679
specialbindframe::sym
pointer sym
Definition: eus.h:486
code::subrtype
pointer subrtype
Definition: eus.h:233
funlambda
pointer funlambda(context *ctx, pointer fn, pointer formal, pointer body, pointer *argp, struct bindframe *env, int noarg)
Definition: eval.c:346
AUX
pointer AUX
Definition: eus.c:170
cell::cix
short cix
Definition: eus.h:398
symbol::vtype
pointer vtype
Definition: eus.h:203
K_DOUBLE
pointer K_DOUBLE
Definition: eus.c:133
bindframe::dynblink
struct bindframe * dynblink
Definition: eus.h:480
fletframe::lexlink
struct fletframe * lexlink
Definition: eus.h:513
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
KEY
pointer KEY
Definition: eus.c:170
eusinteger_t
long eusinteger_t
Definition: eus.h:19
code
Definition: eus.h:230
GC_POINT
#define GC_POINT
Definition: eus.h:172
unbindspecial
void unbindspecial(context *ctx, struct specialbindframe *limit)
Definition: eval.c:165
SEND
pointer SEND(context *, int, pointer *)
count
int count
Definition: thrtest.c:11
makestring
pointer makestring(char *, int)
Definition: makes.c:147
specialbindframe::sblink
struct specialbindframe * sblink
Definition: eus.h:485
max
#define max(I1, I2)
Definition: eustags.c:134
E_UNDEF
Definition: eus.h:941
fastbind
struct bindframe * fastbind(context *ctx, pointer var, pointer val, struct bindframe *lex)
Definition: eval.c:180
NULL
#define NULL
Definition: transargv.c:8
ehbypass
int ehbypass
Definition: eus.c:160
cell::cellunion::obj
struct object obj
Definition: eus.h:417
symbol::pname
pointer pname
Definition: eus.h:203
K_FLOAT
pointer K_FLOAT
Definition: eus.c:133
csend
pointer csend(va_alist)
Definition: eval.c:1715
make_foreign_string
pointer make_foreign_string(eusinteger_t, int)
Definition: makes.c:157
funcode
pointer funcode(context *ctx, pointer func, pointer args, int noarg)
Definition: eval.c:1410
v
GLfloat v[8][3]
Definition: cube.c:21
LAMCLOSURE
pointer LAMCLOSURE
Definition: eus.c:170
K_INTEGER
pointer K_INTEGER
Definition: eus.c:132
symbol::spefunc
pointer spefunc
Definition: eus.h:203
E_UNBOUND
Definition: eus.h:940
cixpair::cix
short cix
Definition: eus.h:453
eusfloat_t
double eusfloat_t
Definition: eus.h:21
NIL
pointer NIL
Definition: eus.c:110
fletframe
Definition: eus.h:509
eval
pointer eval(context *ctx, pointer form)
Definition: eval.c:1622
vector::v
pointer v[1]
Definition: eus.h:301
ufuncall
pointer ufuncall(context *ctx, pointer form, pointer fn, pointer args, struct bindframe *env, int noarg)
Definition: eval.c:1469
getfunc
pointer getfunc(context *ctx, pointer f)
Definition: eval.c:97
keywordpkg
pointer keywordpkg
Definition: eus.c:109
get_sym_func
pointer get_sym_func(pointer s)
Definition: eval.c:109
makeflt
pointer makeflt()
numunion::ival
eusinteger_t ival
Definition: eus.h:431

euslisp
Author(s): Toshihiro Matsui
autogenerated on Mon Feb 28 2022 22:18:27