00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
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
00025 static pointer genhead;
00026 static int genindex,tempindex=0;
00027 static pointer QRETFROM,QEVAL,QPROGN,QIF;
00028
00029
00030
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;
00173 #else
00174 addr &= ~3;
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
00194 ctx->vsp=argp-1;
00195 return(mac);}
00196
00197
00198
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
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
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)
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
00427 while (islist(body)) {
00428 decl=ccar(body);
00429 if (!islist(decl) || (ccar(decl)!=QDECLARE)) break;
00430 env=declare(ctx,ccdr(decl),env);
00431 body=ccdr(body);}
00432
00433 GC_POINT;
00434
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
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);
00454 ctx->bindfp=bfsave;
00455 ctx->vsp=spsave;
00456 unbindspecial(ctx,(struct specialbindframe *)ctx->vsp);
00457
00458 return(result);}
00459
00460 pointer SEQLET(ctx,args)
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;
00475
00476
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
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
00496 result=progn(ctx,body);
00497
00498 ctx->bindfp=bf;
00499 ctx->vsp=spsave;
00500 unbindspecial(ctx,(struct specialbindframe *)ctx->vsp);
00501
00502 return(result);}
00503
00504 pointer CATCH(ctx,arg)
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);
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)) {
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
00641 return(val);}
00642 else return(eval2(ctx,form,env));}
00643
00644 pointer BLOCK(ctx,arg)
00645 register context *ctx;
00646 register pointer arg;
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
00663 ctx->bindfp=bfp;
00664 ctx->vsp=spsave;
00665 return(result);}
00666
00667 pointer RETFROM(ctx,arg)
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
00722
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
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)
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)
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
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 }
00883 } }
00884 return(NIL);}
00885
00886 pointer DECLARE(arg)
00887 pointer arg;
00888 { error(E_DECLARE); }
00889
00890
00891
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);
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
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)
01207
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
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)
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
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
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