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


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