From 1be68291731ed286043bb18ec0062cc2205e77df Mon Sep 17 00:00:00 2001 From: hellerve Date: Wed, 8 Mar 2017 21:55:02 +0100 Subject: [PATCH] initial release --- README.md | 4 + examples/1.png | Bin 0 -> 43294 bytes out.png | Bin 28150 -> 0 bytes quicklisp.lisp | 1757 ------------------------------------------ t.lisp => shinu.lisp | 16 +- 5 files changed, 13 insertions(+), 1764 deletions(-) create mode 100644 README.md create mode 100644 examples/1.png delete mode 100644 out.png delete mode 100644 quicklisp.lisp rename t.lisp => shinu.lisp (75%) diff --git a/README.md b/README.md new file mode 100644 index 0000000..8204207 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# shinu + +Playing around with [snek](https://github.com/inconvergent/snek). +Not much going on here yet. diff --git a/examples/1.png b/examples/1.png new file mode 100644 index 0000000000000000000000000000000000000000..3892ab4c3a4b60cd0616bbb8276b2d7df8278c3b GIT binary patch literal 43294 zcmdSCX;@Qd*C?!_L?jRph0PSeD59m9pduikh$g5}M0^xm)C|-*pcRZtQ$aD9Fl?sc zqp^+{i&CuuPDme>kPu?kN(2=Z2Zq`xic*78D06A79%?cd0oVxw2*E*IB%qJH4pggJh#6 z%Z6f~HiQRs|Bt|)a%p+hqe*+tfBkm+g?W`ORJYsREf7NF)rmM9ht&?)h z+jZa>;gWUl-1$m1n>klZTC%;q*luj*0!w$(+)9PZ!ua!oAT2_zk;^-~kJXFfdB|mp zkW=r8fsf|az8aERKT@PpuFL*QW@dbIA!b>7e26|f#$0NwdLXm@hk=8ui(l`$5yQU# zfEC={nC-+QE6ABTyICrhjrdFF6j=>9D4}#k@~yuPO~=B_Yqpz9P0Z`6}nscyN}hegD)!A#M~f8|6;c9v1=@L zWJdpy(WtTkRLxy~sZ1_hf53F#5jJvYhEr=V*Sw;|4JL6V-0g9CRC@fGYU?m}_i4xo{Nmh5+^k;0$Cx|9 zvAXzYn$tsC$=^G}oP?^s`l(swAR7_aGz;ieD+PMLnkW8#>&-_>%#(kbkp!7kNg?#Cjw2^-0Snu;2^y4wQ%z)&Wq8%FW1ja-Jet+Z^gK78Q6=@C2tpPxczMNv|^`}z>$3l0#=x*F9Rw< zNR&%|WIu}U7uYge*$9yKebCL~@EelWh=`RJNySHI#stLIKI`LQPGpk)x_eqfH{5sa zbi8-fQE!_)Dz!(OlC}jnJqn`EkUrc>8Qd#kWwxLwN~lFI^>prwB+-|Tl1F|j)9g~` z?CO&`>G}!+BmDE!(}AKo{dEl$LPdzV?BQnR>tFhH4LiMP^jo!__J#wiwhnJaY?p#I z);VmptB3B4pB$r;$wIqij1?23cS6UdzpY@)xsX_Ig zu!S1;-Nt?r`rlm4QF7@I9e~4PZ}kAqXnm$o8=iZ6lz7wy1LSQ*E`L7lPM_GqR4CZB zDw>-r!E&3# zi#myyou`fL(@Cdk{Jbpl++$mHO&7$Gydlg=(Oy1$?6f<&L#0_3Hm5e~4vmjzcW}4A z_KNJ>Ft*RHfn)62p*M=!SpOtZ`p1j`!|+b)Oy4NWSfUHuw}!w?RXs95NunWC}MX z)!r|Un>*e%;@CD=WkSZ;aMW2={%@-RCvvxFT)$rWaDxOBQ^%?NSwc4F_tpZ+oJ0=} z@6%3d=?_VA^+ppmZ>qq;Ca#gyO1SB)$Dtwiq_(XVJ|ATAnHmovCK#=xN;7-s#$1Mv ziBNSnJ56;4PQ~Z*nlQ!eX5G;d3dq_`4TLIj?sY6|raisdpxc zcsu&@&%SBHp#~B; zH>>Ev1s2DZKPm(h580ficmP23W?xK(a&Yo(8v=WMJfaR9-0e2MA>=^p6lf%BD=6kf)_o0Z}r()_|(CK;4Mk z`w-k>-aS#d(oB!Fdp(-Zgl#*rJ43V-qNc_jbM8Y$KM&QXuoGOGu2y+~r9kpW53cF| zQ~$arxlM_dXa+NjGZY&(k~qK6aL-wwnhsLqb`Y+-F=-}caE4<8UFi$OcmwZH`7Ud< zA(BCCO|qZ%MEZN945oY#Wp{>RdtYcroWH$y8j+ulyF&{`>lm|IreR?4UqJIz>02#5 zCXA5PbaiChr?sQNNG(WXr^e_>t)3sWt!Ul0SuJ7OspcSG4$)UXJ-b64B_DpI(}uuI z*UJj!Q*d@J5l=zuPRwfgT07HqWN)^fDclR*+{~QLe<>4w4hIo9euQk~Z5(pR;`~aD zb1}d2boWh{Q~*RKK{oOh{x}+cmAOKc>h_K?1_0k!RycIB{@z-9Yz6nhk`EWEI$6rU zwVE`N8n??{AN1XjW;&x!p3ZtBkhW7s!)bGlW&cl@YoCs_wq+2tKg1CKRpY``&p zb>VFMGhRi$JVJCAKKWYETEynm5dYPyE4A>{0WNbhdN!_KVr`FUsBIFNlda)A(V2L7B_rtBZ-h^_30iY1ii$*zKvjkdYv;}PqrW-e z_D=OciL7v1VG(pWPuOdP_sfrNn6AxiZM&8IJFCkVq1!Q*3Bop>tPg%1e8SXp4u~Hd z3?@~myCz2mdHM0CDjRCs)o~#fy?*8Zz*=ydPt?Es#VuV>OAYdN+*h|qE-MvSrk^(4 zg%&UZ6K?Y<>*^gLEq}1N+(yz=W55kKDi(iqEOyWYxp=!M$Z7GlKuXqA^?9oY)|NMkYHhWHjj)OMm`QOeEG|j;bEWC}xc>E8Ws1A3nT&VgGA< zC;Oa80N7wXpY^bK(JG650ZgYAWO?O}gyfvx0mp~)`oanWcD>82?JgFd zkB*I6SICa(n5kLR=V2S-%p^_K$y09E;=)mpZ>b=UFh(}(i=&9uqBAb5pD!wt<>T{S{2J~$O>5Pyoo&vdA>}!nBV;fs-O}F&CHwWxu4m&ANQ(R4 zNX`Si?JSL|bLKR(Zk6O;Pc80Eax$uO<0ILckM)bBvWo)Ca&-=_kstqzcKRBSljG?y z-BD6j*J|Z+ z*K^$`5t|yokSi^``e2a^Gh}2XV}^e@bWFN+IW@4ITKWZ|AA9M6y?6dspN8N2mW9RJ1XY<9nZ_`o+*pVO-tlR$Z#pb6*nT15InR+|1_8VB&>bbh6L$%?UB z5cZD~=IsWZdLDD;9k`m|eQeTAXFU`J@w96e3Q^k&bt=G^SEkI-yZq_{_*<|-9Z^#A zZIz9d%8k%L>$5U-*Hpyi-ag5A40zTQMtAOvAtxqPsuQqrS>5C8DGdE|f*#7@JY>)7 zU@5zN`Iu@N#L}d=ME31TcTU7!@}XY68_r;otgby&%aX_7?d!c`+KyL1!FE+nuXm!RCwQZmgcAEe#;A0-)o z7#A2d5F(*|fnCa2Db%UGx>a{ept>O1ir&L$K@R9~z_G8wnfAiA3)!73HDy3~?43C_ zckn2W^OB{xYWFkdDkE%-k?7}k^vNH`rUDz2CZmUs_Q6RjwY++S`L8tok#tOx1QBWc zUHCg9)8Blf8VSrInm`X*f~(5rg4Xkl4!VGCNX%_Y#tX|(%pxRV$xp7$dLH2jlQD+V z7qW0COO>g+CiYA=l-)GjM^EDQ{18*=Zz9~@6=ZeM~>KHP)L&^du#PUg`p5)d7O1z&Bu{(GtwSv$I+;94S3d;6kYpRB>gJr z^rzX7cmR2UzJO_`it{oF+u&9cu5aba*PD4hTBwb(+09PfG%CVQBAPs0a%vzak%)@> zL5z*E2uy4-XmgRk@R8}NTS;u*7Rq3WXfWLP4BQXNQ*m#psFfX812&u{oas$pcn~bm zm2iLJf@KUy({j4ZWy%KSx`Dd1ofi18O1;(fU2qH!oqsS=dzxr&Wcl$a)?>KQlg-$1 znkq+GU5bU|)WG`;k~49AwdB$p_V&1LZ)!O4hNsDHg1~VgbdR%RUdQujRxZnlitz;O zc&#bYLL#2IDQ88_*tKZKkmY2#yB&-Wi8C7+6)(Cr?DCEfOYPEw zK?Cq{GyuUwac`AdjVP&Yvl2`8bIUCFx7Eoc_Qv2!^~;&a3cNcDk~^{aQudu4Np0J@ zze!Ws3;}AA5a`=v9%MzYa_JLg*1P7uZg%~U(>;2pisHOK%be1DVjTU_Hk>_)Ox!PA z6V!!`!SF?xK+lSqM|Inr^LwgP-GK*^687TGAZlA-qKzL0lHs(tv818&Z6sW-$Z7~j z%U~$*rS=Lt8u8nOH|Z#n1+n?I+lM!y7+8XZIg|m%(n7tetnj0g_W~@qO7bSA*Wsa} zB7`98*sPqQr7I=XGY)^j&(XTGf}*)t5D{Ci4>Yc2dQ>=+3ZVdz0#zrcwqtc+kfU~= z`ADD}{(+q7Z$#|oebSEgC74J=xSF9m4^jt;Lzp>&z-`{lZWc&u>M;w{TBx!y2xRo? zZ|cR5wiiFzF`c!G=OKZ4xQn}6`G@nL2e%FCXX;{GS3TB1Q(!eLX{3)2NNaqBfH8`M67q#kC)8;&zy8 zfyg+m4sEo{qGzL@l17?^+lNOIlNS=!1D40HHIld{mK)YlEJJGyN+ zaIElsiCUUpf=AQGZsMv(0;RY-t;o9mdcNC-ib4z%!vVVkcp5_@tyNr?I6CecQA;ka zz5b;{yjPEh<4ZX6I+iIDrtmP9a|7!VcTIQah=Lhnmo?!6x&dXDM~K zffUdmiD_jweRR5*_!!POoTCYK!gc7rBQ|H{JeowQIpGL;gocun^fuo6s)s8 zeMlUEtqqrr*?-m^NeF+(McI=t;Sy~ z#=Bo6`ND`nDA^2m1Yr{WO=V76>TB~%*fOBZFe|Z}s-zH)iar1GKAh_Xs-oZqsaxMF z+B@E?fXIzxm6?_eI}kDz0oX~XM*&-BjI_k)9&wmAX- zd1dOs_-11}YkOA^r*pUKRBS&ijX^b8FSC@;rgp~3#lsd)#-giq5`LzD%rW{5ei-{DYzl(S29*?PJsVeZ*L`SXJqIX4Fx;fO(69Gzy-2PqYwy@x z)6y)x2^s^3#+VB+vI8{6Exj3D^FS_A02L zf{brLf?#<~JcZgCH(d)-q~kghu`NK*TsPeMs}9smut3!yDt|1lk^@*eYX+C8bMP04 zX2&GRK;=TlWQy(r{UWOvn|>#iKO2Ag4)OOvPyca5K)h?m25b{@bq=l{6VGa$`Tnj} zIt5z~l3+D*hE%NGPBa#Na4kEUGV>1uj$vc=K9n>#k!C-Q(fZl^vAA|*{v>kB)d&A5 zyGv+4CS1lAQWS>HT5YgU57-|f%Ur&Jby8>^yRsh`a)I_6(Im{%8jOdjnqy+Tr zwQ2t}qT0pg(F_TF#>RhwD>MBx3J?Jsn?Q z`f!(uf_q)ss_ePK!2dIC3-$BPsG2F?VLPSrkK+@pFEbr$3AL=d9O*QGCb}3B*?jxuSx*mF25{ zoB81>@HePed`%|iF&BOsv7F@AW%783R!?Dy5eG4ly3Aj--nDa8&G~JxI|@p!!e=jX z?!#4*uRj6NE;K>OO3Cl>=?{Bj0s6i|kD{cxVS?J5PQo|IHE>^NKecm>M*Rk`U4W`g zaA#?)f~y*T{`+@u+9h&zQh%*NwXGItS`wq!MEvq;&blL+OEEI^|2LIihMO&$KS>Cw zt(|LXJJ#3Muw}_j+8cr;07Wdre*k>MrQ$tT?R+lOsIP_pbi@kePj0Hp1V6I&R<3zz z0yf%Qxq7fK-emEkB;2@;EYLk8sr+Yn;>CkZMlRnLo&ChPakUnE2y?J0VZ{&llB-gm=?t$CXLP2 z_1{x!NKPjc8&V)8h=3bCYmkbrzrJRDhw;0)^~#$A8>EH8>ATpclSAtNGP|ihB3Gt38@DK4~|godw!vrP_*Cg)pWI*jKjEq z!~f6<5`x!#aK1kEo5*cds=$8U=;sVcJoM*CB%@iLnLkfTS%8jYp8mGIM%t8pm-xui z|E2(gJE!68nyUtP8nR)OOB)D39h#qcMRrDz*&@YYN!u9k!`BAHv`D7j5Q*%dp5HKc zi%Bux>O06$W|Os-O^ub3Zw=H=wN37$_s5sGlqSx4ZoS^6=w)by>=;a6pq<{Gd~2Ek zAslZ^T0@{bO1+gRMpDS%Lr&K1MWeCf-K6rL42G&HgYi(i!;JZE-@&akw?O5eB{d_x zxk^Zy4%8ZJaF_R&sXfkx)JgW@hZm?9+BJ)A1aO)*wFbv4c~vTBZ6>MFk4m_lhtj6= z|6Y6dDp}*q;}Nt_52x`DWA`Zo#K{@xkAeOsEU;gL-uj$c6#O8Vu~i#jfXm9;Ayo8? zek~tJQE4XOC+GQTSCVTuxePlj!=JE%;QYK$3#(Qn&?O0~#|F?iq(EKX@J-X!>1f~@ zNZ7U1-oE7u8Sf15if@V!ZhblP;)b>CX+e|OaVAe-L)vJaI3VDM69#DZP-LZU_^i5g zLB__Q6q3y39t_sH;bL!Q_~8KtN(u+etk(TWo{Y>Da&g9KVT&_Q-0Rb&>BEK=#GL2y z{SWKde;yZ`$=WrpH`wO{8)5uzL)>Zs%&^VhcEsvH!k&`BM^;9~QDb=y3i@-Id=2dX z;-+3NO<$JhkCJu#P}^}(aCuVNt;fokA9z)4VfSnUq`pS6M>D_Z#T>hk=eg_bn1Mc% zPd*G5+2dywkBTste3*9q^^V0ioEFpEzGM9v4V-9!!Q&{E{{v3Uhsc~aW2Zxc>EhS2 zAIbZCrI!AsLcpPDBzb|%@VunYnLqmkOugw=LFClzs&PFP@?5ayKL8ml^h=md5Bo)l zxM!X2E{rSJJqf{r%-pbrQ#b4MckGwL3mAJ{4#91+U`XzPd)d_!X~>G+-ab9502453 zR+CTQ#rJ_;-^Q#f$e4S9blkK%g?J}7?v4YKRD}E0sA?O@hxt{VpSkkEN=$o^rmD7s zcroKN-%4@9cI-3*WWy#S14cc1uHNW=DQj@GV4(yvz&xNlB`l&wp8P6!??A_pw30cm z^N_>q1aacLThiTT`^~>+Y?FZho6Gy$!vA5>si3V@M;&bedqWuC-Mksl<(ad6VVH>TrZR+)Zhg7Q91#ge( zU~_7lLZ!-%;21=hDwRW>&C5-&-VX-rQTx2^3FYk_*QtInQ=s=t4vmR90|P+?SgCrJ zcgLmT_k~dj>!LWym#tp0jC)4x3({D{-LQ(gqTQ)(H}X!&@=3zrxZ0-H)Vv$@4U}|f z(t_PD;4Cs0^5^YeJa{Aj%8s_t_3k0pHYNXUQO;k+#`7v`S~lO2kkZedMHe_NC+6D; z*$qnZt3b73H8||Qn<3Yx#%2mpmRlYIb>wAQ9{+U}8#!*Zf+)0j)2oF%?0MOBZPp7d$>Sv+gSdlNq6ott~X{5bgtIodDkC99#NX7PFXp(Vs~ zJSvBG>3gVf9Uw5ZVA@WLn_;D(=jZ&M^Ly0;b^L6QC65_i^l5$9!@6RP77Ow5w8LGV zi(l<3n3K=ON_(B)YoNXOP+nC5+muK-FlPa}5x-{fPbw|Jb6uNk(|!{h#tBtLVJf## zR_p3;$fA+d0aD2xRFb6&{r>#V(2Z|&*X@-voR`m}_ulNfJnZp;+PdK*DaS44F6TiH zUIEAk`a|Xe32nhdTOT6(WQ`d4@>6PU&}gRfxCH7fe(;}EVx#1Sv|WiT5A>Outg-kB z*5_{*FKN@1DH9DW6D>*Qp%Y#-E;_Yi_WaFN6)8pL$4&Ds5AelMc$MyUO2Fp%l|pQO zx^UP_oQ;#FF@Fxay+}P>T9@)_sg>j7*CleOjD)+~*_0dMKLQ`RA+{%bDOY#*-_!V? zhC8|lK@mGN#*ujP4nETJG}4Yqy=c*rI0s&)PHYM1dSE8z_oR& zc6{8R9%9wsCN%E3@QrXmU@?Mb+=$Bd^%tg6pkiD7rz_?g&O`iIMwVeRKUrRxlyVa) zOi#^OD)1C~T7rYmo5+d8Ux@q#a_>aQn@8;C<|H`_*`MVlvfxfO!9r+DVQ_}NpP|oF4u;AW&;T&ULq=@YP;|@{X_+)m>pUUmL zSR@c!#4)DB@Gn}1LTG6uZR^OzCb^aQmdlB9A$(Q>RqP0OVi6Ey1pE2PK(CQWcCXnn zCV$7A+d+uZYZkKHxp*ay7-142y6J*_XCz|FsT0=(jk?eorF?Gf?dYDxll z%biwy&P>FPMKs61kWR7maHFl`&U;n%$LeT5D@S{7uBa%7R{RBaU3Ov&-4b8!HnG3> zaF+F)dyX(xNRrjKRztx+5RYg>P-$_tXeX`@OO8Um+>rqlgiH%J2YZ41ZE7PHQ=Q1h zkE!Me*$I^G31c}OVajzW;b9Ym4+cZmEI5>@ON+6cF41RnU>^>QgKk=SgW_aW7k>tc4`z)Zj+;<%i6z(MTmzr;?=`2XupeX6Fj3LM?VTy`=nT*}$YqAU$RvbKWZReA@$Hc*MM{0yCnJ4W+P9 ziA3w>5hG<%;*VWpW8Npp3&EiVxl9w2*RiADu{m0~5_x<;u&M^L0Zft#RA*;RGr4?C zcvIL4oz#dC1R0gagOy_ol2Rq_R9KJ-wAE2O$c}~F|JmnXg-LJHFPhjn+Dp;}?MmK|mX{=zcbN|9n;pCB~j zjBqh}3%h9jH`N1oy-^|5AG^lJX(Y{3EP3r*5!f}+ZB!o`l7ASPtPO}Bor$lb9nn)y zcR!gFvP|TenUQhY^biSfQ!Af|?DL(V)zHMWY&;gL&_Mnj7c%u?{&Yn>MQ1D(VDTnnnaH9s*Muz&NO3=IYcHsQxM)EN8}~|% zGML1hF??SaHFkT8$@M%g?_02#krkg8^D!eoh`1Q;QjD1hq_3E#u3C6)F4*8w{H?1G zQF6oWT@L7@9GVZ*X|n+-SXxkowQPtBeu{}ZiSnVSszO!4Lfl0QCFhD-LE&3M`IzMq z|5@E|N*@l*Zw4MaWN>b^2wKEgm)EpVq&Gu+?Bw)I1b0&##$LwPTyQT+YL1->v1Qm% zux@8yOby?O-#uXzaP08Qq&Xwp|3zX3g8q+<{sCczeja*w)VpqDikOaHgL0fbD`BEI zz%OA^HksE&g;o{I(#>Tx){?zgvMZP!nYejcp5i+nf1UY$TgvNitWQ}w3SS8J2allp znAo}Bdxa4r%`=WpTZm`2`_ir^j`s44X=tx0$0`;Vj-cP0Uw{RfCvq3z-e!i%o8G5p zw^^?@4F$Dn3r5jh0J7>hE1Qha_ffEH?gFSf!_C!z%O}WQEJe-)+53RSj9`5Ys@6t{ z7k`Td;v?(@LvZisX^G5@pUkej*$tgQpr0<{o#AB(jt#V;ZL^Z>!xCRlcnjy;!x7n} zEdezhz9k)BmB@n;cS0`Xd9~wY*5(=ycNbYXzE;^n%L}q&k`MSt`|&VW*acb^E}UR` z`>4z_|KH;%78KDRI16QQ{-njZq}L|e(ZCB`?zG&wl+O#AO8a%>HZf(*+WOEkWj&sY zFBnbQ_t8A>Bgl_pf8>DGk?b$lu}^SPOP3(#ImtE0xMFb3BDd5i z-rDncmB-#e3K?R%6;ImUfr`yg^>gU(8Do`U&W&J%lKkEO73hV=rcFn)PH{WBGT&%*yEX!zD7^E z%wG5@C7T=#y?CJ`2h-A-aw=HS-lWb5e}9z1%^q8d45zFoSJcw@;sM$XV|RCFS;sQ< z6mPmMxNLXJ9 zi3)B1YDRwMpd)Js~zwHSgF%Z50;|{R69a-*D#9xzi{ctdW zojsW9Ak6ulK1TQ#UWqfokvuWMHYUN77gUTu^OOasub1Cq>NtK5ZH_Y!p-&r?Y<8W* zKwtfVtA>W7XKyEaGUk06vBDW8O*V0%FJq*Hk(mF6%5vhlK?iC#RVWj2O&~0%c0qE- zBI>sgS`)OxDWN92DZ66R3+Lg?bCv*l&vJJkCtC50fkGWfkwTr2;4c0mI?xpq`wAz8 zLNPwMs9^kE;ymgDXI}Pd9*xHgwYX_5Gm~`2;%WLZ`Kvz-KeAkzKm!lO$+>ZH*znw+ z4v%790A}MTkq5I7cls?BbY8<(+(Gn~^={RW{vM0Pox&`I0HvY%e~sL>9cdcGga3L} zm87Vx+wJLNpp?234|7x537$=fw%Fd?MK{OW=AO#B7e8~l+7)ea<$Vh(f-wng$;5?u z6Qor~QZJ~dpc$T-=_IVR;38~$%5si~_7nShJFc*Rdo%)<^i@E^ z-V#|rrWc-55FGJL6k0|D$Kkk@A6K+|U zb4&3RiRrXF5M%fQL6~hB_%`K0PZ#-KIP`>8nJb7dqmHH5mjmMXGq(eWKTsoMMPZ3l zZCo9P$T&Z77JY5w=;-KTFK7zQ5w#Yja&ui?Vf79MB-OpIiAc?Lz#@2{j9yvzdsT%9 z>tBY4p_i{Nm-WU1Jo4>Lw*;svW`dGC;E;`!g10~4Nf>**zIt+%(FHlgm#kyyQmPlg z9BY>TEv8ympvY7~U$0O@Ttzqw{0}Op_zSnpQ&j{b%Pk$jp=gGNNyZM9kJS7nR|s1n z>*wYAhzr=SZ|Ci;Wacsn8(8peYb zjA$0gMzZ>(QB?oHT6DtZ0N4xOE-NgTqX;weu(YrHuHgot=brOIaK|m-hE%rO>^g40b zDcgcnzh~2m{UJ7#74~`)R_vO&D$!c<8$#rT<>CEFHaS4jQsgAJD?TM=LG8Ke7ThM{D%A~uUTTnNNMcYP>H)dg?x z?*8d=QdQGWDPhZ-jCZiggdtQkY-9hM35LQuSfHBzv+)LcSnH$HnSITI2M7ueDqpmv zzt`@6cXogD$+ymC#tzPi2 zT$wz*|51bPkNSD!C}8|SfA4yOJ*0_-(%)2B_BH$;0Gntk|HM{bZ2=9A_-=3m$X}54 zb>!|}w%gMn`JqoPJ6jro4X;unjv_YSJoZjxVnl#@kmHamo2NTLAO+XKYR#6bo$K=Y z8uSi09<)zrvi!;zj|D{2_~W;E7!z3yZdt17zl0c-^rYqJlk3h#1$(@btNE=3>q%pX z`fenJkR{u;g6{fglcM198=|Ef%Yb<+ zl2MTw&_Lz?5s$T`!A~i-PFGF8Zi2P)z@MFFCD|r^fz`a@|9y(-mQ2-OCRo1}7yxg0 z7!s~WJ|fw6bgl6jXoJxw`}2nx1y6-9^<*RZ+lkS}M?|wUmOeikAy3#=?#|#tYomQG z7$rXscN2mCU1iKXh%Vw2s7L-7`kQ!dB`iK5Xrrkob2Ap8-Bs&7V*>Q6#$2U^meYJ_ z+B(nyaMJQ6B-3yEHOKfa$b*dXKpMf?ID`aPByoVu>9+TRjoJi^Rwx}dLe-LZs{ur{ zsPArG^bgn)4EmqgOMi@HxN)?ThZ-ju(hyuwlbkUUr{XArUW^We%m1ytWMPISVemho z{eK(OzQ!0H8be{_$=am{64d|CaEstp^~^M?C&L5&&l1!BMFjTqZGC_EMk`}Tmbird zKeCrT0ntM`|EGAxTGUUA#@(U+t~~pHjBf{bBeMM;)Wd&Yp8Y?Dc6O==YZ+)ffd2K<`YHVXgBU_p!8_VM8@wC8cnk8jA2u3mVhb9d zwTa;Dv)&SNJ@WC(L1DY+D~YxKO;lP`oD#pH4{W1|%z9^DQ|2@uh&K?qHa%^GtOqnw z$)6~k6f0tjhZZADr~O!%1UIk_Voe;67R#L>h6k4sFJ~HGSQx%AmeInKL92Epl8>7M zhxx!w+=KT|=WQ!vZ=VGhqa&H0Z^jE~gNvEBOFF+!HLM8B{>b=^4oTYCG_Tk%IQ&O= z!9vUyO~ZEZMtKY#DO(;0*RF&IsG+;li)jj#PH+~gMmLn#*1$bK#Bqwr17F+e6Yq;E zKx;#+XLSs6fWMv7-cI%LSB%%$2j>TEadeN9Uu^|ZdxkK@ouw#E147Ae}RsqN+H`uz!v*5ExZ-^ru)9&5v$WJY`(ADef_S^db)A1-1G@8 zM`hGfsr*-Ilj?!`<=a-(1372$T_dc1zI;hD+^X>A&qNM5LCYjaz@tTNhrDbd8%q+3 zg8L#PhWJ$40)Mp{dAt}dI6n7Epkf(y5YxS%KA%*q_mrH@_FSnewBJ}my1?o&)#{ii zPHjyYHFQA!d^f6~VP&?ZzZcr#JC9ntAHWP@*%RG)T?*VNP(WHiD&b#*Ly>5U8RU%# zPKzSZ`7>fB2_GD}`rv;3it}daL{!z$|;zJ^(B(=h|&B&39urBVgY+jg6 zxw-@1O0k6G2bl)1vIJ;5`E82&C|oBGPBQ0K3o^3cG6Qa%20CsSS6PvZoOv87p9N(B zzQug86RI^K2I4FgE4mp&m4c>*;}#e~NfY?-#>=h9 z701EvfF_`P*1%mbTCE@%TAMDUfEpzO(DukuP7E0R&?J?NpU=UdVb1gk8{sftf4o~L znA8+A5RDf20VJV@AG%cGcB%m8gJNcT2?M|7WH=E^t~6fEoED7Ke2tYuL)Epha_I8H z#74+iS%?GaN*QTF4XAiA_qp4BYU50C+}*bdMw-N5>r2wJ19W zx2sQlJ1cSr>B>_=v-$S|fHqX$8+n)^p52t_f@MHMOK+GEIxDO<3=C>X|E)}&Ff$G; zt3yJ>)~_&BtC9rz?mK`m#F6r$la&y}qhU?vV65K|Tq1+)+*4Tun-jJevZ3nqi5~cS ze@K&3U!0THly$^+H(g~nDRHVh0A(6#+|x`l20RMtv>#Uph)n4%mC}xFSo^BavAxle zKo0)ig3!8eLcXrXdLph(X6N9RDaOC$M0HJT`sjQGo6FSbTmkeq=ddK}BTiUv$V0y( zw*A|Kw{mnuY#~dN=oq(S<56r}nz3fOBr>u2T;7NJ?7vK~kkOLz!ccsH+D<+FRQMz- zjuFlo z6L(yH6o=O{x4?$md_ONe2{Oa9t%!#c)AryBY#E{PWwYCdVetN`FV^G{3NSPA8w1Hq z8ehJX%HjTgYI4o@Sc5lTs^?pLdRawm{={x3jQK!<`+CkEtZTG`a1MTh+WM@bHWO8+ zsH7eG$vX2qgv0QAvOy~gRcH43GRjp!CfP`Ak#;7C!X)m`x5boD?@)g>}#EEdVZpr1!Le2;*-{B^`1E{i*D_LoE+ve

dBqXTnQ1OQVBOiwF^1pPPOK#ew^AX-yJOWp7VdDt6*OwY76`CZ)kW zdCu$s1?W8h&W0X~my}%`EYAv`11pxu+dD3obd1w5|glqVoT%YP(BvU4= zSln@CO7l_4m&pro-w=Z}enT!pXO&gVedAixdyNpQ1i@a^!eBD7Z~9(s5FYS~dipl; z*o!-m3KLB*V!go()&GG*)%Smvrc1=%)6QJ=z6Hjttr57u1hS6Xu0Oa#-Rlh_UJax{ z^=z{jRyu10?<|0_$V-qgV`K|y;j~-tj|!-zUm2k>4@Kr$DE7S6pQGn)uTK=N%xZg{ z75$Qt+DmeUIG$&k;PWczSZ^$#UzF=@d8qg&C?AsPLP+N*;Y_FedB6;dV(?Qn;4?+W z+N%WTWYy>R>HrFuC+4q(DT<9S$tZ5+lovoZ_;w69+<(XOQakk^$tv%InfMZDtbxTNPdyVS> zBZhf|3Dl()JPc;|#8X+k4>^LITf2(zAq(|&X;5TtYH5qMEQCiK|LQxD9y8LW(jWth zCxBARfS+kM6W4K~o>S8GNuf{B?_vFP>nPU-y2M`G=1ML7ZXoTB)sCeh5gSPUrPA|q z^;Xg-`ZhekL6+E)PttoXyHYdW|65tP#$XiFH>P?3sOm(^r&8fbAPdFSA2 zybv_VV0A-?y`qb-AksVI(1~R469u17775|b$EA8{(WhRn+A7mDiPCFO(r7qyv zGaVGRnM#h#jMP5zLwzzkDeX7RbfmH(OPwl0Ot|UO#K_N7pXu6!)t583M*WqdAg z8uk_{vwx;^)s2tXOqS)fO*s{G+7_DU_8ggmg6xIadC&<9Yt>S1A~_)o58%=Gb>Hu5 z-5+xLfqJ#;JFv#C^fHQQ8vU#ZeF)h?kR(&qXE+hG*)1=URVGlH%K3t;nc|x!@>1Ad z!ZHAtPx7WO6QO1WN!M-C+5GHVeO;oU{L`6w=j|HbDm#j3vj2Ck)C;dMpQNX0S4~;% z9ox84$BGaaN#*C>F3yzZ5Jhc`+c|)=10;UYiu>NlrI<+WV~%3AgX9D}#4sB&*1%1k zOwSq=g&g@}@lE>*in;900}pZ#vaGIL9(x@MV!qwZ-;`>To^wmsFDIPPm3C$Az)R3V zQC@gncvz8L@nUzuS8u>A$b?omMeL}TIe)3+U?~CB^D){`pOu>NE-BQJ+R575FB)9Y zsAZrcnV$oLW>-6)fmY(hogfQ&(9k6dN~w0i>d_ddv5~z&bm&ueT<%x&@?-}4eZOi} zB3G^gq`)fMtH`ddo5_x8nYnd*sc&g*&t9-+XQ455a6ZsAT~Rn?GS;wc+*QKF6=kn> zU+yoOg0N#7)>x=Uu6{w>Kf?++aNzA_b9ZQDc!HuBZ3Z#9FRZYK=UW@=(VXg=Fw!JL zRo$P*jhajDyTO4Y(u#hh@n{?xmeX45=NbgHr!s2jb|9RuQ74SfET8}oI~Cq6%n|gn z%Rnl++euFRj7jrdt>BkKl_9jWh6H@jWxG|~i>K-?&NQQ+#X4}f52Ku*z_T>mxSOUg zq)_J#S4hF&Fq8H}u$UJ21?I71%rtx9iC!XQ(8eK`55phCOVCMyc{i*Du`eihqoTJc z`PxftD~`6%2WILxL2x1;ZQfWGy&|pl9r` z)HJNWqr>pVkuDW7QsaCR7)YX{hnMz>H()1@#(%i>m_g|0&Tf$UC|B=>3RI{Lz!D8f z-oP>>ZTU|TS!hn<37-2_Psq{cZXM@<5gi%F!1O^5Vq6jXq_E#-g!n$=?! zKpn0!b&hE{7Vmposay;F9XX4sfmF|oF()3td_8+{rNsrpQwB6I^zcd+NT~cwCv>Cj za7sGm)G+NN;1ACN#X=ZKqEEA65a-)rhgnLTe?s{}=N;fsGzwm`4M$0m6Lw9!WDClv zaib*%hLvmk?gKoa*(cau9L;&G)f*%Z>wKGUr&vaEyZVlVO$tm%`cs8eGf%&2N{c!{iPPin%9ke`si zKx|V;Pq-*oplU9`Xasx00{h0()P#H*`@-)DhUaxXhAt#42xqiA{&FQj3iDW zqZ=I{%robk2sFi3)JsaRqNCpI??!D zunrB203~FzG_%;QG@lPdpJ|q+%oy>`8qB|lqVhZXHkKy(40IOkS^J(7X$ZO!Ar2K@ zHhCNaQh9Bi02H{K z8(E93bdbvT*NFrTp`RsTD~-c|Mx{?0WI6<@=Y5L6bCH!}jcn_Ms_MSmvm{7S3qr0e zgy@=hDX8I~G9>UFD6&VXuWX^r=HnuH&DI%Ejm!4I_EMo^OcBldH#BngE^Nk5kZ<(?CrzwaO^3jSJ%EwX82W8Y+GO?6l#r$IhYBXnJS;#6ihD9# z2z4m$W?9JU1m==cE)&I(mu#BD#N7s4)#rA7%W?Q@O)2)NHiimeY7?%kq{jLbT+&=} zQB;c9>qJBHYi=n!x+BiCiS*wl>nyB*&E5`YP7gSUMG`FmlMUr1HQ#eg;VOzWmQJMK zpXNj@b-{S2LeAFwM<9yST;&O2gLt;>~sp+Eft z#`2JKj~+hTw`&lm&XW6i*r!;4e~O|IO*`T*R*bpPe>)D%{uTMQD=ZKAy3qhzFoRcD$S_%*HfuiLl75@3 zb8dG_%6*A)OEYXuTahY6_PSjMg=xce_xXj*k#l%glz&Upavp2%cCoL&*8SQ-a{p)e zZG+t}IIx?TW?Z;ki{)sn%4;=A@~R3*6{Z%K=Iv5-X$djkN%F_JUg?1yTBK^mT3okc zanuZ|=j1V8FN{V#8D3Cp?Pv5v6}d_faAzZj=804rx@7Q>6L}>)ii9x|7>L&Hd;ZG)J;fRdVYE|J1#?eUYVV{yjXv z8{-sH@uJm~IWbU<6jxGKi;)KBCA;ZwOypr8!hUyfno5z&iDb}*TDYWMXQ|;LR4S*_ zR!5d=-~Ge<8C|TzKcn)y07ckMM}$4)>xnV;#4i;g_a{RXC=PK;*CMb$l=IFO)vb9= zk`?;fFI|?^kb|X;E>Sc^k7*+MrqO5@sY5VdA%8Hr2-$l{hkgQlsr(f%1t#4{R*HYW z$e#Q=6mCbBxQa-g|LK8Qp)S8QK-2N&7PwS`(__tXSBE^$;w(Ww-_GhTg~UkwY#(`n z240D-%mU4!eH1Q5HTe<5sfu219|$AdtW!h?VLL*eH*Hh#eFHD!MHeRFY8YgP-6a%FCgF>aT{1U=2o5Yo$f%qi%r&2&i0ZN_GR!4(tfy0UQ%1t^UJ>suR=b8K^Z7v5<`#8=J$AO-S=(d1Otd!#={LyiOQ1wA+N2~CYooV6mDW`h7UUgkVd2vUan z7Om|S$D56WBI8qcNUYvMhJ<3L_@D$ONhQH(sLL^)*dPxE&A_>Xx)XxcOD&Mw=|MIJ zgNPCbcd#E|oiE&}Gs%uD9>pHJyP;jLd$@N+@D?;h1|b0sDwVaO@kwHhF14KIVp4KQ z**@dJ2<^zt{!~{c%`ueU;ty9@HpVN3L0=NP6Bloj#6w)79g`!>ScOY22^?EFXi&4r zW?%iFl=I0Cn-lA`9R<+3wzN?r7_suSh$vgnZ(M+>g&&HfS&jwlhcLk2miwP2P^mvJ zQR@VL`2(WC$77K*P!GUtc{r(iyV^&|LTa~&DwzdW2emFOhDpvBf#T}!aRG&iS7N-0 z^KAr!PvH@s{*h7w9#QGirq%)K$u@<27z?->VNbGhUXg*2kX#Z1?I)U%Gug}>Th>v9 z<4@vqv!ARieDZ5c;uOrCsC!jtpb*qc0 z{}AvHcR>tkDoTsxKmku2a`@$fxJ5?(_Q-&R5>Z^4<%P`v*`w0!#K@b{Whp*F;d30; z2^^At8k?Sc{U7o>*yVK-?*lT%|FnP^Qb_Q56~k7ZAaR);GxD?<=>^+imv?7PQS<}c z!vgN~>@fJyw1`H{FXbnW(M&7u%*ez)dTt`zah^Aym!zxp1;Ey8t<bHvko_8S2h9sa|AKj%F8T`=vClrohVYNTOi8VotW@+xrOQ~l+?(Cj?75RoLXs# z(=W3M$Of%iQ>&JTpI+m>4GcRNJXA5vZnra~5k)p2glL(AI ze?Zu+&f_Z#wCAG-BC<{LQhCYmj3q2dnbl#qOcc|Xdzml`3xHsN20J)p#(=Rbz1t$f z9{p5n;`U2XaqB98J)atFni5!KkW@OpWzA)p4-4p6qcrWd+D#mHPevnIP_Hc+3`! z&_rl3C5#|;IVJ3JO#(=l!`T8mPPTq`DuF+C2X0y?C*K*|UajOb+&JjrXpQf}w`o8h zifvKEc?Ey#pGY7DdpFd|`{QW#8m1abN{E`MuhdD_wmq1;`@Vxki?&-pt2(?tk5yc-%=rFm5HNVmm)z!)EEfn` zBL13?d~2rX%q1DrnQ41keoWLCeji%(;p-D7FvLq2hpif?U@6#TmNW`-G-%%8Y|ojd z+^59f(Lw|1G@vmMdFa=82#Aee%TxxhOzhud-6v8%0q^ zmzgz*+22?Ln4S=o+zy<-rlQaiyxZ3l;*1B_&E1)TLM>7kRuEO9GyN$exP2|V1e-P& z=}53IkuEg#)mA#KZ0}*`iMJ<(-v8w#{jzwf)XaAwt%EL>KJ1%7{AREaMq;zJW{bZR z>6;OrV!Rg9U!WWUJ&*^4#fgJ^=qT4X>mjAd{|0hvbT&po*bxgeM4WyzG`4+^{z4ZVt)6C1 zAqHPo?I(E#W)s!v0LfjkNvA{6o((N?NbcsUYtbRdg#v8f7JpL?Ei9{|bFEVSZPCr` zfDsD6+SlTb5+4eAjIo3)vNqhX@=lsl@o@8d7q2tK0 zvN+}yOO0twZlLm=XYy5Bf4Cu2Zy%r?8~C!9CZb|ZqYw|aka#)wNY zW^4F?O7b6)@^ek}JRB8*LB44{j&hE&s*{&+`ys6#`2&fAri9R2>Z{hj{6yqkDLGrA z*vruw8mI5q=!#7-`Y5;7lP{<%3Bm`S<=O9~DlKVA`!q<4{HK^HEvMW>n}S*uJYL)F z2Y)gI2uh`$E34={lUni>CEpL>8j&R?j~4X^$`@fs+i(4II` zJ)aA}c!9_nDEx7t!fpMZzLLR@Jmehja)>QXm1x6e(OX~z-!l7s46sa4ntPnR+M-fd z$)G#o$vKg+#z2=q`P2F zE^aHYrz&&S76wK>$P`UBY=$==AU+AQ!!1N*->ZuRTD*k1lj@~(3$hchd9QuxrkChi z2_aH@vN^$I17%PhG2X|o0e(qgVC=P-5iC@fjm|F=awi%46($hlaPzI6EpeH4Z~-BA z<+=0o)@US^dA62@342nd|H-XApfe6%(N>HtKk)R8W8!$>;Ql^##*?;csl7pMASZMG zUY%y+(w6ZKDUqxhbQ11_uPvO-(+|S5<$NT5JJ?5y&ln{Blzds*{0&Dd_F|zCM}5XO_7J9$HJAlAIZAn1z2Gz`U)o4dIO!bL$k(Z=!l{kZz2iFgbSV dL@#@ScjV25gWp|qo&f)rz8$mp%%a4s{{z*rIiUam literal 0 HcmV?d00001 diff --git a/out.png b/out.png deleted file mode 100644 index 1a071c70e0bf1ba09e57aac3d6e7db13e205c728..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 28150 zcmd^IT})eb6u*o?Yo#j$*bql8;*jYUcQxWyomLp7Nu7fdLwtfuW-!x45_FZQDJ!g_ zYh?J9t66kQ4ar`Xm}oMM8W@yq#wAGwH9YM>ypzk&(Y(hO@jr3Z@G|{r&qT6jMSJzq_mp1#Y16d^_lV&FYu4pj3^&HU z+-rNwzzF;@Hk#Y&u|dt=dCpyTU#z+otu<`fGW%&@$aZu4V%fET%`@SG;N41)8Jc|| zDj2e<%Cc}Ue=XAHnRLM$*y``YKZ~K61J{zW4teSeG(aY9(Rd{$=wZGAQ7PDyxrWcU z$pzrvu8o)s2$KA-A~?CcNY}^Z*s>9Sx@!twZUjim=cE3C%fMj)46zg<+s+n)l}RuZ zIE&1<^q0#DXNddhB9zSMy-`A7Lr%2Rhu+RPDO0^5lqDcy75f@;LMf87&%-R@KE7Wv zRe*j69`rc|DS?DT=cn@oeEf&+euZcOCd19PRRgw}y|`iZ1+6xFWvz$=VW%(L3MOQk zfqop1tE#ny*&@M^=_{EHnEx=uwy+gBr$hnY%NFEMiN++!Qwq^zGkJnT=CG$9N|XFj zTkvt9rrQ*Fo!V?}U*a0G>j6!HQArH7zy)Qoek8hVTglit(b((bii4dD2?h zN7NCzuCK?huM3JXV@~udJE94&2KSrjkf#h9GFpQYdAbQw_9Cvm8p9Q?{rHjR-Yp8& zs!~r!z7$_3LX262$y7uk_C;*iGZRzc>(bDw`n)-sSLplX9=j(e4LE&t_7S25$d^h0 zGbd={jpS^F@sg_75?0LqnQ`o(qGu6JWxW(pMW_TsrMRS#V7X@cC4jL()NxkMmh`rq z1fnc}Pq0z=l90#=sK@OzXqZtv~rb|YGapy4E zmetLO#2T^1W^4yE6A9(Jedicr%!VXMdV!jG6& zo?Z*v{(bO+Pl*4`eGs~Bze;E9lQKyqb9*0UfAeU8eu<4?lkiywJo@rgh5PB@<* zK-7eW0(r_myaaOO*>#b> zD~zEi9bbx}v2BYo?<2czn|B{B`u?cKj?qGV?0uSa_c)i`g|TzM^K?our0Z>rsY9%G zlHtz9lh`{4JbJR#iWm#RlO9F|Jr}050$!*R9rm!Dur8@a3O;?3QZRleHhq9}4mf_E zNchv#O&1<7*=KeWEg*mH{TBg67c4=m4xwRr?o_|Nlfb-;3Tino9)ApEl5|6T0+9jb zJVHB3CxL0lTZ4u8I~D}*Kn%6sIH!7lobh}Rd($YKbI2QWsKQd@@CT4__+@n#DZ_Y5 z(N-=Sl0geSU4jl$g)(;#iH8~J*?}$j%dROD(qb1XrW-Bbi_Vj)yHm8GCb%BQ4)j>gePSd zR~2FGB_7{L-17xqo<(^ zm^FG}3)@OM3G9b>(Wj5kABbiM6l$*cjxS<+F5}~BCh^#Ia9S2-NpZc{R)Q=zmyRli z<*5(-JTmc)Cyc=Z1bf02<%1YI2fTyMofGo^yNL3?LH2hBYq8~jRRl`&^0nM!O7t^o cXSyj{=>GZ5bqDR-^W3Pwp1sYdpXoaEAIRgOwg3PC diff --git a/quicklisp.lisp b/quicklisp.lisp deleted file mode 100644 index 6cda472..0000000 --- a/quicklisp.lisp +++ /dev/null @@ -1,1757 +0,0 @@ -;;;; -;;;; This is quicklisp.lisp, the quickstart file for Quicklisp. To use -;;;; it, start Lisp, then (load "quicklisp.lisp") -;;;; -;;;; Quicklisp is beta software and comes with no warranty of any kind. -;;;; -;;;; For more information about the Quicklisp beta, see: -;;;; -;;;; http://www.quicklisp.org/beta/ -;;;; -;;;; If you have any questions or comments about Quicklisp, please -;;;; contact: -;;;; -;;;; Zach Beane -;;;; - -(cl:in-package #:cl-user) -(cl:defpackage #:qlqs-user - (:use #:cl)) -(cl:in-package #:qlqs-user) - -(defpackage #:qlqs-info - (:export #:*version*)) - -(defvar qlqs-info:*version* "2015-01-28") - -(defpackage #:qlqs-impl - (:use #:cl) - (:export #:*implementation*) - (:export #:definterface - #:defimplementation) - (:export #:lisp - #:abcl - #:allegro - #:ccl - #:clasp - #:clisp - #:cmucl - #:cormanlisp - #:ecl - #:gcl - #:lispworks - #:mkcl - #:scl - #:sbcl)) - -(defpackage #:qlqs-impl-util - (:use #:cl #:qlqs-impl) - (:export #:call-with-quiet-compilation)) - -(defpackage #:qlqs-network - (:use #:cl #:qlqs-impl) - (:export #:open-connection - #:write-octets - #:read-octets - #:close-connection - #:with-connection)) - -(defpackage #:qlqs-progress - (:use #:cl) - (:export #:make-progress-bar - #:start-display - #:update-progress - #:finish-display)) - -(defpackage #:qlqs-http - (:use #:cl #:qlqs-network #:qlqs-progress) - (:export #:fetch - #:*proxy-url* - #:*maximum-redirects* - #:*default-url-defaults*)) - -(defpackage #:qlqs-minitar - (:use #:cl) - (:export #:unpack-tarball)) - -(defpackage #:quicklisp-quickstart - (:use #:cl #:qlqs-impl #:qlqs-impl-util #:qlqs-http #:qlqs-minitar) - (:export #:install - #:help - #:*proxy-url* - #:*asdf-url* - #:*quicklisp-tar-url* - #:*setup-url* - #:*help-message* - #:*after-load-message* - #:*after-initial-setup-message*)) - - -;;; -;;; Defining implementation-specific packages and functionality -;;; - -(in-package #:qlqs-impl) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun error-unimplemented (&rest args) - (declare (ignore args)) - (error "Not implemented"))) - -(defmacro neuter-package (name) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (let ((definition (fdefinition 'error-unimplemented))) - (do-external-symbols (symbol ,(string name)) - (unless (fboundp symbol) - (setf (fdefinition symbol) definition)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun feature-expression-passes-p (expression) - (cond ((keywordp expression) - (member expression *features*)) - ((consp expression) - (case (first expression) - (or - (some 'feature-expression-passes-p (rest expression))) - (and - (every 'feature-expression-passes-p (rest expression))))) - (t (error "Unrecognized feature expression -- ~S" expression))))) - - -(defmacro define-implementation-package (feature package-name &rest options) - (let* ((output-options '((:use) - (:export #:lisp))) - (prep (cdr (assoc :prep options))) - (class-option (cdr (assoc :class options))) - (class (first class-option)) - (superclasses (rest class-option)) - (import-options '()) - (effectivep (feature-expression-passes-p feature))) - (dolist (option options) - (ecase (first option) - ((:prep :class)) - ((:import-from - :import) - (push option import-options)) - ((:export - :shadow - :intern - :documentation) - (push option output-options)) - ((:reexport-from) - (push (cons :export (cddr option)) output-options) - (push (cons :import-from (cdr option)) import-options)))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(when effectivep - prep) - (defclass ,class ,superclasses ()) - (defpackage ,package-name ,@output-options - ,@(when effectivep - import-options)) - ,@(when effectivep - `((setf *implementation* (make-instance ',class)))) - ,@(unless effectivep - `((neuter-package ,package-name)))))) - -(defmacro definterface (name lambda-list &body options) - (let* ((forbidden (intersection lambda-list lambda-list-keywords)) - (gf-options (remove :implementation options :key #'first)) - (implementations (set-difference options gf-options))) - (when forbidden - (error "~S not allowed in definterface lambda list" forbidden)) - (flet ((method-option (class body) - `(:method ((*implementation* ,class) ,@lambda-list) - ,@body))) - (let ((generic-name (intern (format nil "%~A" name)))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defgeneric ,generic-name (lisp ,@lambda-list) - ,@gf-options - ,@(mapcar (lambda (implementation) - (destructuring-bind (class &rest body) - (rest implementation) - (method-option class body))) - implementations)) - (defun ,name ,lambda-list - (,generic-name *implementation* ,@lambda-list))))))) - -(defmacro defimplementation (name-and-options - lambda-list &body body) - (destructuring-bind (name &key (for t) qualifier) - (if (consp name-and-options) - name-and-options - (list name-and-options)) - (unless for - (error "You must specify an implementation name.")) - (let ((generic-name (find-symbol (format nil "%~A" name)))) - (unless (and generic-name - (fboundp generic-name)) - (error "~S does not name an implementation function" name)) - `(defmethod ,generic-name - ,@(when qualifier (list qualifier)) - ,(list* `(*implementation* ,for) lambda-list) ,@body)))) - - -;;; Bootstrap implementations - -(defvar *implementation* nil) -(defclass lisp () ()) - - -;;; Allegro Common Lisp - -(define-implementation-package :allegro #:qlqs-allegro - (:documentation - "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") - (:class allegro) - (:reexport-from #:socket - #:make-socket) - (:reexport-from #:excl - #:read-vector)) - - -;;; Armed Bear Common Lisp - -(define-implementation-package :abcl #:qlqs-abcl - (:documentation - "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") - (:class abcl) - (:reexport-from #:system - #:make-socket - #:get-socket-stream)) - -;;; Clozure CL - -(define-implementation-package :ccl #:qlqs-ccl - (:documentation - "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") - (:class ccl) - (:reexport-from #:ccl - #:make-socket)) - - -;;; CLASP - -(define-implementation-package :clasp #:qlqs-clasp - (:documentation "CLASP - http://github.com/drmeister/clasp") - (:class clasp) - (:prep - (require 'sockets)) - (:intern #:host-network-address) - (:reexport-from #:sb-bsd-sockets - #:get-host-by-name - #:host-ent-address - #:socket-connect - #:socket-make-stream - #:inet-socket)) - - -;;; GNU CLISP - -(define-implementation-package :clisp #:qlqs-clisp - (:documentation "GNU CLISP - http://clisp.cons.org/") - (:class clisp) - (:reexport-from #:socket - #:socket-connect) - (:reexport-from #:ext - #:read-byte-sequence)) - - -;;; CMUCL - -(define-implementation-package :cmu #:qlqs-cmucl - (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") - (:class cmucl) - (:reexport-from #:ext - #:*gc-verbose*) - (:reexport-from #:system - #:make-fd-stream) - (:reexport-from #:extensions - #:connect-to-inet-socket)) - -(defvar qlqs-cmucl:*gc-verbose* nil) - - -;;; Scieneer CL - -(define-implementation-package :scl #:qlqs-scl - (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") - (:class scl) - (:reexport-from #:system - #:make-fd-stream) - (:reexport-from #:extensions - #:connect-to-inet-socket)) - -;;; ECL - -(define-implementation-package :ecl #:qlqs-ecl - (:documentation "ECL - http://ecls.sourceforge.net/") - (:class ecl) - (:prep - (require 'sockets)) - (:intern #:host-network-address) - (:reexport-from #:sb-bsd-sockets - #:get-host-by-name - #:host-ent-address - #:socket-connect - #:socket-make-stream - #:inet-socket)) - - -;;; LispWorks - -(define-implementation-package :lispworks #:qlqs-lispworks - (:documentation "LispWorks - http://www.lispworks.com/") - (:class lispworks) - (:prep - (require "comm")) - (:reexport-from #:comm - #:open-tcp-stream - #:get-host-entry)) - - -;;; SBCL - -(define-implementation-package :sbcl #:qlqs-sbcl - (:class sbcl) - (:documentation - "Steel Bank Common Lisp - http://www.sbcl.org/") - (:prep - (require 'sb-bsd-sockets)) - (:intern #:host-network-address) - (:reexport-from #:sb-ext - #:compiler-note) - (:reexport-from #:sb-bsd-sockets - #:get-host-by-name - #:inet-socket - #:host-ent-address - #:socket-connect - #:socket-make-stream)) - -;;; MKCL - -(define-implementation-package :mkcl #:qlqs-mkcl - (:class mkcl) - (:documentation - "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") - (:prep - (require 'sockets)) - (:intern #:host-network-address) - (:reexport-from #:sb-bsd-sockets - #:get-host-by-name - #:inet-socket - #:host-ent-address - #:socket-connect - #:socket-make-stream)) - -;;; -;;; Utility function -;;; - -(in-package #:qlqs-impl-util) - -(definterface call-with-quiet-compilation (fun) - (:implementation t - (let ((*load-verbose* nil) - (*compile-verbose* nil) - (*load-print* nil) - (*compile-print* nil)) - (handler-bind ((warning #'muffle-warning)) - (funcall fun))))) - -(defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) - (fun) - (declare (ignorable fun)) - (handler-bind ((qlqs-sbcl:compiler-note #'muffle-warning)) - (call-next-method))) - -(defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) - (fun) - (declare (ignorable fun)) - (let ((qlqs-cmucl:*gc-verbose* nil)) - (call-next-method))) - - -;;; -;;; Low-level networking implementations -;;; - -(in-package #:qlqs-network) - -(definterface host-address (host) - (:implementation t - host) - (:implementation mkcl - (qlqs-mkcl:host-ent-address (qlqs-mkcl:get-host-by-name host))) - (:implementation sbcl - (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host)))) - -(definterface open-connection (host port) - (:implementation t - (declare (ignorable host port)) - (error "Sorry, quicklisp in implementation ~S is not supported yet." - (lisp-implementation-type))) - (:implementation allegro - (qlqs-allegro:make-socket :remote-host host - :remote-port port)) - (:implementation abcl - (let ((socket (qlqs-abcl:make-socket host port))) - (qlqs-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) - (:implementation ccl - (qlqs-ccl:make-socket :remote-host host - :remote-port port)) - (:implementation clasp - (let* ((endpoint (qlqs-clasp:host-ent-address - (qlqs-clasp:get-host-by-name host))) - (socket (make-instance 'qlqs-clasp:inet-socket - :protocol :tcp - :type :stream))) - (qlqs-clasp:socket-connect socket endpoint port) - (qlqs-clasp:socket-make-stream socket - :element-type '(unsigned-byte 8) - :input t - :output t - :buffering :full))) - (:implementation clisp - (qlqs-clisp:socket-connect port host :element-type '(unsigned-byte 8))) - (:implementation cmucl - (let ((fd (qlqs-cmucl:connect-to-inet-socket host port))) - (qlqs-cmucl:make-fd-stream fd - :element-type '(unsigned-byte 8) - :binary-stream-p t - :input t - :output t))) - (:implementation scl - (let ((fd (qlqs-scl:connect-to-inet-socket host port))) - (qlqs-scl:make-fd-stream fd - :element-type '(unsigned-byte 8) - :input t - :output t))) - (:implementation ecl - (let* ((endpoint (qlqs-ecl:host-ent-address - (qlqs-ecl:get-host-by-name host))) - (socket (make-instance 'qlqs-ecl:inet-socket - :protocol :tcp - :type :stream))) - (qlqs-ecl:socket-connect socket endpoint port) - (qlqs-ecl:socket-make-stream socket - :element-type '(unsigned-byte 8) - :input t - :output t - :buffering :full))) - (:implementation lispworks - (qlqs-lispworks:open-tcp-stream host port - :direction :io - :errorp t - :read-timeout nil - :element-type '(unsigned-byte 8) - :timeout 5)) - (:implementation mkcl - (let* ((endpoint (qlqs-mkcl:host-ent-address - (qlqs-mkcl:get-host-by-name host))) - (socket (make-instance 'qlqs-mkcl:inet-socket - :protocol :tcp - :type :stream))) - (qlqs-mkcl:socket-connect socket endpoint port) - (qlqs-mkcl:socket-make-stream socket - :element-type '(unsigned-byte 8) - :input t - :output t - :buffering :full))) - (:implementation sbcl - (let* ((endpoint (qlqs-sbcl:host-ent-address - (qlqs-sbcl:get-host-by-name host))) - (socket (make-instance 'qlqs-sbcl:inet-socket - :protocol :tcp - :type :stream))) - (qlqs-sbcl:socket-connect socket endpoint port) - (qlqs-sbcl:socket-make-stream socket - :element-type '(unsigned-byte 8) - :input t - :output t - :buffering :full)))) - -(definterface read-octets (buffer connection) - (:implementation t - (read-sequence buffer connection)) - (:implementation allegro - (qlqs-allegro:read-vector buffer connection)) - (:implementation clisp - (qlqs-clisp:read-byte-sequence buffer connection - :no-hang nil - :interactive t))) - -(definterface write-octets (buffer connection) - (:implementation t - (write-sequence buffer connection) - (finish-output connection))) - -(definterface close-connection (connection) - (:implementation t - (ignore-errors (close connection)))) - -(definterface call-with-connection (host port fun) - (:implementation t - (let (connection) - (unwind-protect - (progn - (setf connection (open-connection host port)) - (funcall fun connection)) - (when connection - (close connection)))))) - -(defmacro with-connection ((connection host port) &body body) - `(call-with-connection ,host ,port (lambda (,connection) ,@body))) - - -;;; -;;; A text progress bar -;;; - -(in-package #:qlqs-progress) - -(defclass progress-bar () - ((start-time - :initarg :start-time - :accessor start-time) - (end-time - :initarg :end-time - :accessor end-time) - (progress-character - :initarg :progress-character - :accessor progress-character) - (character-count - :initarg :character-count - :accessor character-count - :documentation "How many characters wide is the progress bar?") - (characters-so-far - :initarg :characters-so-far - :accessor characters-so-far) - (update-interval - :initarg :update-interval - :accessor update-interval - :documentation "Update the progress bar display after this many - internal-time units.") - (last-update-time - :initarg :last-update-time - :accessor last-update-time - :documentation "The display was last updated at this time.") - (total - :initarg :total - :accessor total - :documentation "The total number of units tracked by this progress bar.") - (progress - :initarg :progress - :accessor progress - :documentation "How far in the progress are we?") - (pending - :initarg :pending - :accessor pending - :documentation "How many raw units should be tracked in the next - display update?")) - (:default-initargs - :progress-character #\= - :character-count 50 - :characters-so-far 0 - :update-interval (floor internal-time-units-per-second 4) - :last-update-time 0 - :total 0 - :progress 0 - :pending 0)) - -(defgeneric start-display (progress-bar)) -(defgeneric update-progress (progress-bar unit-count)) -(defgeneric update-display (progress-bar)) -(defgeneric finish-display (progress-bar)) -(defgeneric elapsed-time (progress-bar)) -(defgeneric units-per-second (progress-bar)) - -(defmethod start-display (progress-bar) - (setf (last-update-time progress-bar) (get-internal-real-time)) - (setf (start-time progress-bar) (get-internal-real-time)) - (fresh-line) - (finish-output)) - -(defmethod update-display (progress-bar) - (incf (progress progress-bar) (pending progress-bar)) - (setf (pending progress-bar) 0) - (setf (last-update-time progress-bar) (get-internal-real-time)) - (let* ((showable (floor (character-count progress-bar) - (/ (total progress-bar) (progress progress-bar)))) - (needed (- showable (characters-so-far progress-bar)))) - (setf (characters-so-far progress-bar) showable) - (dotimes (i needed) - (write-char (progress-character progress-bar))) - (finish-output))) - -(defmethod update-progress (progress-bar unit-count) - (incf (pending progress-bar) unit-count) - (let ((now (get-internal-real-time))) - (when (< (update-interval progress-bar) - (- now (last-update-time progress-bar))) - (update-display progress-bar)))) - -(defmethod finish-display (progress-bar) - (update-display progress-bar) - (setf (end-time progress-bar) (get-internal-real-time)) - (terpri) - (format t "~:D bytes in ~$ seconds (~$KB/sec)" - (total progress-bar) - (elapsed-time progress-bar) - (/ (units-per-second progress-bar) 1024)) - (finish-output)) - -(defmethod elapsed-time (progress-bar) - (/ (- (end-time progress-bar) (start-time progress-bar)) - internal-time-units-per-second)) - -(defmethod units-per-second (progress-bar) - (if (plusp (elapsed-time progress-bar)) - (/ (total progress-bar) (elapsed-time progress-bar)) - 0)) - -(defun kb/sec (progress-bar) - (/ (units-per-second progress-bar) 1024)) - - - -(defparameter *uncertain-progress-chars* "?") - -(defclass uncertain-size-progress-bar (progress-bar) - ((progress-char-index - :initarg :progress-char-index - :accessor progress-char-index) - (units-per-char - :initarg :units-per-char - :accessor units-per-char)) - (:default-initargs - :total 0 - :progress-char-index 0 - :units-per-char (floor (expt 1024 2) 50))) - -(defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) - unit-count) - (incf (total progress-bar) unit-count)) - -(defmethod progress-character ((progress-bar uncertain-size-progress-bar)) - (let ((index (progress-char-index progress-bar))) - (prog1 - (char *uncertain-progress-chars* index) - (setf (progress-char-index progress-bar) - (mod (1+ index) (length *uncertain-progress-chars*)))))) - -(defmethod update-display ((progress-bar uncertain-size-progress-bar)) - (setf (last-update-time progress-bar) (get-internal-real-time)) - (multiple-value-bind (chars pend) - (floor (pending progress-bar) (units-per-char progress-bar)) - (setf (pending progress-bar) pend) - (dotimes (i chars) - (write-char (progress-character progress-bar)) - (incf (characters-so-far progress-bar)) - (when (<= (character-count progress-bar) - (characters-so-far progress-bar)) - (terpri) - (setf (characters-so-far progress-bar) 0) - (finish-output))) - (finish-output))) - -(defun make-progress-bar (total) - (if (or (not total) (zerop total)) - (make-instance 'uncertain-size-progress-bar) - (make-instance 'progress-bar :total total))) - -;;; -;;; A simple HTTP client -;;; - -(in-package #:qlqs-http) - -;;; Octet data - -(deftype octet () - '(unsigned-byte 8)) - -(defun make-octet-vector (size) - (make-array size :element-type 'octet - :initial-element 0)) - -(defun octet-vector (&rest octets) - (make-array (length octets) :element-type 'octet - :initial-contents octets)) - -;;; ASCII characters as integers - -(defun acode (char) - (cond ((eql char :cr) - 13) - ((eql char :lf) - 10) - (t - (let ((code (char-code char))) - (if (<= 0 code 127) - code - (error "Character ~S is not in the ASCII character set" - char)))))) - -(defvar *whitespace* - (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) - -(defun whitep (code) - (member code *whitespace*)) - -(defun ascii-vector (string) - (let ((vector (make-octet-vector (length string)))) - (loop for char across string - for code = (char-code char) - for i from 0 - if (< 127 code) do - (error "Invalid character for ASCII -- ~A" char) - else - do (setf (aref vector i) code)) - vector)) - -(defun ascii-subseq (vector start end) - "Return a subseq of octet-specialized VECTOR as a string." - (let ((string (make-string (- end start)))) - (loop for i from 0 - for j from start below end - do (setf (char string i) (code-char (aref vector j)))) - string)) - -(defun ascii-downcase (code) - (if (<= 65 code 90) - (+ code 32) - code)) - -(defun ascii-equal (a b) - (eql (ascii-downcase a) (ascii-downcase b))) - -(defmacro acase (value &body cases) - (flet ((convert-case-keys (keys) - (mapcar (lambda (key) - (etypecase key - (integer key) - (character (char-code key)) - (symbol - (ecase key - (:cr 13) - (:lf 10) - ((t) t))))) - (if (consp keys) keys (list keys))))) - `(case ,value - ,@(mapcar (lambda (case) - (destructuring-bind (keys &rest body) - case - `(,(if (eql keys t) - t - (convert-case-keys keys)) - ,@body))) - cases)))) - -;;; Pattern matching (for finding headers) - -(defclass matcher () - ((pattern - :initarg :pattern - :reader pattern) - (pos - :initform 0 - :accessor match-pos) - (matchedp - :initform nil - :accessor matchedp))) - -(defun reset-match (matcher) - (setf (match-pos matcher) 0 - (matchedp matcher) nil)) - -(define-condition match-failure (error) ()) - -(defun match (matcher input &key (start 0) end error) - (let ((i start) - (end (or end (length input))) - (match-end (length (pattern matcher)))) - (with-slots (pattern pos) - matcher - (loop - (cond ((= pos match-end) - (let ((match-start (- i pos))) - (setf pos 0) - (setf (matchedp matcher) t) - (return (values match-start (+ match-start match-end))))) - ((= i end) - (return nil)) - ((= (aref pattern pos) - (aref input i)) - (incf i) - (incf pos)) - (t - (if error - (error 'match-failure) - (if (zerop pos) - (incf i) - (setf pos 0))))))))) - -(defun ascii-matcher (string) - (make-instance 'matcher - :pattern (ascii-vector string))) - -(defun octet-matcher (&rest octets) - (make-instance 'matcher - :pattern (apply 'octet-vector octets))) - -(defun acode-matcher (&rest codes) - (make-instance 'matcher - :pattern (make-array (length codes) - :element-type 'octet - :initial-contents - (mapcar 'acode codes)))) - - -;;; "Connection Buffers" are a kind of callback-driven, -;;; pattern-matching chunky stream. Callbacks can be called for a -;;; certain number of octets or until one or more patterns are seen in -;;; the input. cbufs automatically refill themselves from a -;;; connection as needed. - -(defvar *cbuf-buffer-size* 8192) - -(define-condition end-of-data (error) ()) - -(defclass cbuf () - ((data - :initarg :data - :accessor data) - (connection - :initarg :connection - :accessor connection) - (start - :initarg :start - :accessor start) - (end - :initarg :end - :accessor end) - (eofp - :initarg :eofp - :accessor eofp)) - (:default-initargs - :data (make-octet-vector *cbuf-buffer-size*) - :connection nil - :start 0 - :end 0 - :eofp nil) - (:documentation "A CBUF is a connection buffer that keeps track of - incoming data from a connection. Several functions make it easy to - treat a CBUF as a kind of chunky, callback-driven stream.")) - -(define-condition cbuf-progress () - ((size - :initarg :size - :accessor cbuf-progress-size - :initform 0))) - -(defun call-processor (fun cbuf start end) - (signal 'cbuf-progress :size (- end start)) - (funcall fun (data cbuf) start end)) - -(defun make-cbuf (connection) - (make-instance 'cbuf :connection connection)) - -(defun make-stream-writer (stream) - "Create a callback for writing data to STREAM." - (lambda (data start end) - (write-sequence data stream :start start :end end))) - -(defgeneric size (cbuf) - (:method ((cbuf cbuf)) - (- (end cbuf) (start cbuf)))) - -(defgeneric emptyp (cbuf) - (:method ((cbuf cbuf)) - (zerop (size cbuf)))) - -(defgeneric refill (cbuf) - (:method ((cbuf cbuf)) - (when (eofp cbuf) - (error 'end-of-data)) - (setf (start cbuf) 0) - (setf (end cbuf) - (read-octets (data cbuf) - (connection cbuf))) - (cond ((emptyp cbuf) - (setf (eofp cbuf) t) - (error 'end-of-data)) - (t (size cbuf))))) - -(defun process-all (fun cbuf) - (unless (emptyp cbuf) - (call-processor fun cbuf (start cbuf) (end cbuf)))) - -(defun multi-cmatch (matchers cbuf) - (let (start end) - (dolist (matcher matchers (values start end)) - (multiple-value-bind (s e) - (match matcher (data cbuf) - :start (start cbuf) - :end (end cbuf)) - (when (and s (or (null start) (< s start))) - (setf start s - end e)))))) - -(defun cmatch (matcher cbuf) - (if (consp matcher) - (multi-cmatch matcher cbuf) - (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) - -(defun call-until-end (fun cbuf) - (handler-case - (loop - (process-all fun cbuf) - (refill cbuf)) - (end-of-data () - (return-from call-until-end)))) - -(defun show-cbuf (context cbuf) - (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) - -(defun call-for-n-octets (n fun cbuf) - (let ((remaining n)) - (loop - (when (<= remaining (size cbuf)) - (let ((end (+ (start cbuf) remaining))) - (call-processor fun cbuf (start cbuf) end) - (setf (start cbuf) end) - (return))) - (process-all fun cbuf) - (decf remaining (size cbuf)) - (refill cbuf)))) - -(defun call-until-matching (matcher fun cbuf) - (loop - (multiple-value-bind (start end) - (cmatch matcher cbuf) - (when start - (call-processor fun cbuf (start cbuf) end) - (setf (start cbuf) end) - (return))) - (process-all fun cbuf) - (refill cbuf))) - -(defun ignore-data (data start end) - (declare (ignore data start end))) - -(defun skip-until-matching (matcher cbuf) - (call-until-matching matcher 'ignore-data cbuf)) - - -;;; Creating HTTP requests as octet buffers - -(defclass octet-sink () - ((storage - :initarg :storage - :accessor storage)) - (:default-initargs - :storage (make-array 1024 :element-type 'octet - :fill-pointer 0 - :adjustable t)) - (:documentation "A simple stream-like target for collecting - octets.")) - -(defun add-octet (octet sink) - (vector-push-extend octet (storage sink))) - -(defun add-octets (octets sink &key (start 0) end) - (setf end (or end (length octets))) - (loop for i from start below end - do (add-octet (aref octets i) sink))) - -(defun add-string (string sink) - (loop for char across string - for code = (char-code char) - do (add-octet code sink))) - -(defun add-strings (sink &rest strings) - (mapc (lambda (string) (add-string string sink)) strings)) - -(defun add-newline (sink) - (add-octet 13 sink) - (add-octet 10 sink)) - -(defun sink-buffer (sink) - (subseq (storage sink) 0)) - -(defvar *proxy-url* nil) - -(defun full-proxy-path (host port path) - (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" - (= port 443) - host - (or (= port 80) - (= port 443)) - port - path)) - -(defun make-request-buffer (host port path &key (method "GET")) - (setf method (string method)) - (when *proxy-url* - (setf path (full-proxy-path host port path))) - (let ((sink (make-instance 'octet-sink))) - (flet ((add-line (&rest strings) - (apply #'add-strings sink strings) - (add-newline sink))) - (add-line method " " path " HTTP/1.1") - (add-line "Host: " host (if (= port 80) "" - (format nil ":~D" port))) - (add-line "Connection: close") - ;; FIXME: get this version string from somewhere else. - (add-line "User-Agent: quicklisp-bootstrap/" - qlqs-info:*version*) - (add-newline sink) - (sink-buffer sink)))) - -(defun sink-until-matching (matcher cbuf) - (let ((sink (make-instance 'octet-sink))) - (call-until-matching - matcher - (lambda (buffer start end) - (add-octets buffer sink :start start :end end)) - cbuf) - (sink-buffer sink))) - - -;;; HTTP headers - -(defclass header () - ((data - :initarg :data - :accessor data) - (status - :initarg :status - :accessor status) - (name-starts - :initarg :name-starts - :accessor name-starts) - (name-ends - :initarg :name-ends - :accessor name-ends) - (value-starts - :initarg :value-starts - :accessor value-starts) - (value-ends - :initarg :value-ends - :accessor value-ends))) - -(defmethod print-object ((header header) stream) - (print-unreadable-object (header stream :type t) - (prin1 (status header) stream))) - -(defun matches-at (pattern target pos) - (= (mismatch pattern target :start2 pos) (length pattern))) - -(defun header-value-indexes (field-name header) - (loop with data = (data header) - with pattern = (ascii-vector (string-downcase field-name)) - for start across (name-starts header) - for i from 0 - when (matches-at pattern data start) - return (values (aref (value-starts header) i) - (aref (value-ends header) i)))) - -(defun ascii-header-value (field-name header) - (multiple-value-bind (start end) - (header-value-indexes field-name header) - (when start - (ascii-subseq (data header) start end)))) - -(defun all-field-names (header) - (map 'list - (lambda (start end) - (ascii-subseq (data header) start end)) - (name-starts header) - (name-ends header))) - -(defun headers-alist (header) - (mapcar (lambda (name) - (cons name (ascii-header-value name header))) - (all-field-names header))) - -(defmethod describe-object :after ((header header) stream) - (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) - -(defun content-length (header) - (let ((field-value (ascii-header-value "content-length" header))) - (when field-value - (let ((value (ignore-errors (parse-integer field-value)))) - (or value - (error "Content-Length header field value is not a number -- ~A" - field-value)))))) - -(defun chunkedp (header) - (string= (ascii-header-value "transfer-encoding" header) "chunked")) - -(defun location (header) - (ascii-header-value "location" header)) - -(defun status-code (vector) - (let* ((space (position (acode #\Space) vector)) - (c1 (- (aref vector (incf space)) 48)) - (c2 (- (aref vector (incf space)) 48)) - (c3 (- (aref vector (incf space)) 48))) - (+ (* c1 100) - (* c2 10) - (* c3 1)))) - -(defun force-downcase-field-names (header) - (loop with data = (data header) - for start across (name-starts header) - for end across (name-ends header) - do (loop for i from start below end - for code = (aref data i) - do (setf (aref data i) (ascii-downcase code))))) - -(defun skip-white-forward (pos vector) - (position-if-not 'whitep vector :start pos)) - -(defun skip-white-backward (pos vector) - (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) - (if nonwhite - (1+ nonwhite) - pos))) - -(defun contract-field-value-indexes (header) - "Header field values exclude leading and trailing whitespace; adjust -the indexes in the header accordingly." - (loop with starts = (value-starts header) - with ends = (value-ends header) - with data = (data header) - for i from 0 - for start across starts - for end across ends - do - (setf (aref starts i) (skip-white-forward start data)) - (setf (aref ends i) (skip-white-backward end data)))) - -(defun next-line-pos (vector) - (let ((pos 0)) - (labels ((finish (&optional (i pos)) - (return-from next-line-pos i)) - (after-cr (code) - (acase code - (:lf (finish pos)) - (t (finish (1- pos))))) - (pending (code) - (acase code - (:cr #'after-cr) - (:lf (finish pos)) - (t #'pending)))) - (let ((state #'pending)) - (loop - (setf state (funcall state (aref vector pos))) - (incf pos)))))) - -(defun make-hvector () - (make-array 16 :fill-pointer 0 :adjustable t)) - -(defun process-header (vector) - "Create a HEADER instance from the octet data in VECTOR." - (let* ((name-starts (make-hvector)) - (name-ends (make-hvector)) - (value-starts (make-hvector)) - (value-ends (make-hvector)) - (header (make-instance 'header - :data vector - :status 999 - :name-starts name-starts - :name-ends name-ends - :value-starts value-starts - :value-ends value-ends)) - (mark nil) - (pos (next-line-pos vector))) - (unless pos - (error "Unable to process HTTP header")) - (setf (status header) (status-code vector)) - (labels ((save (value vector) - (vector-push-extend value vector)) - (mark () - (setf mark pos)) - (clear-mark () - (setf mark nil)) - (finish () - (if mark - (save mark value-ends) - (save pos value-ends)) - (force-downcase-field-names header) - (contract-field-value-indexes header) - (return-from process-header header)) - (in-new-line (code) - (acase code - ((#\Tab #\Space) (setf mark nil) #'in-value) - (t - (when mark - (save mark value-ends)) - (clear-mark) - (save pos name-starts) - (in-name code)))) - (after-cr (code) - (acase code - (:lf #'in-new-line) - (t (in-new-line code)))) - (pending-value (code) - (acase code - ((#\Tab #\Space) #'pending-value) - (:cr #'after-cr) - (:lf #'in-new-line) - (t (save pos value-starts) #'in-value))) - (in-name (code) - (acase code - (#\: - (save pos name-ends) - (save (1+ pos) value-starts) - #'in-value) - ((:cr :lf) - (finish)) - ((#\Tab #\Space) - (error "Unexpected whitespace in header field name")) - (t - (unless (<= 0 code 127) - (error "Unexpected non-ASCII header field name")) - #'in-name))) - (in-value (code) - (acase code - (:lf (mark) #'in-new-line) - (:cr (mark) #'after-cr) - (t #'in-value)))) - (let ((state #'in-new-line)) - (loop - (incf pos) - (when (<= (length vector) pos) - (error "No header found in response")) - (setf state (funcall state (aref vector pos)))))))) - - -;;; HTTP URL parsing - -(defclass url () - ((hostname - :initarg :hostname - :accessor hostname - :initform nil) - (port - :initarg :port - :accessor port - :initform 80) - (path - :initarg :path - :accessor path - :initform "/"))) - -(defun parse-urlstring (urlstring) - (setf urlstring (string-trim " " urlstring)) - (let* ((pos (mismatch urlstring "http://" :test 'char-equal)) - (mark pos) - (url (make-instance 'url))) - (labels ((save () - (subseq urlstring mark pos)) - (mark () - (setf mark pos)) - (finish () - (return-from parse-urlstring url)) - (hostname-char-p (char) - (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." - :test 'char-equal)) - (at-start (char) - (case char - (#\/ - (setf (port url) nil) - (mark) - #'in-path) - (t - #'in-host))) - (in-host (char) - (case char - ((#\/ :end) - (setf (hostname url) (save)) - (mark) - #'in-path) - (#\: - (setf (hostname url) (save)) - (mark) - #'in-port) - (t - (unless (hostname-char-p char) - (error "~S is not a valid URL" urlstring)) - #'in-host))) - (in-port (char) - (case char - ((#\/ :end) - (setf (port url) - (parse-integer urlstring - :start (1+ mark) - :end pos)) - (mark) - #'in-path) - (t - (unless (digit-char-p char) - (error "Bad port in URL ~S" urlstring)) - #'in-port))) - (in-path (char) - (case char - ((#\# :end) - (setf (path url) (save)) - (finish))) - #'in-path)) - (let ((state #'at-start)) - (loop - (when (<= (length urlstring) pos) - (funcall state :end) - (finish)) - (setf state (funcall state (aref urlstring pos))) - (incf pos)))))) - -(defun url (thing) - (if (stringp thing) - (parse-urlstring thing) - thing)) - -(defgeneric request-buffer (method url) - (:method (method url) - (setf url (url url)) - (make-request-buffer (hostname url) (port url) (path url) - :method method))) - -(defun urlstring (url) - (format nil "~@[http://~A~]~@[:~D~]~A" - (hostname url) - (and (/= 80 (port url)) (port url)) - (path url))) - -(defmethod print-object ((url url) stream) - (print-unreadable-object (url stream :type t) - (prin1 (urlstring url) stream))) - -(defun merge-urls (url1 url2) - (setf url1 (url url1)) - (setf url2 (url url2)) - (make-instance 'url - :hostname (or (hostname url1) - (hostname url2)) - :port (or (port url1) - (port url2)) - :path (or (path url1) - (path url2)))) - - -;;; Requesting an URL and saving it to a file - -(defparameter *maximum-redirects* 10) -(defvar *default-url-defaults* (url "http://src.quicklisp.org/")) - -(defun read-http-header (cbuf) - (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) - (acode-matcher :cr :cr) - (acode-matcher :cr :lf :cr :lf)) - cbuf))) - (process-header header-data))) - -(defun read-chunk-header (cbuf) - (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) - (end (or (position (acode :cr) header-data) - (position (acode #\;) header-data)))) - (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) - -(defun save-chunk-response (stream cbuf) - "For a chunked response, read all chunks and write them to STREAM." - (let ((fun (make-stream-writer stream)) - (matcher (acode-matcher :cr :lf))) - (loop - (let ((chunk-size (read-chunk-header cbuf))) - (when (zerop chunk-size) - (return)) - (call-for-n-octets chunk-size fun cbuf) - (skip-until-matching matcher cbuf))))) - -(defun save-response (file header cbuf) - (with-open-file (stream file - :direction :output - :if-exists :supersede - :element-type 'octet) - (let ((content-length (content-length header))) - (cond ((chunkedp header) - (save-chunk-response stream cbuf)) - (content-length - (call-for-n-octets content-length - (make-stream-writer stream) - cbuf)) - (t - (call-until-end (make-stream-writer stream) cbuf)))))) - -(defun call-with-progress-bar (size fun) - (let ((progress-bar (make-progress-bar size))) - (start-display progress-bar) - (flet ((update (condition) - (update-progress progress-bar - (cbuf-progress-size condition)))) - (handler-bind ((cbuf-progress #'update)) - (funcall fun))) - (finish-display progress-bar))) - -(defun fetch (url file &key (follow-redirects t) quietly - (maximum-redirects *maximum-redirects*)) - "Request URL and write the body of the response to FILE." - (setf url (merge-urls url *default-url-defaults*)) - (setf file (merge-pathnames file)) - (let ((redirect-count 0) - (original-url url) - (connect-url (or (url *proxy-url*) url)) - (stream (if quietly - (make-broadcast-stream) - *trace-output*))) - (loop - (when (<= maximum-redirects redirect-count) - (error "Too many redirects for ~A" original-url)) - (with-connection (connection (hostname connect-url) (port connect-url)) - (let ((cbuf (make-instance 'cbuf :connection connection)) - (request (request-buffer "GET" url))) - (write-octets request connection) - (let ((header (read-http-header cbuf))) - (loop while (= (status header) 100) - do (setf header (read-http-header cbuf))) - (cond ((= (status header) 200) - (let ((size (content-length header))) - (format stream "~&; Fetching ~A~%" url) - (if (and (numberp size) - (plusp size)) - (format stream "; ~$KB~%" (/ size 1024)) - (format stream "; Unknown size~%")) - (if quietly - (save-response file header cbuf) - (call-with-progress-bar (content-length header) - (lambda () - (save-response file header cbuf)))))) - ((not (<= 300 (status header) 399)) - (error "Unexpected status for ~A: ~A" - url (status header)))) - (if (and follow-redirects (<= 300 (status header) 399)) - (let ((new-urlstring (ascii-header-value "location" header))) - (when (not new-urlstring) - (error "Redirect code ~D received, but no Location: header" - (status header))) - (incf redirect-count) - (setf url (merge-urls new-urlstring - url)) - (format stream "~&; Redirecting to ~A~%" url)) - (return (values header (and file (probe-file file))))))))))) - - -;;; A primitive tar unpacker - -(in-package #:qlqs-minitar) - -(defun make-block-buffer () - (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0)) - -(defun skip-n-blocks (n stream) - (let ((block (make-block-buffer))) - (dotimes (i n) - (read-sequence block stream)))) - -(defun ascii-subseq (vector start end) - (let ((string (make-string (- end start)))) - (loop for i from 0 - for j from start below end - do (setf (char string i) (code-char (aref vector j)))) - string)) - -(defun block-asciiz-string (block start length) - (let* ((end (+ start length)) - (eos (or (position 0 block :start start :end end) - end))) - (ascii-subseq block start eos))) - -(defun prefix (header) - (when (plusp (aref header 345)) - (block-asciiz-string header 345 155))) - -(defun name (header) - (block-asciiz-string header 0 100)) - -(defun payload-size (header) - (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) - -(defun nth-block (n file) - (with-open-file (stream file :element-type '(unsigned-byte 8)) - (let ((block (make-block-buffer))) - (skip-n-blocks (1- n) stream) - (read-sequence block stream) - block))) - -(defun payload-type (code) - (case code - (0 :file) - (48 :file) - (53 :directory) - (t :unsupported))) - -(defun full-path (header) - (let ((prefix (prefix header)) - (name (name header))) - (if prefix - (format nil "~A/~A" prefix name) - name))) - -(defun save-file (file size stream) - (multiple-value-bind (full-blocks partial) - (truncate size 512) - (ensure-directories-exist file) - (with-open-file (outstream file - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)) - (let ((block (make-block-buffer))) - (dotimes (i full-blocks) - (read-sequence block stream) - (write-sequence block outstream)) - (when (plusp partial) - (read-sequence block stream) - (write-sequence block outstream :end partial)))))) - -(defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) - (let ((block (make-block-buffer))) - (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) - (loop - (let ((size (read-sequence block stream))) - (when (zerop size) - (return)) - (unless (= size 512) - (error "Bad size on tarfile")) - (when (every #'zerop block) - (return)) - (let* ((payload-code (aref block 156)) - (payload-type (payload-type payload-code)) - (tar-path (full-path block)) - (full-path (merge-pathnames tar-path directory)) - (payload-size (payload-size block))) - (case payload-type - (:file - (save-file full-path payload-size stream)) - (:directory - (ensure-directories-exist full-path)) - (t - (warn "Unknown tar block payload code -- ~D" payload-code) - (skip-n-blocks (ceiling (payload-size block) 512) stream))))))))) - -(defun contents (tarfile) - (let ((block (make-block-buffer)) - (result '())) - (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) - (loop - (let ((size (read-sequence block stream))) - (when (zerop size) - (return (nreverse result))) - (unless (= size 512) - (error "Bad size on tarfile")) - (when (every #'zerop block) - (return (nreverse result))) - (let* ((payload-type (payload-type (aref block 156))) - (tar-path (full-path block)) - (payload-size (payload-size block))) - (skip-n-blocks (ceiling payload-size 512) stream) - (case payload-type - (:file - (push tar-path result)) - (:directory - (push tar-path result))))))))) - - -;;; -;;; The actual bootstrapping work -;;; - -(in-package #:quicklisp-quickstart) - -(defvar *home* - (merge-pathnames (make-pathname :directory '(:relative "quicklisp")) - (user-homedir-pathname))) - -(defun qmerge (pathname) - (merge-pathnames pathname *home*)) - -(defun renaming-fetch (url file) - (let ((tmpfile (qmerge "tmp/fetch.dat"))) - (fetch url tmpfile) - (rename-file tmpfile file))) - -(defvar *quickstart-parameters* nil - "This plist is populated with parameters that may carry over to the - initial configuration of the client, e.g. :proxy-url - or :initial-dist-url") - -(defvar *quicklisp-hostname* "beta.quicklisp.org") - -(defvar *client-info-url* - (format nil "http://~A/client/quicklisp.sexp" - *quicklisp-hostname*)) - -(defclass client-info () - ((setup-url - :reader setup-url - :initarg :setup-url) - (asdf-url - :reader asdf-url - :initarg :asdf-url) - (client-tar-url - :reader client-tar-url - :initarg :client-tar-url) - (version - :reader version - :initarg :version) - (plist - :reader plist - :initarg :plist) - (source-file - :reader source-file - :initarg :source-file))) - -(defmethod print-object ((client-info client-info) stream) - (print-unreadable-object (client-info stream :type t) - (prin1 (version client-info) stream))) - -(defun safely-read (stream) - (let ((*read-eval* nil)) - (read stream))) - -(defun fetch-client-info-plist (url) - "Fetch and return the client info data at URL." - (let ((local-client-info-file (qmerge "tmp/client-info.sexp"))) - (ensure-directories-exist local-client-info-file) - (renaming-fetch url local-client-info-file) - (with-open-file (stream local-client-info-file) - (list* :source-file local-client-info-file - (safely-read stream))))) - -(defun fetch-client-info (url) - (let ((plist (fetch-client-info-plist url))) - (destructuring-bind (&key setup asdf client-tar version - source-file - &allow-other-keys) - plist - (unless (and setup asdf client-tar version) - (error "Invalid data from client info URL -- ~A" url)) - (make-instance 'client-info - :setup-url (getf setup :url) - :asdf-url (getf asdf :url) - :client-tar-url (getf client-tar :url) - :version version - :plist plist - :source-file source-file)))) - -(defun client-info-url-from-version (version) - (format nil "http://~A/client/~A/client-info.sexp" - *quicklisp-hostname* - version)) - -(defun distinfo-url-from-version (version) - (format nil "http://~A/dist/~A/distinfo.txt" - *quicklisp-hostname* - version)) - -(defvar *help-message* - (format nil "~&~% ==== quicklisp quickstart install help ====~%~% ~ - quicklisp-quickstart:install can take the following ~ - optional arguments:~%~% ~ - :path \"/path/to/installation/\"~%~% ~ - :proxy \"http://your.proxy:port/\"~%~% ~ - :client-url ~%~% ~ - :client-version ~%~% ~ - :dist-url ~%~% ~ - :dist-version ~%~%")) - -(defvar *after-load-message* - (format nil "~&~% ==== quicklisp quickstart ~A loaded ====~%~% ~ - To continue with installation, evaluate: (quicklisp-quickstart:install)~%~% ~ - For installation options, evaluate: (quicklisp-quickstart:help)~%~%" - qlqs-info:*version*)) - -(defvar *after-initial-setup-message* - (with-output-to-string (*standard-output*) - (format t "~&~% ==== quicklisp installed ====~%~%") - (format t " To load a system, use: (ql:quickload \"system-name\")~%~%") - (format t " To find systems, use: (ql:system-apropos \"term\")~%~%") - (format t " To load Quicklisp every time you start Lisp, use: (ql:add-to-init-file)~%~%") - (format t " For more information, see http://www.quicklisp.org/beta/~%~%"))) - -(defun initial-install (&key (client-url *client-info-url*) dist-url) - (setf *quickstart-parameters* - (list :proxy-url *proxy-url* - :initial-dist-url dist-url)) - (ensure-directories-exist (qmerge "tmp/")) - (let ((client-info (fetch-client-info client-url)) - (tmptar (qmerge "tmp/quicklisp.tar")) - (setup (qmerge "setup.lisp")) - (asdf (qmerge "asdf.lisp"))) - (renaming-fetch (client-tar-url client-info) tmptar) - (unpack-tarball tmptar :directory (qmerge "./")) - (renaming-fetch (setup-url client-info) setup) - (renaming-fetch (asdf-url client-info) asdf) - (rename-file (source-file client-info) (qmerge "client-info.sexp")) - (load setup :verbose nil :print nil) - (write-string *after-initial-setup-message*) - (finish-output))) - -(defun help () - (write-string *help-message*) - t) - -(defun non-empty-file-namestring (pathname) - (let ((string (file-namestring pathname))) - (unless (or (null string) - (equal string "")) - string))) - -(defun install (&key ((:path *home*) *home*) - ((:proxy *proxy-url*) *proxy-url*) - client-url - client-version - dist-url - dist-version) - (setf *home* (merge-pathnames *home* (truename *default-pathname-defaults*))) - (let ((name (non-empty-file-namestring *home*))) - (when name - (warn "Making ~A part of the install pathname directory" - name) - ;; This corrects a pathname like "/foo/bar" to "/foo/bar/" and - ;; "foo" to "foo/" - (setf *home* - (make-pathname :defaults *home* - :directory (append (pathname-directory *home*) - (list name)))))) - (let ((setup-file (qmerge "setup.lisp"))) - (when (probe-file setup-file) - (multiple-value-bind (result proceed) - (with-simple-restart (load-setup "Load ~S" setup-file) - (error "Quicklisp has already been installed. Load ~S instead." - setup-file)) - (declare (ignore result)) - (when proceed - (return-from install (load setup-file)))))) - (if (find-package '#:ql) - (progn - (write-line "!!! Quicklisp has already been set up. !!!") - (write-string *after-initial-setup-message*) - t) - (call-with-quiet-compilation - (lambda () - (let ((client-url (or client-url - (and client-version - (client-info-url-from-version client-version)) - *client-info-url*)) - ;; It's ok for dist-url to be nil; there's a default in - ;; the client - (dist-url (or dist-url - (and dist-version - (distinfo-url-from-version dist-version))))) - (initial-install :client-url client-url - :dist-url dist-url)))))) - -(write-string *after-load-message*) - -;;; End of quicklisp.lisp diff --git a/t.lisp b/shinu.lisp similarity index 75% rename from t.lisp rename to shinu.lisp index 30b7fbd..6be8309 100644 --- a/t.lisp +++ b/shinu.lisp @@ -8,17 +8,19 @@ (defmacro rand () `(random 1.0)) (defun rand-rgba () - (list (rand) (rand) (rand) (rand))) + (list (rand) (rand) (rand) 1.0)) (defun main () - (let ((mid (* *size* .5)) - (repeat (random 100)) - (grains (random 10)) - (itt (random 5000)) - (sand (sandpaint* *size* :active (rand-rgba) :bg (rand-rgba)))) + (let* ((mid (* *size* .5)) + (repeat (random 100)) + (grains (random 10)) + (itt (random 5000)) + (bg (rand-rgba)) + (active (rand-rgba)) + (sand (sandpaint* *size* :active active :bg bg))) (loop for i in (linspace 100 900 repeat) for j from 1 to repeat do - (print j) + (format "~d/~d (~d)~%" j repeat (/ j repeat)) (let ((snk (snek*)) (va (list 0 0)) (vb (list 0 0))