specials.c
Go to the documentation of this file.
1 /*****************************************************************
2 /* specials.c
3 /* special-forms (let,let*,catch,throw,unwind-protect,...)
4 /* control structures,
5 /* macros ...
6 /*
7 /* Copyright: Toshihiro Matsui ETL, Umezono, Sakura-mura
8 /*
9 /* 1986
10 /* 1986-Dec let*
11 /* 1987-Mar special binding declaration
12 *****************************************************************/
13 static char *rcsid="@(#)$Id$";
14 
15 #include "eus.h"
18 extern struct bindframe *declare();
19 
20 #ifdef EVAL_DEBUG
21 extern int evaldebug;
22 #endif
23 
24 /*gensym*/
26 static int genindex,tempindex=0;
28 
29 /****************************************************************/
30 /* special forms
31 /****************************************************************/
32 
33 pointer quote(ctx,arg)
34 register context *ctx;
35 register pointer arg;
36 {
37 #ifdef SPEC_DEBUG
38  printf( "quote:" ); hoge_print(arg);
39 #endif
40  return(carof(arg,E_MISMATCHARG));
41 }
42 
43 pointer EVAL(ctx,n,argv)
44 register context *ctx;
45 int n;
46 register pointer argv[];
47 { pointer env;
48  ckarg2(1,2);
49  if (n==2) env=argv[1]; else env=NULL;
50 #ifdef SPEC_DEBUG
51  printf( "EVAL:" );
52  hoge_print_sub(argv[0]);
53  if( env != NULL )
54  hoge_print_sub( env );
55  printf( "\n" );
56 #endif
57  return(eval2(ctx,argv[0],env));}
58 
59 pointer PROGN(ctx,arg)
60 register context *ctx;
61 register pointer arg;
62 {
63 #ifdef SPEC_DEBUG
64  printf( "PROGN:" ); hoge_print( arg );
65 #endif
66  return(progn(ctx,arg));}
67 
68 pointer PROG1(ctx,n,argv)
69 register context *ctx;
70 int n;
71 pointer *argv;
72 {
73 #ifdef SPEC_DEBUG
74  printf( "PROG1:" );
75  if( n >= 0 ) hoge_print_sub( argv[0] );
76  printf( "\n" );
77 #endif
78  return((n>=1)?argv[0]:NIL);}
79 
80 pointer APPLY(ctx,n,argv)
81 register context *ctx;
82 int n;
83 register pointer argv[];
84 { register pointer a,*spsave=ctx->vsp,fun=argv[0];
85  register int i=1,argc=n-2;
86 
87  if (n<2) error(E_MISMATCHARG);
88 #ifdef SPEC_DEBUG
89  printf( "APPLY:" );
90  { int i;
91  for( i = 0; i < n; i++ )
92  hoge_print_sub( argv[i] );
93 }
94  printf( "\n" );
95 #endif
96  if (issymbol(fun)) {
97  if (fun->c.sym.spefunc==UNBOUND) error(E_UNDEF,argv[0]);}
98  while (i<n-1) ckpush(argv[i++]);
99  a=argv[i];
100  while (islist(a)) {
101  ckpush(ccar(a));
102  a=ccdr(a);
103  argc++;}
104  a=(pointer)ufuncall(ctx,(ctx->callfp?ctx->callfp->form:NIL),
105  fun,(pointer)spsave,NULL,argc);
106  ctx->vsp=spsave;
107 #ifdef SAFETY
108  take_care(a);
109 #endif
110  return(a);}
111 
112 pointer FUNCALL(ctx,n,argv)
113 register context *ctx;
114 int n;
115 register pointer argv[];
116 { register pointer fun=argv[0];
117  if (n<1) error(E_MISMATCHARG);
118 #if SPEC_DEBUG
119  printf( "FUNCALL:" );
120  {
121  int i;
122  for( i = 0; i < n; i++ )
123  hoge_print_sub( argv[i] );
124  }
125  printf( "\n" );
126 #endif
127  if (issymbol(fun)) {
128  if (fun->c.sym.spefunc==UNBOUND) error(E_UNDEF,fun);}
129  pointer_update(Spevalof(QEVALHOOK),NIL);
130  return((pointer)ufuncall(ctx,ctx->callfp->form,fun,(pointer)&argv[1],NULL,n-1));}
131 
133 register context *ctx;
134 pointer arg;
135 { pointer funcname;
136  if (!islist(arg)) error(E_MISMATCHARG);
137  if (ccdr(arg)!=NIL) error(E_MISMATCHARG);
138 #ifdef SPEC_DEBUG
139  printf( "FUNCTION_CLOSURE:" );
140  hoge_print( arg );
141 #endif
142  arg=ccar(arg);
143  if (issymbol(arg)) { funcname=arg; arg=getfunc(ctx,arg);}
144  else funcname=NIL;
145  if (iscode(arg)) return(arg);
146  else if (ccar(arg)==LAMCLOSURE) return(arg);
147  else if (ccar(arg)==LAMBDA) {
148  arg=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),ccdr(arg));
149  arg=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),arg);
150  arg=cons(ctx,funcname,arg);
151  return(cons(ctx,LAMCLOSURE,arg));}
152  else error(E_ILLFUNC);}
153 
155 register context *ctx;
156 int n;
157 register pointer argv[];
158 { pointer mac,args,expander,*argp,result;
159  int noarg=0;
160  ckarg(1);
161 #ifdef SPEC_DEBUG
162  printf( "MACEXPAND2:" ); hoge_print( argv[0] );
163 #endif
164  if (!islist(argv[0])) return(argv[0]);
165  mac=ccar(argv[0]); args=ccdr(argv[0]);
166  if (issymbol(mac)) mac=getfunc(ctx,mac);
167  if (iscode(mac)) {
168 #if ARM
169  eusinteger_t addr = (eusinteger_t)(mac->c.code.entry);
170 #if (WORD_SIZE == 64)
171  addr &= ~3L; /*0xfffffffc; ???? */
172 #else
173  addr &= ~3; /*0xfffffffc; ???? */
174 #endif
175 #if (WORD_SIZE == 64)
176  addr = addr | (intval(mac->c.code.entry2)&0x00000000ffffffff);
177 #else
178  addr = addr | (intval(mac->c.code.entry2)&0x0000ffff);
179 #endif
180 #endif // ARM
181  if (mac->c.code.subrtype!=(pointer)SUBR_MACRO) return(argv[0]);
182 #if ARM
183  expander=makecode(mac,(pointer (*)())addr,SUBR_FUNCTION);
184  pointer_update(expander->c.code.entry2,mac->c.code.entry2)
185 #else
186  expander=makecode(mac,(pointer (*)())mac->c.code.entry,SUBR_FUNCTION);
187 #endif
188  pointer_update(expander->c.code.entry,mac->c.code.entry);}
189  else if (carof(mac,E_NOLIST)==MACRO) expander=cons(ctx,LAMBDA,ccdr(mac));
190  else return(argv[0]);
191  vpush(expander);
192  argp=ctx->vsp;
193  while (islist(args)) { vpush(ccar(args)); args=ccdr(args); noarg++;}
194  GC_POINT;
195  mac=ufuncall(ctx,ctx->callfp->form,expander,(pointer)argp,NULL,noarg);
196  /* ???? ctx->lastalloc=mac; ????*/
197  ctx->vsp=argp-1;
198  return(mac);}
199 
200 /****************************************************************/
201 /* mapping
202 /****************************************************************/
203 pointer MAPC(ctx,n,argv)
204 register context *ctx;
205 int n;
206 register pointer *argv;
207 { register pointer a;
208  register int i;
209  if (n<2) error(E_MISMATCHARG);
210 #ifdef SPEC_DEBUG
211  printf( "MAPC:" );
212  { int i;
213  for( i = 0; i < n; i++ )
214  hoge_print_sub( argv[i] );
215 }
216  printf( "\n" );
217 #endif
218  while (islist(argv[1])) {
219  i=1;
220  while (i<n) {
221  a=argv[i];
222  if (!islist(a)) error(E_NOLIST);
223  ckpush(ccar(a));
224  argv[i]=ccdr(a);
225  i++;}
226  i--;
227  GC_POINT;
228  ufuncall(ctx,ctx->callfp->form,argv[0],(pointer)(ctx->vsp - i),NULL,i);
229  ctx->vsp -= i;}
230  return(argv[1]);}
231 
232 pointer MAPCAR(ctx,n,argv)
233 register context *ctx;
234 register int n;
235 register pointer *argv;
236 { register pointer a,r;
237  register int rcount=0,i;
238  pointer (*subr)();
239 
240  if (n<2) error(E_MISMATCHARG);
241 #ifdef SPEC_DEBUG
242  printf( "MAPCAR:" );
243  { int i;
244  for( i = 0; i < n; i++ )
245  hoge_print_sub( argv[i] );
246 }
247  printf( "\n" );
248 #endif
249  while (islist(argv[1])) {
250  i=1;
251  while (i<n) {
252  a=argv[i];
253  if (!islist(a)) error(E_NOLIST);
254  ckpush(ccar(a));
255  argv[i]=ccdr(a);
256  i++;}
257  i--;
258  GC_POINT;
259  r=ufuncall(ctx,ctx->callfp->form,argv[0],(pointer)(ctx->vsp - i),NULL,i);
260  ctx->vsp -=i;
261  vpush(r);
262  rcount++;}
263  GC_POINT;
264  r=(pointer)stacknlist(ctx,rcount);
265  return(r);}
266 
267 pointer MAPCAN(ctx,n,argv)
268 register context *ctx;
269 int n;
270 register pointer *argv;
271 { register pointer a,r;
272  register int i,rcount=0;
273  pointer *spsave=ctx->vsp;
274  if (n<2) error(E_MISMATCHARG);
275 #ifdef SPEC_DEBUG
276  printf( "MAPCAN:" );
277  { int i;
278  for( i = 0; i < n; i++ )
279  hoge_print_sub( argv[i] );
280 }
281  printf( "\n" );
282 #endif
283  while (islist(argv[1])) {
284  i=1;
285  while (i<n) {
286  a=argv[i];
287  if (!islist(a)) error(E_NOLIST);
288  ckpush(ccar(a));
289  argv[i]=ccdr(a);
290  i++;}
291  i--;
292  GC_POINT;
293  r=ufuncall(ctx,ctx->callfp->form,argv[0],(pointer)(ctx->vsp -i),NULL,i);
294  ctx->vsp -=i;
295  vpush(r);
296  rcount++;}
297  GC_POINT;
298  a=(pointer)NCONC(ctx,rcount,spsave);
299  ctx->vsp=spsave;
300  return(a);}
301 
302 /****************************************************************/
303 /* SETQ
304 /****************************************************************/
305 pointer SETQ(ctx,arg)
306 register context *ctx;
307 register pointer arg;
308 { register pointer var,val=NIL, *p;
309 #ifdef SPEC_DEBUG
310  printf( "SETQ:" ); hoge_print( arg );
311 #endif
312  while (iscons(arg)) {
313  var=ccar(arg); arg=ccdr(arg);
314  if (!islist(arg)) error(E_MISMATCHARG);
315  GC_POINT;
316  val=eval(ctx,ccar(arg)); arg=ccdr(arg);
317  if (issymbol(var)) setval(ctx,var,val);
318  else if (islist(var) && issymbol(ccdr(var)) && ccdr(var)!=NIL) {
319  vpush(val);
320  p=(pointer *)ovafptr(eval(ctx,ccar(var)),ccdr(var)); pointer_update(*p,vpop());}
321  else error(E_NOSYMBOL,var);}
322  return(val);}
323 
324 
325 /****************************************************************/
326 /* control structures
327 /****************************************************************/
328 
329 pointer IF(ctx,arg)
330 register context *ctx;
331 register pointer arg;
332 { register pointer rest;
333  rest=cdrof(arg, E_MISMATCHARG);
334  if (!iscons(rest)) return(NIL);
335 #ifdef SPEC_DEBUG
336  printf( "IF:" ); hoge_print( arg );
337 #endif
338  GC_POINT;
339  if (eval(ctx,ccar(arg))!=NIL) return(eval(ctx,ccar(rest)));
340  else {
341  rest=ccdr(rest);
342  if (iscons(rest)) return(eval(ctx,ccar(rest)));
343  else return(NIL); } }
344 
345 pointer WHEN(ctx,n,argv)
346 register context *ctx;
347 int n;
348 pointer *argv;
349 { pointer form=NIL;
350  int i;
351  if (n<1) error(E_MISMATCHARG);
352 #ifdef SPEC_DEBUG
353  printf( "WHEN:" );
354  { int i;
355  for( i = 0; i < n; i++ )
356  hoge_print_sub( argv[i] );
357 }
358  printf( "\n" );
359 #endif
360  while (n>1) form=cons(ctx,argv[--n],form);
361  form=cons(ctx,QPROGN,form);
362  form=cons(ctx,argv[0],cons(ctx,form,NIL));
363  return(cons(ctx,QIF,form));}
364 
365 pointer WHILE(ctx,arg)
366 register context *ctx;
367 pointer arg;
368 { pointer cond,body,*spsave=ctx->vsp,result;
369  struct blockframe *myblock;
370  struct bindframe *bfp=ctx->bindfp;
371  jmp_buf whilejmp;
372  int i;
373 
374 #ifdef SPEC_DEBUG
375  printf( "WHILE:" ); hoge_print(arg);
376 #endif
377  if (!islist(arg)) return(NIL);
378  cond=ccar(arg); body=ccdr(arg);
379  myblock=(struct blockframe *)
380  makeblock(ctx,BLOCKFRAME,NIL,&whilejmp,ctx->blkfp); /* ???? */
381  if ((result=(pointer)eussetjmp(whilejmp))==0) {
382  while (eval(ctx,cond)!=NIL) {GC_POINT;progn(ctx,body);}
383  result=NIL;}
384  else if ((eusinteger_t)result==1) result=makeint(0);
385  ctx->blkfp=myblock->dynklink;
386  ctx->vsp=spsave;
387  ctx->bindfp=bfp;
388  return(result);}
389 
390 pointer COND(ctx,arg)
391 register context *ctx;
392 pointer arg;
393 { register pointer clause,cond;
394 
395 #ifdef SPEC_DEBUG
396  printf( "COND:" ); hoge_print(arg);
397 #endif
398  while (islist(arg)) {
399  clause=ccar(arg);
400  if (!islist(clause)) error(E_NOLIST);
401  GC_POINT;
402  cond=eval(ctx,ccar(clause));
403  if (cond!=NIL) if (islist(ccdr(clause))) return(progn(ctx,ccdr(clause)));
404  else return(cond);
405  arg=ccdr(arg);}
406  return(NIL);}
407 
408 pointer PARLET(ctx,args) /*let special form*/
409 register context *ctx;
410 pointer args;
411 { pointer vlist,vlistsave,var,init,body,result,decl,*spsave=ctx->vsp,*vinits;
412  register struct bindframe *env, *bfsave=ctx->bindfp, *declenv;
413  struct specialbindframe *sbfps=ctx->sbindfp;
414  int i=0,vcount=0;
415 #if defined(PARLET_DEBUG) || defined(DEBUG_COUNT)
416  static int count = 0;
417 
418  count++;
419 #endif
420 
421 #if defined(SPEC_DEBUG) || defined(PARLET_DEBUG)
422  printf( "PARLET:%d",count ); hoge_print(args);
423 #endif
424 
425  vlist=carof(args,E_MISMATCHARG);
426  body=ccdr(args);
427  env=bfsave;
428 
429  /*declaration*/
430  while (islist(body)) {
431  decl=ccar(body);
432  if (!islist(decl) || (ccar(decl)!=QDECLARE)) break;
433  env=declare(ctx,ccdr(decl),env); /*add special decl. to current env*/
434  body=ccdr(body);}
435 
436  GC_POINT;
437  /*evaluate variable initializers*/
438  vlistsave=vlist;
439  vinits=ctx->vsp;
440  while (islist(vlist)) {
441  var=ccar(vlist); vlist=ccdr(vlist);
442  if (islist(var)) {
443  init=ccdr(var); var=ccar(var);
444  if (islist(init)) init=eval(ctx,ccar(init));
445  else init=NIL;}
446  else init=NIL;
447  vpush(init); vcount++;}
448  /*update bindings at once*/
449  GC_POINT;
450  vlist=vlistsave;
451  while (i<vcount) {
452  var=ccar(vlist); vlist=ccdr(vlist);
453  if (islist(var)) var=ccar(var);
454  env=vbind(ctx,var,vinits[i++],env,bfsave);}
455 
456  result=progn(ctx,body); /*evaluate body*/
457  ctx->bindfp=bfsave; /*restore environments*/
458  ctx->vsp=spsave;
459  unbindspecial(ctx,(struct specialbindframe *)ctx->vsp);
460  /* unbindspecial(ctx,sbfps+1); */
461  return(result);}
462 
463 pointer SEQLET(ctx,args) /* let* special form*/
464 register context *ctx;
465 pointer args;
466 { pointer vlist,var,init,body,result,decl,*spsave=ctx->vsp;
467  register struct bindframe *bf=ctx->bindfp, *env;
468  struct specialbindframe *sbfps=ctx->sbindfp;
469 
470 #ifdef SPEC_DEBUG
471  printf( "SEQLET:" ); hoge_print(args);
472 #endif
473 
474  GC_POINT;
475  vlist=carof(args,E_MISMATCHARG);
476  body=ccdr(args);
477  env=bf; /*inherit lexical variable scope*/
478 
479  /*declaration*/
480  while (islist(body)) {
481  decl=ccar(body);
482  if (!islist(decl) || (ccar(decl)!=QDECLARE)) break;
483  env=declare(ctx,ccdr(decl),env);
484  body=ccdr(body);}
485 
486  /*bind let* variables*/
487  while (islist(vlist)) {
488  GC_POINT;
489  var=ccar(vlist); vlist=ccdr(vlist);
490  if (islist(var)) {
491  init=ccdr(var); var=ccar(var);
492  if (islist(init)) init=eval(ctx,ccar(init));
493  else init=NIL;}
494  else init=NIL;
495  env=vbind(ctx,var,init,env,bf);
496  }
497 
498  /*evaluate body*/
499  result=progn(ctx,body);
500  /*restore environments*/
501  ctx->bindfp=bf;
502  ctx->vsp=spsave;
503  unbindspecial(ctx,(struct specialbindframe *)ctx->vsp);
504 /* unbindspecial(ctx,sbfps+1); */
505  return(result);}
506 
507 pointer CATCH(ctx,arg) /*special form*/
508 register context *ctx;
509 pointer arg;
510 { pointer tag,body,val;
511  jmp_buf catchbuf;
512  int i;
513 
514 #ifdef SPEC_DEBUG
515  printf( "CATCH:" ); hoge_print(arg);
516 #endif
517 
518  tag=carof(arg,E_MISMATCHARG); tag=eval(ctx,tag);
519  body=ccdr(arg);
520  mkcatchframe(ctx,tag,&catchbuf);
521  if ((val=(pointer)eussetjmp(catchbuf))==0) val=progn(ctx,body);
522  else if ((eusinteger_t)val==1) val=makeint(0); /*longjmp cannot return 0*/
523  ctx->callfp=ctx->catchfp->cf;
524  ctx->bindfp=ctx->catchfp->bf;
525  ctx->fletfp=ctx->catchfp->ff;
526  ctx->vsp=(pointer *)ctx->catchfp;
527  ctx->catchfp=(struct catchframe *)*ctx->vsp;
528 #ifdef __RETURN_BARRIER
529  check_return_barrier(ctx);
530 #endif
531  return(val);}
532 
533 void throw(ctx,tag,result)
534 register context *ctx;
535 register pointer tag,result;
536 { register struct catchframe *cfp=ctx->catchfp;
537  while (cfp!=NULL)
538  if (cfp->label==tag) {
539  ctx->catchfp=cfp;
540  unwind(ctx,(pointer *)ctx->catchfp);
541  euslongjmp(*(ctx->catchfp->jbp),result);}
542  else cfp=cfp->nextcatch;}
543 
544 pointer THROW(ctx,arg)
545 register context *ctx;
546 register pointer arg;
547 {
548  pointer tag,result;
549 #ifdef SPEC_DEBUG
550  printf( "THROW:" ); hoge_print(arg);
551 #endif
552  tag=carof(arg,E_MISMATCHARG);
553  arg=ccdr(arg);
554  result=carof(arg,E_MISMATCHARG);
555  GC_POINT;
556  tag=eval(ctx,tag);
557  GC_POINT;
558  result=eval(ctx,result);
559  throw(ctx,tag,result);
560  error(E_NOCATCHER,tag);}
561 
562 pointer FLET(ctx,arg)
563 register context *ctx;
564 register pointer arg;
565 { register pointer fns, fn;
566  register struct fletframe *ffp=ctx->fletfp;
567  pointer result;
568 #ifdef SPEC_DEBUG
569  printf( "FLET:" ); hoge_print(arg);
570 #endif
571  GC_POINT;
572  fns=ccar(arg);
573  while (iscons(fns)) {
574  fn=ccar(fns); fns=ccdr(fns);
575  makeflet(ctx,ccar(fn),ccdr(fn),ffp,ctx->fletfp);}
576  result=progn(ctx,ccdr(arg));
577  ctx->fletfp=ffp;
578  return(result);}
579 
580 pointer LABELS(ctx,arg)
581 register context *ctx;
582 register pointer arg;
583 { register pointer fns, fn;
584  register struct fletframe *ffp=ctx->fletfp, *ffpp;
585  pointer result;
586 #ifdef SPEC_DEBUG
587  printf( "LABELS:" ); hoge_print(arg);
588 #endif
589  GC_POINT;
590  fns=ccar(arg);
591  while (iscons(fns)) {
592  fn=ccar(fns); fns=ccdr(fns);
593  makeflet(ctx,ccar(fn),ccdr(fn),ctx->fletfp,ctx->fletfp);}
594  fns=ccar(arg); ffpp=ctx->fletfp;
595  while (iscons(fns)) { /*allow mutual references between labels functions*/
596  fn=ffpp->fclosure;
597  fn=ccdr(fn); fn=ccdr(fn); fn=ccdr(fn); ccar(fn)=makeint(hide_ptr((pointer)(ctx->fletfp)));
598  fns=ccdr(fns); ffpp=ffpp->lexlink;}
599  result=progn(ctx,ccdr(arg));
600  ctx->fletfp=ffp;
601  return(result);}
602 
603 pointer RESET(ctx,n,argv)
604 register context *ctx;
605 int n;
606 pointer *argv;
607 {
608 #ifdef SPEC_DEBUG
609  printf( "RESET:" );
610  { int i;
611  for( i = 0; i < n; i++ )
612  hoge_print_sub(argv[i] );
613 }
614  printf( "\n" );
615 #endif
616  throw(ctx,makeint(0),T);
617  error(E_USER,(pointer)"cannot reset");}
618 
619 pointer EVALHOOK(ctx,n,argv)
620 register context *ctx;
621 int n;
622 pointer *argv;
623 { pointer form,val,env, *vspsave=ctx->vsp;
624  struct specialbindframe *sbfps=ctx->sbindfp;
625 
626  ckarg2(2,3);
627 #ifdef SPEC_DEBUG
628  printf( "EVALHOOK:" );
629  { int i;
630  for( i = 0; i < n; i++ )
631  hoge_print_sub(argv[i] );
632 }
633  printf( "\n" );
634 #endif
635  if (n==3) env=argv[2]; else env=NULL;
636  form=argv[0];
637  GC_POINT;
638  if (islist(form)) {
639  ehbypass=1;
640  bindspecial(ctx,QEVALHOOK,argv[1]);
641  val=eval2(ctx,form,env);
642  unbindspecial(ctx,(struct specialbindframe *)vspsave);
643 /* unbindspecial(ctx,sbfps+1); */
644  return(val);}
645  else return(eval2(ctx,form,env));}
646 
647 pointer BLOCK(ctx,arg) /*special form*/
648 register context *ctx;
649 register pointer arg; /*must be called via ufuncall*/
650 { pointer name,result,*spsave=ctx->vsp;
651  struct blockframe *myblock;
652  struct bindframe *bfp=ctx->bindfp;
653  jmp_buf blkjmp;
654 #ifdef SPEC_DEBUG
655  printf( "BLOCK:" ); hoge_print(arg);
656 #endif
657 
658  GC_POINT;
659  name=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
660  if (!issymbol(name)) error(E_NOSYMBOL);
661  myblock=(struct blockframe *)makeblock(ctx,BLOCKFRAME,name,&blkjmp,ctx->blkfp); /* ???? */
662  if ((result=(pointer)eussetjmp(blkjmp))==0) result=progn(ctx,arg);
663  else if ((eusinteger_t)result==1) result=makeint(0);
664  ctx->blkfp=myblock->dynklink;
665  /*restorations of bindfp and callfp are caller's responsibility???*/
666  ctx->bindfp=bfp;
667  ctx->vsp=spsave;
668  return(result);}
669 
670 pointer RETFROM(ctx,arg) /*special-form*/
671 register context *ctx;
672 pointer arg;
673 { pointer name,result;
674  struct blockframe *blkfp_old, *blkfp_new;
675 #ifdef SPEC_DEBUG
676  printf( "RETFROM:" ); hoge_print(arg);
677 #endif
678  GC_POINT;
679  name=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
680  blkfp_old = ctx->blkfp;
681  while (ctx->blkfp!=NULL)
682  if (ctx->blkfp->kind==BLOCKFRAME && ctx->blkfp->name==name) {
683  blkfp_new = ctx->blkfp;
684  ctx->blkfp = blkfp_old;
685  if (islist(arg)) result=eval(ctx,ccar(arg)); else result=NIL;
686  if (result==makeint(0)) result=(pointer)1;
687  ctx->blkfp = blkfp_new;
688  unwind(ctx,(pointer *)ctx->blkfp);
689  euslongjmp(*ctx->blkfp->jbp,result);}
690  else ctx->blkfp=ctx->blkfp->lexklink;
691  error(E_NOBLOCK);}
692 
693 pointer RETURN(ctx,n,argv)
694 register context *ctx;
695 int n;
696 pointer argv[];
697 { pointer result=NIL;
698  if (n==1) result=argv[0];
699  if (n>1) error(E_MISMATCHARG);
700 #ifdef SPEC_DEBUG
701  printf( "RETURN:" ); hoge_print(result);
702 #endif
703  return(cons(ctx,QRETFROM,cons(ctx,NIL,cons(ctx,result,NIL))));}
704 
706 register context *ctx;
707 pointer arg;
708 { pointer *spsave=ctx->vsp;
709  struct protectframe *oldprotfp=ctx->protfp;
710  pointer protform,cleanupform,cleaner,result;
711 
712  if (!islist(arg)) error(E_NOLIST);
713 #ifdef SPEC_DEBUG
714  printf( "UNWINDPROTECT:" ); hoge_print(arg);
715 #endif
716  GC_POINT;
717  protform=ccar(arg);
718  if (islist(arg)) cleanupform=ccdr(arg); else cleanupform=NIL;
719  cleaner=cons(ctx,NIL,cleanupform);
720  cleaner=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),cleaner);
721  cleaner=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),cleaner);
722  cleaner=cons(ctx,NIL,cleaner);
723  cleaner=cons(ctx,LAMCLOSURE,cleaner);
724  /*(LAMDA-CLOSURE bindfp fletfp () . body) */
725  /*bug...blocks and special variable bindings are not saved*/
726  vpush(ctx->protfp); vpush(cleaner);
727  ctx->protfp=(struct protectframe *)spsave;
728  GC_POINT;
729  result=eval(ctx,protform);
730  ctx->vsp=spsave;
731  ctx->protfp=oldprotfp;
732  progn(ctx,cleanupform);
733  return(result);
734 }
735 
736 pointer TAGBODY(ctx,arg)
737 register context *ctx;
738 pointer arg;
739 { pointer p,golist=NIL,forms;
740  jmp_buf tagjmp;
741  struct blockframe *tagblock;
742  pointer *spsave=ctx->vsp, *tagspsave;
743  struct bindframe *bfpsave=ctx->bindfp;
744 #ifdef SPEC_DEBUG
745  printf( "TAGBODY:" ); hoge_print(arg);
746 #endif
747  GC_POINT;
748  p=forms=arg;
749  while (iscons(p)) {
750  if (!iscons(ccar(p))) golist=cons(ctx,p,golist);
751  p=ccdr(p);}
752  tagblock=(struct blockframe *)
753  makeblock(ctx,TAGBODYFRAME,golist,&tagjmp,ctx->blkfp); /* ???? */
754  tagspsave=ctx->vsp;
755 repeat:
756  if ((p=(pointer)eussetjmp(tagjmp))==0)
757  {
758  ctx->vsp=tagspsave;
759  ctx->bindfp=bfpsave;
760  while (iscons(forms)) {
761  GC_POINT;
762  p=ccar(forms);
763  if (iscons(p)) eval(ctx,p);
764  forms=ccdr(forms);} }
765  else { forms=ccdr(p); goto repeat;}
766  ctx->blkfp=tagblock->dynklink;
767  ctx->vsp=spsave;
768  return(NIL);}
769 
770 pointer GO(ctx,arg)
771 register context *ctx;
772 pointer arg;
773 { pointer tag,body;
774 #ifdef SPEC_DEBUG
775  printf( "GO:" ); hoge_print( arg );
776 #endif
777  tag=carof(arg,"GO TAG?");
778  while (ctx->blkfp!=NULL) {
779  if (ctx->blkfp->kind==TAGBODYFRAME &&
780  (body=(pointer)assq(tag,ctx->blkfp->name))!=NIL) {
781  unwind(ctx,(pointer *)ctx->blkfp);
782  euslongjmp(*(ctx->blkfp->jbp),body);}/* ???? */
783  /* euslongjmp(*(ctx->blkfp->jbp),body);} *//* ??? eus_rbar */
784  ctx->blkfp=ctx->blkfp->lexklink;}
785  error(E_USER,(pointer)"go tag not found");}
786 
788 register context *ctx;
789 pointer arg;
790 { pointer situation,forms;
791 #ifdef SPEC_DEBUG
792  printf( "EVALWHEN:" ); hoge_print( arg );
793 #endif
794  situation=carof(arg,E_MISMATCHARG); forms=ccdr(arg);
795  while (islist(situation))
796  if (ccar(situation)==QEVAL) return(progn(ctx,forms));
797  else situation=ccdr(situation);
798  return(NIL);}
799 
800 pointer THE(ctx,arg)
801 register context *ctx;
802 pointer arg;
803 { pointer typeid,form,result;
804 #ifdef SPEC_DEBUG
805  printf( "THE:" ); hoge_print( arg );
806 #endif
807  typeid=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
808  form=carof(arg,E_MISMATCHARG);
809  if (islist(ccdr(arg))) error(E_MISMATCHARG);
810  GC_POINT;
811  result=eval(ctx,form);
812  if (typeid==QINTEGER || typeid==QFIXNUM)
813  if (!isint(result)) error(E_NOINT);
814  else return(result);
815  else if (typeid==QFLOAT)
816  if (!isflt(result)) error(E_NONUMBER);
817  else return(result);
818  else if (typeid==QNUMBER)
819  if (!isnum(result)) error(E_NONUMBER);
820  else return(result);
821  else {
822  if (isnum(result)) error(E_NOOBJECT);
823  if (speval(typeid)!=classof(result)) error(E_TYPEMISMATCH);
824  else return(result);} }
825 
826 pointer AND(ctx,arg) /*special form (should be macro)*/
827 register context *ctx;
828 register pointer arg;
829 { register pointer r;
830 #ifdef SPEC_DEBUG
831  printf( "AND:" ); hoge_print( arg );
832 #endif
833  while (islist(arg)) {
834  GC_POINT;
835  if ((r=eval(ctx,ccar(arg)))==NIL) return(r);
836  arg=ccdr(arg); }
837  return(r);}
838 
839 pointer OR(ctx,arg) /*special form (should be macro)*/
840 register context *ctx;
841 register pointer arg;
842 { register pointer r;
843 #ifdef SPEC_DEBUG
844  printf( "OR:" ); hoge_print( arg );
845 #endif
846  while (islist(arg)) {
847  GC_POINT;
848  if ((r=eval(ctx,ccar(arg)))!=NIL) return(r);
849  arg=ccdr(arg); }
850  return(NIL);}
851 
852 pointer PROCLAIM(ctx,n,argv)
853 register context *ctx;
854 int n;
855 pointer argv[];
856 { pointer decl,var,curval;
857  int i=0,vt;
858 #ifdef SPEC_DEBUG
859  printf( "PROCLAIM:" );
860  { int i;
861  for( i = 0; i < n; i++ )
862  hoge_print_sub( argv[i] );}
863  printf( "\n" );
864 #endif
865  GC_POINT;
866  while (i<n) {
867  decl=argv[i++];
868  if (!islist(decl)) error(E_DECLFORM);
869  if (ccar(decl)==QSPECIAL) {
870  decl=ccdr(decl);
871  while (islist(decl)) {
872  var=ccar(decl); decl=ccdr(decl);
873  if (!issymbol(var)) error(E_NOSYMBOL);
874  if (var->c.sym.vtype==V_CONSTANT) error(E_SETCONST);
875  else if (var->c.sym.vtype>=V_SPECIAL) {
876  if (debug)
877  fprintf(stderr, "%s has already been declared as special\n",
878  var->c.sym.pname->c.str.chars);}
879  else {
880  /*first time to change to a special var*/
881  curval=speval(var);
882  var->c.sym.vtype=makeint(special_index());
883  vt=intval(var->c.sym.vtype);
884  ctx->specials->c.vec.v[vt]=curval;}
885  /*V_SPECIAL*/}
886  } }
887  return(NIL);}
888 
890 pointer arg;
891 { error(E_DECLARE); } /*just ignore when interpretting*/
892 
893 /****************************************************************/
894 /* package
895 /****************************************************************/
896 pointer ALLPACKAGES(ctx,n,argv)
897 register context *ctx;
898 int n;
899 pointer argv[];
900 { ckarg(0);
901 #ifdef SPEC_DEBUG
902  printf( "ALLPACKAGES:\n" );
903 #endif
904  return(pkglist);}
905 
906 pointer FINDPACKAGE(ctx,n,argv)
907 register context *ctx;
908 int n;
909 register pointer *argv;
910 { pointer pkg;
911  ckarg(1);
912 #ifdef SPEC_DEBUG
913  printf( "FINDPACKAGE:" ); hoge_print( argv[0] );
914 #endif
915  pkg=findpkg(argv[0]);
916  if (pkg) return(pkg); else return(NIL);}
917 
918 pointer MAKEPACKAGE(ctx,n,argv)
919 register context *ctx;
920 int n;
921 pointer *argv;
922 { pointer pkg,name,nick,use;
923  int i=0;
924  ckarg2(1,3);
925 #ifdef SPEC_DEBUG
926  printf( "MAKEPACKAGE:" );
927  { int i;
928  for( i = 0; i < n; i++ )
929  hoge_print_sub( argv[i] );
930 }
931 #endif
932  name=argv[0];
933  if (n>1) nick=argv[1]; else nick=NIL;
934  if (n>2) use=argv[2]; else use=NIL;
935  pkg=makepkg(ctx,name,nick,use); /*pkg is protected from gc in pkglist*/
936  return(pkg);}
937 
939 pointer x;
940 {
941  eusinteger_t h=0;
942  int s,i;
943  numunion nu;
944 
945  if (isstring(x)) return(rehash(x));
946  else if (issymbol(x)) return(rehash(x->c.sym.pname));
947  else if (isint(x)) return(intval(x));
948  else if (isflt(x)) {
949  nu.fval=fltval(x); return(nu.ival);}
950  else if (islist(x)) {
951  while (islist(x)) { h += sxhash(ccar(x)); x=ccdr(x);}}
952  else if (isvector(x)) {
953  s=vecsize(x);
954  switch( elmtypeof(x)) {
955  case ELM_BIT: s /= 8*sizeof(pointer); break;
956  case ELM_CHAR:
957  case ELM_BYTE: s /= sizeof(pointer); break;
958  case ELM_POINTER:
959  for (i=0; i<s; i++) h += sxhash(x->c.vec.v[i]);
960  return(h);}
961  for (i=0; i<s; i++) h += x->c.ivec.iv[i]; }
962  else { h=(eusinteger_t)x >> 2;}
963  return(h);}
964 
965 
966 pointer SXHASH(ctx,n,argv)
967 register context *ctx;
968 int n;
969 pointer argv[];
970 { pointer h;
971  eusinteger_t m;
972  if (n==1) m=(eusinteger_t)1 << (WORD_SIZE-3);
973  else if (n==2) m=ckintval(argv[1]);
974  else error(E_MISMATCHARG);
975 #ifdef SPEC_DEBUG
976  printf( "SXHASH:" );
977  { int i;
978  for( i = 0; i < n; i++ )
979  hoge_print_sub( argv[i] );
980 }
981  printf( "\n" );
982 #endif
983  m=(sxhash(argv[0]) & MAXPOSFIXNUM) % m;
984  return(makeint(m));}
985 
986 /****************************************************************/
987 /* symbol attributes
988 /****************************************************************/
989 pointer SYMVALUE(ctx,n,argv)
990 register context *ctx;
991 int n;
992 register pointer argv[];
993 { register pointer sy=argv[0],val;
994  ckarg(1);
995  if (!issymbol(sy)) error(E_NOSYMBOL);
996  val=speval(sy);
997  if (val==UNBOUND) error(E_UNBOUND,sy);
998 #ifdef SPEC_DEBUG
999  printf( "SYMVALUE:" );
1000  { int i;
1001  for( i =0; i < n; i++ )
1002  hoge_print_sub(argv[i] );
1003 }
1004  printf( "\n" );
1005 #endif
1006  return(val);}
1007 
1009 register context *ctx;
1010 int n;
1011 register pointer argv[];
1012 { register pointer sy=argv[0],val;
1013  ckarg(1);
1014  if (!issymbol(sy)) error(E_NOSYMBOL);
1015  val=SPEVALOF(sy);
1016  if (val==UNBOUND) error(E_UNBOUND,sy);
1017  return(val);}
1018 
1019 pointer SETFUNC(ctx,n,argv)
1020 register context *ctx;
1021 int n;
1022 register pointer *argv;
1023 { if (n!=2) error(E_MISMATCHARG);
1024  if (!issymbol(argv[0])) error(E_NOSYMBOL);
1025 #ifdef SPEC_DEBUG
1026  printf( "SETFUNC:" ); hoge_print_sub(argv[0]); hoge_print(argv[1]);
1027 #endif
1028  setfunc(argv[0],argv[1]);
1029  return(argv[1]);}
1030 
1031 pointer SYMFUNC(ctx,n,argv)
1032 register context *ctx;
1033 int n;
1034 pointer *argv;
1035 { ckarg(1);
1036  if (!issymbol(argv[0])) error(E_NOSYMBOL);
1037 #ifdef SPEC_DEBUG
1038  printf( "SYMFUNC:" ); hoge_print( argv[0] );
1039 #endif
1040  return(getfunc(ctx,argv[0]));}
1041 
1042 pointer MAKUNBOUND(ctx,n,argv)
1043 register context *ctx;
1044 int n;
1045 pointer *argv;
1046 { ckarg(1);
1047  if (!issymbol(argv[0])) error(E_NOSYMBOL);
1048 #ifdef SPEC_DEBUG
1049  printf( "MAKEUNBOUND:" ); hoge_print( argv[0] );
1050 #endif
1051  pointer_update(argv[0]->c.sym.speval,UNBOUND);
1052  return(T);}
1053 
1054 void set_special(ctx, var, val)
1055 context *ctx;
1056 pointer var, val;
1057 { pointer vt;
1058  int x;
1059  vt=var->c.sym.vtype;
1060  if (vt==V_CONSTANT) error(E_SETCONST);
1061  else if (vt==V_VARIABLE || vt==V_GLOBAL) {pointer_update(speval(var),val);}
1062  else {
1063  x=intval(vt);
1064  pointer_update(ctx->specials->c.vec.v[x],val);} }
1065 
1066 pointer SETSPECIAL(ctx,n,argv)
1067 context *ctx;
1068 int n;
1069 pointer *argv;
1070 { pointer var, val;
1071  ckarg(2);
1072  var=argv[0]; val=argv[1];
1073  if (!issymbol(var)) error(E_NOSYMBOL);
1074 #ifdef SPEC_DEBUG
1075  printf( "SETSPECIAL:" ); hoge_print_sub(var); hoge_print(val);
1076 #endif
1077  set_special(ctx, var, val);
1078  return(val);}
1079 
1080 pointer DEFUN(ctx,arg)
1081 register context *ctx;
1082 pointer arg;
1083 { pointer funcname;
1084  extern pointer putprop();
1085 #ifdef SPEC_DEBUG
1086  printf( "DEFUN:" ); hoge_print( arg );
1087 #endif
1088  funcname=carof(arg,E_MISMATCHARG);
1089  arg=ccdr(arg);
1090  if (issymbol(funcname)) {pointer_update(funcname->c.sym.spefunc,cons(ctx,LAMBDA,arg));}
1091  else error(E_NOSYMBOL);
1092  putprop(ctx,funcname,
1093  (isstring(ccar(ccdr(arg))))?(ccar(ccdr(arg))):(ccar(arg)),
1094  K_FUNCTION_DOCUMENTATION);
1095  return(funcname);}
1096 
1098 register context *ctx;
1099 pointer arg;
1100 { pointer macname;
1101 #ifdef SPEC_DEBUG
1102  printf("DEFMACRO:" ); hoge_print(arg);
1103 #endif
1104  macname=carof(arg,E_MISMATCHARG);
1105  arg=ccdr(arg);
1106  if (issymbol(macname)) {pointer_update(macname->c.sym.spefunc,cons(ctx,MACRO,arg));}
1107  else error(E_NOSYMBOL);
1108  return(macname);}
1109 
1110 pointer FINDSYMBOL(ctx,n,argv)
1111 register context *ctx;
1112 int n;
1113 pointer argv[];
1114 { pointer str,sym,pkg;
1115  ckarg2(1,2);
1116  str=argv[0];
1117  if (n==2) {
1118  pkg=findpkg(argv[1]);
1119  if (pkg==NULL) error(E_NOPACKAGE);}
1120  else pkg=Spevalof(PACKAGE);
1121  if (!ispackage(pkg)) error(E_NOPACKAGE);
1122  if (!isstring(str)) error(E_NOSTRING);
1123 #ifdef SPEC_DEBUG
1124  printf( "FINDSYMBOL:" );
1125  { int i;
1126  for( i = 0; i < n; i++ )
1127  hoge_print_sub( argv[i] );
1128 }
1129  printf( "\n" );
1130 #endif
1131  sym=(pointer)findsymbol(str->c.str.chars,intval(str->c.str.length),
1132  pkg->c.pkg.intsymvector,&n);
1133  if (sym) return(sym);
1134  else return(NIL);}
1135 
1136 pointer INTERN(ctx,n,argv)
1137 register context *ctx;
1138 int n;
1139 register pointer argv[];
1140 { register pointer str,sym,pkg;
1141  int x;
1142  ckarg2(1,3);
1143  str=argv[0];
1144  if (n>=2) pkg=findpkg(argv[1]);
1145  else pkg=Spevalof(PACKAGE);
1146  if (!isstring(str)) error(E_NOSTRING);
1147 #ifdef SPEC_DEBUG
1148  printf( "INTERN:" );
1149  { int i;
1150  for( i = 0; i < n; i++ )
1151  hoge_print_sub( argv[i] );
1152 }
1153  printf( "\n" );
1154 #endif
1155  return((pointer)intern(ctx,(char *)str->c.str.chars, strlength(str),pkg));}
1156 
1158 register context *ctx;
1159 { byte buf[64];
1160  sprintf((char *)buf,"%s%d",genhead->c.str.chars,genindex++);
1161  return(makesymbol(ctx,(char *)buf,strlen(buf),NIL));}
1162 
1163 pointer GENSYM(ctx,n,argv)
1164 register context *ctx;
1165 int n;
1166 pointer argv[];
1167 {
1168 #ifdef SPEC_DEBUG
1169  printf( "GENSYM:" );
1170  { int i;
1171  for( i =0 ; i<n; i++ )
1172  hoge_print_sub(argv[i] );
1173  }
1174  printf( "\n" );
1175 #endif
1176 
1177  if (n==1) {
1178  n--;
1179  if (isstring(argv[0])) {
1180  if (intval(argv[0]->c.str.length)>50) error(E_LONGSTRING);
1181  genhead=argv[0];}
1182  else if (isint(argv[0])) genindex=intval(argv[0]);
1183  else error(E_NOSTRING);
1184  }
1185  ckarg(0);
1186  return(gensym(ctx));}
1187 
1188 pointer GETPROP(ctx,n,argv)
1189 register context *ctx;
1190 int n;
1191 register pointer argv[];
1192 { register pointer p,attr=argv[1];
1193  ckarg2(2,3);
1194  if (!ispropobj(argv[0]) || !ispropobj(attr)) error(E_NOSYMBOL);
1195 #ifdef SPEC_DEBUG
1196  printf( "GETPROP:" );
1197  { int i;
1198  for( i = 0; i < n; i++ )
1199  hoge_print_sub(argv[i] );
1200 }
1201  printf( "\n" );
1202 #endif
1203  p=argv[0]->c.sym.plist;
1204  while (iscons(p))
1205  if (ccar(ccar(p))==attr) return(ccdr(ccar(p)));
1206  else p=ccdr(p);
1207  if (n==3) return(argv[2]); else return(NIL);}
1208 
1209 pointer EXPORT (ctx,n,argv) /*further name conflict checks should be
1210  performed by EusLisp*/
1211 register context *ctx;
1212 int n;
1213 register pointer argv[];
1214 { pointer sym, pkg;
1215  ckarg2(1,2);
1216 #ifdef SPEC_DEBUG
1217  printf( "EXPORT:" );
1218  { int i;
1219  for( i =0; i< n; i++ )
1220  hoge_print_sub(argv[i]);
1221 }
1222  printf( "\n" );
1223 #endif
1224  sym=argv[0];
1225  if (n==2) pkg = findpkg(argv[1]);
1226  else pkg=Spevalof(PACKAGE);
1227  if (!ispackage(pkg)) error(E_NOPACKAGE);
1228  if (issymbol(sym)) export(sym,pkg);
1229  else if (iscons(sym))
1230  while (iscons(sym)) {
1231  export(ccar(sym),pkg); sym=ccdr(sym);}
1232  else error(E_NOSYMBOL);
1233  return(T);}
1234 
1235 pointer putprop(ctx,sym,val,attr)
1236 register context *ctx;
1237 register pointer sym,val,attr;
1238 { register pointer p;
1239  p=sym->c.sym.plist;
1240  while (iscons(p))
1241  if (ccar(ccar(p))==attr) { pointer_update(ccdr(ccar(p)),val); return(val);}
1242  else p=ccdr(p);
1243  /* no such a property; create it */
1244  p=cons(ctx,attr,val);
1245  pointer_update(sym->c.sym.plist,cons(ctx,p,sym->c.sym.plist));
1246  return(val);}
1247 
1248 pointer PUTPROP(ctx,n,argv) /*(putprop sym val attr)*/
1249 register context *ctx;
1250 int n;
1251 register pointer argv[];
1252 { register pointer p,pp;
1253  ckarg(3);
1254  if (!ispropobj(argv[0]) || !ispropobj(argv[2])) error(E_NOSYMBOL);
1255 #ifdef SPEC_DEBUG
1256  printf( "PUTPROP:" );
1257  { int i;
1258  for( i =0 ; i < n; i++ )
1259  hoge_print_sub(argv[i]);
1260 }
1261  printf( "\n" );
1262 #endif
1263  return(putprop(ctx,argv[0],argv[1],argv[2]));}
1264 
1265 #ifdef EVAL_DEBUG
1266 pointer EVALDEBUG(ctx,n,argv)
1267 register context *ctx;
1268 int n;
1269 register pointer argv[];
1270 {
1271  ckarg2(0,1);
1272  if( n == 1 ) {
1273  evaldebug = ( argv[0] != NIL );
1274  }
1275  return evaldebug ? T : NIL;
1276 }
1277 #endif
1278 
1279 
1280 
1281 /****************************************************************/
1282 /* initialize
1283 /****************************************************************/
1284 void specials(ctx,mod)
1285 register context *ctx;
1286 pointer mod;
1287 {
1288  genindex=0;
1289  genhead=makestring("G",1);
1290  sysobj=cons(ctx,genhead,sysobj);
1291 
1292  QUOTE=defspecial(ctx,"QUOTE",mod,quote);
1293  QEVAL=defun(ctx,"EVAL",mod,EVAL,NULL);
1294  defun(ctx,"APPLY",mod,APPLY,NULL);
1295  defun(ctx,"FUNCALL",mod,FUNCALL,NULL);
1296  QPROGN=defspecial(ctx,"PROGN",mod,progn);
1297  defun(ctx,"PROG1",mod,PROG1,NULL);
1298  FUNCTION=defspecial(ctx,"FUNCTION",mod,FUNCTION_CLOSURE);
1299  defun(ctx,"MAPC",mod,MAPC,NULL);
1300  defun(ctx,"MAPCAR",mod,MAPCAR,NULL);
1301  defun(ctx,"MAPCAN",mod,MAPCAN,NULL);
1302  defspecial(ctx,"SETQ",mod,SETQ);
1303  QIF=defspecial(ctx,"IF",mod,IF);
1304  defmacro(ctx,"WHEN",mod,WHEN);
1305  defspecial(ctx,"COND",mod,COND);
1306  defspecial(ctx,"WHILE",mod,WHILE);
1307  defspecial(ctx,"LET",mod,PARLET);
1308  defspecial(ctx,"LET*",mod,SEQLET);
1309  defspecial(ctx,"UNWIND-PROTECT",mod,UNWINDPROTECT);
1310  defspecial(ctx,"CATCH",mod,CATCH);
1311  defspecial(ctx,"THROW",mod,THROW);
1312  defspecial(ctx,"FLET",mod,FLET);
1313  defspecial(ctx,"LABELS",mod,LABELS);
1314  defspecial(ctx,"BLOCK",mod,BLOCK);
1315  QRETFROM=defspecial(ctx,"RETURN-FROM",mod,RETFROM);
1316  defmacro(ctx,"RETURN",mod,RETURN);
1317  defspecial(ctx,"TAGBODY",mod,TAGBODY);
1318  defspecial(ctx,"GO",mod,GO);
1319  defun(ctx,"RESET",mod,RESET,NULL);
1320  defun(ctx,"EVALHOOK",mod,EVALHOOK,NULL);
1321  defun(ctx,"MACROEXPAND2",mod,MACEXPAND2,NULL);
1322  defspecial(ctx,"EVAL-WHEN",mod,EVALWHEN);
1323  defspecial(ctx,"THE",mod,THE);
1324  QAND=defspecial(ctx,"AND",mod,AND);
1325  QOR=defspecial(ctx,"OR",mod,OR);
1326  defun(ctx,"PROCLAIM",mod,PROCLAIM,NULL);
1327  defspecial(ctx,"DECLARE",mod,DECLARE);
1328  defun(ctx,"SETFUNC",mod,SETFUNC,NULL);
1329  defun(ctx,"SYMBOL-VALUE",mod,SYMVALUE,NULL);
1330  defun(ctx,"SYMBOL-BOUND-VALUE",mod,SYMBNDVALUE,NULL);
1331  defun(ctx,"SYMBOL-FUNCTION",mod,SYMFUNC,NULL);
1332  defun(ctx,"MAKUNBOUND",mod,MAKUNBOUND,NULL);
1333  defun(ctx,"SET",mod,SETSPECIAL,NULL);
1334  defspecial(ctx,"DEFUN",mod,DEFUN);
1335  defspecial(ctx,"DEFMACRO",mod,DEFMACRO);
1336  defun(ctx,"FIND-SYMBOL",mod,FINDSYMBOL,NULL);
1337  defun(ctx,"INTERN",mod,INTERN,NULL);
1338  defun(ctx,"GENSYM",mod,GENSYM,NULL);
1339  defun(ctx,"LIST-ALL-PACKAGES",mod,ALLPACKAGES,NULL);
1340  defun(ctx,"FIND-PACKAGE",mod,FINDPACKAGE,NULL);
1341  defunpkg(ctx,"MAKEPACKAGE",mod,MAKEPACKAGE,syspkg);
1342 /* defun(ctx,"IN-PACKAGE",mod,INPACKAGE,NULL); */
1343  defun(ctx,"SXHASH",mod,SXHASH,NULL);
1344  defun(ctx,"GET",mod,GETPROP,NULL);
1345  defun(ctx,"EXPORT",mod,EXPORT,NULL);
1346  defun(ctx,"PUTPROP",mod,PUTPROP,NULL);
1347 
1348 #ifdef EVAL_DEBUG
1349  defun(ctx,"EVALDEBUG",mod,EVALDEBUG,NULL);
1350 #endif
1351  }
1352 
1353 
pointer K_FUNCTION_DOCUMENTATION
Definition: eus.c:175
pointer makesymbol(context *, char *, int, pointer)
Definition: makes.c:164
pointer DEFMACRO(context *ctx, pointer arg)
Definition: specials.c:1097
pointer QNUMBER
Definition: eus.c:120
pointer intern(context *, char *, int, pointer)
Definition: intern.c:105
pointer RETFROM(context *ctx, pointer arg)
Definition: specials.c:670
pointer LAMCLOSURE
Definition: eus.c:170
pointer SETSPECIAL(context *ctx, int n, pointer *argv)
Definition: specials.c:1066
pointer QFLOAT
Definition: eus.c:120
pointer FUNCTION
Definition: eus.c:111
struct blockframe * makeblock(context *, pointer, pointer, jmp_buf *, struct blockframe *)
Definition: makes.c:766
pointer EVAL(context *ctx, int n, argv)
Definition: specials.c:43
#define makeint(v)
Definition: sfttest.c:2
struct cell * pointer
Definition: eus.h:165
pointer GENSYM(context *ctx, int n, argv)
Definition: specials.c:1163
pointer PROGN(context *ctx, pointer arg)
Definition: specials.c:59
Definition: eus.h:524
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
pointer makecode(pointer, pointer(*)(), pointer)
Definition: makes.c:282
pointer DEFUN(context *ctx, pointer arg)
Definition: specials.c:1080
pointer QAND
Definition: eus.c:127
struct string str
Definition: eus.h:402
eusfloat_t fval
Definition: eus.h:430
pointer entry2
Definition: eus.h:236
byte chars[1]
Definition: eus.h:212
pointer FLET(context *ctx, pointer arg)
Definition: specials.c:562
pointer val
Definition: eus.h:482
Definition: eus.h:195
pointer SYMBNDVALUE(context *ctx, int n, argv)
Definition: specials.c:1008
pointer T
Definition: eus.c:110
GLfloat n[6][3]
Definition: cube.c:15
pointer intsymvector
Definition: eus.h:224
static GLfloat body[][2]
Definition: dinoshade.c:75
pointer IF(context *ctx, pointer arg)
Definition: specials.c:329
pointer putprop(context *ctx, pointer sym, pointer val, pointer attr)
Definition: specials.c:1235
void bindspecial(context *, pointer, pointer)
Definition: eval.c:131
pointer makepkg(context *, pointer, pointer, pointer)
Definition: makes.c:201
Definition: eus.h:949
static int argc
Definition: transargv.c:56
pointer defunpkg(context *, char *, pointer, pointer(*)(), pointer)
Definition: makes.c:636
struct code code
Definition: eus.h:408
eusinteger_t hide_ptr(pointer p)
Definition: eus.c:1407
pointer SYMFUNC(context *ctx, int n, pointer *argv)
Definition: specials.c:1031
int special_index(void)
Definition: makes.c:673
#define intval(p)
Definition: sfttest.c:1
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
pointer NCONC(context *, int, pointer *)
pointer ufuncall(context *, pointer, pointer, pointer, struct bindframe *, int)
Definition: eval.c:1469
static int tempindex
Definition: specials.c:26
pointer progn(context *, pointer)
Definition: eval.c:1679
pointer BLOCK(context *ctx, pointer arg)
Definition: specials.c:647
Definition: eus.h:1006
pointer PARLET(context *ctx, pointer args)
Definition: specials.c:408
pointer PUTPROP(context *ctx, int n, argv)
Definition: specials.c:1248
pointer SXHASH(context *ctx, int n, argv)
Definition: specials.c:966
pointer entry
Definition: eus.h:234
struct blockframe * dynklink
Definition: eus.h:491
Definition: eus.h:943
pointer MACEXPAND2(context *ctx, int n, argv)
Definition: specials.c:154
struct symbol sym
Definition: eus.h:401
ckarg(2)
pointer FUNCTION_CLOSURE(context *ctx, pointer arg)
Definition: specials.c:132
pointer QUOTE
Definition: eus.c:110
pointer TAGBODY(context *ctx, pointer arg)
Definition: specials.c:736
pointer QDECLARE
Definition: eus.c:112
pointer INTERN(context *ctx, int n, argv)
Definition: specials.c:1136
union cell::cellunion c
void unbindspecial(context *, struct specialbindframe *)
Definition: eval.c:165
pointer label
Definition: eus.h:497
static int genindex
Definition: specials.c:26
Definition: eus.h:479
Definition: eus.h:428
pointer * ovafptr(pointer, pointer)
Definition: eval.c:120
void specials(context *ctx, pointer mod)
Definition: specials.c:1284
pointer setval(context *, pointer, pointer)
Definition: eval.c:68
pointer SETQ(context *ctx, pointer arg)
Definition: specials.c:305
struct fletframe * makeflet(context *, pointer, pointer, struct fletframe *, struct fletframe *)
Definition: makes.c:782
pointer THROW(context *ctx, pointer arg)
Definition: specials.c:544
pointer SYMVALUE(context *ctx, int n, argv)
Definition: specials.c:989
static pointer QPROGN
Definition: specials.c:27
Definition: eus.h:986
pointer LABELS(context *ctx, pointer arg)
Definition: specials.c:580
Definition: eus.h:381
pointer EXPORT(context *ctx, int n, argv)
Definition: specials.c:1209
pointer assq(pointer, pointer)
Definition: lists.c:317
pointer EVALHOOK(context *ctx, int n, pointer *argv)
Definition: specials.c:619
pointer QEVALHOOK
Definition: eus.c:121
pointer getfunc(context *, pointer)
Definition: eval.c:97
pointer QINTEGER
Definition: eus.c:120
pointer QSPECIAL
Definition: eus.c:112
short s
Definition: structsize.c:2
pointer PROCLAIM(context *ctx, int n, argv)
Definition: specials.c:852
pointer subrtype
Definition: eus.h:233
pointer THE(context *ctx, pointer arg)
Definition: specials.c:800
pointer vtype
Definition: eus.h:203
struct bindframe * vbind(context *, pointer, pointer, struct bindframe *, struct bindframe *)
Definition: eval.c:194
pointer GO(context *ctx, pointer arg)
Definition: specials.c:770
int rehash(pointer)
Definition: intern.c:13
Definition: eus.h:953
void set_special(context *ctx, pointer var, pointer val)
Definition: specials.c:1054
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
long eusinteger_t
Definition: eus.h:19
pointer plist
Definition: eus.h:203
struct catchframe * nextcatch
Definition: eus.h:496
pointer LAMBDA
Definition: eus.c:170
pointer MAKUNBOUND(context *ctx, int n, pointer *argv)
Definition: specials.c:1042
pointer WHILE(context *ctx, pointer arg)
Definition: specials.c:365
static pointer QIF
Definition: specials.c:27
pointer gensym(context *ctx)
Definition: specials.c:1157
pointer PACKAGE
Definition: eus.c:110
pointer MACRO
Definition: eus.c:170
pointer PROG1(context *ctx, int n, pointer *argv)
Definition: specials.c:68
pointer OR(context *ctx, pointer arg)
Definition: specials.c:839
void init(void)
Definition: cube.c:48
pointer stacknlist(context *, int)
Definition: makes.c:129
struct bindframe * declare()
struct catchframe * catchfp
Definition: eus.h:530
void unwind(context *ctx, pointer *p)
Definition: eus.c:274
pointer FINDPACKAGE(context *ctx, int n, pointer *argv)
Definition: specials.c:906
jmp_buf * jbp
Definition: eus.h:501
int findsymbol(char *s)
#define GC_POINT
Definition: eus.h:172
eusinteger_t sxhash(pointer x)
Definition: specials.c:938
pointer APPLY(context *ctx, int n, argv)
Definition: specials.c:80
float fltval()
pointer QFIXNUM
Definition: eus.c:120
pointer FINDSYMBOL(context *ctx, int n, argv)
Definition: specials.c:1110
pointer COND(context *ctx, pointer arg)
Definition: specials.c:390
pointer EVALDEBUG(context *ctx, int n, argv)
Definition: specials.c:1266
static char * rcsid
Definition: specials.c:13
int count
Definition: thrtest.c:11
pointer EVALWHEN(context *ctx, pointer arg)
Definition: specials.c:787
pointer makestring(char *, int)
Definition: makes.c:147
Definition: eus.h:941
#define NULL
Definition: transargv.c:8
pointer quote(context *ctx, pointer arg)
Definition: specials.c:33
pointer RETURN(context *ctx, int n, argv)
Definition: specials.c:693
int ehbypass
Definition: eus.c:160
pointer pname
Definition: eus.h:203
#define export
Definition: test_foreign.c:12
static pointer QRETFROM
Definition: specials.c:27
void setfunc(pointer, pointer)
Definition: eval.c:116
static pointer QEVAL
Definition: specials.c:27
pointer sysobj
Definition: eus.c:54
pointer MAPCAR(context *ctx, int n, pointer *argv)
Definition: specials.c:232
pointer findpkg()
static pointer genhead
Definition: specials.c:25
unsigned char byte
Definition: eus.h:163
pointer SEQLET(context *ctx, pointer args)
Definition: specials.c:463
pointer cleaner
Definition: eus.h:506
pointer MAKEPACKAGE(context *ctx, int n, pointer *argv)
Definition: specials.c:918
pointer QOR
Definition: eus.c:127
pointer AND(context *ctx, pointer arg)
Definition: specials.c:826
pointer MAPC(context *ctx, int n, pointer *argv)
Definition: specials.c:203
pointer ALLPACKAGES(context *ctx, int n, argv)
Definition: specials.c:896
pointer spefunc
Definition: eus.h:203
Definition: eus.h:940
static char buf[CHAR_SIZE]
Definition: helpsub.c:23
pointer pkglist
Definition: eus.c:109
pointer CATCH(context *ctx, pointer arg)
Definition: specials.c:507
pointer MAPCAN(context *ctx, int n, pointer *argv)
Definition: specials.c:267
void mkcatchframe(context *, pointer, jmp_buf *)
Definition: makes.c:801
pointer NIL
Definition: eus.c:110
pointer syspkg
Definition: eus.c:109
pointer SETFUNC(context *ctx, int n, pointer *argv)
Definition: specials.c:1019
Definition: eus.h:509
pointer eval(context *, pointer)
Definition: eval.c:1622
pointer RESET(context *ctx, int n, pointer *argv)
Definition: specials.c:603
pointer UNWINDPROTECT(context *ctx, pointer arg)
Definition: specials.c:705
pointer defmacro(context *, char *, pointer, pointer(*)())
Definition: makes.c:646
pointer eval2(context *, pointer, pointer)
Definition: eval.c:1664
Definition: eus.h:956
char a[26]
Definition: freq.c:4
pointer FUNCALL(context *ctx, int n, argv)
Definition: specials.c:112
pointer length
Definition: eus.h:211
struct package pkg
Definition: eus.h:404
pointer DECLARE(pointer arg)
Definition: specials.c:889
pointer WHEN(context *ctx, int n, pointer *argv)
Definition: specials.c:345
pointer GETPROP(context *ctx, int n, argv)
Definition: specials.c:1188
eusinteger_t ival
Definition: eus.h:431
pointer name
Definition: eus.h:492
pointer defspecial(context *, char *, pointer, pointer(*)())
Definition: makes.c:682


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