/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Lisprolog -- Interpreter for a simple Lisp. Written in Prolog. Written Nov. 26th, 2006 by Markus Triska (triska@gmx.at). Public domain code. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ :-module(moo_ext_lisp_triska,[codelist_to_forms/2]). % #include_ % #include_ % #include_ % #include_ % #include_ % #include_ % #include_ % #include_ % #include_ % #ifdef_MACH_ % #define_setjmp(e)sigsetjmp(e,0) % #define_longjmp_siglongjmp % #endif % #ifdef_WIN32 % #include_ % #defineXdeclspec(dllexport) % #else % #defineX % #endif % #ifndef_WIN32 % #include_ % #include_ % #include_ % #include_ % #endif % #typedef_int_lval; lisp500_fn([lval_PTR_o2c(lval_o)]):-true. %- { %= return (lval_PTR)(o-1); %- } lisp500_fn([lval_c2o(lval_PTR_c)]):-true. %- { %= return (lval)c+1; %- } lisp500_fn([int_cp(lval_o)]):-true. %- { %= return (o &3)==1; %- } lisp500_fn([lval_PTR_o2a(lval_o)]):-true. %- { %= return (lval_PTR)(o-2); %- } lisp500_fn([lval_a2o(lval_PTR_a)]):-true. %- { %= return (lval)a+2; %- } lisp500_fn([int_ap(lval_o)]):-true. %- { %= return (o &3)==2; %- } lisp500_fn([lval_PTR_o2s(lval_o)]):-true. %- { %= return (lval_PTR)(o-3); %- } lisp500_fn([char_PTR_o2z(lval_o)]):-true. %- { %= return (char_PTR)(o-3+2PTR_sizeof(lval)); %- } lisp500_fn([lval_s2o(lval_PTR_s)]):-true. %- { %= return (lval)s+3; %- } lisp500_fn([int_sp(lval_o)]):-true. %- { %= return (o &3)==3; %- } lisp500_fn([struct_symbol_init{ %= const_char_PTR_name; %= lval(PTR_fun)(); %= int_argc; %= lval(PTR_setfun)(); %= int_setargc; %= lval_sym; %- }; % #extern_struct_symbol_init_symi_ARRAY; % #define_TRUE_symi[1].sym % #defineTg[-2] % #defineUg[-3] % #defineVg[-4] % #defineWg[-5] % #define_NF(n)lval_PTR_g;g=f+n+3;f[1]=0;g[-1]=(n<<5)|16;PTR_g=PTR_f; % #defineEPTRf % #define_NE_PTRg lisp500_fn([lval_car(lval_c)]):-true. %- { %= return (c &3)==1?o2c(c)[0]_:0; %- } lisp500_fn([lval_cdr(lval_c)]):-true. %- { %= return (c &3)==1?o2c(c)[1]_:0; %- } lisp500_fn([lval_caar(lval_c)]):-true. %- { %= return car(car(c)); %- } lisp500_fn([lval_lread(lval_PTR)]):-true. %- { %- } lisp500_fn([lval_cdar(lval_c)]):-true. %- { %= return cdr(car(c)); %- } lisp500_fn([lval_evca(lval_PTR,lval)]):-true. %- { %- } lisp500_fn([lval_cadr(lval_c)]):-true. %- { %= return car(cdr(c)); %- } lisp500_fn([int_dbgr(lval_PTR,int,lval,lval_PTR)]):-true. %- { %- } lisp500_fn([lval_cddr(lval_c)]):-true. %- { %= return cdr(cdr(c)); %- } lisp500_fn([void_print(lval)]):-true. %- { %- } lisp500_fn([lval_set_car(lval_c,lval_val)]):-true. %- { %= return o2c(c)[0]=val; %- } lisp500_fn([lval_set_cdr(lval_c,lval_val)]):-true. %- { %= return o2c(c)[1]=val; %- } lisp500_fn([lval_PTR_binding(lval_PTR_f,lval_sym,int_type,int_PTR_macro)]):-true. %- { %= lval_env; %= st: %= for(env=E;env;env=cdr(env)) { %= lval_e=caar(env); %= if(type||cp(e)?car(e)==sym &&(cdr(e)>>4)==type:e==sym) { %= if(macro) %= PTR_macro=cp(e)&& cdr(e)&8; %= return o2c(car(env))+1; %= } %= } %= if(macro) %= PTR_macro=(o2a(sym)[8]>>type)&32; %= if(type>2) { %= dbgr(f,type,sym,&sym); %= goto_st; %= } %= return o2a(sym)+4+type; %- } %= lval_PTR_memory; %= lval_PTR_memf; %= int_memory_size; %= lval_PTR_stack; %= lval_xvalues=8; %= lval_dyns=0; %= jmp_buf_top_jmp; %= lval_pkg; %= lval_pkgs; %= lval_kwp=0; lisp500_fn([void_gcm(lval_v)]):-true. %- { %= lval_PTR_t; %= int_i; %= st: t=(lval_PTR)(v&~3); %= if(v &3&& !(t[0] &4)) { %= t[0]|=4; %= switch(v &3) { %= case 1: %= gcm(t[0]-4); %= v=t[1]; %= goto_st; %= case 2: %= gcm(t[1]-4); %= if(t[0]>>8) { %= for(i=1;i>8;i++) %= gcm(t[i+1]); %= v=t[i+1]; %= goto_st; %= } %= } %= } %- } lisp500_fn([lval_gc(lval_PTR_f)]):-true. %- { %= int_i; %= lval_PTR_m; %= int_l; %= int_u=0; %= int_ml; %= printf(";garbage_collectingREST\n"); %= while(memf) { %= lval_PTR_n=(lval_PTR)memf[0]; %= memset(memf,0,4PTR_memf[1]); %= memf=(lval_PTR)n; %= } %= gcm(xvalues); %= gcm(pkgs); %= gcm(dyns); %= for(;f>stack;f--) { %= if((PTRf&3)&&(PTRfmemory+memory_size/4)) %= printf("%x\n",PTR_f); %= gcm(PTR_f); %= } %= memf=0; %= m=memory; %= i=0; %= while(m>8:0)+1)&~1; %= if(m[0] &4) { %= if(u) { %= m[-ml]=(lval)memf; %= m[1-_ml]=ml; %= memf=m-ml; %= u=0; %= i+=ml; %= } %= } else{ %= if(!u) %= ml=0; %= ml+=l+2; %= u=1; %= } %= m[0] &=~4; %= m+=l+2; %= } %= if(u) { %= m[-ml]=(lval)memf; %= m[1-_ml]=ml; %= memf=m-ml; %= i+=ml; %= } %= printf(";done._%d_free.\n",i); %= return 0; %- } lisp500_fn([lval_PTR_m0(lval_PTR_g,int_n)]):-true. %- { %= lval_PTR_m=memf; %= lval_PTR_p=0; %= n=(n+1)&~1; %= for(;m;m=(lval_PTR)m[0]) { %= if(n_<=m[1]) { %= if(m[1]==n) %= if(p) %= p[0]=m[0]; %= else %= memf=(lval_PTR)m[0]; %= else{ %= m[1]-=n; %= m+=m[1]; %= } %= return m; %= } p=m; %= } return 0; %- } lisp500_fn([lval_PTR_ma0(lval_PTR_g,int_n)]):-true. %- { %= lval_PTR_m; %= st: m=m0(g,n+2); %= if(!m) { %= gc(g); %= goto_st; %= } PTR_m=n_<<8; %= return m; %- } lisp500_fn([lval_PTR_ms0(lval_PTR_g,int_n)]):-true. %- { %= lval_PTR_m; %= st: m=m0(g,(n+12)/4); %= if(!m) { %= gc(g); %= goto_st; %= } PTR_m=(n+4)<<6; %= return m; %- } lisp500_fn([lval_PTR_mb0(lval_PTR_g,int_n)]):-true. %- { %= lval_PTR_m; %= st: m=m0(g,(n+95)/32); %= if(!m) { %= gc(g); %= goto_st; %= } PTR_m=(n+31)<<3; %= return m; %- } lisp500_fn([X_lval_ma(lval_PTR_g,int_n,REST)]):-true. %- { %= va_list_v; %= int_i; %= lval_PTR_m; %= st: va_start(v,n); %= m=m0(g,n+2); %= if(!m) { %= for(i=-1;i>5; %- } lisp500_fn([lval_d2o(lval_PTR_g,double_d)]):-true. %- { %= lval_x=(lval)d<<5|16; %= lval_PTR_a; %= if(o2d(x)==d) %= return x; %= a=ma0(g,2); %= a[1]=84; %= PTR(double_PTR)(a+2)=d; %= return s2o(a); %- } lisp500_fn([int_o2i(lval_o)]):-true. %- { %= return (int)o2d(o); %- } lisp500_fn([unsigned_o2u(lval_o)]):-true. %- { %= return (unsigned)o2d(o); %- } lisp500_fn([lval_cons(lval_PTR_g,lval_a,lval_d)]):-true. %- { %= lval_PTR_c=m0(g,2); %= if(!c) { %= gcm(a); %= gcm(d); %= gc(g); %= c=m0(g,2); %= } c[0]=a; %= c[1]=d; %= return c2o(c); %- } lisp500_fn([int_string_equal_do(lval_a,lval_b)]):-true. %- { %= int_i; %= for(i=0;i=g;f--) %= r=cons(h,PTR_f,r); %= return r; %- } lisp500_fn([lval_args(lval_PTR,lval,int)]):-true. %- { %- } lisp500_fn([lval_argd(lval_PTR_f,lval_n,lval_a)]):-true. %- { %= if(cp(n)) { %= lval_PTR_h=f; %= for(;a;a=cdr(a)) %= PTR++h=car(a); %= ++h; %= PTR++h=PTR_f; %= return args(f,n,h-f-2); %= } %= return cons(f,cons(f,n,a),PTR_f); %- } lisp500_fn([lval_args(lval_PTR_f,lval_m,int_c)]):-true. %- { %= lval_PTR_g=f+1; %= lval_PTR_h=f+c+2; %= int_t; %= lval_k,PTR_l; %= st: t=0; %= while(cp(m)) { %= lval_n=car(m); %= m=cdr(m); %= switch(cp(n)?-1:o2a(n)[7]>>3) { %= case 2: %= case 3: %= t=1; %= continue; %= case 4: %= t=2; %= continue; %= case 5: %= t=-2; %= continue; %= case 6: %= t=4; %= continue; %= case 7: %= t=5; %= continue; %= default: %= switch(t) { %= case 0: %= if(g>=h-1) { %= dbgr(g,7,0,h); %= goto_st; %= } PTR_h=argd(h,n,PTR_g); %= break; %= case 1: %= PTR_h=cons(h,cons(h,n,rest(h-1,g)),PTR_h); %= t=-1; %= continue; %= case 2: %= n=argi(n,&k); %= PTR_h=argd(h,n,g=0) { %= h[-1]=(c_<<5)|16; %= dbgr(h,6,0,h); %= goto_st; %= } return PTR_h; %- } lisp500_fn([lval_eval_body(lval_PTR_f,lval_ex)]):-true. %- { %= NF(1)T=0; %= for(;ex;ex=cdr(ex)) %= T=evca(g,ex); %= return T; %- } lisp500_fn([int_map_eval(lval_PTR_f,lval_ex)]):-true. %- { %= lval_PTR_g=f+3; %= for(;ex;ex=cdr(ex),g++) { %= g[-1]=((g-f-3)<<5)|16; %= PTR_g=PTR_f; %= g[-1]=evca(g,ex); %= } return g-f-3; %- } lisp500_fn([lval_eval(lval_PTR_f,lval_expr)]):-true. %- { %= NF(1)T=0; %= T=cons(g,expr,0); %= return evca(g,T); %- } lisp500_fn([lval_rvalues(lval_PTR_g,lval_v)]):-true. %- { %= return xvalues==8?cons(g,v,0):xvalues; %- } lisp500_fn([lval_mvalues(lval_a)]):-true. %- { %= xvalues=a; %= return car(a); %- } lisp500_fn([lval_infn(lval_PTR_f,lval_PTR_h)]):-true. %- { %= jmp_buf_jmp; %= lval_vs; %= lval_PTR_g=h+1; %= lval_fn=PTR_f; %= int_d=h-f-1; %= h[1]=o2a(fn)[3]; %= NE=args(f,o2a(fn)[4],d); %= g[-1]=cons(g,dyns,ms(g,1,20,&jmp)); %= NE=cons(g,cons(g,cons(g,o2a(fn)[6],64),g[-1]),NE); %= g[-1]=(d_<<5)|16; %= if(!(vs=setjmp(jmp))) %= return eval_body(g,o2a(fn)[5]); %= return mvalues(car(vs)); %- } lisp500_fn([X_lval_call(lval_PTR_f,lval_fn,unsigned_d)]):-true. %- { %= lval_PTR_g=f+d+3; %= xvalues=8; %= if(o2a(fn)[1]==20) %= fn=o2a(fn)[5]; %= if(o2a(fn)[0] &16) %= fn=o2a(fn)[3]; %= PTR++f=fn; %= fn=o2a(fn)[2]; %= if(d_<(unsigned)o2s(fn)[3]) %= dbgr(g,7,0,f); %= if(d>(unsigned)o2s(fn)[4]) %= dbgr(g,6,0,f); %= return ((lval(PTR)())o2s(fn)[2])(f,f+d+1); %- } lisp500_fn([lval_eval_quote(lval_PTR_g,lval_ex)]):-true. %- { %= return car(ex); %- } lisp500_fn([int_specp(lval_PTR_f,lval_ex,lval_s)]):-true. %- { %= for(;ex;ex=cdr(ex)) %= if(ap(caar(ex))&& o2a(caar(ex))[7]==3<<3) { %= lval_e=cdar(ex); %= for(;e;e=cdr(e)) %= if(o2a(caar(e))[7]==4<<3) { %= lval_sp=cdar(e); %= for(;sp;sp=cdr(sp)) %= if(car(sp)==s) %= return 1; %= } %= } else %= break; %= return 0; %- } lisp500_fn([void_unwind(lval_PTR_f,lval_c)]):-true. %- { %= lval_e; %= NF(0)for(;dyns_!=c;dyns=cdr(dyns)) %= if(ap(car(dyns))) %= if(o2a(car(dyns))[1]==52) { %= NE=o2a(car(dyns))[2]; %= eval_body(g,o2a(car(dyns))[3]); %= } else %= for(e=o2a(car(dyns))[2];e;e=cdr(e)) %= o2a(caar(e))[4]=cdar(e); %= else %= o2s(car(dyns))[2]=0; %- } lisp500_fn([lval_eval_let(lval_PTR_f,lval_ex)]):-true. %- { %= lval_r; %= NF(3)T=car(ex); %= U=E; %= V=0; %= r=ma(g,1,84,0); %= dyns=cons(g,r,dyns); %= for(;T;T=cdr(T)) { %= V=evca(g,cdar(T)); %= if(o2a(caar(T))[8] &128||specp(g,cdr(ex),caar(T))) { %= o2a(r)[2]=cons(g,cons(g,caar(T),V),o2a(r)[2]); %= } else %= U=cons(g,cons(g,caar(T),V),U); %= } for(r=o2a(r)[2];r;r=cdr(r)) { %= T=o2a(caar(r))[4]; %= o2a(caar(r))[4]=cdar(r); %= set_cdr(car(r),T); %= U=cons(g,cons(g,caar(r),-8),U); %= } NE=U; %= T=eval_body(g,cdr(ex)); %= unwind(g,cdr(dyns)); %= return T; %- } lisp500_fn([lval_eval_letm(lval_PTR_f,lval_ex)]):-true. %- { %= lval_r; %= NF(2)T=U=0; %= r=ma(g,1,84,0); %= dyns=cons(g,r,dyns); %= for(T=car(ex);T;T=cdr(T)) { %= U=evca(g,cdar(T)); %= if(o2a(caar(T))[8] &128||specp(g,cdr(ex),caar(T))) { %= o2a(r)[2]=cons(g,cons(g,caar(T),o2a(caar(T))[4]),o2a(r)[2]); %= o2a(caar(T))[4]=U; %= U=-8; %= } U=cons(g,caar(T),U); %= NE=cons(g,U,NE); %= } %= T=eval_body(g,cdr(ex)); %= unwind(g,cdr(dyns)); %= return T; %- } lisp500_fn([lval_eval_progv(lval_PTR_f,lval_ex)]):-true. %- { %= lval_r; %= NF(2)T=U=0; %= r=ma(g,1,84,0); %= T=evca(g,ex); %= U=evca(g,cdr(ex)); %= dyns=cons(g,r,dyns); %= for(;T&& U;T=cdr(T),U=cdr(U)) { %= o2a(r)[2]=cons(g,cons(g,car(T),o2a(car(T))[4]),o2a(r)[2]); %= o2a(car(T))[4]=car(U); %= } T=eval_body(g,cddr(ex)); %= unwind(f,cdr(dyns)); %= return T; %- } lisp500_fn([lval_eval_flet(lval_PTR_f,lval_ex)]):-true. %- { %= NF(4)V=W=0; %= U=E; %= for(T=car(ex);T;T=cdr(T)) { %= V=ma(g,5,212,ms(f,3,212,infn,0,-1),E,cadr(car(T)),cddr(car(T)),caar(T)); %= W=cons(g,caar(T),16); %= V=cons(g,W,V); %= U=cons(g,V,U); %= } NE=U; %= return eval_body(g,cdr(ex)); %- } lisp500_fn([lval_eval_labels(lval_PTR_f,lval_ex)]):-true. %- { %= NF(4)V=W=0; %= U=E; %= for(T=car(ex);T;T=cdr(T)) %= U=cons(g,0,U); %= NE=U; %= for(T=car(ex);T;T=cdr(T),U=cdr(U)) { %= V=ma(g,5,212,ms(f,3,212,infn,0,-1),NE,cadr(car(T)),cddr(car(T)),caar(T)); %= W=cons(g,caar(T),16); %= set_car(U,cons(g,W,V)); %= } return eval_body(g,cdr(ex)); %- } lisp500_fn([lval_eval_macrolet(lval_PTR_f,lval_ex)]):-true. %- { %= NF(4)V=W=0; %= U=E; %= for(T=car(ex);T;T=cdr(T)) { %= V=ma(g,5,212,ms(f,3,212,infn,0,-1),E,cadr(car(T)),cddr(car(T)),caar(T)); %= W=cons(g,caar(T),24); %= V=cons(g,W,V); %= U=cons(g,V,U); %= } NE=U; %= return eval_body(g,cdr(ex)); %- } lisp500_fn([lval_eval_symbol_macrolet(lval_PTR_f,lval_ex)]):-true. %- { %= NF(3)V=0; %= U=E; %= for(T=car(ex);T;T=cdr(T)) { %= V=cons(g,caar(T),8); %= V=cons(g,V,cadr(car(T))); %= U=cons(g,V,U); %= } NE=U; %= return eval_body(g,cdr(ex)); %- } lisp500_fn([lval_eval_setq(lval_PTR_f,lval_ex)]):-true. %- { %= lval_r; %= do{ %= r=evca(f,cdr(ex)); %= PTR_binding(f,car(ex),0,0)=r; %= ex=cddr(ex); %= } while(ex); %= return r; %- } lisp500_fn([lval_eval_function(lval_PTR_f,lval_ex)]):-true. %- { %= lval_x; %= ex=car(ex); %= if(cp(ex)) %= if(car(ex)==symi[75].sym) { %= lval_n=0; %= x=cddr(ex); %= if(!cdr(x)&& caar(x)==symi[23].sym) { %= x=car(x); %= n=cadr(x); %= x=cddr(x); %= } %= return ma(f,5,212,ms(f,3,212,infn,0,-1),E,cadr(ex),x,n); %= } else %= x=PTR_binding(f,cadr(ex),2,0); %= else %= x=PTR_binding(f,ex,1,0); %= if(x_!=8) %= return x; %= dbgr(f,1,ex,&x); %= return x; %- } lisp500_fn([lval_eval_tagbody(lval_PTR_f,lval_ex)]):-true. %- { %= jmp_buf_jmp; %= lval_tag; %= lval_e; %= NF(2)T=U=0; %= U=ms(g,1,52,&jmp); %= dyns=cons(g,U,dyns); %= for(e=ex;e;e=cdr(e)) %= if(ap(car(e))) { %= T=cons(g,dyns,U); %= NE=cons(g,cons(g,cons(g,car(e),48),T),NE); %= } e=ex; %= again: %= if(!(tag=setjmp(jmp))) { %= for(;e;e=cdr(e)) %= if(!ap(car(e))) %= evca(g,e); %= } else %= for(e=ex;e;e=cdr(e)) %= if(car(e)==tag) { %= e=cdr(e); %= goto_again; %= } %= unwind(g,cdr(dyns)); %= return 0; %- } lisp500_fn([lval_eval_go(lval_PTR_f,lval_ex)]):-true. %- { %= lval_b=PTR_binding(f,car(ex),3,0); %= if(o2s(cdr(b))[2]) { %= unwind(f,car(b)); %= longjmp(PTR(jmp_buf_PTR)(o2s(cdr(b))[2]),car(ex)); %= } dbgr(f,9,car(ex),&ex); %= longjmp(top_jmp,1); %- } lisp500_fn([lval_eval_block(lval_PTR_f,lval_ex)]):-true. %- { %= jmp_buf_jmp; %= lval_vs; %= NF(2)T=U=0; %= T=ms(g,1,52,&jmp); %= U=cons(g,dyns,T); %= dyns=cons(g,T,dyns); %= NE=cons(g,cons(g,cons(g,car(ex),64),U),NE); %= if(!(vs=setjmp(jmp))) { %= T=eval_body(g,cdr(ex)); %= unwind(g,cdr(dyns)); %= return T; %= } %= return mvalues(car(vs)); %- } lisp500_fn([lval_eval_return from(lval_PTR_f,lval_ex)]):-true. %- { %= lval_b; %= jmp_buf_PTR_jmp; %= NF(1)T=0; %= b=PTR_binding(g,car(ex),4,0); %= jmp=(jmp_buf_PTR)o2s(cdr(b))[2]; %= if(jmp) { %= unwind(g,car(b)); %= T=rvalues(g,evca(g,cdr(ex))); %= longjmp(PTR_jmp,cons(g,T,0)); %= } dbgr(g,8,car(ex),&T); %= longjmp(top_jmp,1); %- } lisp500_fn([lval_eval_catch(lval_PTR_f,lval_ex)]):-true. %- { %= jmp_buf_jmp; %= lval_vs; %= lval_oc=dyns; %= NF(2) %= T=U=0; %= U=evca(g,ex); %= T=ms(g,1,20,&jmp); %= T=cons(g,U,T); %= dyns=cons(g,T,dyns); %= if(!(vs=setjmp(jmp))) %= vs=eval_body(g,cdr(ex)); %= else %= vs=mvalues(car(vs)); %= dyns=oc; %= return vs; %- } lisp500_fn([lval_eval_throw(lval_PTR_f,lval_ex)]):-true. %- { %= lval_c; %= NF(1)T=0; %= T=evca(g,ex); %= st: %= for(c=dyns;c;c=cdr(c)) %= if(cp(car(c))&& caar(c)==T) { %= unwind(g,c); %= T=evca(g,cdr(ex)); %= T=rvalues(g,T); %= longjmp(PTR(jmp_buf_PTR)(o2s(cdar(c))[2]),cons(g,T,0)); %= } %= dbgr(g,5,T,&T); %= goto_st; %- } lisp500_fn([lval_eval_unwind_protect(lval_PTR_f,lval_ex)]):-true. %- { %= NF(1)T=0; %= T=ma(g,2,52,E,cdr(ex)); %= dyns=cons(g,T,dyns); %= T=evca(g,ex); %= T=rvalues(g,T); %= unwind(g,cdr(dyns)); %= return mvalues(T); %- } lisp500_fn([lval_eval_if(lval_PTR_f,lval_ex)]):-true. %- { %= return evca(f,evca(f,ex)?cdr(ex):cddr(ex)); %- } lisp500_fn([lval_eval_multiple_value_call(lval_PTR_f,lval_ex)]):-true. %- { %= lval_PTR_g=f+3; %= lval_l; %= f[1]=evca(f,ex); %= for(ex=cdr(ex);ex;ex=cdr(ex)) { %= PTR_g=PTR_f; %= g[-1]=((g-f-3)<<5)|16; %= for(l=rvalues(g,evca(g,ex));l;l=cdr(l)) { %= g[-1]=car(l); %= g++; %= } %= } xvalues=8; %= return call(f,f[1],g-f-3); %- } lisp500_fn([lval_eval_multiple_value_prog1(lval_PTR_f,lval_ex)]):-true. %- { %= NF(1)T=0; %= T=evca(g,ex); %= T=rvalues(g,T); %= eval_body(g,cdr(ex)); %= return mvalues(T); %- } lisp500_fn([lval_eval_declare(lval_PTR_f,lval_ex)]):-true. %- { %= return 0; %- } lisp500_fn([lval_l2(lval_PTR_f,lval_a,lval_b)]):-true. %- { %= return cons(f,a,cons(f,b,0)); %- } lisp500_fn([lval_eval_setf(lval_PTR_f,lval_ex)]):-true. %- { %= lval_r; %= int_m; %= NF(1)T=0; %= ag: if(!cp(car(ex))) { %= r=PTR_binding(g,car(ex),0,&m); %= if(!m) %= return PTR_binding(g,car(ex),0,0) %= =evca(g,cdr(ex)); %= set_car(ex,r); %= goto_ag; %= } r=PTR_binding(g,caar(ex),2,0); %= if(r==8) %= dbgr(g,1,l2(f,symi[33].sym,caar(ex)),&r); %= T=cons(g,cadr(ex),cdar(ex)); %= return call(g,r,map_eval(g,T)); %- } lisp500_fn([lval_llist(lval_PTR_f,lval_PTR_h)]):-true. %- { %= return rest(h,f+1); %- } lisp500_fn([lval_lvalues(lval_PTR_f,lval_PTR_h)]):-true. %- { %= return mvalues(rest(h,f+1)); %- } lisp500_fn([lval_lfuncall(lval_PTR_f,lval_PTR_h)]):-true. %- { %= return call(f,f[1],h-f-2); %- } lisp500_fn([lval_lapply(lval_PTR_f,lval_PTR_h)]):-true. %- { %= while(h[-1]) { %= h[0]=cdr(h[-1]); %= h[-1]=car(h[-1]); %= h++; %= } return call(f,f[1],h-f-3); %- } lisp500_fn([lval_leq(lval_PTR_f)]):-true. %- { %= return f[1]==f[2]?TRUE_:0; %- } lisp500_fn([lval_lcons(lval_PTR_f)]):-true. %- { %= return cons(f,f[1],f[2]); %- } lisp500_fn([lval_lcar(lval_PTR_f)]):-true. %- { %= return car(f[1]); %- } lisp500_fn([lval_setfcar(lval_PTR_f)]):-true. %- { %= return set_car(f[2],f[1]); %- } lisp500_fn([lval_lcdr(lval_PTR_f)]):-true. %- { %= return cdr(f[1]); %- } lisp500_fn([lval_setfcdr(lval_PTR_f)]):-true. %- { %= return set_cdr(f[2],f[1]); %- } lisp500_fn([lval_lequ(lval_PTR_f,lval_PTR_h)]):-true. %- { %= double_s=o2d(f[1]); %= for(f+=2;f>p&((1<2?o2d(f[2]):1; %= double_q=floor(n/d); %= return mvalues(l2(f,d2o(f,q),d2o(f,n-q_PTR_d))); %- } % #int_gensymc=0; lisp500_fn([lval_lgensym(lval_PTR_f)]):-true. %- { %= lval_PTR_r=ms0(f,4); %= r[1]=20; %= sprintf((char_PTR)(r+2), %= "g%3.3d",gensymc++); %= return ma(f,9,20,s2o(r),0,8,8,8,-8,16,0,0); %- } lisp500_fn([lval_lcode_char(lval_PTR_f)]):-true. %- { %= unsigned_int c=o2u(f[1]); %= return c<256?32PTR_c+24:0; %- } lisp500_fn([lval_lchar_code(lval_PTR_f)]):-true. %- { %= return f[1]&~8; %- } lisp500_fn([lval_lmakef(lval_PTR_f)]):-true. %- { %= return d2o(f,f-stack); %- } lisp500_fn([lval_lfref(lval_PTR_f)]):-true. %- { %= return stack[o2i(f[1])]; %- } lisp500_fn([lval_stringify(lval_PTR_f,lval_l)]):-true. %- { %= int_i; %= lval_PTR_r; %= lval_t=l; %= PTR++f=l; %= for(i=0;t;i++,t=cdr(t)); %= r=ms0(f,i); %= r[1]=20; %= ((char_PTR)r)[i+8]=0; %= for(i=8;l;i++,l=cdr(l)) %= ((char_PTR)r)[i]=car(l)>>5; %= return s2o(r); %- } lisp500_fn([lval_lstring(lval_PTR_f,lval_PTR_h)]):-true. %- { %= return stringify(f,rest(h,f+1)); %- } lisp500_fn([lval_lival(lval_PTR_f)]):-true. %- { %= return d2o(f,f[1]); %- } lisp500_fn([lval_lmakei(lval_PTR_f,lval_PTR_h)]):-true. %- { %= int_i=2; %= int_l=o2i(f[1]); %= lval_PTR_r=ma0(h,l); %= r[1]=f[2]|4; %= memset(r+2,0,4PTR_o2i(f[1])); %= for(f+=3;f=l+2) %= printf("overinitializing_in_makei\n"); %= r[i]=PTR_f; %= } %= return a2o(r); %- } lisp500_fn([lval_liboundp(lval_PTR_f)]):-true. %- { %= return o2a(f[1])[o2u(f[2])]==8?0:TRUE; %- } lisp500_fn([lval_limakunbound(lval_PTR_f)]):-true. %- { %= o2a(f[1])[o2u(f[2])]=8; %= return 0; %- } lisp500_fn([lval_liref(lval_PTR_f)]):-true. %- { %= if(o2u(f[2])>=o2a(f[1])[0]/256+2) %= write(1,"out_of_bounds_in_iref\n",22); %= return ((lval_PTR)(f[1]&~3))[o2u(f[2])]&~4; %- } lisp500_fn([lval_setfiref(lval_PTR_f)]):-true. %- { %= int_i=o2i(f[3]); %= if(i>=o2a(f[2])[0]/256+2) %= printf("out_of_bounds_in_setf_iref\n"); %= return ((lval_PTR)(f[2]&~3))[i]=i==1?f[1]|4:f[1]; %- } lisp500_fn([lval_lmakej(lval_PTR_f)]):-true. %- { %= lval_PTR_r=mb0(f,o2i(f[1])); %= r[1]=o2i(f[2]); %= memset(r+2,0,(o2i(f[1])+7)/8); %= return s2o(r); %- } lisp500_fn([lval_ljref(lval_PTR_f)]):-true. %- { %= return d2o(f,o2s(f[1])[o2u(f[2])]); %- } lisp500_fn([lval_setfjref(lval_PTR_f)]):-true. %- { %= return o2s(f[2])[o2u(f[3])]=o2u(f[1]); %- } % #ifdef_WIN32 lisp500_fn([lval_lmake_fs(lval_PTR_f)]):-true. %- { %= HANDLE_fd=CreateFile(o2z(f[1]),f[2]?GENERIC_WRITE: %= GENERIC_READ,f[2]?FILE_SHARE_WRITE:FILE_SHARE_READ,NULL,OPEN_EXISTING, %= FILE_ATTRIBUTE_NORMAL,NULL); %= return ms(f,4,116,1,fd,f[2],0); %- } lisp500_fn([lval_lclose_fs(lval_PTR_f)]):-true. %- { %= CloseHandle(o2s(f[1])[3]); %= return 0; %- } lisp500_fn([lval_llisten_fs(lval_PTR_f)]):-true. %- { %= return WaitForSingleObject(o2s(f[1])[3],0)==WAIT_OBJECT0?TRUE_:0; %- } lisp500_fn([lval_lread_fs(lval_PTR_f)]):-true. %- { %= int_l=o2i(f[3]); %= if(!ReadFile(o2s(f[1])[3], %= o2z(f[2])+l,(o2s(f[2])[0]>>6)-4-_l,&l,NULL)) %= return 0; %= return d2o(f,l); %- } lisp500_fn([lval_lwrite_fs(lval_PTR_f)]):-true. %- { %= int_l=o2i(f[3]); %= if(!WriteFile(o2s(f[1])[3], %= o2z(f[2])+l,o2i(f[4])-l,&l,NULL)) %= return 0; %= return d2o(f,l); %- } lisp500_fn([lval_lfinish_fs(lval_PTR_f)]):-true. %- { %= FlushFileBuffers(o2s(f[1])[3]); %= return 0; %- } lisp500_fn([lval_lfasl(lval_PTR_f)]):-true. %- { %= HMODULE_h; %= FARPROC_s; %= h=LoadLibrary(o2z(f[1])); %= s=GetProcAddress(h,"init"); %= return s(f); %- } lisp500_fn([lval_luname(lval_PTR_f)]):-true. %- { %= OSVERSIONINFO_osvi; %= osvi.dwOSVersionInfoSize=sizeof(OSVERSIONINFO); %= GetVersionEx(&osvi); %= f[1]=cons(f+1,strf(f+1,osvi.szCSDVersion),0); %= f[1]=cons(f+1,d2o(f+1,osvi.dwBuildNumber),f[1]); %= f[1]=cons(f+1,d2o(f+1,osvi.dwMinorVersion),f[1]); %= return cons(f+1,d2o(f,osvi.dwMajorVersion),f[1]); %- } % #else lisp500_fn([lval_lmake_fs(lval_PTR_f)]):-true. %- { %= int_fd=open(o2z(f[1]),f[2]?O_WRONLY|O_CREAT|O_TRUNC:O_RDONLY,0600); %= return fd>=0?ms(f,4,116,1,fd,f[2],0):d2o(f,errno); %- } lisp500_fn([lval_lclose_fs(lval_PTR_f)]):-true. %- { %= close(o2s(f[1])[3]); %= return 0; %- } lisp500_fn([lval_llisten_fs(lval_PTR_f)]):-true. %- { %= fd_set_r; %= struct_timeval_t; %= t.tv_sec=0; %= t.tv_usec=0; %= FD_ZERO(&r); %= FD_SET(o2s(f[1])[3],&r); %= return select(o2s(f[1])[3]+1,&r,NULL,NULL,&t)?TRUE_:0; %- } lisp500_fn([lval_lread_fs(lval_PTR_f)]):-true. %- { %= int_l=o2i(f[3]); %= l=read(o2s(f[1])[3],o2z(f[2])+l, %= (o2s(f[2])[0]>>6)-4-_l); %= return l<0?cons(f,errno,0):d2o(f,l); %- } lisp500_fn([lval_lwrite_fs(lval_PTR_f)]):-true. %- { %= int_l=o2i(f[3]); %= l=write(o2s(f[1])[3], %= o2z(f[2])+l,o2i(f[4])-l); %= return l<0?cons(f,errno,0):d2o(f,l); %- } lisp500_fn([lval_lfinish_fs(lval_PTR_f)]):-true. %- { %= fsync(o2s(f[1])[3]); %= return 0; %- } lisp500_fn([lval_lfasl(lval_PTR_f)]):-true. %- { %= void_PTR_h; %= lval(PTR_s)(); %= h=dlopen(o2z(f[1]),RTLD_NOW); %= s=dlsym(h,"init"); %= return s(f); %- } lisp500_fn([lval_luname(lval_PTR_f)]):-true. %- { %= struct_utsname_un; %= uname(&un); %= f[1]=cons(f+1,strf(f+1,un.machine),0); %= f[1]=cons(f+1,strf(f+1,un.version),f[1]); %= f[1]=cons(f+1,strf(f+1,un.release),f[1]); %= return cons(f+1,strf(f,un.sysname),f[1]); %- } % #endif % #FILE_PTR_ins; lisp500_fn([void_load(lval_PTR_f,char_PTR_s)]):-true. %- { %= lval_r; %= FILE_PTR_oldins=ins; %= ins=fopen(s,"r"); %= if(ins) { %= do %= r=eval(f,lread(f)); %= while(r_!=8); %= fclose(ins); %= } %= ins=oldins; %- } lisp500_fn([lval_lload(lval_PTR_f)]):-true. %- { %= load(f,o2z(f[1])); %= return symi[1].sym; %- } lisp500_fn([lval_lstring_equal(lval_PTR_f)]):-true. %- { %= return string_equal(f[1],f[2])?TRUE_:0; %- } lisp500_fn([lval_leval(lval_PTR_f,lval_PTR_h)]):-true. %- { %= f[-1]=h-f>2?f[2]_:0; %= return eval(f-1,f[1]); %- } lisp500_fn([void_psym(lval_p,lval_n)]):-true. %- { %= int_i; %= if(!p) %= printf("#:"); %= else_if(p_!=pkg) { %= lval_m=car(o2a(p)[2]); %= for(i=0;i>5<256&& isgraph(x>>5)) %= printf("#\\%c",x>>5); %= else %= printf("#\\U+%d",x>>5); %= else %= printf("%d",x>>5); %= else %= printf("nil"); %= break; %= case 1: %= printf("("); %= print(car(x)); %= for(x=cdr(x);cp(x);x=cdr(x)) { %= printf("_"); %= print(car(x)); %= } %= if(x) { %= printf("."); %= print(x); %= } printf(")"); %= break; %= case 2: %= switch(o2a(x)[1]) { %= case 212: %= printf("#"); %= break; %= case 20: %= psym(o2a(x)[9],o2a(x)[2]); %= break; %= case 116: %= printf("#("); %= for(i=0;i>8;i++) { %= if(i) %= printf("_"); %= print(o2a(x)[i+2]); %= } printf(")"); %= break; %= case 180: %= printf("#"); %= break; %= default: %= if(ap(o2a(x)[1])) { %= printf("#<"); %= print(o2a(o2a(o2a(x)[1]-4)[2])[2]); %= printf(">"); %= } else{ %= printf("#("); %= for(i=0;i<=o2a(x)[0]>>8;i++) %= print(o2a(x)[i+1]); %= printf(")"); %= } %= } break; %= case 3: %= switch(o2s(x)[1]) { %= case 20: %= printf("\""); %= for(i=0;iinstead\n;[r]eturn_
from_function\n"); %= while(1) { %= lval_PTR_j; %= printf(";%d>",l); %= ex=lread(g); %= if(ex==8) %= longjmp(top_jmp,1); %= if(sp(ex)&& o2s(ex)[1]==84) { %= for(h=f,l=i=o2i(ex);i;i--) { %= if(!h[2]) %= break; %= h=o2a(h[2]); %= } %= } else_if(ap(ex)&& o2a(ex)[1]==20) { %= switch(o2z(o2a(ex)[2])[0]) { %= case 'B': %= printf(";backtrace:\n"); %= j=f; %= for(i=0;j;i++) { %= printf(";%d:",i); %= if(j[0]>>5==4) { %= print(o2a(j[5])[6]); %= printf("_"); %= print(j[4]); %= } printf("\n"); %= if(!j[2]) %= break; %= j=o2a(j[2]); %= } break; %= case 'R': %= PTR_vp=eval(g,lread(g)); %= return 1; %= case 'T': %= longjmp(top_jmp,1); %= case 'U': %= PTR_vp=eval(g,lread(g)); %= return 0; %= } %= } else %= ep(h,ex); %= } %- } lisp500_fn([lval_evca(lval_PTR_f,lval_co)]):-true. %- { %= lval_ex=car(co); %= lval_x=ex; %= int_m; %= ag: xvalues=8; %= if(cp(ex)) { %= lval_fn=8; %= if(ap(car(ex))&& o2a(car(ex))[1]==20) { %= int_i=o2a(car(ex))[7]>>3; %= if(i>11&&i<34) %= return symi[i].fun(f,cdr(ex)); %= fn=PTR_binding(f,car(ex),1,&m); %= if(m) { %= lval_PTR_g=f+1; %= for(ex=cdr(ex);ex;ex=cdr(ex)) %= PTR++g=car(ex); %= x=ex=call(f,fn,g-f-1); %= set_car(co,ex); %= goto_ag; %= }} %= st: if(fn==8) { %= if(dbgr(f,1,car(ex),&fn)) %= return fn; %= else %= goto_st; %= } ex=cdr(ex); %= ex=call(f,fn,map_eval(f,ex)); %= } else_if(ap(ex)&& o2a(ex)[1]==20) { %= ex=PTR_binding(f,ex,0,&m); %= if(m) { %= x=ex; %= set_car(co,ex); %= goto_ag; %= } %= if(ex==8) %= dbgr(f,0,x,&ex); %= } return ex==-8?o2a(x)[4]:ex; %- } lisp500_fn([int_getnws()]):-true. %- { %= int_c; %= do %= c=getc(ins); %= while(isspace(c)); %= return c; %- } lisp500_fn([lval_read_list(lval_PTR_f)]):-true. %- { %= int_c; %= NF(1)T=0; %= c=getnws(); %= if(c==')') %= return 0; %= if(c=='.') { %= lval_r=lread(g); %= getnws(); %= return r; %= } %= ungetc(c,ins); %= T=lread(g); %= return cons(g,T,read_list(g)); %- } lisp500_fn([lval_read_stri`ng_list(lval_PTR_g)]):-true. %- { %= int c=getc(ins); %= if(c=='\"') %= return 0; %= if(c=='\\') %= c=getc(ins); %= return cons(g,(c_<<5)|24,read_string_list(g)); %- } lisp500_fn([unsigned_hash(lval_s)]):-true. %- { %= unsigned_char_PTR_z=o2z(s); %= unsigned_i=0,h=0,g; %= while(i>24)^g; %= } %= return h; %- } lisp500_fn([lval_lhash(lval_PTR_f)]):-true. %- { %= return d2o(f,hash(f[1])); %- } lisp500_fn([lval_is(lval_PTR_g,lval_p,lval_s)]):-true. %- { %= int_h=hash(s)%1021; %= int_i=3; %= lval_m; %= for(;i<5;i++) { %= m=o2a(o2a(p)[i])[2+h]; %= for(;m;m=cdr(m)) { %= lval_y=car(m); %= if(string_equal(o2a(y)[2],s)) %= return o2a(y)[7]?y_:0; %= } %= } %= m=ma(g,9,20,s,0,8,8,8,-8,16,p,0); %= if(p==kwp) %= o2a(m)[4]=m; %= o2a(o2a(p)[3])[2+h]=cons(g,m,o2a(o2a(p)[3])[2+h]); %= return m; %- } lisp500_fn([lval_read_symbol(lval_PTR_g)]):-true. %- { %= int c=getc(ins); %= if(isspace(c)||c==')'||c==EOF) { %= if(c_!=EOF) %= ungetc(c,ins); %= return 0; %= } if(c>96&&c<123) %= c-=32; %= return cons(g,(c_<<5)|24,read_symbol(g)); %- } lisp500_fn([lval_list2(lval_PTR_g,int_a)]):-true. %- { %= return l2(g,symi[a].sym,lread(g)); %- } lisp500_fn([lval_lread(lval_PTR_g)]):-true. %- { %= int c=getnws(); %= if(c==EOF) %= return 8; %= if(c=='(') %= return read_list(g); %= if(c=='\"') %= return stringify(g,read_string_list(g)); %= if(c=='\'') %= return list2(g,12); %= if(c=='#') { %= c=getnws(); %= if(c=='\'') %= return list2(g,20); %= return 0; %= } if(c=='`') %= return list2(g,38); %= if(c==',') { %= c=getnws(); %= if(c=='@') %= return list2(g,40); %= ungetc(c,ins); %= return list2(g,39); %= } ungetc(c,ins); %= if(isdigit(c)) { %= double_d; %= fscanf(ins,"%lf",&d); %= return d2o(g,d); %= } if(c==':') %= getnws(); %= return is(g,c==':'?kwp:pkg,stringify(g,read_symbol(g))); %- } lisp500_fn([lval_strf(lval_PTR_f,const_char_PTR_s)]):-true. %- { %= int_j=strlen(s); %= lval_PTR_str=ms0(f,j); %= str[1]=20; %= for(j++;j;j--) %= ((char_PTR)str)[7+j]=s[j-1]; %= return s2o(str); %- } lisp500_fn([lval_mkv(lval_PTR_f)]):-true. %- { %= int_i=2; %= lval_PTR_r=ma0(f,1021); %= r[1]=116; %= while(i_<1023) %= r[i++]=0; %= return a2o(r); %- } lisp500_fn([lval_mkp(lval_PTR_f,const_char_PTR_s0,const_char_PTR_s1)]):-true. %- { %= return ma(f,6,180, %= l2(f,strf(f,s0),strf(f,s1)),mkv(f),mkv(f),0,0,0); %- } % #if_0 lisp500_fn([lval_fr(lval_PTR_o,lval_PTR_p,lval_PTR_s,lval_PTR_c,lval_PTR_b,lval_x)]):-true. %- { %= int_t; %= if(!(x &3)) %= return x; %= t=(x>>30)&3; %= x &=0x3fffffff; %= switch(t) { %= case 0: %= return sp(x)?(lval)o+x_:(lval)b+x; %= case 1: %= return c[x/4]; %= case 2: %= return s[x/4]; %= default: %= return p[x/4]; %= } %- } lisp500_fn([X_lval_fasr(lval_PTR_f,lval_PTR_p,int_pz,lval_PTR_s,lval_PTR_sp,int_sz,lval_PTR_c,int_cz,lval_PTR_v,int_vz,lval_PTR_o,int_oz,lval_PTR_PTR_rv,lval_PTR_PTR_ro)]):-true. %- { %= lval_PTR_x,PTR_y; %= int_i,l,j; %= lval_pc,nc; %= y=ma0(f,oz-2); %= memcpy(y,o,4PTR_oz); %= for(i=0;i>8; %= x[i+1]=fr(y,p,s,c,x,x[i+1]-4)+4; %= for(j=0;j ws, expression(E), ws, !, % single solution: longest input match expressions(Es). expressions([]) --> []. ws --> [W], { code_type(W, space) }, ws. ws --> []. % A number N is represented as n(N), a symbol S as s(S). expression(s(A)) --> symbol(Cs), { atom_codes(A, Cs) }. expression(n(N)) --> number(Cs), { number_codes(N, Cs) }. expression(List) --> "(", expressions(List), ")". expression([s(quote),Q]) --> "'", expression(Q). number([D|Ds]) --> digit(D), number(Ds). number([D]) --> digit(D). digit(D) --> [D], { code_type(D, digit) }. symbol([A|As]) --> [A], { memberchk(A, "+/-*><=") ; code_type(A, alpha) }, symbolr(As). symbolr([A|As]) --> [A], { memberchk(A, "+/-*><=") ; code_type(A, alnum) }, symbolr(As). symbolr([]) --> []. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Interpretation -------------- Declaratively, execution of a Lisp form is a relation between the (function and variable) binding environment before its execution and the environment after its execution. A Lisp program is a sequence of Lisp forms, and its result is the sequence of their results. The environment is represented as a pair of association lists Fs-Vs, associating function names with argument names and bodies, and variables with values. DCGs are used to implicitly thread the environment state through. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ codelist_to_forms(AsciiCodesList,FormsOut):- parsing(AsciiCodesList, Forms0), compile_all(Forms0, FormsOut),!. run(Program, Values) :- parsing(Program, Forms0), empty_assoc(E), compile_all(Forms0, Forms), writeq(seeingFormas(Forms)),nl, phrase(eval_all(Forms, Values0), [E-E], _), maplist(unfunc, Values0, Values). unfunc(s(S), S). unfunc(t, t). unfunc(n(N), N). unfunc([], []). unfunc([Q0|Qs0], [Q|Qs]) :- unfunc(Q0, Q), unfunc(Qs0, Qs). fold([], _, V, n(V)). fold([n(F)|Fs], Op, V0, V) :- E =.. [Op,V0,F], V1 is E, fold(Fs, Op, V1, V). compile_all(Fs0, Fs) :- maplist(compile, Fs0, Fs). /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - compile/2 marks (with 'user/1') calls of user-defined functions. This eliminates an otherwise defaulty representation of function calls and thus allows for first argument indexing in eval//3. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ compile(F0, F) :- ( F0 = n(_) -> F = F0 ; F0 = s(t) -> F = t ; F0 = s(nil) -> F = [] ; F0 = s(_) -> F = F0 ; F0 = [] -> F = [] ; F0 = [s(quote),Arg] -> F = [quote,Arg] ; F0 = [s(setq),s(Var),Val0] -> compile(Val0, Val), F = [setq,Var,Val] ; F0 = [s(Op)|Args0], memberchk(Op, [+,-,*,equal,if,>,<,=,progn,eval,list,car,cons, cdr,while,not]) -> compile_all(Args0, Args), F = [Op|Args] ; F0 = [s(defun),s(Name),Args0|Body0] -> compile_all(Body0, Body), maplist(arg(1), Args0, Args), F = [defun,Name,Args|Body] ; F0 = [s(Op)|Args0] -> compile_all(Args0, Args), F = [user(Op)|Args] ). eval_all([], []) --> []. eval_all([A|As], [B|Bs]) --> eval(A, B), eval_all(As, Bs). eval(n(N), n(N)) --> []. eval(t, t) --> []. eval([], []) --> []. eval(s(A), V), [Fs-Vs] --> [Fs-Vs], { get_assoc(A, Vs, V) }. eval([L|Ls], Value) --> eval(L, Ls, Value). eval(quote, [Q], Q) --> []. eval(+, As0, V) --> eval_all(As0, As), { fold(As, +, 0, V) }. eval(-, As0, V) --> eval_all(As0, [n(V0)|Vs0]), { fold(Vs0, -, V0, V) }. eval(*, As0, V) --> eval_all(As0, Vs), { fold(Vs, *, 1, V) }. eval(car, [A], C) --> eval(A, V), { V == [] -> C = [] ; V = [C|_] }. eval(cdr, [A], C) --> eval(A, V), { V == [] -> C = [] ; V = [_|C] }. eval(list, Ls0, Ls) --> eval_all(Ls0, Ls). eval(not, [A], V) --> eval(A, V0), goal_truth(V0=[], V). eval(>, [A,B], V) --> eval(A, n(V1)), eval(B, n(V2)), goal_truth(V1>V2, V). eval(<, [A,B], V) --> eval(>, [B,A], V). eval(=, [A,B], V) --> eval(A, n(V1)), eval(B, n(V2)), goal_truth(V1=:=V2, V). eval(progn, Ps, V) --> eval_all(Ps, Vs), { last(Vs, V) }. eval(eval, [A], V) --> eval(A, F0), { compile(F0, F1) }, eval(F1, V). eval(equal, [A,B], V) --> eval(A, V1), eval(B, V2), goal_truth(V1=V2, V). eval(cons, [A,B], [V0|V1]) --> eval(A, V0), eval(B, V1). eval(while, [Cond|Bs], []) --> ( eval(Cond, []) -> [] ; eval_all(Bs, _), eval(while, [Cond|Bs], _) ). eval(defun, [F,As|Body], s(F)), [Fs-Vs0] --> [Fs0-Vs0], { put_assoc(F, Fs0, As-Body, Fs) }. eval(user(F), As0, V), [Fs-Vs] --> eval_all(As0, As1), [Fs-Vs], { empty_assoc(E), get_assoc(F, Fs, As-Body), bind_arguments(As, As1, E, Bindings), phrase(eval_all(Body, Results), [Fs-Bindings], _), last(Results, V) }. eval(setq, [Var,V0], V), [Fs0-Vs] --> eval(V0, V), [Fs0-Vs0], { put_assoc(Var, Vs0, V, Vs) }. eval(if, [Cond,Then|Else], Value) --> ( eval(Cond, []) -> eval_all(Else, Values), { last(Values, Value) } ; eval(Then, Value) ). :- meta_predicate user:goal_truth(0,*,*,*). goal_truth(Goal, T) --> { Goal -> T = t ; T = [] }. bind_arguments([], [], Bs, Bs). bind_arguments([A|As], [V|Vs], Bs0, Bs) :- put_assoc(A, Bs0, V, Bs1), bind_arguments(As, Vs, Bs1, Bs). run(S):-'format'('~n~s~n',[S]),run(S,V),writeq(V). if_script_file_time(X):-if_startup_script(time(X)). % Append: :- if_script_file_time(run(" (defun append (x y) (if x (cons (car x) (append (cdr x) y)) y)) (append '(a b) '(3 4 5))")). %@ V = [append, [a, b, 3, 4, 5]]. % Fibonacci, naive version: :- if_script_file_time(run(" (defun fib (n) (if (= 0 n) 0 (if (= 1 n) 1 (+ (fib (- n 1)) (fib (- n 2)))))) (fib 24)")). %@ % 14,255,802 inferences, 3.71 CPU in 3.87 seconds (96% CPU, 3842534 Lips) %@ V = [fib, 46368]. % Fibonacci, accumulating version: :- if_script_file_time(run(" (defun fib (n) (if (= 0 n) 0 (fib1 0 1 1 n))) (defun fib1 (f1 f2 i to) (if (= i to) f2 (fib1 f2 (+ f1 f2) (+ i 1) to))) (fib 250)")). %@ % 39,882 inferences, 0.010 CPU in 0.013 seconds (80% CPU, 3988200 Lips) %@ V = [fib, fib1, 7896325826131730509282738943634332893686268675876375]. % Fibonacci, iterative version: :- if_script_file_time(run(" (defun fib (n) (setq f (cons 0 1)) (setq i 0) (while (< i n) (setq f (cons (cdr f) (+ (car f) (cdr f)))) (setq i (+ i 1))) (car f)) (fib 350)")). %@ % 34,233 inferences, 0.010 CPU in 0.010 seconds (98% CPU, 3423300 Lips) %@ V = [fib, 6254449428820551641549772190170184190608177514674331726439961915653414425]. % Higher-order programming and eval: :- if_startup_script(run(" (defun map (f xs) (if xs (cons (eval (list f (car xs))) (map f (cdr xs))) ())) (defun plus1 (x) (+ 1 x)) (map 'plus1 '(1 2 3)) " )). %@ V = [map, plus1, [2, 3, 4]].