euslisp: specials.c Source File

Go to the documentation of this file.
00001 /*****************************************************************
00002 /*      specials.c
00003 /*      special-forms (let,let*,catch,throw,unwind-protect,...)
00004 /*      control structures,
00005 /*      macros ...
00006 /*
00007 /*      Copyright: Toshihiro Matsui  ETL, Umezono, Sakura-mura
00008 /*        
00009 /*      1986
00010 /*      1986-Dec        let*
00011 /*      1987-Mar        special binding declaration
00012 *****************************************************************/
00013 static char *rcsid="@(#)$Id$";
00014 
00015 #include "eus.h"
00016 extern pointer MACRO,LAMBDA,LAMCLOSURE;
00017 extern pointer K_FUNCTION_DOCUMENTATION;
00018 extern struct bindframe  *declare();
00019 
00020 #ifdef EVAL_DEBUG
00021 extern int evaldebug;
00022 #endif
00023 
00024 /*gensym*/
00025 static pointer genhead;
00026 static int     genindex,tempindex=0;
00027 static pointer QRETFROM,QEVAL,QPROGN,QIF;
00028 
00029 /****************************************************************/
00030 /* special forms
00031 /****************************************************************/
00032 
00033 pointer quote(ctx,arg)
00034 register context *ctx;
00035 register pointer arg;
00036 {
00037 #ifdef SPEC_DEBUG
00038     printf( "quote:" ); hoge_print(arg);
00039 #endif
00040  return(carof(arg,E_MISMATCHARG));
00041 }
00042 
00043 pointer EVAL(ctx,n,argv)
00044 register context *ctx;
00045 int n;
00046 register pointer argv[];
00047 { pointer env;
00048   ckarg2(1,2);
00049   if (n==2) env=argv[1]; else env=NULL;
00050 #ifdef SPEC_DEBUG
00051   printf( "EVAL:" );
00052   hoge_print_sub(argv[0]);
00053   if( env != NULL )
00054     hoge_print_sub( env );
00055   printf( "\n" );
00056 #endif
00057   return(eval2(ctx,argv[0],env));}
00058 
00059 pointer PROGN(ctx,arg)
00060 register context *ctx;
00061 register pointer arg;
00062 {
00063 #ifdef SPEC_DEBUG
00064     printf( "PROGN:" ); hoge_print( arg );
00065 #endif
00066  return(progn(ctx,arg));}
00067 
00068 pointer PROG1(ctx,n,argv)
00069 register context *ctx;
00070 int n;
00071 pointer *argv;
00072 {
00073 #ifdef SPEC_DEBUG
00074     printf( "PROG1:" );
00075     if( n >= 0 ) hoge_print_sub( argv[0] );
00076     printf( "\n" );
00077 #endif
00078  return((n>=1)?argv[0]:NIL);}
00079 
00080 pointer APPLY(ctx,n,argv)
00081 register context *ctx;
00082 int n;
00083 register pointer argv[];
00084 { register pointer a,*spsave=ctx->vsp,fun=argv[0];
00085   register int i=1,argc=n-2;
00086 
00087   if (n<2) error(E_MISMATCHARG);
00088 #ifdef SPEC_DEBUG
00089   printf( "APPLY:" );
00090   { int i;
00091     for( i = 0; i < n; i++ )
00092       hoge_print_sub( argv[i] );
00093 }
00094   printf( "\n" );
00095 #endif
00096   if (issymbol(fun)) {
00097     if (fun->c.sym.spefunc==UNBOUND) error(E_UNDEF,argv[0]);}
00098   while (i<n-1) ckpush(argv[i++]);
00099   a=argv[i];
00100   while (islist(a)) {
00101     ckpush(ccar(a));
00102     a=ccdr(a);
00103     argc++;}
00104   a=(pointer)ufuncall(ctx,(ctx->callfp?ctx->callfp->form:NIL),
00105                         fun,(pointer)spsave,NULL,argc);
00106   ctx->vsp=spsave;
00107 #ifdef SAFETY
00108   take_care(a);
00109 #endif
00110   return(a);}
00111 
00112 pointer FUNCALL(ctx,n,argv)
00113 register context *ctx;
00114 int n;
00115 register pointer argv[];
00116 { register pointer fun=argv[0];
00117   if (n<1) error(E_MISMATCHARG);
00118 #if SPEC_DEBUG
00119   printf( "FUNCALL:" );
00120   {
00121       int i;
00122       for( i = 0; i < n; i++ )
00123         hoge_print_sub( argv[i] );
00124   }
00125   printf( "\n" );
00126 #endif
00127   if (issymbol(fun)) {
00128     if (fun->c.sym.spefunc==UNBOUND) error(E_UNDEF,fun);}
00129   pointer_update(Spevalof(QEVALHOOK),NIL);
00130   return((pointer)ufuncall(ctx,ctx->callfp->form,fun,(pointer)&argv[1],NULL,n-1));}
00131 
00132 pointer FUNCTION_CLOSURE(ctx,arg)
00133 register context *ctx;
00134 pointer arg;
00135 { pointer funcname;
00136   if (!islist(arg)) error(E_MISMATCHARG);
00137   if (ccdr(arg)!=NIL) error(E_MISMATCHARG);
00138 #ifdef SPEC_DEBUG
00139   printf( "FUNCTION_CLOSURE:" );
00140   hoge_print( arg );
00141 #endif
00142   arg=ccar(arg);
00143   if (issymbol(arg)) { funcname=arg; arg=getfunc(ctx,arg);}
00144   else funcname=NIL;
00145   if (iscode(arg)) return(arg);
00146   else if (ccar(arg)==LAMCLOSURE) return(arg);
00147   else if (ccar(arg)==LAMBDA) {
00148     arg=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),ccdr(arg));
00149     arg=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),arg);
00150     arg=cons(ctx,funcname,arg);
00151     return(cons(ctx,LAMCLOSURE,arg));}
00152   else error(E_ILLFUNC);}
00153 
00154 pointer MACEXPAND2(ctx,n,argv)
00155 register context *ctx;
00156 int n;
00157 register pointer argv[];
00158 { pointer mac,args,expander,*argp,result;
00159   int noarg=0;
00160   ckarg(1);
00161 #ifdef SPEC_DEBUG
00162   printf( "MACEXPAND2:" ); hoge_print( argv[0] );
00163 #endif
00164   if (!islist(argv[0])) return(argv[0]);
00165   mac=ccar(argv[0]); args=ccdr(argv[0]);
00166   if (issymbol(mac)) mac=getfunc(ctx,mac);
00167   if (iscode(mac)) {
00168 #if ARM
00169     eusinteger_t addr = (eusinteger_t)(mac->c.code.entry);
00170 #if (WORD_SIZE == 64)
00171     addr &= ~3L;  /*0xfffffffc; ???? */
00172 #else
00173     addr &= ~3;  /*0xfffffffc; ???? */
00174 #endif
00175     addr = addr | (intval(mac->c.code.entry2)&0x0000ffff);
00176 #endif // ARM
00177     if (mac->c.code.subrtype!=(pointer)SUBR_MACRO) return(argv[0]);
00178 #if ARM
00179     expander=makecode(mac,(pointer (*)())addr,SUBR_FUNCTION);
00180     pointer_update(expander->c.code.entry2,mac->c.code.entry2)
00181 #else
00182     expander=makecode(mac,(pointer (*)())mac->c.code.entry,SUBR_FUNCTION);
00183 #endif
00184     pointer_update(expander->c.code.entry,mac->c.code.entry);}
00185   else if (carof(mac,E_NOLIST)==MACRO) expander=cons(ctx,LAMBDA,ccdr(mac));
00186   else return(argv[0]);
00187   vpush(expander);
00188   argp=ctx->vsp; 
00189   while (islist(args)) { vpush(ccar(args)); args=ccdr(args); noarg++;}
00190   GC_POINT;
00191   mac=ufuncall(ctx,ctx->callfp->form,expander,(pointer)argp,NULL,noarg);
00192   /* ???? ctx->lastalloc=mac; ????*/
00193   ctx->vsp=argp-1;
00194   return(mac);}
00195 
00196 /****************************************************************/
00197 /* mapping
00198 /****************************************************************/
00199 pointer MAPC(ctx,n,argv)
00200 register context *ctx;
00201 int n;
00202 register pointer *argv;
00203 { register pointer a;
00204   register int i;
00205   if (n<2) error(E_MISMATCHARG);
00206 #ifdef SPEC_DEBUG
00207   printf( "MAPC:" );
00208   { int i;
00209     for( i = 0; i < n; i++ )
00210       hoge_print_sub( argv[i] );
00211 }
00212   printf( "\n" );
00213 #endif
00214   while (islist(argv[1])) {
00215     i=1;
00216     while (i<n) {
00217       a=argv[i];
00218       if (!islist(a)) error(E_NOLIST);
00219       ckpush(ccar(a));
00220       argv[i]=ccdr(a);
00221       i++;}
00222     i--;
00223     GC_POINT;
00224     ufuncall(ctx,ctx->callfp->form,argv[0],(pointer)(ctx->vsp - i),NULL,i);
00225     ctx->vsp -= i;}
00226   return(argv[1]);}
00227 
00228 pointer MAPCAR(ctx,n,argv)
00229 register context *ctx;
00230 register int n;
00231 register pointer *argv;
00232 { register pointer a,r;
00233   register int rcount=0,i;
00234   pointer (*subr)();
00235 
00236   if (n<2) error(E_MISMATCHARG);
00237 #ifdef SPEC_DEBUG
00238   printf( "MAPCAR:" );
00239   { int i;
00240     for( i = 0; i < n; i++ )
00241       hoge_print_sub( argv[i] );
00242 }
00243   printf( "\n" );
00244 #endif
00245   while (islist(argv[1])) {
00246     i=1;
00247     while (i<n) {
00248       a=argv[i];
00249       if (!islist(a)) error(E_NOLIST);
00250       ckpush(ccar(a));
00251       argv[i]=ccdr(a);
00252       i++;}
00253     i--;
00254     GC_POINT;
00255     r=ufuncall(ctx,ctx->callfp->form,argv[0],(pointer)(ctx->vsp - i),NULL,i);
00256     ctx->vsp -=i;
00257     vpush(r);
00258     rcount++;}
00259     GC_POINT;
00260   r=(pointer)stacknlist(ctx,rcount);
00261   return(r);}
00262 
00263 pointer MAPCAN(ctx,n,argv)
00264 register context *ctx;
00265 int n;
00266 register pointer *argv;
00267 { register pointer a,r;
00268   register int i,rcount=0;
00269   pointer *spsave=ctx->vsp;
00270   if (n<2) error(E_MISMATCHARG);
00271 #ifdef SPEC_DEBUG
00272   printf( "MAPCAN:" );
00273   { int i;
00274     for( i = 0; i < n; i++ )
00275       hoge_print_sub( argv[i] );
00276 }
00277   printf( "\n" );
00278 #endif
00279   while (islist(argv[1])) {
00280     i=1;
00281     while (i<n) {
00282       a=argv[i];
00283       if (!islist(a)) error(E_NOLIST);
00284       ckpush(ccar(a));
00285       argv[i]=ccdr(a);
00286       i++;}
00287     i--;
00288     GC_POINT;
00289     r=ufuncall(ctx,ctx->callfp->form,argv[0],(pointer)(ctx->vsp -i),NULL,i);
00290     ctx->vsp -=i;
00291     vpush(r);
00292     rcount++;}
00293     GC_POINT;
00294   a=(pointer)NCONC(ctx,rcount,spsave);
00295   ctx->vsp=spsave;
00296   return(a);}
00297 
00298 /****************************************************************/
00299 /* SETQ
00300 /****************************************************************/
00301 pointer SETQ(ctx,arg)
00302 register context *ctx;
00303 register pointer arg;
00304 { register pointer var,val=NIL, *p;
00305 #ifdef SPEC_DEBUG
00306   printf( "SETQ:" );  hoge_print( arg );
00307 #endif
00308   while (iscons(arg)) {
00309     var=ccar(arg); arg=ccdr(arg);
00310     if (!islist(arg)) error(E_MISMATCHARG);
00311     GC_POINT;
00312     val=eval(ctx,ccar(arg)); arg=ccdr(arg);
00313     if (issymbol(var)) setval(ctx,var,val);
00314     else if (islist(var) && issymbol(ccdr(var)) && ccdr(var)!=NIL) {
00315       vpush(val);
00316       p=(pointer *)ovafptr(eval(ctx,ccar(var)),ccdr(var)); pointer_update(*p,vpop());}
00317     else error(E_NOSYMBOL,var);}
00318   return(val);}
00319 
00320 
00321 /****************************************************************/
00322 /* control structures
00323 /****************************************************************/
00324 
00325 pointer IF(ctx,arg)
00326 register context *ctx;
00327 register pointer arg;
00328 { register pointer rest;
00329   rest=cdrof(arg, E_MISMATCHARG);
00330   if (!iscons(rest)) return(NIL);
00331 #ifdef SPEC_DEBUG
00332   printf( "IF:" ); hoge_print( arg );
00333 #endif
00334   GC_POINT;
00335   if (eval(ctx,ccar(arg))!=NIL) return(eval(ctx,ccar(rest)));
00336   else {
00337     rest=ccdr(rest);
00338     if (iscons(rest)) return(eval(ctx,ccar(rest)));
00339     else return(NIL);  } }
00340 
00341 pointer WHEN(ctx,n,argv)
00342 register context *ctx;
00343 int n;
00344 pointer *argv;
00345 { pointer form=NIL;
00346   int i;
00347   if (n<1) error(E_MISMATCHARG);
00348 #ifdef SPEC_DEBUG
00349   printf( "WHEN:" );
00350   { int i;
00351     for( i = 0; i < n; i++ )
00352       hoge_print_sub( argv[i] );
00353 }
00354   printf( "\n" );
00355 #endif
00356   while (n>1) form=cons(ctx,argv[--n],form);
00357   form=cons(ctx,QPROGN,form);
00358   form=cons(ctx,argv[0],cons(ctx,form,NIL));
00359   return(cons(ctx,QIF,form));}
00360 
00361 pointer WHILE(ctx,arg)
00362 register context *ctx;
00363 pointer arg;
00364 { pointer cond,body,*spsave=ctx->vsp,result;
00365   struct blockframe *myblock;
00366   struct bindframe *bfp=ctx->bindfp;
00367   jmp_buf whilejmp;
00368   int i;
00369 
00370 #ifdef SPEC_DEBUG
00371   printf( "WHILE:" );   hoge_print(arg);
00372 #endif
00373   if (!islist(arg)) return(NIL);
00374   cond=ccar(arg); body=ccdr(arg);
00375   myblock=(struct blockframe *)
00376                 makeblock(ctx,BLOCKFRAME,NIL,(jmp_buf *)whilejmp,ctx->blkfp); /* ???? */
00377   if ((result=(pointer)eussetjmp(whilejmp))==0) {
00378     while (eval(ctx,cond)!=NIL) {GC_POINT;progn(ctx,body);}
00379     result=NIL;}
00380   else if ((eusinteger_t)result==1) result=makeint(0);
00381   ctx->blkfp=myblock->dynklink;
00382   ctx->vsp=spsave;
00383   ctx->bindfp=bfp;
00384   return(result);}
00385 
00386 pointer COND(ctx,arg)
00387 register context *ctx;
00388 pointer arg;
00389 { register pointer clause,cond;
00390 
00391 #ifdef SPEC_DEBUG
00392   printf( "COND:" );    hoge_print(arg);
00393 #endif
00394   while (islist(arg)) {
00395     clause=ccar(arg);
00396     if (!islist(clause)) error(E_NOLIST);
00397     GC_POINT;
00398     cond=eval(ctx,ccar(clause));
00399     if (cond!=NIL) if (islist(ccdr(clause))) return(progn(ctx,ccdr(clause)));
00400                    else return(cond);
00401     arg=ccdr(arg);}
00402   return(NIL);}
00403 
00404 pointer PARLET(ctx,args)        /*let special form*/
00405 register context *ctx;
00406 pointer args;
00407 { pointer vlist,vlistsave,var,init,body,result,decl,*spsave=ctx->vsp,*vinits;
00408   register struct bindframe *env, *bfsave=ctx->bindfp, *declenv;
00409   struct specialbindframe *sbfps=ctx->sbindfp;
00410   int i=0,vcount=0;
00411 #if defined(PARLET_DEBUG) || defined(DEBUG_COUNT)
00412   static int count = 0;
00413 
00414   count++;
00415 #endif
00416 
00417 #if defined(SPEC_DEBUG) || defined(PARLET_DEBUG)
00418   printf( "PARLET:%d",count );  hoge_print(args);
00419 #endif
00420 
00421   vlist=carof(args,E_MISMATCHARG);
00422   body=ccdr(args);
00423   env=bfsave;
00424 
00425   /*declaration*/
00426   while (islist(body)) {
00427     decl=ccar(body);
00428     if (!islist(decl) || (ccar(decl)!=QDECLARE)) break;
00429     env=declare(ctx,ccdr(decl),env);    /*add special decl. to current env*/
00430     body=ccdr(body);}
00431 
00432   GC_POINT;
00433   /*evaluate variable initializers*/
00434   vlistsave=vlist;
00435   vinits=ctx->vsp;
00436   while (islist(vlist)) {
00437     var=ccar(vlist); vlist=ccdr(vlist);
00438     if (islist(var)) {
00439       init=ccdr(var); var=ccar(var);
00440       if (islist(init)) init=eval(ctx,ccar(init));
00441       else init=NIL;}
00442     else init=NIL;
00443     vpush(init); vcount++;}
00444   /*update bindings at once*/
00445   GC_POINT;
00446   vlist=vlistsave;
00447   while (i<vcount)  {
00448     var=ccar(vlist); vlist=ccdr(vlist);
00449     if (islist(var)) var=ccar(var);
00450     env=vbind(ctx,var,vinits[i++],env,bfsave);}
00451 
00452   result=progn(ctx,body);       /*evaluate body*/
00453   ctx->bindfp=bfsave;           /*restore environments*/
00454   ctx->vsp=spsave;
00455   unbindspecial(ctx,(struct specialbindframe *)ctx->vsp);
00456   /* unbindspecial(ctx,sbfps+1); */
00457   return(result);}
00458 
00459 pointer SEQLET(ctx,args)        /* let* special form*/
00460 register context *ctx;
00461 pointer args;
00462 { pointer vlist,var,init,body,result,decl,*spsave=ctx->vsp;
00463   register struct bindframe *bf=ctx->bindfp, *env;
00464   struct specialbindframe *sbfps=ctx->sbindfp;
00465 
00466 #ifdef SPEC_DEBUG
00467   printf( "SEQLET:" );  hoge_print(args);
00468 #endif
00469 
00470   GC_POINT;
00471   vlist=carof(args,E_MISMATCHARG);
00472   body=ccdr(args);
00473   env=bf;       /*inherit lexical variable scope*/
00474 
00475   /*declaration*/
00476   while (islist(body)) {
00477     decl=ccar(body);
00478     if (!islist(decl) || (ccar(decl)!=QDECLARE)) break;
00479     env=declare(ctx,ccdr(decl),env);
00480     body=ccdr(body);}
00481 
00482   /*bind let* variables*/
00483   while (islist(vlist)) {
00484     GC_POINT;
00485     var=ccar(vlist); vlist=ccdr(vlist);
00486     if (islist(var)) {
00487       init=ccdr(var); var=ccar(var);
00488       if (islist(init)) init=eval(ctx,ccar(init));
00489       else init=NIL;}
00490     else init=NIL;
00491     env=vbind(ctx,var,init,env,bf);
00492     }
00493 
00494   /*evaluate body*/
00495   result=progn(ctx,body);
00496   /*restore environments*/
00497   ctx->bindfp=bf;
00498   ctx->vsp=spsave;
00499   unbindspecial(ctx,(struct specialbindframe *)ctx->vsp); 
00500 /*  unbindspecial(ctx,sbfps+1); */
00501   return(result);}
00502 
00503 pointer CATCH(ctx,arg)  /*special form*/
00504 register context *ctx;
00505 pointer arg;
00506 { pointer tag,body,val;
00507   jmp_buf catchbuf;
00508   int i;
00509 
00510 #ifdef SPEC_DEBUG
00511   printf( "CATCH:" );   hoge_print(arg);
00512 #endif
00513 
00514   tag=carof(arg,E_MISMATCHARG); tag=eval(ctx,tag);
00515   body=ccdr(arg);
00516   mkcatchframe(ctx,tag,catchbuf);
00517   if ((val=(pointer)eussetjmp(catchbuf))==0) val=progn(ctx,body);
00518   else if ((eusinteger_t)val==1) val=makeint(0);        /*longjmp cannot return 0*/
00519   ctx->callfp=ctx->catchfp->cf;
00520   ctx->bindfp=ctx->catchfp->bf;
00521   ctx->fletfp=ctx->catchfp->ff;
00522   ctx->vsp=(pointer *)ctx->catchfp;
00523   ctx->catchfp=(struct catchframe *)*ctx->vsp;
00524 #ifdef __RETURN_BARRIER
00525   check_return_barrier(ctx);
00526 #endif
00527   return(val);}
00528 
00529 void throw(ctx,tag,result)
00530 register context *ctx;
00531 register pointer tag,result;
00532 { register struct catchframe *cfp=ctx->catchfp;
00533   while (cfp!=NULL) 
00534     if (cfp->label==tag) {
00535       ctx->catchfp=cfp;
00536       unwind(ctx,(pointer *)ctx->catchfp);
00537       euslongjmp(*(ctx->catchfp->jbp),result);}
00538     else cfp=cfp->nextcatch;}
00539 
00540 pointer THROW(ctx,arg)
00541 register context *ctx;
00542 register pointer arg;
00543 {
00544   pointer tag,result;
00545 #ifdef SPEC_DEBUG
00546   printf( "THROW:" ); hoge_print(arg);
00547 #endif
00548   tag=carof(arg,E_MISMATCHARG);
00549   arg=ccdr(arg);
00550   result=carof(arg,E_MISMATCHARG);
00551   GC_POINT;
00552   tag=eval(ctx,tag); 
00553   GC_POINT;
00554   result=eval(ctx,result);
00555   throw(ctx,tag,result);
00556   error(E_NOCATCHER,tag);}
00557 
00558 pointer FLET(ctx,arg)
00559 register context *ctx;
00560 register pointer arg;
00561 { register pointer fns, fn;
00562   register struct fletframe *ffp=ctx->fletfp;
00563   pointer result;
00564 #ifdef SPEC_DEBUG
00565   printf( "FLET:" ); hoge_print(arg);
00566 #endif
00567   GC_POINT;
00568   fns=ccar(arg);
00569   while (iscons(fns)) {
00570     fn=ccar(fns); fns=ccdr(fns);
00571     makeflet(ctx,ccar(fn),ccdr(fn),ffp,ctx->fletfp);}
00572   result=progn(ctx,ccdr(arg));
00573   ctx->fletfp=ffp;
00574   return(result);}
00575 
00576 pointer LABELS(ctx,arg)
00577 register context *ctx;
00578 register pointer arg;
00579 { register pointer fns, fn;
00580   register struct fletframe *ffp=ctx->fletfp, *ffpp;
00581   pointer result;
00582 #ifdef SPEC_DEBUG
00583   printf( "LABELS:" ); hoge_print(arg);
00584 #endif
00585   GC_POINT;
00586   fns=ccar(arg);
00587   while (iscons(fns)) {
00588     fn=ccar(fns); fns=ccdr(fns);
00589     makeflet(ctx,ccar(fn),ccdr(fn),ctx->fletfp,ctx->fletfp);}
00590   fns=ccar(arg); ffpp=ctx->fletfp;
00591   while (iscons(fns)) { /*allow mutual references between labels functions*/
00592     fn=ffpp->fclosure;
00593     fn=ccdr(fn); fn=ccdr(fn); fn=ccdr(fn); ccar(fn)=makeint(hide_ptr((pointer)(ctx->fletfp)));
00594     fns=ccdr(fns); ffpp=ffpp->lexlink;}
00595   result=progn(ctx,ccdr(arg));
00596   ctx->fletfp=ffp;
00597   return(result);}
00598 
00599 pointer RESET(ctx,n,argv)
00600 register context *ctx;
00601 int n;
00602 pointer *argv;
00603 {
00604 #ifdef SPEC_DEBUG
00605   printf( "RESET:" );
00606   { int i;
00607     for( i = 0; i < n; i++ )
00608       hoge_print_sub(argv[i] );
00609 }
00610   printf( "\n" );
00611 #endif
00612  throw(ctx,makeint(0),T);
00613   error(E_USER,(pointer)"cannot reset");}
00614 
00615 pointer EVALHOOK(ctx,n,argv)
00616 register context *ctx;
00617 int n;
00618 pointer *argv;
00619 { pointer form,val,env, *vspsave=ctx->vsp;
00620   struct specialbindframe *sbfps=ctx->sbindfp;
00621 
00622   ckarg2(2,3);
00623 #ifdef SPEC_DEBUG
00624   printf( "EVALHOOK:" );
00625   { int i;
00626     for( i = 0; i < n; i++ )
00627       hoge_print_sub(argv[i] );
00628 }
00629   printf( "\n" );
00630 #endif
00631   if (n==3) env=argv[2]; else env=NULL;
00632   form=argv[0];
00633   GC_POINT;
00634   if (islist(form)) {
00635     ehbypass=1;
00636     bindspecial(ctx,QEVALHOOK,argv[1]);
00637     val=eval2(ctx,form,env);
00638     unbindspecial(ctx,(struct specialbindframe *)vspsave);
00639 /*    unbindspecial(ctx,sbfps+1); */
00640     return(val);}
00641   else return(eval2(ctx,form,env));}
00642 
00643 pointer BLOCK(ctx,arg)  /*special form*/
00644 register context *ctx;
00645 register pointer arg;           /*must be called via ufuncall*/
00646 { pointer name,result,*spsave=ctx->vsp;
00647   struct blockframe *myblock;
00648   struct bindframe *bfp=ctx->bindfp;
00649   jmp_buf blkjmp;
00650 #ifdef SPEC_DEBUG
00651   printf( "BLOCK:" ); hoge_print(arg);
00652 #endif
00653 
00654   GC_POINT;
00655   name=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
00656   if (!issymbol(name)) error(E_NOSYMBOL);
00657   myblock=(struct blockframe *)makeblock(ctx,BLOCKFRAME,name,(jmp_buf *)blkjmp,ctx->blkfp); /* ???? */
00658   if ((result=(pointer)eussetjmp(blkjmp))==0) result=progn(ctx,arg);
00659   else if ((eusinteger_t)result==1) result=makeint(0);
00660   ctx->blkfp=myblock->dynklink;
00661   /*restorations of bindfp and callfp are caller's responsibility???*/
00662   ctx->bindfp=bfp;
00663   ctx->vsp=spsave;
00664   return(result);}
00665 
00666 pointer RETFROM(ctx,arg)        /*special-form*/
00667 register context *ctx;
00668 pointer arg;
00669 { pointer name,result;
00670  struct blockframe *blkfp_old, *blkfp_new; 
00671 #ifdef SPEC_DEBUG
00672   printf( "RETFROM:" ); hoge_print(arg);
00673 #endif
00674   GC_POINT;
00675   name=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
00676   blkfp_old = ctx->blkfp;
00677   while (ctx->blkfp!=NULL) 
00678     if (ctx->blkfp->kind==BLOCKFRAME && ctx->blkfp->name==name) {
00679       blkfp_new = ctx->blkfp;
00680       ctx->blkfp = blkfp_old;
00681       if (islist(arg)) result=eval(ctx,ccar(arg)); else result=NIL;
00682       if (result==makeint(0)) result=(pointer)1;
00683       ctx->blkfp = blkfp_new;
00684       unwind(ctx,(pointer *)ctx->blkfp);
00685       euslongjmp(*ctx->blkfp->jbp,result);}
00686     else ctx->blkfp=ctx->blkfp->lexklink;
00687   error(E_NOBLOCK);}
00688   
00689 pointer RETURN(ctx,n,argv)
00690 register context *ctx;
00691 int n;
00692 pointer argv[];
00693 { pointer result=NIL;
00694   if (n==1) result=argv[0];
00695   if (n>1) error(E_MISMATCHARG);
00696 #ifdef SPEC_DEBUG
00697   printf( "RETURN:" ); hoge_print(result);
00698 #endif
00699   return(cons(ctx,QRETFROM,cons(ctx,NIL,cons(ctx,result,NIL))));}
00700 
00701 pointer UNWINDPROTECT(ctx,arg)
00702 register context *ctx;
00703 pointer arg;
00704 { pointer *spsave=ctx->vsp;
00705   struct protectframe *oldprotfp=ctx->protfp;
00706   pointer protform,cleanupform,cleaner,result;
00707 
00708   if (!islist(arg)) error(E_NOLIST);
00709 #ifdef SPEC_DEBUG
00710   printf( "UNWINDPROTECT:" );   hoge_print(arg);
00711 #endif
00712   GC_POINT;
00713   protform=ccar(arg);
00714   if (islist(arg)) cleanupform=ccdr(arg); else cleanupform=NIL;
00715   cleaner=cons(ctx,NIL,cleanupform);
00716   cleaner=cons(ctx,makeint(hide_ptr((pointer)(ctx->fletfp))),cleaner);
00717   cleaner=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),cleaner);
00718   cleaner=cons(ctx,NIL,cleaner);
00719   cleaner=cons(ctx,LAMCLOSURE,cleaner);
00720   /*(LAMDA-CLOSURE bindfp fletfp () . body) */
00721   /*bug...blocks and special variable bindings are not saved*/
00722   vpush(ctx->protfp); vpush(cleaner);
00723   ctx->protfp=(struct protectframe *)spsave;
00724   GC_POINT;
00725   result=eval(ctx,protform);
00726   ctx->vsp=spsave;
00727   ctx->protfp=oldprotfp;
00728   progn(ctx,cleanupform);
00729   return(result);
00730 }
00731 
00732 pointer TAGBODY(ctx,arg)
00733 register context *ctx;
00734 pointer arg;
00735 { pointer p,golist=NIL,forms;
00736   jmp_buf tagjmp;
00737   struct blockframe *tagblock;
00738   pointer *spsave=ctx->vsp, *tagspsave;
00739   struct bindframe *bfpsave=ctx->bindfp;
00740 #ifdef SPEC_DEBUG
00741   printf( "TAGBODY:" ); hoge_print(arg);
00742 #endif
00743   GC_POINT;
00744   p=forms=arg;
00745   while (iscons(p)) {
00746     if (!iscons(ccar(p))) golist=cons(ctx,p,golist);
00747     p=ccdr(p);}
00748   tagblock=(struct blockframe *)
00749         makeblock(ctx,TAGBODYFRAME,golist,(jmp_buf*)tagjmp,ctx->blkfp); /* ???? */
00750   tagspsave=ctx->vsp;
00751 repeat:
00752   if ((p=(pointer)eussetjmp(tagjmp))==0) 
00753     {
00754     ctx->vsp=tagspsave;
00755     ctx->bindfp=bfpsave;
00756     while (iscons(forms)) {
00757       GC_POINT;
00758       p=ccar(forms);
00759       if (iscons(p)) eval(ctx,p);
00760       forms=ccdr(forms);} }
00761   else { forms=ccdr(p); goto repeat;}
00762   ctx->blkfp=tagblock->dynklink;
00763   ctx->vsp=spsave;
00764   return(NIL);}
00765 
00766 pointer GO(ctx,arg)
00767 register context *ctx;
00768 pointer arg;
00769 { pointer tag,body;
00770 #ifdef SPEC_DEBUG
00771   printf( "GO:" ); hoge_print( arg );
00772 #endif
00773   tag=carof(arg,"GO TAG?");
00774   while (ctx->blkfp!=NULL) {
00775     if (ctx->blkfp->kind==TAGBODYFRAME &&
00776         (body=(pointer)assq(tag,ctx->blkfp->name))!=NIL) {
00777       unwind(ctx,(pointer *)ctx->blkfp);
00778       euslongjmp(ctx->blkfp->jbp,body);}/* ???? */
00779       /* euslongjmp(*(ctx->blkfp->jbp),body);} *//* ??? eus_rbar */
00780     ctx->blkfp=ctx->blkfp->lexklink;}
00781   error(E_USER,(pointer)"go tag not found");}
00782 
00783 pointer EVALWHEN(ctx,arg)
00784 register context *ctx;
00785 pointer arg;
00786 { pointer situation,forms;
00787 #ifdef SPEC_DEBUG
00788   printf( "EVALWHEN:" ); hoge_print( arg );
00789 #endif
00790   situation=carof(arg,E_MISMATCHARG); forms=ccdr(arg);
00791   while (islist(situation)) 
00792     if (ccar(situation)==QEVAL) return(progn(ctx,forms));
00793     else situation=ccdr(situation);
00794   return(NIL);}
00795 
00796 pointer THE(ctx,arg)
00797 register context *ctx;
00798 pointer arg;
00799 { pointer typeid,form,result;
00800 #ifdef SPEC_DEBUG
00801   printf( "THE:" ); hoge_print( arg );
00802 #endif
00803   typeid=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
00804   form=carof(arg,E_MISMATCHARG);
00805   if (islist(ccdr(arg))) error(E_MISMATCHARG);
00806   GC_POINT;
00807   result=eval(ctx,form);
00808   if (typeid==QINTEGER || typeid==QFIXNUM)
00809     if (!isint(result)) error(E_NOINT);
00810     else return(result);
00811   else if (typeid==QFLOAT)
00812     if (!isflt(result)) error(E_NONUMBER);
00813     else return(result);
00814   else if (typeid==QNUMBER)
00815     if (!isnum(result)) error(E_NONUMBER);
00816     else return(result);
00817   else {
00818     if (isnum(result)) error(E_NOOBJECT);
00819     if (speval(typeid)!=classof(result)) error(E_TYPEMISMATCH);
00820     else return(result);} }
00821 
00822 pointer AND(ctx,arg)    /*special form (should be macro)*/
00823 register context *ctx;
00824 register pointer arg;
00825 { register pointer r;
00826 #ifdef SPEC_DEBUG
00827   printf( "AND:" ); hoge_print( arg );
00828 #endif
00829   while (islist(arg)) {
00830     GC_POINT;
00831     if ((r=eval(ctx,ccar(arg)))==NIL) return(r);
00832     arg=ccdr(arg); }
00833   return(r);}
00834 
00835 pointer OR(ctx,arg)     /*special form (should be macro)*/
00836 register context *ctx;
00837 register pointer arg;
00838 { register pointer r;
00839 #ifdef SPEC_DEBUG
00840   printf( "OR:" );      hoge_print( arg );
00841 #endif
00842   while (islist(arg)) {
00843     GC_POINT;
00844     if ((r=eval(ctx,ccar(arg)))!=NIL) return(r);
00845     arg=ccdr(arg);    }
00846   return(NIL);}
00847 
00848 pointer PROCLAIM(ctx,n,argv)
00849 register context *ctx;
00850 int n;
00851 pointer argv[];
00852 { pointer decl,var,curval;
00853   int i=0,vt;
00854 #ifdef SPEC_DEBUG
00855   printf( "PROCLAIM:" );
00856   { int i;
00857     for( i = 0; i < n; i++ )
00858       hoge_print_sub( argv[i] );}
00859   printf( "\n" );
00860 #endif
00861   GC_POINT;
00862   while (i<n) {
00863     decl=argv[i++];
00864     if (!islist(decl)) error(E_DECLFORM);
00865     if (ccar(decl)==QSPECIAL) {
00866       decl=ccdr(decl);
00867       while (islist(decl)) {
00868         var=ccar(decl); decl=ccdr(decl);
00869         if (!issymbol(var)) error(E_NOSYMBOL);
00870         if (var->c.sym.vtype==V_CONSTANT) error(E_SETCONST);
00871         else if (var->c.sym.vtype>=V_SPECIAL) {
00872           if (debug)
00873              fprintf(stderr, "%s has already been declared as special\n",
00874                         var->c.sym.pname->c.str.chars);}
00875         else {
00876           /*first time to change to a special var*/
00877           curval=speval(var);
00878           var->c.sym.vtype=makeint(special_index());
00879           vt=intval(var->c.sym.vtype);
00880           ctx->specials->c.vec.v[vt]=curval;}
00881         /*V_SPECIAL*/}
00882       } } 
00883   return(NIL);}
00884 
00885 pointer DECLARE(arg)
00886 pointer arg;
00887 { error(E_DECLARE); }           /*just ignore when interpretting*/
00888 
00889 /****************************************************************/
00890 /* package
00891 /****************************************************************/
00892 pointer ALLPACKAGES(ctx,n,argv)
00893 register context *ctx;
00894 int n;
00895 pointer argv[];
00896 { ckarg(0);
00897 #ifdef SPEC_DEBUG
00898   printf( "ALLPACKAGES:\n" );
00899 #endif
00900  return(pkglist);}
00901 
00902 pointer FINDPACKAGE(ctx,n,argv)
00903 register context *ctx;
00904 int n;
00905 register pointer *argv;
00906 { pointer pkg;
00907   ckarg(1);
00908 #ifdef SPEC_DEBUG
00909   printf( "FINDPACKAGE:" ); hoge_print( argv[0] );
00910 #endif
00911   pkg=findpkg(argv[0]);
00912   if (pkg) return(pkg); else return(NIL);}
00913 
00914 pointer MAKEPACKAGE(ctx,n,argv)
00915 register context *ctx;
00916 int n;
00917 pointer *argv;
00918 { pointer pkg,name,nick,use;
00919   int i=0;
00920   ckarg2(1,3);
00921 #ifdef SPEC_DEBUG
00922   printf( "MAKEPACKAGE:" );
00923   { int i;
00924     for( i = 0; i < n; i++ )
00925       hoge_print_sub( argv[i] );
00926 }
00927 #endif
00928   name=argv[0];
00929   if (n>1) nick=argv[1]; else nick=NIL;
00930   if (n>2) use=argv[2]; else use=NIL;
00931   pkg=makepkg(ctx,name,nick,use);       /*pkg is protected from gc in pkglist*/
00932   return(pkg);}
00933 
00934 eusinteger_t sxhash(x)
00935 pointer x;
00936 { 
00937   eusinteger_t h=0;
00938   int s,i;
00939   numunion nu;
00940 
00941   if (isstring(x)) return(rehash(x));
00942   else if (issymbol(x)) return(rehash(x->c.sym.pname));
00943   else if (isint(x)) return(intval(x));
00944   else if (isflt(x)) {
00945     nu.fval=fltval(x);  return(nu.ival);}
00946   else if (islist(x)) {
00947     while (islist(x)) { h += sxhash(ccar(x)); x=ccdr(x);}}
00948   else if (isvector(x)) {
00949     s=vecsize(x);
00950     switch( elmtypeof(x)) {
00951       case ELM_BIT:  s /= 8*sizeof(pointer); break;
00952       case ELM_CHAR:
00953       case ELM_BYTE: s /= sizeof(pointer); break;
00954       case ELM_POINTER: 
00955         for (i=0; i<s; i++) h += sxhash(x->c.vec.v[i]);
00956         return(h);}
00957     for (i=0; i<s; i++) h += x->c.ivec.iv[i]; } 
00958   else {  h=(eusinteger_t)x >> 2;}
00959   return(h);}  
00960 
00961 
00962 pointer SXHASH(ctx,n,argv)
00963 register context *ctx;
00964 int n;
00965 pointer argv[];
00966 { pointer h;
00967   eusinteger_t m;
00968   if (n==1) m=(eusinteger_t)1  << (WORD_SIZE-3);
00969   else if (n==2) m=ckintval(argv[1]);
00970   else error(E_MISMATCHARG);
00971 #ifdef SPEC_DEBUG
00972   printf( "SXHASH:" );
00973   { int i;
00974     for( i = 0; i < n; i++ )
00975       hoge_print_sub( argv[i] );
00976 }
00977   printf( "\n" );
00978 #endif
00979   m=(sxhash(argv[0]) & MAXPOSFIXNUM) % m;
00980   return(makeint(m));}
00981 
00982 /****************************************************************/
00983 /* symbol attributes
00984 /****************************************************************/
00985 pointer SYMVALUE(ctx,n,argv)
00986 register context *ctx;
00987 int n;
00988 register pointer argv[];
00989 { register pointer sy=argv[0],val;
00990   ckarg(1);
00991   if (!issymbol(sy)) error(E_NOSYMBOL);
00992   val=speval(sy);
00993   if (val==UNBOUND) error(E_UNBOUND,sy);
00994 #ifdef SPEC_DEBUG
00995   printf( "SYMVALUE:" );
00996   { int i;
00997     for( i =0; i < n; i++ )
00998       hoge_print_sub(argv[i] );
00999 }
01000   printf( "\n" );
01001 #endif
01002   return(val);}
01003 
01004 pointer SYMBNDVALUE(ctx,n,argv)
01005 register context *ctx;
01006 int n;
01007 register pointer argv[];
01008 { register pointer sy=argv[0],val;
01009   ckarg(1);
01010   if (!issymbol(sy)) error(E_NOSYMBOL);
01011   val=SPEVALOF(sy);
01012   if (val==UNBOUND) error(E_UNBOUND,sy);
01013   return(val);}
01014 
01015 pointer SETFUNC(ctx,n,argv)
01016 register context *ctx;
01017 int n;
01018 register pointer *argv;
01019 { if (n!=2) error(E_MISMATCHARG);
01020   if (!issymbol(argv[0])) error(E_NOSYMBOL);
01021 #ifdef SPEC_DEBUG
01022   printf( "SETFUNC:" ); hoge_print_sub(argv[0]); hoge_print(argv[1]);
01023 #endif
01024   setfunc(argv[0],argv[1]);
01025   return(argv[1]);}
01026 
01027 pointer SYMFUNC(ctx,n,argv)
01028 register context *ctx;
01029 int n;
01030 pointer *argv;
01031 { ckarg(1);
01032   if (!issymbol(argv[0])) error(E_NOSYMBOL);
01033 #ifdef SPEC_DEBUG
01034   printf( "SYMFUNC:" ); hoge_print( argv[0] );
01035 #endif
01036   return(getfunc(ctx,argv[0]));}
01037 
01038 pointer MAKUNBOUND(ctx,n,argv)
01039 register context *ctx;
01040 int n;
01041 pointer *argv;
01042 { ckarg(1);
01043   if (!issymbol(argv[0])) error(E_NOSYMBOL);
01044 #ifdef SPEC_DEBUG
01045   printf( "MAKEUNBOUND:" ); hoge_print( argv[0] );
01046 #endif
01047   pointer_update(argv[0]->c.sym.speval,UNBOUND);
01048   return(T);}
01049 
01050 void set_special(ctx, var, val)
01051 context *ctx;
01052 pointer var, val;
01053 { pointer vt;
01054   int x;
01055   vt=var->c.sym.vtype;
01056   if (vt==V_CONSTANT) error(E_SETCONST);
01057   else if (vt==V_VARIABLE || vt==V_GLOBAL) {pointer_update(speval(var),val);}
01058   else {
01059     x=intval(vt);
01060     pointer_update(ctx->specials->c.vec.v[x],val);} }
01061 
01062 pointer SETSPECIAL(ctx,n,argv)
01063 context *ctx;
01064 int n;
01065 pointer *argv;
01066 { pointer var, val;
01067   ckarg(2);
01068   var=argv[0]; val=argv[1];
01069   if (!issymbol(var)) error(E_NOSYMBOL);
01070 #ifdef SPEC_DEBUG
01071   printf( "SETSPECIAL:" ); hoge_print_sub(var); hoge_print(val);
01072 #endif
01073   set_special(ctx, var, val);
01074   return(val);}
01075 
01076 pointer DEFUN(ctx,arg)
01077 register context *ctx;
01078 pointer arg;
01079 { pointer funcname;
01080   extern pointer putprop();
01081 #ifdef SPEC_DEBUG
01082   printf( "DEFUN:" ); hoge_print( arg );
01083 #endif
01084   funcname=carof(arg,E_MISMATCHARG);
01085   arg=ccdr(arg);
01086   if (issymbol(funcname)) {pointer_update(funcname->c.sym.spefunc,cons(ctx,LAMBDA,arg));}
01087   else error(E_NOSYMBOL);
01088   putprop(ctx,funcname,
01089          (isstring(ccar(ccdr(arg))))?(ccar(ccdr(arg))):(ccar(arg)),
01090          K_FUNCTION_DOCUMENTATION);
01091   return(funcname);}
01092  
01093 pointer DEFMACRO(ctx,arg)
01094 register context *ctx;
01095 pointer arg;
01096 { pointer macname;
01097 #ifdef SPEC_DEBUG
01098   printf("DEFMACRO:" ); hoge_print(arg);
01099 #endif
01100   macname=carof(arg,E_MISMATCHARG);
01101   arg=ccdr(arg);
01102   if (issymbol(macname)) {pointer_update(macname->c.sym.spefunc,cons(ctx,MACRO,arg));}
01103   else error(E_NOSYMBOL);
01104   return(macname);}
01105 
01106 pointer FINDSYMBOL(ctx,n,argv)
01107 register context *ctx;
01108 int n;
01109 pointer argv[];
01110 { pointer str,sym,pkg;
01111   ckarg2(1,2);
01112   str=argv[0];
01113   if (n==2) {
01114     pkg=findpkg(argv[1]);
01115     if (pkg==NULL)  error(E_NOPACKAGE);}
01116   else pkg=Spevalof(PACKAGE);
01117   if (!ispackage(pkg)) error(E_NOPACKAGE);
01118   if (!isstring(str)) error(E_NOSTRING);
01119 #ifdef SPEC_DEBUG
01120   printf( "FINDSYMBOL:" );
01121   { int i;
01122     for( i = 0; i < n; i++ )
01123       hoge_print_sub( argv[i] );
01124 }
01125   printf( "\n" );
01126 #endif
01127   sym=(pointer)findsymbol(str->c.str.chars,intval(str->c.str.length),
01128                           pkg->c.pkg.intsymvector,&n);
01129   if (sym) return(sym);
01130   else return(NIL);}
01131 
01132 pointer INTERN(ctx,n,argv)
01133 register context *ctx;
01134 int n;
01135 register pointer argv[];
01136 { register pointer str,sym,pkg;
01137   int x;
01138   ckarg2(1,3);
01139   str=argv[0];
01140   if (n>=2) pkg=findpkg(argv[1]);
01141   else pkg=Spevalof(PACKAGE);
01142   if (!isstring(str)) error(E_NOSTRING);
01143 #ifdef SPEC_DEBUG
01144   printf( "INTERN:" );
01145   { int i;
01146     for( i = 0; i < n; i++ )
01147       hoge_print_sub( argv[i] );
01148 }
01149   printf( "\n" );
01150 #endif
01151   return((pointer)intern(ctx,(char *)str->c.str.chars, strlength(str),pkg));}
01152 
01153 pointer gensym(ctx)
01154 register context *ctx;
01155 { byte buf[64];
01156   sprintf((char *)buf,"%s%d",genhead->c.str.chars,genindex++);
01157   return(makesymbol(ctx,(char *)buf,strlen(buf),NIL));}
01158 
01159 pointer GENSYM(ctx,n,argv)
01160 register context *ctx;
01161 int n;
01162 pointer argv[];
01163 { 
01164 #ifdef SPEC_DEBUG
01165     printf( "GENSYM:" );
01166     { int i;
01167       for( i =0 ; i<n; i++ )
01168         hoge_print_sub(argv[i] );
01169   }
01170     printf( "\n" );
01171 #endif
01172 
01173     if (n==1) {
01174     n--;
01175     if (isstring(argv[0])) {
01176       if (intval(argv[0]->c.str.length)>50) error(E_LONGSTRING);
01177       genhead=argv[0];}
01178     else if (isint(argv[0])) genindex=intval(argv[0]);
01179     else error(E_NOSTRING);
01180     }
01181   ckarg(0);
01182   return(gensym(ctx));}
01183 
01184 pointer GETPROP(ctx,n,argv)
01185 register context *ctx;
01186 int n;
01187 register pointer argv[];
01188 { register pointer p,attr=argv[1];
01189   ckarg2(2,3);
01190   if (!ispropobj(argv[0]) || !ispropobj(attr)) error(E_NOSYMBOL);
01191 #ifdef SPEC_DEBUG
01192   printf( "GETPROP:" );
01193   { int i;
01194     for( i = 0; i < n; i++ )
01195       hoge_print_sub(argv[i] );
01196 }
01197   printf( "\n" );
01198 #endif
01199   p=argv[0]->c.sym.plist;
01200   while (iscons(p))
01201     if (ccar(ccar(p))==attr) return(ccdr(ccar(p)));
01202     else p=ccdr(p);
01203   if (n==3) return(argv[2]); else return(NIL);}
01204 
01205 pointer EXPORT (ctx,n,argv)     /*further name conflict checks should be
01206                                   performed by EusLisp*/
01207 register context *ctx;
01208 int n;
01209 register pointer argv[];
01210 { pointer sym, pkg;
01211   ckarg2(1,2);
01212 #ifdef SPEC_DEBUG
01213   printf( "EXPORT:" );
01214   { int i;
01215     for( i =0; i< n; i++ )
01216       hoge_print_sub(argv[i]);
01217 }
01218   printf( "\n" );
01219 #endif
01220   sym=argv[0];
01221   if (n==2)  pkg = findpkg(argv[1]);
01222   else pkg=Spevalof(PACKAGE);
01223   if (!ispackage(pkg)) error(E_NOPACKAGE);
01224   if (issymbol(sym)) export(sym,pkg);
01225   else if (iscons(sym)) 
01226     while (iscons(sym)) {
01227       export(ccar(sym),pkg); sym=ccdr(sym);}
01228   else error(E_NOSYMBOL);
01229   return(T);}
01230 
01231 pointer putprop(ctx,sym,val,attr)
01232 register context *ctx;
01233 register pointer sym,val,attr;
01234 { register pointer p;
01235   p=sym->c.sym.plist;
01236   while (iscons(p))
01237     if (ccar(ccar(p))==attr) { pointer_update(ccdr(ccar(p)),val); return(val);}
01238     else p=ccdr(p);
01239   /* no such a property; create it */
01240   p=cons(ctx,attr,val);
01241   pointer_update(sym->c.sym.plist,cons(ctx,p,sym->c.sym.plist));
01242   return(val);}
01243 
01244 pointer PUTPROP(ctx,n,argv)     /*(putprop sym val attr)*/
01245 register context *ctx;
01246 int n;
01247 register pointer argv[];
01248 { register pointer p,pp;
01249   ckarg(3);
01250   if (!ispropobj(argv[0]) || !ispropobj(argv[2])) error(E_NOSYMBOL);
01251 #ifdef SPEC_DEBUG
01252   printf( "PUTPROP:" );
01253   { int i;
01254     for( i =0 ; i < n; i++ )
01255       hoge_print_sub(argv[i]);
01256 }
01257   printf( "\n" );
01258 #endif
01259   return(putprop(ctx,argv[0],argv[1],argv[2]));}
01260 
01261 #ifdef EVAL_DEBUG
01262 pointer EVALDEBUG(ctx,n,argv)
01263 register context *ctx;
01264 int n;
01265 register pointer argv[];
01266 {
01267     ckarg2(0,1);
01268     if( n == 1 ) {
01269         evaldebug = ( argv[0] != NIL );
01270     }
01271     return evaldebug ? T : NIL;
01272 }
01273 #endif
01274 
01275 
01276 
01277 /****************************************************************/
01278 /* initialize
01279 /****************************************************************/
01280 void specials(ctx,mod)
01281 register context *ctx;
01282 pointer mod;
01283 {
01284   genindex=0;
01285   genhead=makestring("G",1);
01286   sysobj=cons(ctx,genhead,sysobj);
01287 
01288   QUOTE=defspecial(ctx,"QUOTE",mod,quote);
01289   QEVAL=defun(ctx,"EVAL",mod,EVAL);
01290   defun(ctx,"APPLY",mod,APPLY);
01291   defun(ctx,"FUNCALL",mod,FUNCALL);
01292   QPROGN=defspecial(ctx,"PROGN",mod,progn);
01293   defun(ctx,"PROG1",mod,PROG1); 
01294   FUNCTION=defspecial(ctx,"FUNCTION",mod,FUNCTION_CLOSURE);
01295   defun(ctx,"MAPC",mod,MAPC);
01296   defun(ctx,"MAPCAR",mod,MAPCAR);
01297   defun(ctx,"MAPCAN",mod,MAPCAN);
01298   defspecial(ctx,"SETQ",mod,SETQ);
01299   QIF=defspecial(ctx,"IF",mod,IF);
01300   defmacro(ctx,"WHEN",mod,WHEN);
01301   defspecial(ctx,"COND",mod,COND);
01302   defspecial(ctx,"WHILE",mod,WHILE);
01303   defspecial(ctx,"LET",mod,PARLET);
01304   defspecial(ctx,"LET*",mod,SEQLET);
01305   defspecial(ctx,"UNWIND-PROTECT",mod,UNWINDPROTECT);
01306   defspecial(ctx,"CATCH",mod,CATCH);
01307   defspecial(ctx,"THROW",mod,THROW);
01308   defspecial(ctx,"FLET",mod,FLET);
01309   defspecial(ctx,"LABELS",mod,LABELS);
01310   defspecial(ctx,"BLOCK",mod,BLOCK);
01311   QRETFROM=defspecial(ctx,"RETURN-FROM",mod,RETFROM);
01312   defmacro(ctx,"RETURN",mod,RETURN);
01313   defspecial(ctx,"TAGBODY",mod,TAGBODY);
01314   defspecial(ctx,"GO",mod,GO);
01315   defun(ctx,"RESET",mod,RESET);
01316   defun(ctx,"EVALHOOK",mod,EVALHOOK);
01317   defun(ctx,"MACROEXPAND2",mod,MACEXPAND2);
01318   defspecial(ctx,"EVAL-WHEN",mod,EVALWHEN);
01319   defspecial(ctx,"THE",mod,THE);
01320   QAND=defspecial(ctx,"AND",mod,AND);
01321   QOR=defspecial(ctx,"OR",mod,OR);
01322   defun(ctx,"PROCLAIM",mod,PROCLAIM);
01323   defspecial(ctx,"DECLARE",mod,DECLARE);
01324   defun(ctx,"SETFUNC",mod,SETFUNC);
01325   defun(ctx,"SYMBOL-VALUE",mod,SYMVALUE);
01326   defun(ctx,"SYMBOL-BOUND-VALUE",mod,SYMBNDVALUE);
01327   defun(ctx,"SYMBOL-FUNCTION",mod,SYMFUNC); 
01328   defun(ctx,"MAKUNBOUND",mod,MAKUNBOUND);
01329   defun(ctx,"SET",mod,SETSPECIAL);
01330   defspecial(ctx,"DEFUN",mod,DEFUN);
01331   defspecial(ctx,"DEFMACRO",mod,DEFMACRO);
01332   defun(ctx,"FIND-SYMBOL",mod,FINDSYMBOL);
01333   defun(ctx,"INTERN",mod,INTERN);
01334   defun(ctx,"GENSYM",mod,GENSYM);
01335   defun(ctx,"LIST-ALL-PACKAGES",mod,ALLPACKAGES);
01336   defun(ctx,"FIND-PACKAGE",mod,FINDPACKAGE);
01337   defunpkg(ctx,"MAKEPACKAGE",mod,MAKEPACKAGE,syspkg);
01338 /*  defun(ctx,"IN-PACKAGE",mod,INPACKAGE); */
01339   defun(ctx,"SXHASH",mod,SXHASH);
01340   defun(ctx,"GET",mod,GETPROP);
01341   defun(ctx,"EXPORT",mod,EXPORT);
01342   defun(ctx,"PUTPROP",mod,PUTPROP);
01343 
01344 #ifdef EVAL_DEBUG
01345   defun(ctx,"EVALDEBUG",mod,EVALDEBUG);
01346 #endif
01347   }
01348 
01349