From a3425ec303d960b9f8a061d4517825965df240ad Mon Sep 17 00:00:00 2001 From: Arun Welch Date: Sun, 13 Dec 2020 17:51:51 -0700 Subject: [PATCH] Working for Medley 3.5 --- clos/3.5/CLOS-BROWSER.TEDIT | Bin 0 -> 28277 bytes clos/3.5/NEW-CLOS-BROWSER | 4 + clos/3.5/NEW-CLOS-BROWSER.DFASL | Bin 0 -> 61937 bytes clos/3.5/README.MD | 3 + clos/3.5/WEB-EDITOR | 416 +++++++ clos/3.5/WEB-EDITOR.DFASL | Bin 0 -> 99330 bytes clos/3.5/boot.dfasl | Bin 0 -> 29368 bytes clos/3.5/boot.lisp | 1297 +++++++++++++++++++ clos/3.5/braid.dfasl | Bin 0 -> 14543 bytes clos/3.5/braid.lisp | 503 ++++++++ clos/3.5/cache.dfasl | Bin 0 -> 28207 bytes clos/3.5/cache.lisp | 1089 ++++++++++++++++ clos/3.5/clos-env-internal.DFASL | Bin 0 -> 2992 bytes clos/3.5/clos-env-internal.lisp | 260 ++++ clos/3.5/clos-env.DFASL | Bin 0 -> 42337 bytes clos/3.5/clos-env.lisp | 1609 ++++++++++++++++++++++++ clos/3.5/combin.dfasl | Bin 0 -> 6934 bytes clos/3.5/combin.lisp | 254 ++++ clos/3.5/compat.dfasl | Bin 0 -> 321 bytes clos/3.5/compat.lisp | 11 + clos/3.5/construct.dfasl | Bin 0 -> 22819 bytes clos/3.5/construct.lisp | 1090 ++++++++++++++++ clos/3.5/cpl.dfasl | Bin 0 -> 6464 bytes clos/3.5/cpl.lisp | 271 ++++ clos/3.5/ctypes.dfasl | Bin 0 -> 801 bytes clos/3.5/ctypes.lisp | 25 + clos/3.5/defclass.dfasl | Bin 0 -> 5515 bytes clos/3.5/defclass.lisp | 230 ++++ clos/3.5/defcombin.dfasl | Bin 0 -> 10496 bytes clos/3.5/defcombin.lisp | 410 ++++++ clos/3.5/defs.DFASL | Bin 0 -> 21525 bytes clos/3.5/defs.lisp | 570 +++++++++ clos/3.5/defsys.DFASL | Bin 0 -> 12629 bytes clos/3.5/defsys.lisp | 761 ++++++++++++ clos/3.5/dfun.dfasl | Bin 0 -> 14841 bytes clos/3.5/dfun.lisp | 606 +++++++++ clos/3.5/dlap.dfasl | Bin 0 -> 12774 bytes clos/3.5/dlap.lisp | 492 ++++++++ clos/3.5/env.dfasl | Bin 0 -> 9265 bytes clos/3.5/env.lisp | 200 +++ clos/3.5/fin.dfasl | Bin 0 -> 7209 bytes clos/3.5/fin.lisp | 235 ++++ clos/3.5/fixup.dfasl | Bin 0 -> 547 bytes clos/3.5/fixup.lisp | 15 + clos/3.5/fngen.dfasl | Bin 0 -> 3726 bytes clos/3.5/fngen.lisp | 172 +++ clos/3.5/fsc.dfasl | Bin 0 -> 2139 bytes clos/3.5/fsc.lisp | 72 ++ clos/3.5/init.dfasl | Bin 0 -> 4963 bytes clos/3.5/init.lisp | 183 +++ clos/3.5/iterate.dfasl | Bin 0 -> 24169 bytes clos/3.5/iterate.lisp | 1080 ++++++++++++++++ clos/3.5/lap.dfasl | Bin 0 -> 16273 bytes clos/3.5/lap.lisp | 364 ++++++ clos/3.5/low.dfasl | Bin 0 -> 5165 bytes clos/3.5/low.lisp | 194 +++ clos/3.5/low2.dfasl | Bin 0 -> 3300 bytes clos/3.5/low2.lisp | 144 +++ clos/3.5/macros.dfasl | Bin 0 -> 12420 bytes clos/3.5/macros.lisp | 355 ++++++ clos/3.5/methods.dfasl | Bin 0 -> 39714 bytes clos/3.5/methods.lisp | 1304 +++++++++++++++++++ clos/3.5/patch.dfasl | Bin 0 -> 2852 bytes clos/3.5/patch.lisp | 143 +++ clos/3.5/pkg.dfasl | Bin 0 -> 1975 bytes clos/3.5/pkg.lisp | 81 ++ clos/3.5/plap.dfasl | Bin 0 -> 16188 bytes clos/3.5/plap.lisp | 309 +++++ clos/3.5/precom1.dfasl | Bin 0 -> 686 bytes clos/3.5/precom1.lisp | 31 + clos/3.5/precom2.dfasl | Bin 0 -> 19857 bytes clos/3.5/precom2.lisp | 12 + clos/3.5/precom4.dfasl | Bin 0 -> 5599 bytes clos/3.5/precom4.lisp | 12 + clos/3.5/slots.dfasl | Bin 0 -> 7728 bytes clos/3.5/slots.lisp | 261 ++++ clos/3.5/std-class.dfasl | Bin 0 -> 46612 bytes clos/3.5/std-class.lisp | 997 +++++++++++++++ clos/3.5/vector.dfasl | Bin 0 -> 12305 bytes clos/3.5/vector.lisp | 368 ++++++ clos/3.5/walk.dfasl | Bin 0 -> 19597 bytes clos/3.5/walk.lisp | 2005 ++++++++++++++++++++++++++++++ 82 files changed, 18438 insertions(+) create mode 100644 clos/3.5/CLOS-BROWSER.TEDIT create mode 100644 clos/3.5/NEW-CLOS-BROWSER create mode 100644 clos/3.5/NEW-CLOS-BROWSER.DFASL create mode 100644 clos/3.5/README.MD create mode 100644 clos/3.5/WEB-EDITOR create mode 100644 clos/3.5/WEB-EDITOR.DFASL create mode 100644 clos/3.5/boot.dfasl create mode 100644 clos/3.5/boot.lisp create mode 100644 clos/3.5/braid.dfasl create mode 100644 clos/3.5/braid.lisp create mode 100644 clos/3.5/cache.dfasl create mode 100644 clos/3.5/cache.lisp create mode 100644 clos/3.5/clos-env-internal.DFASL create mode 100644 clos/3.5/clos-env-internal.lisp create mode 100644 clos/3.5/clos-env.DFASL create mode 100644 clos/3.5/clos-env.lisp create mode 100644 clos/3.5/combin.dfasl create mode 100644 clos/3.5/combin.lisp create mode 100644 clos/3.5/compat.dfasl create mode 100644 clos/3.5/compat.lisp create mode 100644 clos/3.5/construct.dfasl create mode 100644 clos/3.5/construct.lisp create mode 100644 clos/3.5/cpl.dfasl create mode 100644 clos/3.5/cpl.lisp create mode 100644 clos/3.5/ctypes.dfasl create mode 100644 clos/3.5/ctypes.lisp create mode 100644 clos/3.5/defclass.dfasl create mode 100644 clos/3.5/defclass.lisp create mode 100644 clos/3.5/defcombin.dfasl create mode 100644 clos/3.5/defcombin.lisp create mode 100644 clos/3.5/defs.DFASL create mode 100644 clos/3.5/defs.lisp create mode 100644 clos/3.5/defsys.DFASL create mode 100644 clos/3.5/defsys.lisp create mode 100644 clos/3.5/dfun.dfasl create mode 100644 clos/3.5/dfun.lisp create mode 100644 clos/3.5/dlap.dfasl create mode 100644 clos/3.5/dlap.lisp create mode 100644 clos/3.5/env.dfasl create mode 100644 clos/3.5/env.lisp create mode 100644 clos/3.5/fin.dfasl create mode 100644 clos/3.5/fin.lisp create mode 100644 clos/3.5/fixup.dfasl create mode 100644 clos/3.5/fixup.lisp create mode 100644 clos/3.5/fngen.dfasl create mode 100644 clos/3.5/fngen.lisp create mode 100644 clos/3.5/fsc.dfasl create mode 100644 clos/3.5/fsc.lisp create mode 100644 clos/3.5/init.dfasl create mode 100644 clos/3.5/init.lisp create mode 100644 clos/3.5/iterate.dfasl create mode 100644 clos/3.5/iterate.lisp create mode 100644 clos/3.5/lap.dfasl create mode 100644 clos/3.5/lap.lisp create mode 100644 clos/3.5/low.dfasl create mode 100644 clos/3.5/low.lisp create mode 100644 clos/3.5/low2.dfasl create mode 100644 clos/3.5/low2.lisp create mode 100644 clos/3.5/macros.dfasl create mode 100644 clos/3.5/macros.lisp create mode 100644 clos/3.5/methods.dfasl create mode 100644 clos/3.5/methods.lisp create mode 100644 clos/3.5/patch.dfasl create mode 100644 clos/3.5/patch.lisp create mode 100644 clos/3.5/pkg.dfasl create mode 100644 clos/3.5/pkg.lisp create mode 100644 clos/3.5/plap.dfasl create mode 100644 clos/3.5/plap.lisp create mode 100644 clos/3.5/precom1.dfasl create mode 100644 clos/3.5/precom1.lisp create mode 100644 clos/3.5/precom2.dfasl create mode 100644 clos/3.5/precom2.lisp create mode 100644 clos/3.5/precom4.dfasl create mode 100644 clos/3.5/precom4.lisp create mode 100644 clos/3.5/slots.dfasl create mode 100644 clos/3.5/slots.lisp create mode 100644 clos/3.5/std-class.dfasl create mode 100644 clos/3.5/std-class.lisp create mode 100644 clos/3.5/vector.dfasl create mode 100644 clos/3.5/vector.lisp create mode 100644 clos/3.5/walk.dfasl create mode 100644 clos/3.5/walk.lisp diff --git a/clos/3.5/CLOS-BROWSER.TEDIT b/clos/3.5/CLOS-BROWSER.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..21d02b63e25fa40134ff8a7857067c00f8e36a38 GIT binary patch literal 28277 zcmeHwe{fvIooBz%7|%dt&&VXe#kP9J12{QbF(#yp@Y$pB$Qo~CWNZ_TZ1$G1HL@m* zG{eluKLU%#jxHVr%9g!Xw;{`csrus&A z8@Rl+@4ju_TU*zylcmhgayCCK*RCaM9ROt6+O-`)kJ#s0Tld2O4sazb{Ssp27WO}%tSu%Uenc;q7$d;jfQ(2~SrF^|osE0yB zA1T;5m>%AxlxO75T)I?}{h5L6aF%>g;yQ*h<-vTv2i`N7-8m?S(hp|jNI|A$X0!A8H4|T^KhsaL2kH~z1dugDUA7ZB`(mNmARm_i|Et^4iL=xzWbS|fxrajAstxTwH z?^J(RZs_gWwoRh%)3ytwlpfo)wYy;l^>l5e_YI=eM4)cf+T~EbewG zEEdNfvXe@YTTkGRrbS{XaQpDb=F~csmM$enY)IA>mL3tp7yPQ0JLoA@)>O}gyEScZ zaxCnY{EP3IdIm5A=S6-r@s04Sa2+)`aQH^eDpvta9q(sy>>~-rN+TojjOQ~>e&JH3qHe(4$mR$Gd=y225OsyJCnZe4r0in3jb$fKT;hqmBIqUcjNFqQ?$7U8A@^j< zgLu&3nLku0^COua9K-1$XC9#*!+11|l<<@<@e`t$&zJQ)LqCnY4+%VN$t!SFQ2d_C zePqsE$1ue|c7p{V%_qpXuqn>&2y=jrgDg z9EF*?{^jZKoco*R9Q*e_{P5r1xA>EdY*9M)f15bYU2MX^mfrR758pj^x(Ua`0kpQ~ zk#*;n-qnPo5o}SsMuKi!foqz5TG&hIG#s9<$t=sn%5KmB{ zhWZ)fzWfMgm!(09DyTW4OqY4~IDpycAWc5N z+$_pl`nGJ})OUARFXAeQ(5$?>YjgL?zO5^JH*MQ4Z~1)p{Zh)#`!?O3?7NTP?VGmu zcFWG5zP_Xi>2z#B7F|k8#8o;Dpd5gk3rIA7*mxUC?+(@j>&UA6t2qIeL6+~9G>B=E*2gFo2 zpcnP(A(Nvu0o+@F`wPV^qGq{$vXuP_s&Z?$rR`Xwix=`G4(x&19vO~*q_zj`Tp_aq zau^E^-3r4-t%4hwDN7v^8_Hv~V!NS?kR$~vX~bQfFJPT355=w@?Z%X|ZkWOtBz zZSE)s;FKSuk}4-*ii!@@3=G3AyLI_tcoLybI9T_seGzb%rx9|sgQu*q_1= zDU-&PyGIYjTxI~HyeNmV{r!kx?qCzhpM_$kL>3|h44hogb`#0=7I%%@kuLJ^1I{%J zVzsK;&4K0eAi5Z}lFL;LR5vPHE@g599V(D3f?~TEMATD?yeM<7i2M+cVKIVSS`_eK z27im9gz_Hd8K%~;ZOzTMuQ|th_||aZaGv7vc8hG&I$AM`xXJ9DMm}kvG>t2%A48Q} zOj&Z(j{II4M0_6_N*5ngi+rZi4WpE&XaJ8A@>WM{A4k0%gB%yLZ*e=zNZe@5ZYSTm zJxWgovU#Q3r7N}h>el0E?9j31A@P|ji6WTMm>E0drXIJJr__bgdPTrWI)aj{a1o_@ zsC0Po+WQ}?{+j}VT__!mCI)&_Sjyf@a_usaOr=uOiZ-rF6(tAGWN+$JRq2G5lT^OOR8sZA)NSMRaVNOR!VLw$n?OMiJb$W82R}A~6KF?bx;z zi7Y3YifyCxSp>JKluVAHM8Rzp+kVJex-^2|wi!0CF1y5X0Sk7)Om4eyO5{&*{gNf~ zo?41X0Qpl~ziinx&qTmU{uI$j#2=v&)7I${%XKYVrf9GeG0G)N{7aW&Qa8Ju-ccZa z1F3auhW6M-%4!2FTfUVZwma0eP^l&==knUyMl|oi{AQQ4<)tov`xaEp?iws(_JSL# zx**+a3RUoJ44mr9a`t3?1y_>y{|Tl2-sRYIt?6+uz}JciT?V~nN(of(r;)tR2Ak8* zOnm049IZk@BmFHGe(H}UM@Nq|q5Fb9rdMatA4{HmyqSJq;LOCy zS1Rrt4&eN32>uDF`ZH>0;#n1bC8KfF^fk8Kc2&FMW0mah2z$B#4 z`=U2bd}~eke>JqvZXN$=JU+Pfv(s&AQ+Y>4UHf|`S(b0&2q@RllPb#0ca4Vh@Wi3V zZhPpuANXIm0oi)_wpgn7)v;jMfAYp-6z8o;JwJLgkQxgH+x?@V@i!MT-Mr*aw)vSJ z0{xF;0oL!O$5N@Wv75sFQAfW)fA1uWs*V-j{(*n=hVcJT_RUPUGs_1vGZ#;gJ?frF zEmit2p4arBH>SV4c5nFyhyU+wGrwXw1np$YpF92hw?DW07w^veJgzC~ucA*c{^Wbl z@BYOvCRu)=axrsi`HM_HKSTA0##z=wKmGjkyLbQnyKKJdytoHvCV;_(H+UErt8+>FVPpBITe^M6OTCZHT1S?Qh}RfA`au&zKU>D9QL7K zp+Dj1H|PP-7ltREoxkA8gk#^46M~Y&MeUDs*7;%mv~__*^lRgsb$%56=BJ{!E?BW_ z;$+Xf{cNlA!_S8!|NWWh@}r-{MP2>+aYxk6RAZ5k_q5Ac?B@CNqzgMaqQ}QUzoqi^ zCiFn{DCn^iZv{GncIL>*rGY~WB<#C2&`7>w2>gcWP3pIVM8%jZ@#dvr4reREpJYK^W!U#N0J4oiFGfs$R|9-`)R$caiE!RXLI zS?JFr%0TO%*_TZEoSrSfiyl7LK%%8wRyjb0Y_4j(^mk${ZiTU(K~}vNjW+? zPPF|-n(leGM!taDW9jB5fv(xyj83X`{=7*)2!-36Xcg3swu)E9Rb zcl;=-q3MO4@3^a8tbh-;V-|-7foCL0D?qY6UB*?T1$*>&hR0}y@ z)GC}k^ZNJRdhDqMx4xq6)QdQO)EZmVwpvzuQ(;-Hs*`5WP$6wmD^P4(G+9lh7DQ+= z9VgJC1&_703DB%4O{7gdww`iVo;jmnn2?K70l&%8hL z{v?$9)clp(@UWUW6YW<-v*?Es>U;Rys(0Vn`w#CfUGleo^Zse`nGkBN`v^uxSs! z_&mv-erYl=Z{o2-J@cPhIk0$&>RU2(@h|qChb`|sJQ=tqhG^Wu$Q@5aNp3$kPyI{= z{E<_szJrlSctHc&Er{^>KwC|;IMr?^>Br=dbVkCgGp-3VK3h&Md$y;?w=@!7vP#KS zLhvCB=kY0M(oD%qSD#G`&Ve<^`1#w{|RwndC=1fKS>uIi}0YwP}cr8>bSQjA-+U*a_CQ zk%${St%;mUX+JKW5uNUXDTKV*U3y5*w!t-yg z-4Di~KOw7u#HxdMo{jq~%b$oddO%h~2bLe47qCL}fL0j21XLb~0re^LQN_DHKxm-q z3k42nUO#x_2cicTR{f!cE{fVJiO9iFDi8{FIkl~oW3cRCsP9z!I8e5%aVtJN8uWkg z==$*~SqTdH!3P^&!5xBIQR(uB1B`}3NqQgv4OD@)i7l0|*b)k*{2INa&mq4{;AHKznHJIb!={JtN zrTyTJ2lSHN;-KFh4?Y()#)B`^_loiZc%AX!YpC5rh+yz*)EN&UFKUkm8S!6I8*0!H(BnZyrVR~xJj6X3^mwRv zQF}Z9buGJ+7B{|YaBDuYpVnY1U(9}mZu_~<^r{tKuotgBNm?n=O_Y!3WQueQ9H%}8 z9d0~3czuW)@E0;zU*iPM+zRAwo7Ipu4A@@GWSZA*R$d0DSu;!GEw#pWyVWYWn$7IZ zyhpG1qv=_}8`?FGkGlPAbuvMV<<@}?|i09)9k5FFWan9TP%oAXq{Y#dCN9jj~ z65}d6OFraNb6>oR5-{`2J3Fsi_11GsmjGYBapT8cZM!Y94Ebat5g7YvBoaaX5z1o@ zPWgiyHwMPqBFuBJvolaV^9;+{23)p1La!L1Q|J{U=YzYdV-po_SIdQGQ(uq8IqwSw zy6<`Agp=Pw&LY`hAQ82BS}x2#7_ntRRcUtraHp|9t*L+o3HGxU;O=MtTfuDUgxxPz z@IQ`$hx^OA5DX&E{bgC4SNtlk^jN_FWUrvVeEiM$WgT_T$BCc^S&)VA^9>`I; z44YN|!pFGA)OD)zG#);Y{>v||?OY>hoZNIQwj;4I$>S%y=*>hTq402Hm5u8r4Pob%^qwd?n_CYf& zBygUs%*zhBO$Q9|D7)OF7PYH|W;byAetiVzzvwc)lGM)2giD4O5r2Wyc9e^RND3fD=6fLQLbWlG3;grpP?9rS;HN~}M8w8F?#`|15NGapQ`t&F@k z^9GRj3kGuOi|yd~a~GMq>raVii;KK>@idSR{=7oaDAlEq_X{TSr^GY$Ckr|j-}xr- zOfCNXr^%jg9K9`?WGR4@rp6CP*2TTZfrtb``c(>zD=A%ukH-&pEMC)Z;ew6}krZ$R z{t2|b9+@}4r)yyG&nG61w{wk`ta*V`-+LmuF&2BkzIj=JYN{)|E*XnSjVvTYnn);h z>U-fR5JxK1)6*4R{Mls_$F-De;fF=kw3nyOq!ixhvX#4<`8*lA&qers>8gqFJJasU zmh{kj)0G+?ygO|o>iuaGu`4&~x;z9G;t}OqDArj*qCEx@;jZ(+07@hfS=q4{xfBBm zx#KnoJf)Ylhf!wfQ zaZejI_no?y-gq>cI)*T>gIJ-b<%VOSX%`XW+|b)fL?oJ+X5(zg6s4zk1?q+}lB5w?gGqdL_N1 zbqoA4*E~}3;B6KDERG%7sGU9{Nd4=ZEb@a!h!^oT06(=Fjm7ouX!Ve#Q}T)`yaH;M z!$BE|N7p6)IC2pxI!OXo8#nkEgOM07{{@gw8K}}T{W$5thaHS0NzW+Z_52ENpr7^B z+jFV>IP}!nZ`Wqof7Ku9ls+ULr;X77HnD2-ICzWO6ZqnfJpT6ED<+#5PvQO4Dz1TKqQ03HiyJi;CZ9u3}fBi@c5we_e8 z3gLmb-;OT(+NfP`gr_OMr8Yq*{gDVEb-0?KToI1x3-d2Lfecbjd!2(;bvU2ZtLIO`W_mo?{5XrJaGY~~?DL0gJNXQr!m+Ksxi?j* zZLcqQ;bb7y*8mr>KnfLG!oBW3fGVthQ%VoxZ_rTqE;gel&rDQRy}+l}zd>uDAHqJJ zSkJ{bW(a>ygZQiP|MSIF!2h}q|C{?y1OGDz4=MiXyG|4S*XtAk8#}h1i;O>qu|tW% zMM}TIe<+VEh^&}+?5Wc0XU|Z(E?zwSx6t!lIgazu*#91DTNF0iE5~sz`qopaJKNgo zaroy|!X?*5KfXxl=rRmd=+SsU#DT9{xL`?iS#@Li^|RooJ`MN?7j8m7@}@CiwYU$y zJ==F!)LeHh6K%0gZTK<}nrS2{qKn=P6cg=rcw3u4cq~c2GL!T#B0Z@(JuPQZ?~hS$ z4ZmaG<>I=wTK?ZU+tdPxH(3e;I+@+`w#uA!qnT7b(pep-%Pw z7+$r+d02XlH&b%J9bRC=mR|S8`QeeF9oTWgDG)V7$4h8fc4YD4MtTz)6KQ;l5jN#_ z@;lyqveVOmev_i#Ue4K*yi3qC`72(O;B_{xRFB#E;W z*@gqTwQuGzrp<>QTELX(8(8#FE6t`uu2 zyss_k)mU^FExpY5e|4|&2t$v0*IYQm?4GEx!{`mq#=0Ft4Rp6O;s2Es=XTyA{HFMF z&24IyORmu#0L|U(6xSJrNfhlDzK|nK?^7bni7>riX+z8xxA!egOz&TsnA*F%HeQci z@5StWO_NXWZZFQ)cmJ(#^O>tgQytc&TKY0DL0 z>>ST{cJ^_#7O*(`xhAIfbv>B9ziVQ8pV!3nes4XdPnPnvg?-_`iQ4PUmWdm(Iy*OJ z?+}1N*Z9&i=k#ILX6q_)fF0*QY`oK_2A7jalIEyrH)GR=~`@l1HPN;^s%g} zSKBI3$8n+Tv-h?unnrDFgxUMvCZFEhu0kY)mau*HK6n-Lyf&=#8EZ?#R`8-B7=GIsH09BrR@&uItAD(oi)_76|3`qsqvUzz#2f&Kl^>HqN3e|>T0$2La# z-hJnjFTM1V;-v3lBIed0(L!N@2-7`>NpQ<4A`fEISJUE zHlK;T3e3}9@R2NizST*{k4Wkd2Z8VHy#7l?o!5T})0LSR;Z0L(uorI=<$?+R0uO(o zn>W?~=$r-Dov-ptT)}Ra$L}IG%4JqWOi;5{_|~ArTWXvzO+SSYcbmuJ+A71~f0*GY9W# z;ab97XrZE6(@LVkc1{ho8_v|sONo0fX6;93IL+x5EkWv)^^LoiZRMZU^sB9>AvZpitNVtcXQo9zHGDb+_j8RT}Vl!H=nm(asx0FxB1rh3@T}Hgt(5FvUiZzb>$x zu5YT7C|9nN%~E~s!|1`(692??^aE|=;#qaNePFv$dB?}k;So|o4tSO_bRLf3w!=j*^wK+-g5EJa$@;*^GbifQ=Bz<1ow(GlR~c8X9A?1 zAMoT85@}Sg@2RWnSkhIe{6VV6XwFSmDn!2dJ|4S`!e=XqjJ2jR>R+=0%c%lTD z?ie&V(57piyn2hfOkGrcoq?X7B#t|5k$Lp4h3DEOf@fgY4M+mk+4A^9cQSzwNg(MS zAb=Jg4nTxD7i=~;oNfiHpXMgB8%69i?z~qs-`h)&PO+wdP;mlY*M?uT5P9@T^q(m4Gjr9H`#Xo%M&G7N@`R Go&N`$+@%Nr literal 0 HcmV?d00001 diff --git a/clos/3.5/NEW-CLOS-BROWSER b/clos/3.5/NEW-CLOS-BROWSER new file mode 100644 index 00000000..c9b89d75 --- /dev/null +++ b/clos/3.5/NEW-CLOS-BROWSER @@ -0,0 +1,4 @@ +(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (CLIN-PACKAGE "CLOS-BROWSER") (CLUSE-PACKAGE "CLOS") ( CLFIND-PACKAGE "USER")) READTABLE "XCL" BASE 10) (IL:FILECREATED " 4-Dec-2020 21:30:58"  IL:|{DSK}arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>CURRENT>NEW-CLOS-BROWSER.;2| 97081 IL:|changes| IL:|to:| (CLOS::CLASSES CLOS-BROWSER:CLOS-ICON CLOS-BROWSER:CLOS-BROWSER CLOS-BROWSER::CLOS-BROWSER-NODE) (CLOS::METHODS (CLOS-BROWSER::ADD-ROOT (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::ADD-ROOTS (CLOS-BROWSER:CLOS-BROWSER)) (WEB:BOX-NODE (CLOS-BROWSER:CLOS-BROWSER)) (WEB:BROWSE (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES ( CLOS-BROWSER:CLOS-BROWSER )) (WEB:ICON-TITLE (CLOS-BROWSER:CLOS-BROWSER)) (WEB:INITIALIZE-EDITOR (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER:CLOS-BROWSER)) (WEB:RECOMPUTE (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::REAL-ADD-ROOT (CLOS-BROWSER:CLOS-BROWSER)) (WEB:SHAPE-TO-HOLD (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::SUBCLASSES-OF NIL) (CLOS-BROWSER::CONTAINS-P (T CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::OBJECT-NAME (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::OVERRIDE (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::CACHE (T CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::UNCACHE (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER:ADD-BROWSER-METHOD (CLOS-BROWSER::CLOS-BROWSER-NODE )) (CLOS-BROWSER::BROWSE-SUBS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::EDIT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::INSPECT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::MENU-METHODS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::MAKE-WHENSELECTEDFN ( CLOS-BROWSER::CLOS-BROWSER-NODE )) (CLOS-BROWSER::DESCRIBE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::DOCUMENTATION-CLASS ( CLOS-BROWSER::CLOS-BROWSER-NODE )) (CLOS-BROWSER::PRINT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::SPECIALIZE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE) ) (CLOS::COMPUTE-INHERITED-METHODS (STANDARD-CLASS)) (CLOS-BROWSER::SPECIALIZE (STANDARD-CLASS)) (CLOS-BROWSER::SUBCLASSES-OF (STANDARD-CLASS)) (CLOS-BROWSER::DELETE-METHOD (STANDARD-METHOD)) (CLOS-BROWSER::COPY (STANDARD-METHOD STANDARD-CLASS)) (WEB:MOVE (STANDARD-METHOD STANDARD-CLASS)) (CLOS-BROWSER::PRINT-DEFINITION (STANDARD-METHOD))) (IL:VARS IL:NEW-CLOS-BROWSERCOMS) (IL:PROPS (IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT)) (IL:VARIABLES CLOS-BROWSER:CLOS-ICON) (IL:FUNCTIONS CLOS-BROWSER:BROWSE-CLASS CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::MAKE-NODES CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN CLOS-BROWSER::BROWSER-CONTAINS-P CLOS-BROWSER::EDIT CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU CLOS-BROWSER::COMPLETE-ADD-METHOD CLOS-BROWSER::COMPLETE-SPECIALIZE CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE CLOS-BROWSER::THIS-CLASS-NODE-P CLOS::CLASS-DIRECT-METHODS) IL:|previous| IL:|date:| " 4-Dec-91 12:16:19" IL:|{DSK}arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>BROWSER>NEW-CLOS-BROWSER.;22|) ; Copyright (c) 1991, 2020 by Venue. All rights reserved. (IL:PRETTYCOMPRINT IL:NEW-CLOS-BROWSERCOMS) (IL:RPAQQ IL:NEW-CLOS-BROWSERCOMS ( (IL:* IL:|;;;| "***************************************") (IL:* IL:|;;;| "") (IL:* IL:|;;;| "Print out a copyright notice when loading") (IL:* IL:|;;| "") (IL:P (FORMAT T "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation. All rights reserved.~%" )) (IL:* IL:|;;;| "LOAD DEPENDENT MODULES") (IL:* IL:|;;| "Note: before compiling clos-browser:") (IL:* IL:|;;| " (load 'web-editor.dfasl)") (IL:* IL:|;;| " (load 'clos-browser.dfasl)") (IL:* IL:|;;| " (load 'clos-browser 'prop)") (IL:* IL:|;;| "") (IL:* IL:|;;;| "PACKAGE STUFF ") (IL:PROPS (IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT) (IL:NEW-CLOS-BROWSER IL:FILETYPE)) (IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)") (IL:* IL:|;;| "") (IL:* IL:|;;;| "SYSTEM PATCHES") (IL:* IL:|;;| "") (IL:* IL:|;;| "") (IL:* IL:|;;| "") (IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION") (CLOS::CLASSES CLOS-BROWSER:CLOS-ICON) (IL:VARIABLES CLOS-BROWSER:CLOS-ICON) (IL:* IL:|;;| "") (IL:* IL:|;;;| "CLOS-BROWSER CLASS") (IL:FUNCTIONS CLOS-BROWSER:BROWSE-CLASS CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::MAKE-NODES CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN CLOS-BROWSER::BROWSER-CONTAINS-P) (CLOS::CLASSES CLOS-BROWSER:CLOS-BROWSER) (CLOS::METHODS (CLOS-BROWSER::ADD-ROOT (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::ADD-ROOTS (CLOS-BROWSER:CLOS-BROWSER)) (WEB:BOX-NODE (CLOS-BROWSER:CLOS-BROWSER)) (WEB:BROWSE (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES (CLOS-BROWSER:CLOS-BROWSER)) (WEB:ICON-TITLE (CLOS-BROWSER:CLOS-BROWSER)) (WEB:INITIALIZE-EDITOR (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER:CLOS-BROWSER)) (WEB:RECOMPUTE (CLOS-BROWSER:CLOS-BROWSER)) (CLOS-BROWSER::REAL-ADD-ROOT (CLOS-BROWSER:CLOS-BROWSER)) (WEB:SHAPE-TO-HOLD (CLOS-BROWSER:CLOS-BROWSER)) (IL:* IL:\; "multi-method") (CLOS-BROWSER::SUBCLASSES-OF NIL) (CLOS-BROWSER::CONTAINS-P (T CLOS-BROWSER:CLOS-BROWSER))) (IL:* IL:|;;| "") (IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS") (CLOS::CLASSES CLOS-BROWSER::CLOS-BROWSER-NODE) (CLOS::METHODS (CLOS-BROWSER::OBJECT-NAME (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::OVERRIDE (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::CACHE (T CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::UNCACHE (CLOS-BROWSER::CLOS-BROWSER-NODE))) (IL:VARS (CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING "Left button to edit the method." "\ +" "Middle button provides a menu of operations." ))) (IL:FUNCTIONS CLOS-BROWSER::EDIT CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU) (IL:* IL:|;;| "") (IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS") (CLOS::METHODS (CLOS-BROWSER:ADD-BROWSER-METHOD (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::BROWSE-SUBS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::EDIT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::INSPECT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::MENU-METHODS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::MAKE-WHENSELECTEDFN (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::DESCRIBE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::DOCUMENTATION-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::PRINT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER::SPECIALIZE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))) (IL:FUNCTIONS CLOS-BROWSER::COMPLETE-ADD-METHOD CLOS-BROWSER::COMPLETE-SPECIALIZE CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE CLOS-BROWSER::THIS-CLASS-NODE-P CLOS::CLASS-DIRECT-METHODS) (IL:* IL:|;;| "") (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)") (CLOS::METHODS (CLOS::COMPUTE-INHERITED-METHODS (STANDARD-CLASS)) (CLOS-BROWSER::SPECIALIZE (STANDARD-CLASS)) (CLOS-BROWSER::SUBCLASSES-OF (STANDARD-CLASS))) (IL:* IL:|;;| "") (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD") (CLOS::METHODS (CLOS-BROWSER::DELETE-METHOD (STANDARD-METHOD)) (CLOS-BROWSER::COPY (STANDARD-METHOD STANDARD-CLASS)) (WEB:MOVE (STANDARD-METHOD STANDARD-CLASS)) (IL:* IL:\;  "web:move is shadowed above") (CLOS-BROWSER::PRINT-DEFINITION (STANDARD-METHOD)) (CLOS-BROWSER::DESCRIBE-METHOD (CLOS::METHOD)) (CLOS-BROWSER::RENAME (STANDARD-METHOD)) (CLOS-BROWSER::UPDATE-CACHED-MENUES (STANDARD-METHOD)) (CLOS-BROWSER::WHO-OWNS (STANDARD-METHOD)) (IL:* IL:|;;|  "update-cached-menues must appear before add-method :after in the coms") (ADD-METHOD :AFTER (STANDARD-GENERIC-FUNCTION STANDARD-METHOD))) (IL:FUNCTIONS CLOS-BROWSER::REPLACE-SPECIALIZERS) (IL:* IL:|;;| "") (IL:* IL:|;;;| "SETUP RELEASE INFO") (IL:VARS (CLOS-BROWSER::RELEASE-ID "0.02") (CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES)))) (IL:* IL:|;;| "") (IL:* IL:|;;| "") (IL:* IL:|;;| "SETUP BACKGROUND MENU") (IL:FUNCTIONS CLOS-BROWSER::IN-SELECT-PACKAGE CLOS-BROWSER::CLASSES-IN-PACKAGE) (IL:P (IL:* IL:|;;| "pushnew should eliminate this") (SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| IL:|BackgroundMenuCommands| :KEY #'CAR)) (PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS) "Bring up a class browser." (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS (CLOS-BROWSER::CLASSES-IN-PACKAGE (CLOS-BROWSER::IN-SELECT-PACKAGE ))) "Select a package and browse all the classes defined in that package." ))) IL:|BackgroundMenuCommands|) (SETQ IL:|BackgroundMenu| NIL)))) (IL:* IL:|;;;| "***************************************") (IL:* IL:|;;;| "") (IL:* IL:|;;;| "Print out a copyright notice when loading") (IL:* IL:|;;| "") (FORMAT T "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation. All rights reserved.~%") (IL:* IL:|;;;| "LOAD DEPENDENT MODULES") (IL:* IL:|;;| "Note: before compiling clos-browser:") (IL:* IL:|;;| " (load 'web-editor.dfasl)") (IL:* IL:|;;| " (load 'clos-browser.dfasl)") (IL:* IL:|;;| " (load 'clos-browser 'prop)") (IL:* IL:|;;| "") (IL:* IL:|;;;| "PACKAGE STUFF ") (IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT (:PACKAGE (LET ((*PACKAGE*)) (IN-PACKAGE "CLOS-BROWSER" ) (USE-PACKAGE "CLOS") (FIND-PACKAGE "USER") ) :READTABLE "XCL" :BASE 10)) (IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:FILETYPE :COMPILE-FILE) (IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)") (IL:* IL:|;;| "") (IL:* IL:|;;;| "SYSTEM PATCHES") (IL:* IL:|;;| "") (IL:* IL:|;;| "") (IL:* IL:|;;| "") (IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION") (DEFCLASS CLOS-BROWSER:CLOS-ICON (STANDARD-OBJECT) ((CLOS-BROWSER::CLASS-BROWSERS :ALLOCATION :CLASS :INITFORM NIL) (IL:* IL:\;  "list of all open browsers") (CLOS-BROWSER::DESTINATION-BROWSER :ALLOCATION :CLASS :INITFORM NIL) (IL:* IL:\;  "browser containing boxed node") (CLOS-BROWSER::MENU-CACHE-SWITCH :ALLOCATION :CLASS :INITFORM :LAZY (IL:* IL:|;;| "valid values:") (IL:* IL:|;;| ":none for never use cache") (IL:* IL:|;;| ":lazy for invalidate cache at method create or remove time causing re-compute and cache at menu request time.") (IL:* IL:|;;|  ":eager (not implemented) for re-compute and cache menu whenever a method is created or removed") ))) (XCL:DEFGLOBALPARAMETER CLOS-BROWSER:CLOS-ICON (MAKE-INSTANCE 'CLOS-BROWSER:CLOS-ICON)) (IL:* IL:|;;| "") (IL:* IL:|;;;| "CLOS-BROWSER CLASS") (DEFUN CLOS-BROWSER:BROWSE-CLASS (&OPTIONAL CLOS-BROWSER::CLASS-NAME-OR-LIST &KEY ( CLOS-BROWSER::DIRECTION :SUB) (CLOS-BROWSER::WINDOW-OR-TITLE "CLOS-browser") CLOS-BROWSER::GOOD-CLASSES POSITION) (LET* ((CLOS-BROWSER::ROOT-CLASSES (WHEN CLOS-BROWSER::CLASS-NAME-OR-LIST (IF (LISTP CLOS-BROWSER::CLASS-NAME-OR-LIST) (MAPCAR #'FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST) (CONS (FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST))))) (CLOS-BROWSER::NODES (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY NIL CLOS-BROWSER::ROOT-CLASSES))) (CLOS-BROWSER:CLOS-BROWSER (MAKE-INSTANCE 'CLOS-BROWSER:CLOS-BROWSER))) (WEB:INITIALIZE-EDITOR CLOS-BROWSER:CLOS-BROWSER) (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-BROWSER 'CLOS-BROWSER::ROOT-CLASSES) CLOS-BROWSER::ROOT-CLASSES) (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-BROWSER 'CLOS-BROWSER::TITLE) CLOS-BROWSER::CLASS-NAME-OR-LIST) (WEB:BROWSE CLOS-BROWSER:CLOS-BROWSER CLOS-BROWSER::NODES CLOS-BROWSER::WINDOW-OR-TITLE CLOS-BROWSER::GOOD-CLASSES POSITION) (UNLESS CLOS-BROWSER::NODES (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER:CLOS-BROWSER)) CLOS-BROWSER:CLOS-BROWSER)) (DEFUN CLOS-BROWSER::COLLECT-FAMILY (CLOS-BROWSER::FAMILY CLOS-BROWSER::CLASS-LIST) "gather all of the sub-classes of the class passed as family" (IL:* IL:|;;| "for efficiency, to avoid gathering and filtering subclasses more than once, we assume family only contains classes whose family has already been gathered.") (IF CLOS-BROWSER::CLASS-LIST (LET ((CLOS-BROWSER::FIRST-CLASS (CAR CLOS-BROWSER::CLASS-LIST)) (REST (CDR CLOS-BROWSER::CLASS-LIST))) (IF (MEMBER CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY) (PROGN (IL:* IL:|;;| "skip gathering class-direct-subclasses ") (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY REST)) (PROGN (PUSH CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY) (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY (APPEND REST ( CLOS::CLASS-DIRECT-SUBCLASSES CLOS-BROWSER::FIRST-CLASS )))))) CLOS-BROWSER::FAMILY)) (DEFUN CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::CLASS-LIST) (LET* ((CLOS-BROWSER::NODE-HASH (MAKE-HASH-TABLE)) (CLOS-BROWSER::NODE-LIST (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::CLASS &AUX (CLOS-BROWSER::NODE (MAKE-INSTANCE ' CLOS-BROWSER::CLOS-BROWSER-NODE ))) (SETF (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS) CLOS-BROWSER::CLASS) (SETF (WEB:NODE-NAME CLOS-BROWSER::NODE) (CLASS-NAME CLOS-BROWSER::CLASS)) (SETF (GETHASH CLOS-BROWSER::CLASS CLOS-BROWSER::NODE-HASH) CLOS-BROWSER::NODE) CLOS-BROWSER::NODE) CLOS-BROWSER::CLASS-LIST))) (DOLIST (CLOS-BROWSER::NODE CLOS-BROWSER::NODE-LIST) (SETF (WEB:NODE-LINKS CLOS-BROWSER::NODE) (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::SUB) (GETHASH CLOS-BROWSER::SUB CLOS-BROWSER::NODE-HASH)) (CLOS::CLASS-DIRECT-SUBCLASSES (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))))) CLOS-BROWSER::NODE-LIST)) (DEFUN CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN (CLOS-BROWSER::WINDOW) (LET ((CLOS-BROWSER::BROWSER (IL:WINDOWPROP CLOS-BROWSER::WINDOW 'WEB:WEB-EDITOR))) (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS) (REMOVE CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS))) (WHEN (EQ CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)) (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) NIL)))) (DEFUN CLOS-BROWSER::BROWSER-CONTAINS-P (CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER) "created because too slow to call contains-p method inside a tight loop" (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::STARTING-LIST) :TEST #'CLOS-BROWSER::THIS-CLASS-NODE-P)))) (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::BAD-LIST) :TEST #'CLOS-BROWSER::THIS-CLASS-NODE-P))) CLOS-BROWSER::NODE))) (DEFCLASS CLOS-BROWSER:CLOS-BROWSER (WEB:WEB-EDITOR) ((CLOS-BROWSER::ROOT-CLASSES) (WEB:TITLE-ITEMS :ALLOCATION :INSTANCE (IL:* IL:|;;| "Items for menu of selections in title of window") :INITFORM '(("Recompute" WEB:RECOMPUTE "Recompute lattice from starting objects" (IL:SUBITEMS ("Recompute" WEB:RECOMPUTE "Recompute lattice from starting objects") ("Recompute labels" WEB:RECOMPUTE-LABELS "Recomputes the labels") ("Recompute in place" WEB:RECOMPUTE-IN-PLACE "Recompute keeping current view in window") ("Clear caches" CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES "Clear cached menues of methods."))) ("Browser looks" NIL "" (IL:SUBITEMS ("Shape to hold" WEB:SHAPE-TO-HOLD "Make window large or small enough to just hold graph" ) ("Change font size" WEB:CHANGE-FONT-SIZE "Choose a new size Font") ("Change format" WEB:CHANGE-FORMAT "Change format between lattice and tree"))) ("Add root " CLOS-BROWSER::ADD-ROOT "Add named item to startingList for browser." (IL:SUBITEMS ("all in a package" CLOS-BROWSER::ADD-ROOTS "Add all the classes in a package to this browser."))) (IL:* IL:|;;|  "(\"Unhide class\" remove-from-bad-list \"Restore item previously deleted from browser\")") )) (WEB:LEFT-BUTTON-ITEMS :ALLOCATION :CLASS (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see local-commands") :INITFORM 'WEB:BOX-NODE) (WEB:MIDDLE-BUTTON-ITEMS :ALLOCATION :INSTANCE (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see local-commands") :INITFORM '(("Edit" CLOS-BROWSER::EDIT-CLASS "Edit the class." (IL:SUBITEMS ("Edit" CLOS-BROWSER::EDIT-CLASS "Edit the class." ) ("Inspect" CLOS-BROWSER::INSPECT-CLASS "Bring up an inspector on the class." ))) ("Add method" CLOS-BROWSER:ADD-BROWSER-METHOD "Add a method to the class.") ("Browse" CLOS-BROWSER::BROWSE-SUBS "Bring up a browser on this class." (WHEN NIL (IL:* IL:\;  "superclasses not implemented") (IL:SUBITEMS ("sub classes" CLOS-BROWSER::BROWSE-SUBS "Bring up a browser on this class.") ("super classes" CLOS-BROWSER::BROWSE-SUPERS "Not Implemented")))) ("Print" CLOS-BROWSER::PRINT-CLASS "Print the form defining the class." (IL:SUBITEMS ("Print" CLOS-BROWSER::PRINT-CLASS "Print the form defining the class.") ("Describe" CLOS-BROWSER::DESCRIBE-CLASS "Print a description of the class.") ("Documentation" CLOS-BROWSER::DOCUMENTATION-CLASS "Display the documentation for the class."))) ("Specialize" CLOS-BROWSER::SPECIALIZE-CLASS "Create a new sub-class of this class.") ("------" CLOS-BROWSER::EDIT-CLASS "Above this line operates on the class.\ +Below this line operates on individual slots and methods." ) ("slots" CLOS-BROWSER::EDIT-CLASS "Edit the defclass definition.") ("methods" (CLOS-BROWSER::MENU-METHODS) "Build a menu of methods local to this class." (IL:SUBITEMS ("local" (CLOS-BROWSER::MENU-METHODS) "Show a menu of methods specialized on this class.." (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS) "Do not recompute the menu of methods") ("Recompute menu" (CLOS-BROWSER::MENU-METHODS NIL NIL NIL T) "Recompute the menu of methods"))) ("inherited" (CLOS-BROWSER::MENU-METHODS :INHERITED) "Show only methods inherited by this class." (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS :INHERITED) "Do not recompute the menu of methods") ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :INHERITED NIL NIL T) "Recompute the menu of methods"))) ("all" (CLOS-BROWSER::MENU-METHODS :ALL) "Show all methods understood by this class." (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS :ALL) "Do not recompute the menu of methods") ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :ALL NIL NIL T) "Recompute the menu of methods"))))))) (CLOS-BROWSER::TITLE :INITFORM "CLOS Browser" (IL:* IL:\;  "Title passed to GRAPHER package")))) (DEFMETHOD CLOS-BROWSER::ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER:CLOS-BROWSER) &OPTIONAL (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER::NEW-ITEM CLOS-BROWSER::BROWSER))) "Add a named item to the starting list of the browser " (IF (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::NEW-ITEM) (WEB:RECOMPUTE CLOS-BROWSER::BROWSER) (IL:* IL:|;;| "otherwise warn the user") (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." CLOS-BROWSER::NEW-ITEM)))) (DEFMETHOD CLOS-BROWSER::ADD-ROOTS ((CLOS-BROWSER::BROWSER CLOS-BROWSER:CLOS-BROWSER) &OPTIONAL (CLOS-BROWSER::NEW-ITEMS (CLOS-BROWSER::CLASSES-IN-PACKAGE (CLOS-BROWSER::IN-SELECT-PACKAGE )))) "Add all classes in a package to the starting list of the browser" (DOLIST (CLOS-BROWSER::CLASS CLOS-BROWSER::NEW-ITEMS) (UNLESS (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::CLASS) (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." CLOS-BROWSER::CLASS)))) (WEB:RECOMPUTE CLOS-BROWSER::BROWSER)) (DEFMETHOD WEB:BOX-NODE ((CLOS-BROWSER::BROWSER CLOS-BROWSER:CLOS-BROWSER) CLOS-BROWSER::OBJECT &OPTIONAL CLOS-BROWSER::KEEP-PREVIOUS-BOX) (CALL-NEXT-METHOD) (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) CLOS-BROWSER::BROWSER)) (DEFMETHOD WEB:BROWSE ((CLOS-BROWSER::SELF CLOS-BROWSER:CLOS-BROWSER) &OPTIONAL CLOS-BROWSER::BROWSE-LIST CLOS-BROWSER::WINDOW-OR-TITLE CLOS-BROWSER::GOOD-LIST POSITION) (LET ((CLOS-BROWSER::BROWSER (CALL-NEXT-METHOD))) (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)))) (DEFMETHOD CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES ((CLOS-BROWSER::SELF CLOS-BROWSER:CLOS-BROWSER) ) (DOLIST (CLOS-BROWSER::NODE (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST (IL:* IL:\;  "starting-list is really all the nodes in the browser.") )) (SETF (SLOT-VALUE CLOS-BROWSER::NODE WEB::MENU-CACHE) NIL))) (DEFMETHOD WEB:ICON-TITLE ((CLOS-BROWSER::SELF CLOS-BROWSER:CLOS-BROWSER)) (WEB:NODE-NAME (CAR (LAST (SLOT-VALUE CLOS-BROWSER::SELF `WEB::STARTING-LIST))))) (DEFMETHOD WEB:INITIALIZE-EDITOR ((CLOS-BROWSER::BROWSER CLOS-BROWSER:CLOS-BROWSER)) "initialize and setup closefn" (CALL-NEXT-METHOD) (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)) (LET ((CLOS-BROWSER::WINDOW (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::WINDOW))) (IL:WINDOWADDPROP CLOS-BROWSER::WINDOW 'IL:CLOSEFN 'CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN T)) CLOS-BROWSER::BROWSER) (DEFMETHOD CLOS-BROWSER::NEW-ITEM ((CLOS-BROWSER::SELF CLOS-BROWSER:CLOS-BROWSER) &OPTIONAL CLOS-BROWSER::NEW-ITEM) (UNLESS CLOS-BROWSER::NEW-ITEM (SETQ CLOS-BROWSER::NEW-ITEM (WEB:PROMPT-READ CLOS-BROWSER::SELF "Class")))) (DEFMETHOD WEB:RECOMPUTE ((CLOS-BROWSER::SELF CLOS-BROWSER:CLOS-BROWSER) &OPTIONAL CLOS-BROWSER::DONT-RESHAPE-FLG) (IL:* IL:|;;| "this should be moved to a more intelligent recompute-nodes function that does not have to re-build every single node.") (SETF (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST) (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY NIL (IL:FOR CLOS-BROWSER::EACH IL:IN (REVERSE (IL:* IL:\;  "so they come out in the original order") (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST)) IL:WHEN CLOS-BROWSER::EACH IL:COLLECT (SLOT-VALUE CLOS-BROWSER::EACH `CLOS-BROWSER::CLASS))))) (CALL-NEXT-METHOD) (WHEN (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) (IL:* IL:|;;| "Node has been invalidated, so get rid of this pointer to it. ") (SETF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) 'WEB:BOXED-NODE) NIL) (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) NIL))) (DEFMETHOD CLOS-BROWSER::REAL-ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER:CLOS-BROWSER) CLOS-BROWSER::CLASS) "Add a class to the starting list of the browser" (WHEN CLOS-BROWSER::CLASS (LET* ((CLOS-BROWSER::CLASS (IF (TYPEP CLOS-BROWSER::CLASS 'STANDARD-CLASS) CLOS-BROWSER::CLASS (FIND-CLASS CLOS-BROWSER::CLASS))) (CLOS-BROWSER::NEW-NODE (CAR (CLOS-BROWSER::MAKE-NODES (LIST CLOS-BROWSER::CLASS))) )) (IF CLOS-BROWSER::NEW-NODE (PROGN (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::STARTING-LIST)) (IF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::GOOD-LIST) (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::GOOD-LIST))) (SETF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::BAD-LIST) (IL:DREMOVE CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::BAD-LIST))) CLOS-BROWSER::BROWSER) (IL:* IL:|;;| "otherwise return nil") NIL)))) (DEFMETHOD WEB:SHAPE-TO-HOLD ((WEB::SELF CLOS-BROWSER:CLOS-BROWSER)) "give a larger width for empty browsers so add-node will have room" (LET* ((WEB::WINDOW (SLOT-VALUE WEB::SELF 'WEB::WINDOW)) (WEB::NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WEB::WINDOW 'IL:GRAPH)))) (IF WEB::NODES (CALL-NEXT-METHOD) (LET ((WEB::REGION (IL:WINDOWPROP WEB::WINDOW 'IL:REGION)) (WEB::MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WEB::WINDOW))) (WEB::MIN-WIDTH (MAX 250 (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE WEB::SELF 'WEB::TITLE) (IL:DSPFONT NIL IL:|WindowTitleDisplayStream|)) )))) (WEB::SET-REGION WEB::SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| WEB::REGION) (IL:|fetch| IL:BOTTOM IL:|of| WEB::REGION ) WEB::MIN-WIDTH WEB::MIN-HEIGHT)))))) (DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS T)) (APPEND (LIST CLOS-BROWSER::CLASS) (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS 'CLOS::DIRECT-SUBCLASSES) IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES) (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS) (LIST CLOS-BROWSER::SUBCLASS))))) (DEFMETHOD CLOS-BROWSER::CONTAINS-P ((CLOS-BROWSER::CLASS T) (CLOS-BROWSER::BROWSER CLOS-BROWSER:CLOS-BROWSER)) (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::STARTING-LIST) :TEST #'CLOS-BROWSER::THIS-CLASS-NODE-P)))) (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::BAD-LIST) :TEST #'CLOS-BROWSER::THIS-CLASS-NODE-P))) CLOS-BROWSER::NODE))) (IL:* IL:|;;| "") (IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS") (DEFCLASS CLOS-BROWSER::CLOS-BROWSER-NODE (WEB:WEB-NODE) ((CLOS-BROWSER::CLASS (IL:* IL:\;  "The class represented by this node") ) (CLOS-BROWSER::MENU-CACHE :INITFORM NIL) (IL:* IL:\;  "Menus of methods and slots. See clos-icon for the switch that controls when this gets updated.") (CLOS-BROWSER::LARGE-MENU-SIZE :ALLOCATION :CLASS :INITFORM 22) (CLOS-BROWSER::LARGE-MENU-FONT :ALLOCATION :INSTANCE :INITFORM (IL:FONTCREATE `(IL:HELVETICA 8))) (CLOS-BROWSER::LOCAL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition." (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method"))) ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition." (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.") ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.") ("Documentation" 'DOCUMENTATION "Print this method's documentation."))) ("Delete" 'CLOS-BROWSER::DELETE-METHOD "Remove this method.") ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.") ("Move" 'WEB:MOVE "Move this method to boxed class.") ("Rename" 'CLOS-BROWSER::RENAME "Change the name of this method to new name you specify") ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.") ("Trace" 'CLOS::TRACE-METHOD "Trace this method.") ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.") ("Who owns" 'CLOS-BROWSER::WHO-OWNS "Show the classes on which this method is specialized."))) (CLOS-BROWSER::INHERITED-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition." (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method"))) ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition." (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.") ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.") ("Documentation" 'DOCUMENTATION "Print this method's documentation."))) ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.") ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.") ("Trace" 'CLOS::TRACE-METHOD "Trace this method.") ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.") ("Who owns" 'CLOS-BROWSER::WHO-OWNS "Show the classes on which this method is specialized."))) (CLOS-BROWSER::ALL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition." (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method"))) ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition." (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.") ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.") ("Documentation" 'DOCUMENTATION "Print this method's documentation."))) ("Delete" 'DELETE "Remove this method.") ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.") ("Move" 'WEB:MOVE "Move this method to boxed class.") ("Rename" 'CLOS-BROWSER::RENAME "Change the name of this method to new name you specify") ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.") ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.") ("Trace" 'CLOS::TRACE-METHOD "Trace this method.") ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.") ("Who owns" 'CLOS-BROWSER::WHO-OWNS "Show the classes on which this method is specialized."))))) (DEFMETHOD CLOS-BROWSER::OBJECT-NAME ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE)) (WEB:NODE-NAME CLOS-BROWSER::SELF)) (DEFMETHOD CLOS-BROWSER::OVERRIDE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) CLOS-BROWSER::METHOD) "Create a method specialized on the class." (ADD-METHOD CLOS-BROWSER::NODE NIL (SLOT-VALUE (CLOS::METHOD-GENERIC-FUNCTION CLOS-BROWSER::METHOD ) 'CLOS::NAME))) (DEFMETHOD CLOS-BROWSER::CACHE (CLOS-BROWSER::MENU (CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL) (LET ((CLOS-BROWSER::MENU-TYPE (CASE CLOS-BROWSER::INHERITED-OR-ALL ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU) (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU) (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU)))) (IF (NOT (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE))) (IL:* IL:|;;| "then initialize alist") (SETF (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE) (ACONS CLOS-BROWSER::MENU-TYPE CLOS-BROWSER::MENU (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE) )) (IL:* IL:|;;| "otherwise replace what is already there") (RPLACD (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE)) CLOS-BROWSER::MENU)))) (DEFMETHOD CLOS-BROWSER::UNCACHE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL) (RPLACD (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU) (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU) (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU)) (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE)) NIL)) (IL:RPAQ CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING "Left button to edit the method." "\ +" "Middle button provides a menu of operations." )) (DEFUN CLOS-BROWSER::EDIT (CLOS-BROWSER::METHOD) (LET ((*PACKAGE* (SYMBOL-PACKAGE (CLOS::GENERIC-FUNCTION-NAME (CLOS::METHOD-GENERIC-FUNCTION CLOS-BROWSER::METHOD))))) (ED (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD) ':DONTWAIT))) (DEFUN CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS (CLOS::METHODS CLOS-BROWSER::CLASS &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL) "gather method-list into menu items list" (LET ((CLOS-BROWSER::METHOD-MENU-ITEMS (CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS CLOS::METHODS CLOS-BROWSER::INHERITED-OR-ALL)) (CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS)) (LET ((CLOS-BROWSER::PREVIOUS.ITEM NIL) (CLOS-BROWSER::THIS.POSITION 0) CLOS-BROWSER::GF-NAME) (DOLIST (CLOS-BROWSER::THIS.ITEM CLOS-BROWSER::METHOD-MENU-ITEMS) (SETQ CLOS-BROWSER::GF-NAME (CAR CLOS-BROWSER::THIS.ITEM)) (INCF CLOS-BROWSER::THIS.POSITION) (IF (NOT (AND CLOS-BROWSER::PREVIOUS.ITEM (IF (NOT (FIRST CLOS-BROWSER::THIS.ITEM)) (IL:* IL:|;;|  "then look for different gf objects with nil name") (EQ (CLOS::METHOD-GENERIC-FUNCTION (SECOND CLOS-BROWSER::PREVIOUS.ITEM )) (CLOS::METHOD-GENERIC-FUNCTION (SECOND CLOS-BROWSER::THIS.ITEM)) ) (IL:* IL:|;;|  "otherwise use slightly more efficient test for same gf") (EQ (FIRST CLOS-BROWSER::PREVIOUS.ITEM ) (FIRST CLOS-BROWSER::THIS.ITEM)))) ) (IL:* IL:|;;| "then go on to the next") (SETQ CLOS-BROWSER::PREVIOUS.ITEM CLOS-BROWSER::THIS.ITEM) (IL:* IL:|;;| "otherwise we have multi-methods") (PROGN (IL:* IL:|;;| "build a sub-menu of all the multi-methods") (IF (NOT (FOURTH CLOS-BROWSER::PREVIOUS.ITEM)) (IL:* IL:|;;| "then create the sub-menu") (NCONC CLOS-BROWSER::PREVIOUS.ITEM (LIST (LIST 'IL:SUBITEMS (  CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU (SECOND CLOS-BROWSER::PREVIOUS.ITEM ) CLOS-BROWSER::CLASS) (  CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU (SECOND CLOS-BROWSER::THIS.ITEM ) CLOS-BROWSER::CLASS)) )) (IL:* IL:|;;| "otherwise add another item to the sub-menu") (NCONC (FOURTH CLOS-BROWSER::PREVIOUS.ITEM) (LIST (CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU (SECOND CLOS-BROWSER::THIS.ITEM) CLOS-BROWSER::CLASS)))) (IL:* IL:|;;|  "collect the position of the extra multi-method menu item") (PUSH CLOS-BROWSER::THIS.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS ))))) (IL:* IL:|;;| "remove extra multi-method menu items last first.") (DOLIST (CLOS-BROWSER::EACH.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS) (SETQ CLOS-BROWSER::METHOD-MENU-ITEMS (DELETE-IF #'XCL:TRUE CLOS-BROWSER::METHOD-MENU-ITEMS :START (- CLOS-BROWSER::EACH.POSITION 1) :END CLOS-BROWSER::EACH.POSITION))) (IL:* IL:|;;| "prepend the Add method item") (APPEND '(("Add method" NIL "Bring up an editor containing a template for a new method on this class.")) CLOS-BROWSER::METHOD-MENU-ITEMS))) (DEFUN CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS (CLOS::METHODS &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL) "gather local-methods into menu items list" (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*)) (SORT (IL:FOR CLOS-BROWSER::EACH.METHOD IL:IN CLOS::METHODS IL:BIND CLOS-BROWSER::METHOD-NAME IL:UNLESS (AND (NOT (EQL CLOS-BROWSER::INHERITED-OR-ALL :ALL)) (CLOS::*TYPEP CLOS-BROWSER::EACH.METHOD 'CLOS::STANDARD-ACCESSOR-METHOD)) (IL:* IL:|;;| "weed out auto-generated slot access methods ") IL:|eachtime| (SETQ CLOS-BROWSER::METHOD-NAME (CAR (CLOS::FULL-METHOD-NAME CLOS-BROWSER::EACH.METHOD NIL))) IL:|collect| (LIST CLOS-BROWSER::METHOD-NAME CLOS-BROWSER::EACH.METHOD CLOS-BROWSER::*METHOD-PROMPT-STRING*)) #'IL:ALPHORDER :KEY #'CAR)) (DEFUN CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU (CLOS-BROWSER::METHOD CLOS-BROWSER::CLASS) "make a menu item to distinguish methods on the same gf" (LET (CLOS-BROWSER::SUB-ITEM-NAME) (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*)) (IL:* IL:|;;| "first put out the qualifiers if any") (DOLIST (CLOS-BROWSER::QUALIFIER (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS)) (SETQ CLOS-BROWSER::SUB-ITEM-NAME (CONCATENATE 'STRING CLOS-BROWSER::SUB-ITEM-NAME (WHEN CLOS-BROWSER::SUB-ITEM-NAME " ") (PRIN1-TO-STRING CLOS-BROWSER::QUALIFIER)))) (IL:* IL:|;;| "then do the specializers ") (IL:* IL:|;;| "(DOLIST (TYPE-SPECIFIER (SLOT-VALUE METHOD 'CLOS::TYPE-SPECIFIERS)) (SETQ SUB-ITEM-NAME (CONCATENATE 'STRING SUB-ITEM-NAME (WHEN SUB-ITEM-NAME \" \") (IF (EQ CLASS TYPE-SPECIFIER) ;; then lets just do a plus sign \"+\" ;; else print the name (PRIN1-TO-STRING ;; test until class-name works properly (IF (TYPEP TYPE-SPECIFIER 'STANDARD-CLASS) (CLASS-NAME TYPE-SPECIFIER) TYPE-SPECIFIER))))))") (LIST CLOS-BROWSER::SUB-ITEM-NAME CLOS-BROWSER::METHOD CLOS-BROWSER::*METHOD-PROMPT-STRING*))) (IL:* IL:|;;| "") (IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS") (DEFMETHOD CLOS-BROWSER:ADD-BROWSER-METHOD ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) &OPTIONAL CLOS-BROWSER::FORM CLOS-BROWSER::METHOD-NAME) "bring up sedit on a template to add a method to this class" (DECLARE (SPECIAL SEDIT::BASIC-GAP SEDIT::BODY-GAP SEDIT::ARGS-GAP)) (LET* ((CLASS-NAME (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) CLOS-BROWSER::CONTEXT (CLOS-BROWSER::NAME (FORMAT NIL "New method on ~A" CLASS-NAME)) (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME))) (UNLESS CLOS-BROWSER::FORM (SETQ CLOS-BROWSER::FORM (LIST 'DEFMETHOD (OR CLOS-BROWSER::METHOD-NAME SEDIT::BASIC-GAP ) (LIST (LIST (INTERN "SELF") CLASS-NAME) SEDIT::ARGS-GAP) SEDIT::BODY-GAP))) (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN #'CLOS-BROWSER::COMPLETE-ADD-METHOD) :DONTWAIT))) (DEFMETHOD CLOS-BROWSER::BROWSE-SUBS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS-BROWSER:BROWSE-CLASS (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS) 'CLOS::NAME))) (DEFMETHOD CLOS-BROWSER::EDIT-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)) (LET* ((CLOS-BROWSER::CLASS (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) (*PACKAGE* (SYMBOL-PACKAGE CLOS-BROWSER::CLASS))) (ED CLOS-BROWSER::CLASS '(CLOS-BROWSER::CLASSES :DONTWAIT)))) (DEFMETHOD CLOS-BROWSER::INSPECT-CLASS ((CLOS::OBJECT CLOS-BROWSER::CLOS-BROWSER-NODE)) (INSPECT (SLOT-VALUE CLOS::OBJECT 'CLOS-BROWSER::CLASS))) (DEFMETHOD CLOS-BROWSER::MENU-METHODS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL CLOS-BROWSER::ITEMS CLOS-BROWSER::FIX-FLAG CLOS-BROWSER::RECOMPUTE-FLAG) "pops up a menu of the methods for the class representing the node." (IL:* IL:|;;| "If INHERITED-OR-ALL is NIL or :local only local methods are menued.") (IL:* IL:|;;| "If INHERITED-OR-ALL is :inherited only inherited methods are menued.") (IL:* IL:|;;| "If INHERITED-OR-ALL is :all all methods are menued.") (IL:* IL:|;;| "If items are present, the list of methods is not re-generated.") (IL:* IL:|;;|  "If the fix-flag is t, the user is asked to position the menu and no \"Fix menu\" item appears.") (IL:* IL:|;;| "The whenselectedfn can call this again to generate a fixed menu.") (LET* ((CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)) (*PACKAGE* (SYMBOL-PACKAGE (SLOT-VALUE CLOS-BROWSER::CLASS 'CLOS::NAME))) (CLOS-BROWSER::MENU (UNLESS (OR CLOS-BROWSER::RECOMPUTE-FLAG (EQ (SLOT-VALUE CLOS-BROWSER:CLOS-ICON ' CLOS-BROWSER::MENU-CACHE-SWITCH ) :NONE)) (REST (IL:* IL:\; "use the cached menu") (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU) (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU) (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU)) (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE)))))) (IL:* IL:|;;| "unless it was cached, make the menu") (UNLESS (AND CLOS-BROWSER::MENU (IL:TYPE? IL:MENU CLOS-BROWSER::MENU)) (IL:* IL:|;;| "unless the menu items were passed in, compute them") (UNLESS CLOS-BROWSER::ITEMS (SETQ CLOS-BROWSER::ITEMS (CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS (CASE CLOS-BROWSER::INHERITED-OR-ALL ((NIL :LOCAL) (CAR (SLOT-VALUE CLOS-BROWSER::CLASS 'CLOS::DIRECT-METHODS))) (:INHERITED (CLOS::COMPUTE-INHERITED-METHODS CLOS-BROWSER::CLASS)) (:ALL (CLOS::COMPUTE-INHERITED-METHODS CLOS-BROWSER::CLASS :ALL))) CLOS-BROWSER::CLASS))) (IL:* IL:|;;| "create the menu using whenselectedfn") (SETQ CLOS-BROWSER::MENU (IL:CREATE IL:MENU IL:TITLE IL:_ (IF CLOS-BROWSER::FIX-FLAG (CLASS-NAME CLOS-BROWSER::CLASS) "methods") IL:MENUFONT IL:_ (WHEN (> (LENGTH CLOS-BROWSER::ITEMS) (SLOT-VALUE CLOS-BROWSER::NODE ' CLOS-BROWSER::LARGE-MENU-SIZE )) (SLOT-VALUE CLOS-BROWSER::NODE ' CLOS-BROWSER::LARGE-MENU-FONT )) IL:MENUUSERDATA IL:_ '(:ESCAPE T) (IL:* IL:\;  "cause symbols to print in mouse process's read-table & package") IL:WHENSELECTEDFN IL:_ ( CLOS-BROWSER::MAKE-WHENSELECTEDFN CLOS-BROWSER::NODE CLOS-BROWSER::INHERITED-OR-ALL CLOS-BROWSER::ITEMS) IL:ITEMS IL:_ (APPEND CLOS-BROWSER::ITEMS (UNLESS CLOS-BROWSER::FIX-FLAG '(("Fix menu" NIL "Place this menu on the screen. WARNING: cached menues are not kept up-to-date" )))))) (IL:* IL:|;;| "cache the menu on the node") (CLOS-BROWSER::CACHE CLOS-BROWSER::MENU CLOS-BROWSER::NODE CLOS-BROWSER::INHERITED-OR-ALL)) (IF CLOS-BROWSER::FIX-FLAG (IL:* IL:|;;| "ask user to position menu") (IL:MOVEW (IL:ADDMENU CLOS-BROWSER::MENU)) (IL:* IL:|;;| "otherwise just pop it up") (IL:MENU CLOS-BROWSER::MENU)))) (DEFMETHOD CLOS-BROWSER::MAKE-WHENSELECTEDFN ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE ) &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL CLOS-BROWSER::ITEMS) `(LAMBDA (CLOS-BROWSER::MENU-ITEM IGNORE CLOS-BROWSER::MOUSE-KEY) (LET ((CLOS-BROWSER::METHOD-NAME (FIRST CLOS-BROWSER::MENU-ITEM)) (CLOS-BROWSER::METHOD (SECOND CLOS-BROWSER::MENU-ITEM))) (IF (NULL CLOS-BROWSER::METHOD) (IL:* IL:|;;| "do the non-method items") (COND ((STRING= CLOS-BROWSER::METHOD-NAME "Add method") (CLOS-BROWSER:ADD-BROWSER-METHOD ',CLOS-BROWSER::NODE NIL)) ((STRING= CLOS-BROWSER::METHOD-NAME "Fix menu") (IL:* IL:|;;| "call MENU-LOCAL-METHODS again to create fixed menu ") (CLOS-BROWSER::MENU-METHODS ',CLOS-BROWSER::NODE ',CLOS-BROWSER::INHERITED-OR-ALL ',CLOS-BROWSER::ITEMS T)) (T CLOS-BROWSER::OPERATION)) (IL:* IL:|;;| "got a method, lets get an operation") (LET ((CLOS-BROWSER::OPERATION (CASE CLOS-BROWSER::MOUSE-KEY (IL:LEFT 'CLOS-BROWSER::EDIT) (IL:MIDDLE (IL:MENU (IL:CREATE IL:MENU IL:TITLE IL:_ CLOS-BROWSER::METHOD-NAME IL:ITEMS IL:_ (SLOT-VALUE ',CLOS-BROWSER::NODE ',(CASE CLOS-BROWSER::INHERITED-OR-ALL ((NIL :LOCAL) ' CLOS-BROWSER::LOCAL-METHOD-OPERATIONS) (:INHERITED ' CLOS-BROWSER::INHERITED-METHOD-OPERATIONS) (:ALL 'CLOS-BROWSER::ALL-METHOD-OPERATIONS)))) ))))) (IL:* IL:|;;| "got an operation, lets use it on the method") (CASE CLOS-BROWSER::OPERATION ((NIL) NIL) ((CLOS-BROWSER::COPY WEB:MOVE) (IL:* IL:\;  "need to supply destination") (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD (IL:* IL:|;;| "to class") (PROGN (UNLESS (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) (ERROR "Please box a destination class, then say OK.")) (SLOT-VALUE (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER ) `WEB:BOXED-NODE) `CLOS-BROWSER::CLASS)) (IL:* IL:|;;| "from class") (SLOT-VALUE ',CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) ((DELETE) (IL:* IL:\;  "need to supply extra confirm") (WHEN (IL:MOUSECONFIRM (FORMAT NIL "Are you sure you wish to delete the ~A method?" (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD))) (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD))) ((CLOS-BROWSER::OVERRIDE) (IL:* IL:\; "use add-method ") (FUNCALL CLOS-BROWSER::OPERATION ',CLOS-BROWSER::NODE CLOS-BROWSER::METHOD)) (OTHERWISE (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD)))))))) (DEFMETHOD CLOS-BROWSER::DESCRIBE-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE)) (CLOS::DESCRIBE-OBJECT (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS) *TRACE-OUTPUT*)) (DEFMETHOD CLOS-BROWSER::DOCUMENTATION-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE )) (DOCUMENTATION (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS))) (DEFMETHOD CLOS-BROWSER::PRINT-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE)) (PPRINT (IL:GETDEF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::SELF `CLOS-BROWSER::CLASS) 'CLOS::NAME) 'CLOS-BROWSER::CLASSES))) (DEFMETHOD CLOS-BROWSER::SPECIALIZE-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) &OPTIONAL CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME) (CLOS-BROWSER::SPECIALIZE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS) CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME)) (DEFUN CLOS-BROWSER::COMPLETE-ADD-METHOD (CLOS-BROWSER::CONTEXT STRUCTURE &OPTIONAL ( CLOS-BROWSER::CHANGED? T)) (DECLARE (IGNORE CLOS-BROWSER::CONTEXT)) (CASE CLOS-BROWSER::CHANGED? ((:ABORT NIL) NIL) (OTHERWISE (EVAL (COPY-TREE (IL:* IL:\;  "to ensure the original list does not get destructively clobbered") STRUCTURE))))) (DEFUN CLOS-BROWSER::COMPLETE-SPECIALIZE (IGNORE STRUCTURE CLOS-BROWSER::CHANGED?) (DECLARE (IGNORE CLOS-BROWSER::CONTEXT)) (CASE CLOS-BROWSER::CHANGED? ((:ABORT NIL) NIL) (T (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR))) (UNWIND-PROTECT (PROGN (IL:SETCURSOR IL:WAITINGCURSOR) (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE (IL:* IL:\;  "so original list does not get clobbered if this class's name changes") STRUCTURE))) CLOS-BROWSER::SUPER-CLASS) (IL:* IL:|;;| "check for bug") (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS) (SETQ CLOS-BROWSER::SUB-CLASS (FIND-CLASS CLOS-BROWSER::SUB-CLASS) )) (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)) (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE CLOS-BROWSER::SUB-CLASS ' CLOS::DIRECT-SUPERCLASSES )) (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS CLOS-BROWSER::BROWSER) (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::SUB-CLASS) (RETURN)))))) (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR)))))) (DEFUN CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE (IGNORE STRUCTURE) (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR))) (UNWIND-PROTECT (PROGN (IL:SETCURSOR IL:WAITINGCURSOR) (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE (IL:* IL:\;  "so original list does not get clobbered if this class's name changes") STRUCTURE))) CLOS-BROWSER::SUPER-CLASS) (IL:* IL:|;;| "check for bug") (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS) (SETQ CLOS-BROWSER::SUB-CLASS (CLOS::SYMBOL-CLASS CLOS-BROWSER::SUB-CLASS ))) (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)) (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE CLOS-BROWSER::SUB-CLASS 'CLOS::LOCAL-SUPERS)) (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS CLOS-BROWSER::BROWSER) (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::SUB-CLASS) (RETURN)))))) (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR)))) (DEFUN CLOS-BROWSER::THIS-CLASS-NODE-P (CLOS-BROWSER::CLASS CLOS-BROWSER::NODE) (EQ CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) (DEFUN CLOS::CLASS-DIRECT-METHODS (CLOS::CLASS) (SLOT-VALUE CLOS::CLASS 'CLOS::DIRECT-METHODS)) (IL:* IL:|;;| "") (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)") (DEFMETHOD CLOS::COMPUTE-INHERITED-METHODS ((CLOS::SELF STANDARD-CLASS) &OPTIONAL CLOS::ALL-FLAG) "Compute and return all inherited methods of a class. If all-flag eq :all then methods on t and the passed class are included." (IL:* IL:|;;| "The following does not use generic function dispatch-orders, discriminating-functions, or classical-method-tables.") (IL:* IL:|;;| "For each method in the direct-methods of each inherited class in the class-precedence-list for the class of interest, in class precedence order check to see if we have already analyzed its generic function.") (IL:* IL:|;;| "If it is a new gf then if there is exactly one type specifier then add the direct method to the list of inherited methods.") (IL:* IL:|;;| "If there is more than one type specifier then for every method in the gf for each specializer if the specializing class is equal to or later than the current class in the class precedence list, ignoring t, pushnew the method on the list of inherited methods.ÿÿ") (LET ((CLOS::FILTERED-CLASSES NIL) (CLOS::MY-GFS NIL) (CLOS::CLASS-PRECEDENCE-LIST (SLOT-VALUE CLOS::SELF 'CLOS::CLASS-PRECEDENCE-LIST)) (CLOS::INHERITED-METHODS NIL) (CLOS::DIRECT-METHODS (CAR (SLOT-VALUE CLOS::SELF 'CLOS::DIRECT-METHODS))) (CLOS::T-CLASS (FIND-CLASS 'T))) (UNLESS (EQ CLOS::ALL-FLAG :ALL) (IL:* IL:\;  "ignore t and the bottom class ") (PUSH CLOS::T-CLASS CLOS::FILTERED-CLASSES) (PUSH CLOS::SELF CLOS::FILTERED-CLASSES) (SETQ CLOS::MY-GFS (MAPCAR #'CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHODS))) (DOLIST (CLOS::CLASS CLOS::CLASS-PRECEDENCE-LIST) (UNLESS (MEMBER CLOS::CLASS CLOS::FILTERED-CLASSES) (DOLIST (CLOS::DIRECT-METHOD (CAR (CLOS::CLASS-DIRECT-METHODS CLOS::CLASS))) (LET ((CLOS::GF (CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHOD))) (UNLESS (MEMBER CLOS::GF CLOS::MY-GFS :TEST #'EQ) (IF (= 1 (LENGTH (SLOT-VALUE CLOS::DIRECT-METHOD 'CLOS::SPECIALIZERS)) (IL:* IL:\; "Note: this check relies on guaranteed congruent lambda lists. There should be some way to query the gf directly.") ) (IL:* IL:|;;|  "then only one specializer so this method must be inherited. ") (PUSH CLOS::DIRECT-METHOD CLOS::INHERITED-METHODS) (IL:* IL:|;;| "otherwise more than one so must look at specializers ") (DOLIST (CLOS::GF-METHOD (SLOT-VALUE CLOS::GF 'CLOS::METHODS)) (DOLIST (CLOS::SPECIFIER (SLOT-VALUE CLOS::GF-METHOD 'CLOS::SPECIALIZERS)) (UNLESS (OR (EQ CLOS::T-CLASS CLOS::SPECIFIER) (NOT (MEMBER CLOS::SPECIFIER CLOS::CLASS-PRECEDENCE-LIST :TEST #'EQ))) (PUSHNEW CLOS::GF-METHOD CLOS::INHERITED-METHODS) (RETURN)))))) (PUSH CLOS::GF CLOS::MY-GFS))))) CLOS::INHERITED-METHODS)) (DEFMETHOD CLOS-BROWSER::SPECIALIZE ((CLOS-BROWSER::CLASS STANDARD-CLASS) &OPTIONAL CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME) (DECLARE (SPECIAL SEDIT::BASIC-GAP)) (LET* ((CLASS-NAME (CLASS-NAME CLOS-BROWSER::CLASS)) CLOS-BROWSER::CONTEXT (CLOS-BROWSER::NAME (FORMAT NIL "New sub-class of ~A" CLASS-NAME)) (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME))) (UNLESS CLOS-BROWSER::FORM (SETQ CLOS-BROWSER::FORM (LIST 'DEFCLASS (OR CLOS-BROWSER::NEW-CLASS-NAME SEDIT::BASIC-GAP) (LIST CLASS-NAME) (LIST SEDIT::BODY-GAP)))) (IL:* IL:|;;| "call sedit") (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN #'CLOS-BROWSER::COMPLETE-SPECIALIZE) :DONTWAIT))) (DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS STANDARD-CLASS)) (APPEND (LIST CLOS-BROWSER::CLASS) (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS 'CLOS::DIRECT-SUBCLASSES) IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES) (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS) (LIST CLOS-BROWSER::SUBCLASS))))) (IL:* IL:|;;| "") (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD") (DEFMETHOD CLOS-BROWSER::DELETE-METHOD ((CLOS-BROWSER::METHOD STANDARD-METHOD)) (REMOVE-METHOD (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::GENERIC-FUNCTION) CLOS-BROWSER::METHOD)) (DEFMETHOD CLOS-BROWSER::COPY ((CLOS-BROWSER::METHOD STANDARD-METHOD) (CLOS-BROWSER::TO-CLASS STANDARD-CLASS) &OPTIONAL CLOS-BROWSER::FROM-CLASS) (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS) (RETURN-FROM CLOS-BROWSER::COPY)) (IL:* IL:|;;| "if we have the source code, find all the references to the from class, change them to the to-class, and evaluate the new form. If from-class is not provided, if method is specialized on just one class, use it, otherwise ask the user.") (IL:* IL:|;;| "If we dont have source code, we could ask if you want to just move the method object, but instead we print a complaint and punt.") (LET ((CLOS-BROWSER::METHOD-DEFINITION (COPY-TREE (XCL:IGNORE-ERRORS (IL:GETDEF ( CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD ) 'CLOS-BROWSER::METHODS )))) (CLOS-BROWSER::NON-T-CLASSES (MAPCAR #'(LAMBDA (CLOS-BROWSER::CLASS) (UNLESS (EQ CLOS-BROWSER::CLASS 'T) CLOS-BROWSER::CLASS)) (CLOS::METHOD-SPECIALIZERS CLOS-BROWSER::METHOD)))) (UNLESS CLOS-BROWSER::METHOD-DEFINITION (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD NIL)) (RETURN-FROM CLOS-BROWSER::COPY NIL)) (IF CLOS-BROWSER::FROM-CLASS (IL:* IL:|;;| "method should be specialized on from-class.") (UNLESS (MEMBER CLOS-BROWSER::FROM-CLASS CLOS-BROWSER::NON-T-CLASSES) (ERROR "The ~A method is not specialized on the ~A class" (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD NIL) (CLASS-NAME CLOS-BROWSER::FROM-CLASS))) (IL:* IL:|;;| "otherwise see if we can deduce FROM-CLASS ") (CASE (LENGTH CLOS-BROWSER::NON-T-CLASSES) (0 (FORMAT T "Unspecialized methods cannot be copied. ~A" (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD NIL))) (1 (SETQ CLOS-BROWSER::FROM-CLASS (CAR CLOS-BROWSER::NON-T-CLASSES))) (OTHERWISE (SETQ CLOS-BROWSER::FROM-CLASS (CLOS::SYMBOL-CLASS (IL:PROMPTFORWORD (FORMAT NIL "Which class in ~A do you wish to move from?" ( CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD NIL)))))))) (IL:* IL:|;;| "should contain from-class. If it is not the same, abort.") (CLOS-BROWSER::REPLACE-SPECIALIZERS CLOS-BROWSER::METHOD-DEFINITION (CLASS-NAME CLOS-BROWSER::FROM-CLASS ) (CLASS-NAME CLOS-BROWSER::TO-CLASS)) (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION)))) (DEFMETHOD WEB:MOVE ((CLOS-BROWSER::METHOD STANDARD-METHOD) (CLOS-BROWSER::TO-CLASS STANDARD-CLASS) &OPTIONAL CLOS-BROWSER::FROM-CLASS) (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS) (RETURN-FROM WEB:MOVE)) (IF (CLOS-BROWSER::COPY CLOS-BROWSER::METHOD CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS) (CLOS-BROWSER::DELETE-METHOD CLOS-BROWSER::METHOD) (FORMAT T "copy of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)) (XCL:IGNORE-ERRORS (CLASS-NAME CLOS-BROWSER::TO-CLASS))))) (DEFMETHOD CLOS-BROWSER::PRINT-DEFINITION ((CLOS-BROWSER::SELF STANDARD-METHOD)) (PPRINT (IL:GETDEF (CLOS::FULL-METHOD-NAME CLOS-BROWSER::SELF) 'CLOS-BROWSER::METHODS))) (DEFMETHOD CLOS-BROWSER::DESCRIBE-METHOD ((CLOS-BROWSER::METHOD CLOS::METHOD)) (CLOS::DESCRIBE-OBJECT CLOS-BROWSER::METHOD *TRACE-OUTPUT*)) (DEFMETHOD CLOS-BROWSER::RENAME ((CLOS-BROWSER::METHOD STANDARD-METHOD) &OPTIONAL CLOS-BROWSER::NEW-NAME) (UNLESS CLOS-BROWSER::NEW-NAME (SETQ CLOS-BROWSER::NEW-NAME (READ (MAKE-STRING-INPUT-STREAM (IL:PROMPTFORWORD (FORMAT NIL "~%New name for ~A" (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)))) ))) (LET ((CLOS-BROWSER::METHOD-DEFINITION (XCL:IGNORE-ERRORS (IL:GETDEF CLOS-BROWSER::METHOD)))) (UNLESS CLOS-BROWSER::METHOD-DEFINITION (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD NIL)) (RETURN-FROM CLOS-BROWSER::RENAME NIL)) (IF (AND (SETF (SECOND CLOS-BROWSER::METHOD-DEFINITION) CLOS-BROWSER::NEW-NAME) (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION))) (DELETE CLOS-BROWSER::METHOD) (FORMAT T "~%Rename of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)) CLOS-BROWSER::NEW-NAME)))) (DEFMETHOD CLOS-BROWSER::UPDATE-CACHED-MENUES ((CLOS-BROWSER::METHOD STANDARD-METHOD) &OPTIONAL (CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE CLOS-BROWSER:CLOS-ICON ' CLOS-BROWSER::MENU-CACHE-SWITCH ))) "set cached menues for this method's class to nil" (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR))) (UNWIND-PROTECT (PROGN (IL:SETCURSOR IL:WAITINGCURSOR) (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)) (DOLIST (CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS) ) (IL:* IL:|;;|  "fix bug in the inconsistent way CLOS objects store T class specializers and do method lookup.") (WHEN (EQ CLOS-BROWSER::CLASS T) (SETQ CLOS-BROWSER::CLASS (CLOS::SYMBOL-CLASS T))) (LET ((CLOS-BROWSER::NODE (CLOS-BROWSER::BROWSER-CONTAINS-P CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER))) (WHEN CLOS-BROWSER::NODE (CASE CLOS-BROWSER::CACHE-SWITCH (:LAZY (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE) (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL) (DOLIST (CLOS-BROWSER::SUB-CLASS (CLOS-BROWSER::SUBCLASSES-OF (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS) )) (WHEN (SETQ CLOS-BROWSER::NODE (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUB-CLASS CLOS-BROWSER::BROWSER)) (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :INHERITED) (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL)))) (:EAGER (PRINT ":eager method menu cacheing not yet implemented." )) (OTHERWISE NIL (IL:* IL:\; "do nothing") ))))))) (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR)))) (DEFMETHOD CLOS-BROWSER::WHO-OWNS ((CLOS-BROWSER::METHOD STANDARD-METHOD)) (PRINT (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD))) (DEFMETHOD ADD-METHOD :AFTER ((CLOS-BROWSER::GENERIC-FUNCTION STANDARD-GENERIC-FUNCTION) (CLOS-BROWSER::METHOD STANDARD-METHOD)) "Update cached menues." (LET (CLOS-BROWSER::CACHE-SWITCH) (WHEN (AND CLOS-BROWSER::METHOD (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS) (IL:* IL:\; "there are some browsers") (NOT (EQ (SETQ CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::MENU-CACHE-SWITCH) ) :NONE)) (IL:* IL:\;  "we want auto cache updating") ) (CLOS-BROWSER::UPDATE-CACHED-MENUES CLOS-BROWSER::METHOD CLOS-BROWSER::CACHE-SWITCH)) CLOS-BROWSER::GENERIC-FUNCTION)) (DEFUN CLOS-BROWSER::REPLACE-SPECIALIZERS (CLOS-BROWSER::METHOD-DEFINITION CLOS-BROWSER::FROM-CLASS-NAME CLOS-BROWSER::TO-CLASS-NAME &KEY CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG) (NSUBST CLOS-BROWSER::TO-CLASS-NAME CLOS-BROWSER::FROM-CLASS-NAME (IF CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG (IL:* IL:|;;| "get the lamba list") (THIRD (MULTIPLE-VALUE-LIST (CLOS::PARSE-DEFMETHOD (CDR CLOS-BROWSER::METHOD-DEFINITION )))) (IL:* IL:\; "note this gets argument names as well as specializers. Usually not what you want. Needs to be made smarter to just get specializers.") (IL:* IL:|;;| "otherwise do the whole method") CLOS-BROWSER::METHOD-DEFINITION))) (IL:* IL:|;;| "") (IL:* IL:|;;;| "SETUP RELEASE INFO") (IL:RPAQ CLOS-BROWSER::RELEASE-ID "0.02") (IL:RPAQ CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES))) (IL:* IL:|;;| "") (IL:* IL:|;;| "") (IL:* IL:|;;| "SETUP BACKGROUND MENU") (DEFUN CLOS-BROWSER::IN-SELECT-PACKAGE () "pops up a menu of packages" (IL:* IL:\;  "Edited 18-Mar-87 13:13 by smL") (IL:* IL:\; "") (IL:* IL:|;;| "kirk: 16Mar88 modified for clos-browser") (LET ((PACKAGE (IL:MENU (IL:|create| IL:MENU IL:TITLE IL:_ "Select package" IL:ITEMS IL:_ (IL:SORT (IL:|for| PACKAGE IL:|in| (LIST-ALL-PACKAGES) IL:|bind| IL:PACKAGE-NAME IL:|collect| (IL:SETQ IL:PACKAGE-NAME (PACKAGE-NAME PACKAGE)) `(,(IL:CONCAT (OR (CAR (PACKAGE-NICKNAMES PACKAGE)) IL:PACKAGE-NAME) ":") ',IL:PACKAGE-NAME ,(IL:CONCAT "Set the current package to " IL:PACKAGE-NAME ":" ))) (IL:FUNCTION (IL:LAMBDA (IL:X IL:Y) (IL:ALPHORDER (CAR IL:X) (CAR IL:Y))))) IL:CENTERFLG IL:_ T)))) (IL:|if| PACKAGE IL:|then| (IN-PACKAGE PACKAGE)))) (DEFUN CLOS-BROWSER::CLASSES-IN-PACKAGE (PACKAGE &OPTIONAL CLOS-BROWSER::MAP-ON-PACKAGE) "Retrieves a list of all the classes for a given package. When map-on-package is t this can be very slow." (IL:* IL:|;;| "The maphash is always fast, whereas for some strange reason map-on-package varys among packages greatly.") (LET ((CLOS-BROWSER::CLASSES)) (UNLESS (TYPEP PACKAGE 'PACKAGE) (SETQ PACKAGE (FIND-PACKAGE PACKAGE))) (IF CLOS-BROWSER::MAP-ON-PACKAGE (DO-SYMBOLS (CLOS-BROWSER::SYM PACKAGE) (IF (AND (EQ (SYMBOL-PACKAGE CLOS-BROWSER::SYM) PACKAGE) (CLOS::SYMBOL-CLASS CLOS-BROWSER::SYM T)) (PUSH CLOS-BROWSER::SYM CLOS-BROWSER::CLASSES))) (MAPHASH #'(LAMBDA (CLOS-BROWSER::KEY CLOS-BROWSER::VAL) (IF (EQ (SYMBOL-PACKAGE CLOS-BROWSER::KEY) PACKAGE) (PUSH CLOS-BROWSER::KEY CLOS-BROWSER::CLASSES))) CLOS::*FIND-CLASS*)) CLOS-BROWSER::CLASSES)) (IL:* IL:|;;| "pushnew should eliminate this") (SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| IL:|BackgroundMenuCommands| :KEY #'CAR)) (PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS) "Bring up a class browser." (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS (  CLOS-BROWSER::CLASSES-IN-PACKAGE (  CLOS-BROWSER::IN-SELECT-PACKAGE ))) "Select a package and browse all the classes defined in that package." ))) IL:|BackgroundMenuCommands|) (SETQ IL:|BackgroundMenu| NIL) (IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:COPYRIGHT ("Venue" 1991 2020)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (16677 18363 (CLOS-BROWSER:BROWSE-CLASS 16677 . 18363)) (18365 19789 ( CLOS-BROWSER::COLLECT-FAMILY 18365 . 19789)) (19791 21823 (CLOS-BROWSER::MAKE-NODES 19791 . 21823)) ( 21825 22500 (CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN 21825 . 22500)) (22502 23434 (CLOS-BROWSER::BROWSER-CONTAINS-P 22502 . 23434)) (47781 48105 (CLOS-BROWSER::EDIT 47781 . 48105)) (48107 53594 ( CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS 48107 . 53594)) (53596 54758 (CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS 53596 . 54758)) (54760 56050 (CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU 54760 . 56050)) (70312 70931 ( CLOS-BROWSER::COMPLETE-ADD-METHOD 70312 . 70931)) (70933 73143 (CLOS-BROWSER::COMPLETE-SPECIALIZE 70933 . 73143)) (73145 74811 (CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE 73145 . 74811)) (74813 74978 ( CLOS-BROWSER::THIS-CLASS-NODE-P 74813 . 74978)) (74980 75082 (CLOS::CLASS-DIRECT-METHODS 74980 . 75082 )) (91908 92935 (CLOS-BROWSER::REPLACE-SPECIALIZERS 91908 . 92935)) (93246 94827 (CLOS-BROWSER::IN-SELECT-PACKAGE 93246 . 94827)) (94829 95976 (CLOS-BROWSER::CLASSES-IN-PACKAGE 94829 . 95976))))) IL:STOP \ No newline at end of file diff --git a/clos/3.5/NEW-CLOS-BROWSER.DFASL b/clos/3.5/NEW-CLOS-BROWSER.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..d98b090ee27301888f52448973a8b1931a8a6685 GIT binary patch literal 61937 zcmeIb33y!9l_&n*t3{G6$&xKE2-}pwHeg)F7|3E0P)RDeN~)?SswB$>gD6{NS4pxY zwAh#qL?TX{Kn0KiQw7OP!jh#)x@EcJcvsTtOky(AS^J-5LQi*R>FETf9Z1jQOTL8v z@0{~qy;oXn$ruPT_Gi_*@4ma=bI&>VoO90|Rth)OggiCfJ9|={iC$0lK!49bzh`@Q zucxnjpm$rsvmNoCzo?Bh-1olbzC>@|&GFuWuHA{wZONNs4V!DD!Hxc#YxSDuus_li zySX_M+;np&7;C(_CZxx1u4#@&5r1>U-{PeRZ*^2}iTR^zZdz9ovz5QCHxchow0Y`! zQ*H4*t35Y(Y7^TMJGY`m>(;JYyV|qvy7kwuU4P?y)|AxwVj*eN3^Kj`$;<)mif#q} zcI19$Q>eUL<>(@MDN{5x^F+F|E*SFHME$-de{D#w(Ui<1>9SR^CSRo17p?UMBaO{X zt1{`b>pcD4J>Jg5u0$t|*iH>aWFAcy)-^|Jnu2;H^O!oQEkS{0wf?$b#P6kYk-bhY zLy1nk(I3%fBZFISZbFf61dD2eQ9oza7G)lzn1V)MO@nWPKl7LinH(X16N;t(kEDxM z8Q)fA9@FqXD;V*bsnf;w@s{tin`3?}fs+!*hhns@*7gPIqSP1+L2Z+-I^@r!9RL$V zIjem!|133=cK=0WptJKn1p}+pSYyg#$pbsa!G$!eV<`^L;;=Q^lEN7HOuGEWal_e1 z>9Y z!aQYX$rNR0V|cTrnF(`|EzhLQ;m=keOaq=>B%_?IoOO979ln3%P4*eY67AX3o7$1= z_guB@YR`4=eeZRijs8fpA0K*qx_jgOsqU^d9*?iH)5FR7JiQ65*IkLWHTSPrka_F| zG#y=2SK-HT(@i&J(pRpU-aqQ|yR+}fq?KIg>c-wwS3hA3Pu#OD*Rrne{uEHg?qs6N z)7c$wOLgtwET~eW8c~2oZD^#}WkVObm$~LG2XQd|?A;ekZMVkPKDx!%>}VPU6d<>Vke+6 zEaQ#7Xppc{EZdRmvNc?D?R}MI5GJMNZ{Xz^YAzN^1geB)X4?@{TBC=6_M5zQzHl(K znd4^BGWSOGTGT~p=G)6=iUzz8;ZJi7(uPruH2KhLZzJL{F-fY;o{ysEAhICrZwlzO zu`Ct|4Mw4_w$>Zf^(IQ7X782QA~Tj+U_}>J>zlY?G)RsXf3@wKTbh!60QhsSEq+l= z$nT4KrCK~9&E6Ux&2C=FvuOIfO~Iy+e?kf6xk&`#s|_~k(FsWk39SYJI(dbHln@?m zZkkwT38+lSYxXiPS4k}3YxH}YbZ~51WD~UB% z8<6GI>$2^G5tbQ2>~wIT}~g6KN+_0h90j=>@BdDFsdlH#T`= zP0?Uv!zykT=;Um4y9QJ*fGbVeLw_CHg=Eb|$(8Jl)$p-8~5*MSW{%O!@%UP68CP z1?}Y3WCuTj6Iodv{??>7dPDw={!ku}TB$0fgyv9F&`g1;W>BWy=FcT?)O*2WMSTF% znCGfpsW>Lm;z4<8ul6vi(qrq_=lDB@oXlgh%^96buxYMtY5lm_*q@$lpcAylSWUKB zpG6~(!!%gKwr?fC6paKgCL+rJT+FLfDxFyHJRXjgfIkxR6YBEUGBV09q7=xhCK{~v zPf^7@lY3{pJVm0}jR2{s8d*j?VAMWY9d3q#d9?h&RQY+O=SFdV+WKIX!q9R_Xmd1J zLqtmQjr&~Q6bQzowLFuIZuh4vcpSaLMjJ4~7+luZ0SE3XH}B>e#^lHuW5LevBph?&sV%g@$U8O+RM z#bygjY5@%x>D(w|x3E7wC)X+?-XJ^98oiOIowP$OG8;i8$r%R1;t0?YZm0E~8cFT_ zR3=>swrKs%?p+B_s?XDxjJI{~#%3Ia2GPS)wdNCBRvD1&NvLDcZ6>4Q3Af znLmcbW{U@90l#C6!jhhWzGPQoHvq4DptH@B=uGWQbzvqkCn=r}^apj{iiR(!j&JMO z(c3-H)fUG5LhP|K-qnUgw6_Lq5xD32gY>hjc{5Pc8Sm@kxoNZb^w7?U%Jmo<4iHS*92J6uFu{}IFNvp)=Kfhp&nsuZ%5Sek!sDt+qS9ot#Erf{+62A}D3L)t zk2R6)8u8&O(uoMfLH++GmP83{ZoOu{?2fwth;w3_!_|5yhe=lQJa#RhJYN9F782j? zi*ATf#Agsu&_a|e%I}||cM|m&?@!Zmv~~yHSW6Ilz-&9^J%F@M!oc+MC|-)GWD|k? z1y|cWz>l78e%wvVcpk8OQxFU&P`}AaW!n>+pzn4haMk%jF+c5P$~XC=*xG=|hLM&; zi5odtzmFf?H}RwAMtB(%BCTZkRlJA*~ZT)s=lgc83cR zvjPSV0)VSK<2$#u#c3g$Q#u7Gpampd#Fkl)HAjJ_)ImjMmO;G_jbf1&u_h$r0$;?5 zNIJLJCUN6x8OT{MM-A{ou(uvnZwTqtzEGntipd3JoTU*0k6Jl;SHcXaxy8@!a1&C* zE(GHk3~LLr9mUxWw2bMVTWa93+nw!DJ^?g#K%s&CZKD0mvmNmxLrGcFOSLZ*aZ8U5 z#gB4;Vz?W}hT_M}7+3Q6Q2e;{c48=gA~1SuU^qFLx??!};ecZ}HJBW|A#gHzD%n~( zmTWB>3qKPXSsPY)2=E%o=%squN__l?UY4wEEj<<1PLBLEz~A|2FnKZ=X2~VLp5p2x zdnrH0^iqxsi`3J23z%<_`i4-6i{@@D@>xBXrA*287b)5Uuj3z&XXdd2j9t-6y^+?4 zF9ez{U`>n7t4C=iG$Dm^C8$rf5P&eJB^asITj(2a))7^_LDy;SnPlR#R6q+NOngrXM3uUQvN+YxPk~MWYA9l)BphLdf(`^KJ|!CI~u53lC27E)yB3e zVvpRbeg$G)2*jc>rm1iwG!_o+WcYW3MeoC*8hAk||z>RzpmH zVKz4!Xp=GQS%L;ycMBLS_=iE4A%a%i>!MN>0 zbGwMNZW=43ssn$lP{z3BHhLSV(5ko(n~x=r*ALeZjjUI1KQT$F29C4V3}?C{#1Uil z+Od(p3u4H3fd;C^kVBtf8)_#3JMjD$rD8o4x zJXXb#x7W)MQJq1-9~h`9s&!7NRyyMHQpFIoQN@>|f3!8Q4J7ZLc3euMBmgWCOdZvX zK-EK9F^|C^?wImLMRB~3Blazj2hp0MEsaglKy##F-6yiU(YsAm*0dkFi=c?#16GiG z$3N1!@t@9&&a)CHIZas-kg}VHnDjtAyl%mJ?nZ7)M)1VJ)$(>FKSG!D<6r@;9ZZ7c zAW1k$&5P>!>wrJo@g50XpY0F?vu9DZLxy4x7zNt7&H@PLi8>XmmwV9P#wwrHVGi*R z&tx%mU)?l%<+;)fCm#Tb8V+zj??FFpNXTGD(gg-%XJ?$6b|Rx z3%N60h0=HTyXdLBb{$Zr6DqH!E76<6YOsz3OfcoG?3^AEoY zLbK-hoO_9SD=ml4nISmS3^Uzx{-4y&82cM?kKXR~-fMM>xm@524`lkiV{Jl43u=$@+Hjqd(4% z?%Vm%Bh=+?qAs(UeX+NvK{B$SOzoF-_lN7U_s*h*{@&cHf56~ZJR(!*rH`j`dk5my za(pyCsiaPza+R^nV}-O?fgl}1d5-#FCOwB)`5+zt50~U6g<)usd2B4fUGZU`M$?Tyd zAh}w44)nsF;Le`T1f+kkN8w?2v96mN|8HR4MDtBOB$E#jq>w--ug{d)n2Phrj!`bG zP4sQ+O>N~Zvhp)@QtFMPLi*4{>i#^wPG+a1wtL$EHJ?zpN$KG_B;TR@A74J;lE49CzNw2731075<3))Q9QW}sqZE3fc|8doT)4O~m1xCe4 z1s!|B&=3(*Y6q>7>I7r@Nt30z+EP$74a7T%9`r-s1i_X-n*o$AjyLOEl3N=Pa|zSS z@~#xyNbsZ<7}>#5aITl2+^QZ(L40WGvWz6KWB~OcBE+3AAyh;GSZ)At7bmfmwJw$f z-I`bwEh`z>ws9aoZUN7MtrdtKNutryt^r%w%WJzmFtmVq2N^C5u$+_hbfSRE^$QbO z8qFnp8T9aO!sEGBl)sDRRF%V4ANhPx>xO}DQOa2O`arCvH988Z7v%!dgL5FNt` z4!j9utLNRnYcE*;uAN5zh>BzYs6706!Yi}GWAsV+Ff>B;ME`>`*a;DsZ~}`Q&X@pQ)f*$8NRZ}(15Uw^!}pRi;1)^-pS60~!fLZ#kFIRNi6d!<_wouo!6%h?%t zL%wQ%D8?<^n@P{lCGKM^*cs;>MA7EvK9Lj-cye0;CC#-;BHaV&Va&3wvNCie5;}&2-pvHFxTceoN4%JYW<3PCuPstmxNOr6C<8XYIF}fl0x(c_ zN8ccu+~m*>8eS4h#(RiQ_9VMI+qiX~%%pD!$2(wy#SOr0^zH!8g*E3+0^&qh_rQ)M zz(w0j&x6A{$`k0;?A6v~SA|!h)J)cQ=rf zK@yPKQ-^$9P)V+!-ktG&BDJ|v$YReN$CY`>pkC|Wogm9G1A++4_xC2C@gSHZ9;3G# zcrSZjCVdUPb;Wm*2BSZ*lR9LAS}28%k^QP67Q#?6W-;*21bqrO24j02Gcn`TB$&yZ z;w47`%z~@Tl0`N2iJJ^0t)9Lb`@;g>KhXYtwIwz7m$B+ld6ES% z%2Std{Np7wGSEA*b+{L%PkNMeJZ@1rE9$#4=|%VZn4O8YwP7`5A)Cuffj#VvyeP-5 zbmCUb)efE#%iWM~8aX}ls1vZSGlUS?cB3E0hU#&X>OD^JT3Y4Cok^^qNT z@~koQA&Fb`L4h3_*+Dz}+;KMed5|Ty4BbZpN0Y~b!@;4E73#4nkt!aVZ$MH#3)Tes zg4)rM9~*!Ms0z*is?Ode$F#tz$ONlcK?}pnlf0AGK3tbwCblI{UBOdVx0D}#UijKa z6}9Rda8qR>bLQ4TS|=j%v%?U95YL5(5grA|0HUl0v!R5v&BXeCI~-j<9wDWm`Q??I zlm$I0O1i-YNsv3PH*Gwp3qD?MvJHGbY=X~1sTdC3`iH_Gk*Qq510s>W#^ap$u z+E_Aig#&Vb=h&?(9`3PQH9QK(Z0&>s0FvpzY5Y1_!da#`NX1#YD&pVNWEw%Og1J-r z=1C!G+FeprLo;S!C9nYIdItUwT`J_Eu9Z*%G-0db3)3bZ*34c~b88Ls4a%C(<{Zqt z2N?L$cEP6JvAYO=^CXEBejHYPgYAdJoPk4h0+Y3!KLfRvH~9UH-o~hZV^D9#`51kZ zI-kE~v^o47m<3&_qTRqR`|>33H}dRiqZ;ORJ?2k68aVA9T^TrCSgvZpEM9^_F%TLz zb36@*hCM4 zmBvGhNqXPZuzBv5PqMPGk$`zrsE*6WypCT=)iS5W`~dDONK)aG=wToh%h{4^aFB!tNm7J=5qj@y6h!ojk#^TP_eE|gIrddPt=vCi&#}I zUvp}5?Rx5@nh}M{K_}x=bq|BHx@T^-L)M~LN#(D_8)SaIOKb7n##(faUV)WotVL&T zEjnc_%79$Zg?Js$(b1JMW4TqxY9j3zl#s#!X(xt2-`rSXGVvyVWSKFuiiiw%#v2*1 zQJyt+cqM}m!^*%;07co!2sV!+mly7}jkH)?dBg?@c{~%CrpXU4On0TSC4u%q=OyS? zQL3*~3_S;#O($0CA#>qgiL-(P248ErTojq$rdlrVID92}@oqN1D; zUEre+98?bJOW8o|w03%NYbDZ|ZhdUUs;(OfUUK zYX#b)FKR!GD)mMB+{3L4^vW~CBQ@=M+3Uk2%^^xXx8nz`{D+`kf#{p@EPMUYk6Sq& zePrY(?fmWXP7Otl{7`a9p+~uf#rjg@y**IHi~gw9!<)|1!=aI@tuCFlgMSLPAHLnC z{-^qe!?!ai8G|(3kgf{0a||;g$CD=-h8u>GW$Koe<)S$rYtW95ysS7_o3H)MF&DEw z%Q9-C6@s%d=}nWOpbG$a<=S|&0A6ck#iz1KjY`%v>how;Y2!w(ucpQiYm%m@uaPZq z)YbSfA3LnDFS^-_1bhg@8xG>I(vDKf`6)(K-=pBeNL#jM4O=}lN2}}8 zOW#S*F@m*I#1>6#cY`QaXRCh+ItoM6SQ90Bo|nSEQBX+tuO_T`PVs9>aqbn)XBUgh84O}=p7%Sd`68^8eE|sfM!l4hF9I{be?;0VnHgAw?_dUUS%ev&Z^R5NB4)tIK}k+<6_@MF zi5X}Rfzt`AlQ-#8caoTaT(8dB$3F$03YM!CRULuSv3U<#e6x)1sd~%`k2gaV^CQIQ zz`S?Ke!Xlj1u78{;m>**bKhg3_QQ9AzX(ST-^uYNe-TO7hiv?XeB=}}+loBafd^ zQ230$<={bj{~RYcO2Jz=_^S%aw;;Ql9_1*MP0amu5qhUxf?;t-i3MBzmh&facIoqc!^yHLUMajDwrb;~ zTs8!o&+<;U9V`rDRTb+Ea&iRPf#;M4Fz&<7(oh=EITM-#Wv`-Q&+e)r%OVBi$^tX( zC-hBylv6yeUdnH8hy%RQ)<>e@Ij!z=hxlCE#wT+O;F~1xxn)XhGQGZB7?BUHEv>y} zxgqdL9&cIRari_K)bL~wwD44rC}IA7m?)x9Kx;27@3J3Gf_hc8dUBM|1L~;DD=6XR z`IPW)bdN;|7bBhdR(bp(-2+NUai_K8A&_6*50}y|crk5%v9bL{>jENEq3K&LujS%OP}-XeZIZ3ZjEX4oY&2Ygnp#hz(gTH%@jTSQ?kDO@D@<5hS1?Hc~mQuuBx|DE#_~*x0t72JYyk8 z>(c%D(xH)6YOCkdBbVtO&M(9ga)c)$dg;njAJ$8gm3N*DX(vX$V>|kSkwe9;r7kt2 zdm8l8FOQAPGwahm#u*n=E;ybPkFMdFx2h9tDOA|{WLbSX=F-}CtjN9mDQ4s1M~^(bfPY_VK%|M?0spouHDL+ImpsdmFTH_o<2z)K{dZxND*5&2c53bT9}GLr2z>B^aD8E zMH>kE&eT}*SxMg~NqHBpa^`C!hItj0r3K&PREIY%Ht2TupDR4P98bQfM!ZjIsSW$MIGxX2UO*Mwjxx>Gp6Ds zR32FERqBsp#dwN_$(sOQ&|TPM95?ZjkafYoIhEmbHcK@&I+st&^W3XUm+CQ4W6MM* zohI8dJ!Mcmrx%k&lXmY#vB&hp9$NxcK1O>NURvsV=AiPbkJ0|H@52(fJy|JojxG53 z{i>6pQ?_$D*fmDcvFqBobqT_C&Zo^5wBdOqp-kAU0Jv zHiH8~BD!(-;7)8(0&%{}0dgEWxxl$VbNfYnE1mu;Cdg-W$p~B{7Xt;g;zoczg&4OH zJNpIWek%lIw@1($PB7CPa5cq+tN&#A>Iwa^z+Hf`PN%Fj0O&3F-OQ`ip6GKC& zMWRP7eo?6PXDHMPbxbXRvY}X!Krv2KTT4e51u~{Atjv;xl|>lUpLRpem5gv=j=vESmIxnm*N63!P_v_2^>|SO~nhsD&+(n^OIq3FA0Q4A#BzotZRb05%^8rZwZtR>pkCq(XPb z(BxoZ79F9E`Ztj8A*=?$Y#Y(8VsZ2;pJ<(2kI32L7p)~&+Z3Rc-K}-6@!C zC*#NmU>7RI`R)6gPuq*bTwwjJTrL> zckP3Y`9xDKl>_e`lxGdpOh&;hv;037ndj*-&u^ZkK~=JH`o;z%Q)zf6G_t-yZC%Qk zlri9w`clTX;ChqbdLIu*E*Tq&oQSX=k^_RAPm*22*A0YeaIPINbeX63|<2xYD!0U0BO! zDV>AP*Q&#ug|X3Fqm6_ilgJV5g8UwCgA-hr1yLqnoCz+CmX_d=wj1eX^ zORAm{4Ol1KJy$hNeV#hc%=Ia?VhQWp%O6bG@22^?8L=ZSg!n^C)7Z^eK{%Wr9&v4>og|v@MmZ_J+Hk>mpR~5GO;(^CPUzV_t;}`}lkm8V`q?9nH&$+^@ zM##O-hllaKUJG;YzcyjI~j!oEV^dX+wo#Hp5>q?qlA&TUcLQU{j zrkczHt9MiEZJ-15$@E_KK3?(mimeK~63}-RsH^1cLe;r|ehRW+UFBlsbO0ACVs$R| zY7~2E?y&Y$g)iq4x$vb{;p_%h3U}n%to)IKRJigx6uyvr=S|gW<+WVF$}72o4L2av zYUO)Y!T;4N_!}sAP6($s$bl_fl+)fyyn+eCLM>HJSOqd_;g-T38I21KgYvXh;DK=k z@+nsKKE{j-kETJK8R4k-m-m`JP+((O*puC^?(Xq~{s#KjeVEl*VllcNMuz+~SH%dSzp8q91!O)BDAg zO<=w(&-F#FEHnVO7Ql@(jz6EX94O~$m+RuJhX@bX4lv^AuV;G|ec6-cj4rCN1lasFN$kop6F3zO+5)XTu z`MhKIJvjKtLP;ZUSo|h4ATT(nbC8!}&zaX9P0+FE{F*P#q~B#6wI)!a1Ub(g(r9W2 zdG_E>d%6ca?5JWpdO-7_?@ILIVxIg`;X%{p7DRkx7=`UlVc*U}Lgh)PT-A{E;JO9| zQ4Auij;o=WYA~=89U8l_hTT5JvC&6T^8`CxCW0Gwdh@!DDNA+j>h8ehCfr0J)rBp|Zcq2_uD)FLJl$|% zaU(m&pdshk6`v=&lc{aS=orI=&e;5dtRcjKqvf)Y?&Y#3B94N$5OGiw95}W6cHj)I z`{}mFu268&tNfdh8N+3@GS*@?B34~{t8l=PYw!s@U1`oEN2b4>yl494y5-L`suvrnUlE`#Mb4KkF z6eB|k^B*VKUBdf>Oq63DBZrl&i&YOgfqoVm@|%elyWmn6s3pbMGI@i>O?jqAMPnCW z+XCdfMkL`OXC|XhI+JbGpYQqL{8bxMTMqJ>(+OIQb1VQ}s<0fKpxdxb>6gqYHT4^J zUes?)PXYQS>Nl$C-h|tS8$MFaYwOGbevDjZygtFN59hrNCU2jnQsdImH4W2ET6IZT z!-*=x^zT2_PduBIr!F}a3Rl9$5QW34@bO4}_{(MH_lVdDnihi2d#7h1IDN2(&P0Tx zf+9$i$9EbDreO3ycIB1`7EbFS=A{crv`vhJNoAtF%L*3cf-0Y^5_1qkWpW86W@)1% zO+j9261QFU7dW9ONLMZs$RSuZj4X&2})bd3y_bVs{cS?!A)!qCsxG=Db_he>+ml*G2+ENs)-Y(AB! zoYE@!d6L(;@)bwf3~y}3B@Ai_4rQL}GFaSzLG^tTXk>+KW_UZyKY$B~vKVw2hAP?F zl4aag9>OoXE`v@*^VgEGTv=VSr3V#$xfowdjSJ3A{FzL~aBU=RqcZLh4c1YN=vm3!1CDcW&S6Ugwk0*| z_Heb|VvVWtEw=P`j_}!T;!k5S?3~o}Q@E3_I;Cn~t?HQuP zO;OxLg*SEg4t{JRdZm1WggoQ!AQ*%*)SRL;-eu}ZjjKY)H8U;;f&D0)3bV(4ypp2J z*mSWEdgxz7`*!wgn^s}7JK@?Uz6Z$I^|7{^uc<&=&81n!?YG@^LLE6x_nlm6+}R{e z@vQg zU!%^46TG$ull9hg93g+LKM7RD zXfiQ3vY=#czU8pyhHfyEu`!pugRMf8Q&(d`=8z8lI=WO{jNHZ2rcKeRZsva&*I!-PV1sas3vJ>$`T6Cv)Q#1=G)W8Bl*~N#pu>~M+H6< zl1p5QC-8IrgbyVYR_nE!t+-6O<=oQK^8)|5&IvLS`$oaZx2&dT8#I(SK2ibk?V{2J zX*9)&IF=1ge+)$ChAELh8o?L!6es!&1;3o-9RY6{)UQ&^^StWp#_jW{G!`;DKSwG4 zNGX&v6#N~SkrLz1dAh8Yz2L~XM=`)VO(UH{5Mm4eDax-NqMwJkvbW3@p0`y$Fr@rc z|3S!`B6$qX{XRO1!}>JMW-o8pqKXLQM>u`6eye#gHLi!m-BRF10-hsSn3ORW_-_F0_vKpAN;)M>WQ;tD$VMo+>ZvJNd zj9?7jgeF_&#Iqax2nkZu5n4V@W=+n@lax~8w{NMFfJHqjs%H5A;~T^cUC8Iyi|^U6 zfJ?iuSRgnh7BCFh-z-G%6B{Dn5gEBi;@?S#z$EOh@=Q85jRikbaGFTkjXNsXuQ#u6 z$1ts=iB$b4&MY#Ot=|k8_UVXHUNTlQiBgEH zJ5F6B>+g`&Ebjg-jvchUc7Jl@(z{4-XmRr#f>)}+)M$cLsau9aA2Gz>ru|Bu^7P@n zH>gtKyOMkvvq>4}gwnA}2D-7y^gSmhZim${l#Ve-!vseq%(rKhTy z;~}S;ll#)5)@xSlUmIODr7y3C^L%*?CfS*EBwPXK$xH7z73R7tE+31WtnyW}=*esd zJV&D;HN#11A2;62?3B#hf(p-A1O-WWF$!vL@A}~D_|GCOv$R>rvBhwWHdga=h&#wX zWfIO~=q}5oqtn3eGsG`o>0G=slbsvgDPxyaO)v$4l#TU0I3raT+~lnb`8Lq4yMB@% zH87XJ>b94oLc#J=jU4X{tH#H8jxwy8BVt0a^ zl^PB#3^KzKJ1xOo+DmB~DCoM1f;NLH8D%!8V%0SpB4{E-V?zX%8Hypo|K?^;h3fy} za@i2!UvpKc--S>SkQDJ#l5bGF+DkuwEB>)x;FNFkUY|G^2ab-4hPALRbq^~dp$EL*^pLKZmYchA4>_)DUE}ez_@a?uWW##r@N;Q zHJK_S<620g)cmW?aea1AZ=w%(_L7d6k43_r&>FBnVvlbafbqEYQrYb$%PS z-18-zGc`zun5b@Y#S$x;TLS(FuIj=GUO(2<%;X>}cO7q-{!a#n#D?h@UiA=TX~y}} z2yqg4&JkBiWYZuaj?aDMfDhj|P;Dk6ZHFyv<*`CmJFK|rhNxMbmMQb5;ebh*r^Oc_ zGyd}*wUYuylsv6ga2qFU=(xE2VUi-J%xgI3G2fguME?je7uu|>$E7MvWlST0a`xF7zOXc8Y;^9H4qcidqA@app&Ot2PqA^IgsS6suDU= z$7_(B8LLbMUG)@vAH}*FD9F~a5_=U&bk_L9vogcBgPedUzo*np9mFevJ4;2# z9rA^%YklR&uO48Epdq$Mhl{&tOEBg)ob|i7XjeVe$HVX0n6euN|7Okenc6s{Zdpvprojd0O4o(bARfo8Ra9n3pDX-G< zcN=jkD>PNs9;`zg`Z+j={wWXB3;55Fzpg1Szw*sq8H^!nj;nq<-iCbA`2sNxc|Uz| zo*@R;UK4!&gA5S z*l3VbV-9I#2@Yf6q$9Q5xP5N3%6;@DxFMoP{rn|LN1B*LFx8J-DKiSL_uCISov%`& zeoCrb3kD_{toFZI^2nd@a#D*N=ADG27v+)f5D7-ha^4WN`=Lb|1l@QkI78L|59^Z+}`MC?b zoToMvVn0-G)-wLL@yqz{E>i7x2-W6&Jriy#l)toLU^g9;p_u{L6iZrc35efq~Nw@C* zjxEZ#&O)qy1>rGupPb`6gL8boM8|87CpsOkWjnP_2P5sVM5p%S_A}3QI^su$Qb*+E z+?mb8!My>})#5r#@g8EJbShCfqbb@0uj8NX)EvYPP5w=AR9OTuNOMgSZg1e)amuN% zCg6)~@YmkrxCw~a>EGxJy$gY&8ohBd?r-<|ODU!HQS}Ns*5<3m=_m8>;cw9Bo5^+W zCSQdzW_VJd#@Km8|_u4W5&>9ipy3tN9axr zTx6s-L8q~b2W}s(Jrta2na^&xaqW#oyD`eMG1|@km^T!RHEqq_cN^tUo)6MPJ-AjL z9)3JkK@ZpW=kVhPZVW;Zt^kp7aMq&wc{#`SjsB=<@wVd{&b?=4wnIgh5;{8y)s|#a z6c~~yvjV3zvlHpk8p!>+ywEvq@9y2%2XVQ=1yI`uRhCM*{soa5t6$W8(zCA#5WkAj zuF1i}G$;R6)L|aNqk~=|3A0bWI*a@KQ@%;>ZJuUs$xD+?>2=o^?dH$_JmpMcmWqvo zzdS+N9ph$|^ZyG^XR$b)h&5w2V_Ew=a-yFr%A)+q_Nhi=^?F*AM6w@FFzQr_Z&%&^21P(^xOV1@c29n{e@#?VAVR z=)U6px@QQqkiv`g%P}S&(k~A$9<9_%aZ^^LbtSH#kKl&Im3whp*2>CL`*e?nn{-FM zi3_w){>XFs+)(8SeSwBHAAG%0I(hK*l@YL=jDg%hCv{V@oikds75Nt$lFtrU6R>8G zd;%1bBOo$anvEr@ofL#a!B1PkGzDGPQ0zV{mMw^!<8%aKrTl8H78^XobOZ6#X(ldirWx!Ry1F@WL%I~ zcLnb zS=p2nON!i)TVZE;jdLEdwU8|4ky{N%ZkdWZ|GPs}jxS}>lV8w2{VqDR@w-2v`Njmu zQA*eq=5PO8ywaRMujgc43+Une%$)2p1~B!jt|pH89B*8d-&FD2FV}PGKDtw`5Db99 zRlz%9dLEq`?HkzYWvC(m!@*H=dnSiP)knDyw$F2Y>q2N&-!qO0F;CY6CYr0cabWgw zyV}{nLKe{notL0bw#$@?sjZ3uCAk~dOxITzZ(MuZr7*B@n&ufVc6V|iZ(MW3p+)tS zGr(?T*wDxU)k#QdBj(0J&aLB#(gpE+`ax$o zwN?286LoX>7MrXe978*4B5Hiq*ni1|$Rwy#k9H~dpQzVbDk{rW*Lb&d%;JfgwYd)z zl&Z<2a>??U#~Rd;iimN*=c5t0Z)0HN^v9%>BdI~ z3nty~&!mIXAimRsm01&1Cpp(wg>Z2t3@!l&Hn_9uqIy`O7E%-&H#(lC;Cl$ZT;HeQ zbre)r^A88VO2L&@a51O-4aL&M)+KVD1%7N=;H->d=ZXuO5=!TM9zV*f93$7DNz8xe zLTDo`*Pv-fDJTy3s6yo%R_+nW{er~MZDjLg<#?@~6UjX9#^I=I zTKFy_*)XKKuwn4Db+gH?X{pPXV{Py4-gygk>6e-Gs^%`cqjPhEx-H&CCq=g6rljtk z6tn zY8l6~rv3yu)k3V&Jt86?dweXb?eSD+ zqRqA>xKuvSAyNbPM*9MosqARHvclS;iJc7?j$nl8)r19+w=2jKA(?zcg$eo)At?(d zWfSO-&D28JnYKpiv(%d;gq5qnU5A;&aebMEIL_xq?c;8k>e`N(j^otwmYhYfxw#_F zdHwoHc2@agxJb5A3vFYl7F9Kx>^W;gT?eMO-9A?vCOBL%NWCc5Tu%euZEWnN1cEB# z+nEm2x+xjhsGmI4od=LzY8xP?pHAPQ6$Y=y2$Oj+4p~2tOy(iS#|b&koeI+ypA$LW zHU$G(ulW|KPuuvw!Q>?P9!zfoSZcNMM1!=VK-LPk_Z0683`V-OjNi^Y7EwnQ=w${g z{V~0)!QiER(?!!oj7NZ`-!~18amvXlnxObFAcsMOR39W;rJ1EOPs*Q!-})Wb&1m^W z4l-K)It7J?`!od|FHn{Y2Z@zb9-|<$lFHufGCr2&e7>6^-GN$u1aILaU*_XixM#Aq z5~dA{_=KmNy72}hI2}O#S^d87e9lu>mR-iy8_wq$-HRUNC{_56oPg2&cO+{7QwS2FIAMQwU+tNvp;Mug^CS6%- zEO}Gwt+~k7<4B^Ntd_LbG98^7qsg&A70iJW9WY$_e5V#?`=5~ocVRkgo-R1H#Uu7O zcyW#;@#`LI@pK$M7VLB$K2EMIPLM~4lkKP4vG;7pPPDys?id#YrK&s^7*A5ak{Wg~ z+5WUHmL)n;r7wo^R+rbO+x4X{!ahnapMMmJ)D!w*m~y~>wRUAcL-m=5375btx!y`5Adg<%KBbys2 zaT(mN^B;oxTtrvnS^D~;AGdNm`p5_**z|2>Co58aD7mCi9w4rzQeTWT9YOSx2b;gx zyL`)8x;!*;oz=%__4rSw6;I)mCR~m(UXM>?()H88Y10JFGS#qQqxB=41=PFauv{?% zxHr}k#MYf9CO@a9xPD5R7*T1zdN;4YgLCPjeUuLX{T)ZqIa>9w75tiUGl~lQhQ|`=jiojJJ=uJAHkVX{e=v~OmGB_ zna=RUiU;iv!!qrl@?-T_;Ixx($rzm%IPGpYEdFE+P~P7#f>?!;aDFC6P%<sQ#!=V*9bF9FyD$5_1Nh8x%2z_Z32r0bt)QeLLi zEa#BvDpD8HkoSCLcTHc{3NBXk&bkKL#Z#L3H`!`lV zst1`Jbp6Y0D&U{U0@Cl>;E&Q9%QoZ;_E$N}GK%HB3Lj)u1dOg_cu?=VmC`uB&HEnh z*RtW+Qw*~_uJz|CW&T%)2i7OzJ8(O+ND|m(g}9+0w+6DIFH=>Mzr(f9pBFSTYH+8fbP{> zBIh88`MUx`!Lm%CvxwbGl-RgM+E3j)4eWRJx~23S>>Jolw*HQ%jV%h zhu53+YRb1cdI}l0-9;h!#Wu!ny{`@;BOC89UIE}a8&|=*d)%GJET3A$ghIVac33No zv2=O?yH&{}zR|UJp>H-8VRXs3h)vujAice*2aFYrk!;xz(%UIRkh1m{fdeuGdY=;8BFzNZtJ>*0t ze_5?rB4WG=wHY2P2WA`E4fRTuMV^Kkxw;x-c@r^XpX+ppOn!{VY^n20uH=!S_>pQ~ zV6>u2?0p$o91Y^em%%FDtqI~#SC2CwCmvV8!E4DSGU+*%^qIFBnRJOMpyqcThy6gA z3xg3aJTTPy*lNkEM?#y~EX#Q#wh8VCEF%oTtvg6^**T5AC?veO^_$(nnWEYB_% zeaw3VLf7F2+q84-nzifX$`aKtR9pE+hRe$~9Sv|B;K3|-g!v@UY`Mz>28NE-(*1hr z(8#Uo9YR5c%7S_#dN9H{xwYKxh`C1P15XE;>zrtKydkvm_});m^7dnNUB>6@ZKm{` z|5V^)AOik5eCLr!s-k!-fG3v;KV?=JeDSF~KV?TECnJH1S!2?yO$WrRs4Qs!0q*QI z$Egqit^9vkqQc@qL|l1%47vio3}q_*QTnm{6BR8W^TFf|WAVddyWpxw&HUmzJ*#AD-(>SEEnAJ(Uh&%9geG7_?f%uWV z*|ve+UXWhcoo(v?sV0G8Ev1&jVi=&^#a8;XO`~0xMtdgSF?|66hE~KXW4>n& zYD*Dw6o0Z$syG%jHcXmf#A2!qlh~P&@hcg@=8~7fI5nGlE0e4WQjL$(kh}e)UIEM3 zF}*@#li5@HTz;KPAN57Ve{$2X-wNwx>tWzJJo4X0-m8~}4|n`#^y*0XFn``6?LV!Y zc`}sZ1u~e-hQN!`o=zJJV=K1k)$m;M#6jgNP`@s)nxz}z^Jq?% z2Z^+`pEbtGZ;sQ6dOAVWx@fB(2!8@ z%;IbXZ)*M;mF5s7^{>fS&7P6eXE`C)%AIs`@Dijqhm5LbdL^GkG4v{8l?QWql@D?7 z)m;)JQoC2<5_yw6cx&o@b)LM@K18brVyzVRmVn^tDq22myncv4WYUW*JZoAt0%aL< zIgx8}z`0WidfyCHaLV=-UdeO zh6((PX7<-{UDhKkO-QzvU2^fbdTRlXvM!~BwbexZR$v|QA-`yFLjZo1uozt%6WG*Y zLJGb?KR-7OjIJ~JRa`e- uYY@q}IjC&OEd{Z4I1|}Uvg+;=g*UdF(8l*C<2lN@Mj_k#g3{Mt|NjA%4~tm< literal 0 HcmV?d00001 diff --git a/clos/3.5/README.MD b/clos/3.5/README.MD new file mode 100644 index 00000000..308045dc --- /dev/null +++ b/clos/3.5/README.MD @@ -0,0 +1,3 @@ +This is based on the '91 PCL. In order to load this into Medley 3.5, load t +the file DEFSYS.DFASL, and then execute (CLOS::LOAD-CLOS). After this all +the CLOS functionality is in the package CLOS. diff --git a/clos/3.5/WEB-EDITOR b/clos/3.5/WEB-EDITOR new file mode 100644 index 00000000..6d039ac6 --- /dev/null +++ b/clos/3.5/WEB-EDITOR @@ -0,0 +1,416 @@ +(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (* ;; "Put IN Seven EXtremely Random USEr Interface COmmands ") (CLPROVIDE "WEB-EDITOR") (CLIN-PACKAGE "WEB" NICKNAMES (QUOTE ("WEB-EDITOR"))) (* ;; "EXPORT") (CLFLET ((XCL-USEREXPORT-FROM-WEB (&REST XCL-USERSYMBOL-NAMES) (LET ((XCL-USERPKG (CLFIND-PACKAGE "WEB"))) (CLDOLIST (XCL-USERNAME XCL-USERSYMBOL-NAMES) (EXPORT (CLINTERN XCL-USERNAME XCL-USERPKG) XCL-USERPKG))))) (* ;; "Class Definitions and Slot Access") (XCL-USEREXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" "NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" "MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT") (* ;; "For Subclassing") (XCL-USEREXPORT-FROM-WEB "GET-LABEL" "GET-SUBS" "ICON-TITLE" "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE") (* ;; "Top Level") (XCL-USEREXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" "BROWSE" "DISPLAY-BROWSER" "DESTROY" "ADD-NODE" "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE") (* ;; "Window Operations") (XCL-USEREXPORT-FROM-WEB "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" "PROMPT-FOR-WORD") (* ;; "Recomputing and Changing parameters") (XCL-USEREXPORT-FROM-WEB "RECOMPUTE" "RECOMPUTE-IN-PLACE" "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" "CHANGE-FONT-SIZE" "CHANGE-FORMAT" "SHAPE-TO-HOLD") (* ;; "For CLOS-BROWSER???") (XCL-USEREXPORT-FROM-WEB "BOXED-NODE" "BOX-NODE")) (* ;; "USE") (CLUSE-PACKAGE (QUOTE ("CLOS" "LISP" "XCL")) "WEB") (* ;; "IMPORT") (CLFLET ((XCL-USERIMPORT-FROM-PACKAGE (XCL-USERNAMES XCL-USERFROM &OPTIONAL XCL-USERSHADOW-P) (LET (( XCL-USERFROM-PACKAGE (CLFIND-PACKAGE XCL-USERFROM))) (CLFUNCALL (CLIF XCL-USERSHADOW-P ( CLFUNCTION CLSHADOWING-IMPORT) (CLFUNCTION IMPORT)) (CLMAPCAR (CLFUNCTION (CLLAMBDA (XCL-USERNAME ) (CLINTERN XCL-USERNAME XCL-USERFROM-PACKAGE))) XCL-USERNAMES))))) (XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("CLASSES" "METHODS")) "CLOS") (XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FALSE")) "XCL") ( XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FUNCTIONS" "FNS" "VARIABLES" "VARS" "BITMAPS" "COMS")) "IL")) ( CLFIND-PACKAGE "WEB")) READTABLE "XCL" BASE 10) (IL:FILECREATED " 4-Dec-2020 21:30:35"  IL:|{DSK}arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>CURRENT>WEB-EDITOR.;2| 129800 IL:|changes| IL:|to:| (FNS TREE-ROOTS) IL:|previous| IL:|date:| "17-May-93 11:16:38" IL:|{DSK}arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>BROWSER>cltl2>WEB-EDITOR.;10|) ; Copyright (c) 1987, 1988, 1989, 1991, 1993, 2020 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:WEB-EDITORCOMS) (IL:RPAQQ IL:WEB-EDITORCOMS ((COMS IL:* FILE-HEADER-COMS) (IL:* IL:|;;| "") (IL:* IL:|;;;| "WEB EDITOR ") (IL:* IL:|;;| "") (IL:* IL:|;;| "Package Setup") (IL:DECLARE\: IL:DONTCOPY (IL:PROPS (IL:WEB-EDITOR IL:MAKEFILE-ENVIRONMENT) (IL:WEB-EDITOR IL:FILETYPE))) (IL:* IL:|;;| "Global Variables") (IL:* IL:|;;| "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)") (VARIABLES DESTINATION-BROWSER) (COMS (IL:* IL:\; "Client Interface") (IL:* IL:|;;| "Web Node Class") (CLASSES WEB-NODE) (IL:* IL:|;;| " Web Editor Class") (CLASSES WEB-EDITOR) (IL:* IL:|;;| "Top Level") (FUNCTIONS MAKE-WEB-EDITOR) (METHODS (INITIALIZE-EDITOR (WEB-EDITOR)) (DESTROY (WEB-EDITOR)) (BROWSE (WEB-EDITOR))) (METHODS (IL:* IL:|;;| "For Subclassing") (GET-LABEL (WEB-EDITOR WEB-NODE)) (GET-SUBS (WEB-EDITOR WEB-NODE)) (ICON-TITLE (WEB-EDITOR)) (IL:* IL:|;;| "Adding, Removing, Hiding Nodes.") (ADD-NODE (WEB-EDITOR WEB-NODE)) (NOTICE-NODE (WEB-EDITOR WEB-NODE WEB-NODE)) (REMOVE-NODE (WEB-EDITOR WEB-NODE)) (DELETE-FROM-BROWSER (WEB-EDITOR)) (REMOVE-FROM-BAD-LIST (WEB-EDITOR)) (IL:* IL:|;;| "") (RENAME-NODE (WEB-EDITOR WEB-NODE))) (IL:* IL:\; "")) (COMS (IL:* IL:\; "Window System Interface") (METHODS (UPDATE (WEB-EDITOR)) (CREATE-WINDOW (WEB-EDITOR)) (SETUP-WINDOW (WEB-EDITOR)) (DETACH-LISP-WINDOW (WEB-EDITOR)) (SHRINK (WEB-EDITOR)) (SET-OUTER-REGION (WEB-EDITOR)) (SET-REGION (WEB-EDITOR)) (MOVE (WEB-EDITOR)) (MOVE1 (WEB-EDITOR)) (AFTER-MOVE (WEB-EDITOR)) (AFTER-RESHAPE (WEB-EDITOR)) (SCROLL-WINDOW (WEB-EDITOR)) (CLEAR (WEB-EDITOR)) (IL:* IL:|;;| "Prompt Window Interactions ") (GET-PROMPT-WINDOW (WEB-EDITOR)) (REMOVE-PROMPT-WINDOW (WEB-EDITOR)) (PROMPT-PRINT (WEB-EDITOR)) (PROMPT-READ (WEB-EDITOR)) (PROMPT-FOR-LIST (WEB-EDITOR)) (PROMPT-FOR-STRING (WEB-EDITOR)) (PROMPT-FOR-WORD (WEB-EDITOR))) (FUNCTIONS MOVE-DOWN-P) (FNS WEB-WINDOW-AFTER-MOVE-FN WEB-WINDOW-BUTTON-EVENT-FN WEB-WINDOW-RESHAPE-FN WEB-WINDOW-CLOSE-FN IL:|PromptRead|) (FNS WEB-WINDOW-EXPAND-FN) (FUNCTIONS WEB-WINDOW-ICON-FN) (BITMAPS *WEB-EDITOR-ICON-BM* *WEB-EDITOR-ICON-MASK*) (VARIABLES *WEB-EDITOR-TEMPLATE*) (VARS (IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW) (WEB-STREAM IL:PROMPTWINDOW))) (COMS (IL:* IL:\;  "Layout and Display Engine") (VARS IL:|BrowserMargin| IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|) (IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|) (VARS IL:GRAYSHADE1 IL:GRAYSHADE2 IL:GRAYSHADE3 IL:GRAYSHADE4) (FNS TREE-ROOTS CHILD-NODES REACHABLE-NODES!) (METHODS (DISPLAY-BROWSER (WEB-EDITOR)) (BROWSER-OBJECTS (WEB-EDITOR)) (GET-NODE-LIST (WEB-EDITOR)) (OBJ-NAME-PAIR (WEB-EDITOR)) (GRAPH-FITS (WEB-EDITOR)) (NODE-REGION (WEB-EDITOR)) (IL:* IL:\; "") (RECOMPUTE (WEB-EDITOR)) (RECOMPUTE-IN-PLACE (WEB-EDITOR)) (RECOMPUTE-LABELS (WEB-EDITOR)) (RECOMPUTE-IF-OPEN (WEB-EDITOR)) (CLEAR-LABEL-CACHE (WEB-EDITOR)) (OBJECT-FROM-LABEL (WEB-EDITOR)) (CHANGE-FONT-SIZE (WEB-EDITOR)) (CHANGE-FORMAT (WEB-EDITOR)) (CHANGE-MAX-LABEL-SIZE (WEB-EDITOR)) (SHAPE-TO-HOLD (WEB-EDITOR)) (IL:* IL:\; "") (IL:* IL:\;  "Node Marking and Selecting") (GET-DISPLAY-LABEL (WEB-EDITOR)) (BOX-NODE (WEB-EDITOR)) (UNMARK-NODES (WEB-EDITOR)) (HIGHLIGHT-NODE (WEB-EDITOR)) (SHADE-NODE (WEB-EDITOR)) (DISPLAY-NODE-HIGHTLIGHTS (WEB-EDITOR)) (DISPLAY-NODE-SHADING (WEB-EDITOR)) (REMOVE-HIGHLIGHTS (WEB-EDITOR)) (REMOVE-SHADING (WEB-EDITOR)) (FLASH-NODE (WEB-EDITOR)) (FLIP-NODE (WEB-EDITOR)) (POSITION-NODE (WEB-EDITOR))) (FNS BOX-PRINT-STRING BREAK-STRING-FOR-BOXING BOX-WINDOW-NODE)) (COMS (IL:* IL:\; "Button Events") (FNS FIND-SELECTED-NODE) (METHODS (BUTTON-EVENT-FN (WEB-EDITOR)) (LEFT-SELECTION (WEB-EDITOR)) (MIDDLE-SELECTION (WEB-EDITOR)) (RIGHT-SELECTION (WEB-EDITOR)) (TITLE-SELECTION (WEB-EDITOR)) (NODE-SELECTION (WEB-EDITOR)) (NODE-ACTION (WEB-EDITOR)) (NODE-MENU-ITEMS (WEB-NODE)) (IL:* IL:|;;| "") (CHOICE-MENU (WEB-EDITOR)) (DO-SELECTED-COMMAND (WEB-EDITOR)) (WHEN-MENU-ITEM-HELD (WEB-EDITOR)) (ITEM-MENU (WEB-EDITOR)) (GET-MENU-ITEMS (WEB-EDITOR)) (CLEAR-MENU-CACHE (WEB-EDITOR))) (FNS WEB-MENU-WHENSELECTEDFN WINDOW-WHEN-HELD-FN) (FNS SUB-ITEM-SELECTION DUAL-SUB-ITEMS WINDOW-WHEN-HELD-FN DO-MENU-METHOD DUAL-MENU DUAL-SELECTION) (IL:* IL:\; "Node Moving Protocol") (METHODS (NODE-MOVE (WEB-EDITOR)) (NODE-MOVE-SHALLOW (WEB-EDITOR)) (SCIONS (WEB-NODE)) (MAKE-REG-ASSOC (WEB-EDITOR)) (REORDER-TREE (WEB-EDITOR)) (MOVE-NODE (WEB-NODE)))) (IL:* IL:\; "") (IL:* IL:|;;| "") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA WINDOW-WHEN-HELD-FN WINDOW-WHEN-HELD-FN WEB-WINDOW-EXPAND-FN WEB-WINDOW-RESHAPE-FN WEB-WINDOW-BUTTON-EVENT-FN WEB-WINDOW-AFTER-MOVE-FN))))) (IL:RPAQQ FILE-HEADER-COMS ((IL:P (FORMAT T "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation. All rights reserved.~%" ) (PROVIDE "WEB-EDITOR")))) (FORMAT T "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation. All rights reserved.~%") (PROVIDE "WEB-EDITOR") (IL:* IL:|;;| "") (IL:* IL:|;;;| "WEB EDITOR ") (IL:* IL:|;;| "") (IL:* IL:|;;| "Package Setup") (IL:DECLARE\: IL:DONTCOPY (IL:PUTPROPS IL:WEB-EDITOR IL:MAKEFILE-ENVIRONMENT (:PACKAGE (LET ((*PACKAGE*)) (IL:* IL:|;;| "Put IN Seven EXtremely Random USEr Interface COmmands ") (PROVIDE "WEB-EDITOR") (IN-PACKAGE "WEB" :NICKNAMES '("WEB-EDITOR")) (IL:* IL:|;;| "EXPORT") (FLET ((XCL-USER::EXPORT-FROM-WEB (&REST XCL-USER::SYMBOL-NAMES) (LET ((XCL-USER::PKG (FIND-PACKAGE "WEB"))) (DOLIST (XCL-USER::NAME XCL-USER::SYMBOL-NAMES) (EXPORT (INTERN XCL-USER::NAME XCL-USER::PKG) XCL-USER::PKG))))) (IL:* IL:|;;| "Class Definitions and Slot Access") (XCL-USER::EXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" "NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" "MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT") (IL:* IL:|;;| "For Subclassing") (XCL-USER::EXPORT-FROM-WEB "GET-LABEL" "GET-SUBS" "ICON-TITLE" "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE") (IL:* IL:|;;| "Top Level") (XCL-USER::EXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" "BROWSE" "DISPLAY-BROWSER" "DESTROY" "ADD-NODE" "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE") (IL:* IL:|;;| "Window Operations") (XCL-USER::EXPORT-FROM-WEB "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" "PROMPT-FOR-WORD") (IL:* IL:|;;| "Recomputing and Changing parameters") (XCL-USER::EXPORT-FROM-WEB "RECOMPUTE" "RECOMPUTE-IN-PLACE" "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" "CHANGE-FONT-SIZE" "CHANGE-FORMAT" "SHAPE-TO-HOLD") (IL:* IL:|;;| "For CLOS-BROWSER???") (XCL-USER::EXPORT-FROM-WEB "BOXED-NODE" "BOX-NODE")) (IL:* IL:|;;| "USE") (USE-PACKAGE '("CLOS" "LISP" "XCL") "WEB") (IL:* IL:|;;| "IMPORT") (FLET ((XCL-USER::IMPORT-FROM-PACKAGE (XCL-USER::NAMES XCL-USER::FROM &OPTIONAL XCL-USER::SHADOW-P) (LET ((XCL-USER::FROM-PACKAGE (FIND-PACKAGE XCL-USER::FROM))) (FUNCALL (IF XCL-USER::SHADOW-P #'SHADOWING-IMPORT #'IMPORT) (MAPCAR #'(LAMBDA (XCL-USER::NAME) (INTERN XCL-USER::NAME XCL-USER::FROM-PACKAGE)) XCL-USER::NAMES))))) (XCL-USER::IMPORT-FROM-PACKAGE '("CLASSES" "METHODS") "CLOS") (XCL-USER::IMPORT-FROM-PACKAGE '("FALSE") "XCL") (XCL-USER::IMPORT-FROM-PACKAGE '("FUNCTIONS" "FNS" "VARIABLES" "VARS" "BITMAPS" "COMS") "IL")) (FIND-PACKAGE "WEB")) :READTABLE "XCL" :BASE 10)) (IL:PUTPROPS IL:WEB-EDITOR IL:FILETYPE :COMPILE-FILE) ) (IL:* IL:|;;| "Global Variables") (IL:* IL:|;;| "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)" ) (DEFGLOBALPARAMETER DESTINATION-BROWSER NIL "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)" ) (IL:* IL:\; "Client Interface") (IL:* IL:|;;| "Web Node Class") (DEFCLASS WEB-NODE () ((NAME :INITFORM NIL (IL:* IL:\; "Name of Node") :ACCESSOR NODE-NAME) (TO-LINKS :INITFORM NIL (IL:* IL:\;  "Nodes that this Node has Links TO") :ACCESSOR GET-TO-LINKS :ACCESSOR NODE-LINKS) (PARENT :INITFORM NIL :ACCESSOR NODE-BACK-LINKS))) (IL:* IL:|;;| " Web Editor Class") (DEFCLASS WEB-EDITOR () ( (IL:* IL:|;;| "NODES ") (STARTING-LIST :INITFORM NIL (IL:* IL:\;  "list of objects used to compute this browser") ) (GOOD-LIST :INITFORM NIL (IL:* IL:\;  "limit choices to this set")) (BAD-LIST :INITFORM NIL (IL:* IL:\;  "Don't put in any items on this set") ) (IL:* IL:|;;| "GRAPHER FORMAT") (TOP-ALIGN :INITFORM NIL) (BROWSE-FONT :INITFORM (IL:FONTCREATE '(IL:HELVETICA 10 IL:BOLD))) (BROWSE-FONT-FAMILY :INITFORM 'IL:HELVETICA) (BROWSE-FONT-FACE :INITFORM 'IL:BOLD) (GRAPH-FORMAT :INITFORM '(IL:LATTICE)) (GRAPH-FORMAT-CHOICES :ALLOCATION :CLASS :INITFORM '((IL:HORIZONTAL/LATTICE '(IL:LATTICE)) (IL:VERTICAL/LATTICE '(IL:VERTICAL IL:LATTICE)) (IL:HORIZONTAL/TREE '(IL:COPIES/ONLY)) (IL:VERTICAL/TREE '(IL:VERTICAL IL:COPIES/ONLY))) ) (IL:* IL:|;;| "WINDOW Interface") (WINDOW :INITFORM NIL) (TITLE :INITFORM "Web Editor" (IL:* IL:\;  "If not NIL will be put in title of window") ) (LEFT :INITFORM 0 (IL:* IL:\; "left position of window") ) (BOTTOM :INITFORM 0 (IL:* IL:\;  "bottom position of window")) (WIDTH :INITFORM 64) (HEIGHT :INITFORM 32) (IL:* IL:|;;| "NODE Labels") (LABEL-CACHE :INITFORM NIL) (LABEL-MAX-LINES :INITFORM NIL (IL:* IL:|;;| "the maximum number of lines to use in 'boxed' labels -- note that if the label wont fit within the LabelMaxLines and LabelMaxCharsWidth restrictions, it will be truncated") ) (LABEL-MAX-CHARS-WIDTH :INITFORM NIL (IL:* IL:|;;| "the maximum width for labels -- if label is too big, it will be 'boxed'") ) (IL:* IL:|;;| "NODE Operations") (LAST-SELECTED-OBJECT :INITFORM NIL (IL:* IL:\; "last object selected")) (BOXED-NODE :INITFORM NIL (IL:* IL:\; "last item Boxed, if any") ) (BOX-LINE-WIDTH :ALLOCATION :CLASS (IL:* IL:|;;| "width to make box for BoxNode") :INITFORM 1) (NODE-MOVER-P :ALLOCATION :CLASS :INITFORM NIL) (IL:* IL:|;;| "MENUS") (CACHE-MENU-P :INITFORM T) (MENU-CACHE :INITFORM NIL (IL:* IL:\;  "Will Cache Menus only if CACHE-MENU-P is T") ) (LOCAL-COMMANDS :ALLOCATION :CLASS (IL:* IL:|;;| "messages that should be sent to browser when item seleted in menu, even if object does understand them") :INITFORM '(BOX-NODE RECOMPUTE ADD-ROOT)) (TITLE-ITEMS :ALLOCATION :CLASS (IL:* IL:|;;| "Items for menu of selections in title of window") :INITFORM '(("Recompute" RECOMPUTE "" (IL:SUBITEMS ("Recompute" RECOMPUTE "Recompute lattice from starting objects" ) ("Recompute Labels" RECOMPUTE-LABELS "Recomputes the labels") ("Recompute In Place" RECOMPUTE-IN-PLACE "Recompute keeping current view in window"))) ("Shape To Hold" SHAPE-TO-HOLD "Make window large or small enough to just hold graph") ("Change Font Size" CHANGE-FONT-SIZE "Choose a new size Font") ("Change Format" CHANGE-FORMAT "Change format between lattice and tree"))) (LEFT-BUTTON-ITEMS :ALLOCATION :CLASS (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see LocalCommands") :INITFORM '(("Box Node" BOX-NODE "Draw box around selected node.\ +Unboxed by another BoxNode") ("Pretty Print" PP "Prettyprint selected item"))) (MIDDLE-BUTTON-ITEMS :ALLOCATION :CLASS (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see LocalCommands") :INITFORM '(("Inspect" IL:|Inspect| INSPECT "Inspect selected item") ("Edit" EDIT-OBJECT "Edit selected item") ("Delete From Browser" DELETE-FROM-BROWSER "Do not show item or its subs"))) (RIGHT-BUTTON-ITEMS :ALLOCATION :CLASS :INITFORM '(("Close" (CLOSEW (("Close" CLOSEW) ("Destroy" DESTROY)))) ("Snap" SNAP) ("Paint" PAINT) ("Clear" CLEAR) ("Bury" BURY) ("Repaint" REPAINT) ("Hardcopy" (HARDCOPY (("Hardcopy to File" HARDCOPY-TO-FILE) ("Hardcopy to Printer" HARDCOPY-TO-PRINTER)) )) ("Move" MOVE) ("Shape" SHAPE) ("Shrink" SHRINK)) (IL:* IL:\;  "Items to be done if Right button is selected") ))) (IL:* IL:|;;| "Top Level") (DEFUN MAKE-WEB-EDITOR () (LET ((EDITOR (MAKE-INSTANCE 'WEB-EDITOR))) (INITIALIZE-EDITOR EDITOR))) (DEFMETHOD INITIALIZE-EDITOR ((SELF WEB-EDITOR)) (LET NIL (CREATE-WINDOW SELF) SELF)) (DEFMETHOD DESTROY ((SELF WEB-EDITOR)) (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) (ICON-WINDOW (IL:WINDOWPROP WINDOW 'IL:ICONWINDOW))) (IL:CLOSEW WINDOW) (IF ICON-WINDOW (IL:CLOSEW ICON-WINDOW)) (DETACH-LISP-WINDOW SELF))) (DEFMETHOD BROWSE ((SELF WEB-EDITOR) &OPTIONAL BROWSE-LIST WINDOW-OR-TITLE GOOD-LIST POSITION) (IL:* IL:\; "11-Sep-84 07:24") (IL:* IL:\;  "Call Show and then shape to hold and move for first time") (COND ((IL:WINDOWP WINDOW-OR-TITLE) (SETF (SLOT-VALUE SELF 'WINDOW) WINDOW-OR-TITLE)) (WINDOW-OR-TITLE (SETF (SLOT-VALUE SELF 'TITLE) WINDOW-OR-TITLE))) (COND ((AND BROWSE-LIST (IL:NLISTP BROWSE-LIST)) (IL:SETQ BROWSE-LIST (LIST BROWSE-LIST)))) (SETF (SLOT-VALUE SELF 'STARTING-LIST) BROWSE-LIST) (SETF (SLOT-VALUE SELF 'GOOD-LIST) GOOD-LIST) (DISPLAY-BROWSER SELF) (SHAPE-TO-HOLD SELF) (MOVE SELF POSITION) SELF) (DEFMETHOD GET-LABEL ((WEB-EDITOR WEB-EDITOR) (NODE WEB-NODE)) (IL:* IL:\;  "Get a label for an object to be displayed in the browser.") (NODE-NAME NODE)) (DEFMETHOD GET-SUBS ((EDITOR WEB-EDITOR) (NODE WEB-NODE)) (IL:* IL:\;  "Gets a set of subs from an object for browsing") (NODE-LINKS NODE)) (DEFMETHOD ICON-TITLE ((SELF WEB-EDITOR)) (IL:* IL:\; "18-Jan-85 15:35") (IL:* IL:|;;| "Compute the icont title for this browser") '|Web Editor|) (DEFMETHOD ADD-NODE ((WEB-EDITOR WEB-EDITOR) (NEW-NODE WEB-NODE)) (IL:* IL:\; "11-Dec-86 10:23") (IL:* IL:|;;| "Add a new node to the browser.") (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'STARTING-LIST)) (IF (SLOT-VALUE WEB-EDITOR 'GOOD-LIST) (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'GOOD-LIST)))) (DEFMETHOD NOTICE-NODE ((WEB-EDITOR WEB-EDITOR) (WEB-NODE WEB-NODE) (PARENT-NODE WEB-NODE)) (PUSH WEB-NODE (SLOT-VALUE PARENT-NODE 'TO-LINKS)) (ADD-NODE WEB-EDITOR WEB-NODE)) (DEFMETHOD REMOVE-NODE ((WEB-EDITOR WEB-EDITOR) (BYE-NODE WEB-NODE)) (WITH-SLOTS (STARTING-LIST GOOD-LIST BAD-LIST) WEB-EDITOR (IL:* IL:|;;| "") (SETF STARTING-LIST (DELETE BYE-NODE STARTING-LIST)) (IF GOOD-LIST (SETF GOOD-LIST (DELETE BYE-NODE GOOD-LIST))) (IF BAD-LIST (SETF BAD-LIST (DELETE BYE-NODE BAD-LIST))) (SETF (NODE-LINKS (NODE-BACK-LINKS BYE-NODE)) (DELETE BYE-NODE (NODE-LINKS (NODE-BACK-LINKS BYE-NODE)))))) (DEFMETHOD DELETE-FROM-BROWSER ((SELF WEB-EDITOR) OBJ OBJ-NAME) (IL:* IL:\; " 5-Aug-86 16:50") (IL:* IL:|;;| "Place on badList for Browser") (PUSHNEW OBJ (SLOT-VALUE SELF 'BAD-LIST)) (RECOMPUTE SELF)) (DEFMETHOD REMOVE-FROM-BAD-LIST ((SELF WEB-EDITOR)) (IL:* IL:\; "28-Dec-85 10:04") (IL:* IL:\;  "Remove an item from BadList to allow it to be displayed once again") (COND ((NULL (SLOT-VALUE SELF 'BAD-LIST)) (IL:CLRPROMPT) (IL:PROMPTPRINT "No BadList items.")) (T (PROG ((IL:|item| (IL:MENU (IL:|create| IL:MENU IL:TITLE IL:_ "BadList Items" IL:ITEMS IL:_ (SLOT-VALUE SELF 'BAD-LIST))))) (COND (IL:|item| (SETF (SLOT-VALUE SELF 'BAD-LIST) '(IL:DREMOVE IL:|item| (SLOT-VALUE SELF 'BAD-LIST))) (RECOMPUTE SELF)) (T (IL:CLRPROMPT) (IL:PROMPTPRINT "Nothing Selected"))))))) (DEFMETHOD RENAME-NODE ((WEB-EDITOR WEB-EDITOR) (WEB-NODE WEB-NODE) NEW-NAME) (SETF (NODE-NAME WEB-NODE) NEW-NAME) (CLEAR-LABEL-CACHE WEB-EDITOR WEB-NODE)) (IL:* IL:\; "") (IL:* IL:\; "Window System Interface") (DEFMETHOD UPDATE ((SELF WEB-EDITOR)) (IL:* IL:\; "29-Sep-86 11:56") (IL:* IL:|;;| "make the Lisp window be consistent with ivs") (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) (REGION (AND (SLOT-VALUE SELF 'WIDTH) (SLOT-VALUE SELF 'HEIGHT) (IL:|create| IL:REGION IL:LEFT IL:_ (OR (SLOT-VALUE SELF 'LEFT) (SETF (SLOT-VALUE SELF 'LEFT) IL:LASTMOUSEX)) IL:BOTTOM IL:_ (OR (SLOT-VALUE SELF 'BOTTOM) (SETF (SLOT-VALUE SELF 'BOTTOM) IL:LASTMOUSEY)) IL:WIDTH IL:_ (SLOT-VALUE SELF 'WIDTH) IL:HEIGHT IL:_ (SLOT-VALUE SELF 'HEIGHT))))) (COND ((AND REGION (NOT (IL:EQUAL REGION (IL:WINDOWPROP WINDOW 'IL:REGION)))) (IL:* IL:\;  "The shape has changed. --- This is complicated because of ATTACHEDWINDOWS.") (LET* ((ATTACHED-WINDOWS (IL:WINDOWPROP WINDOW 'IL:ATTACHEDWINDOWS)) (ATTACHMENT-SPECS (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|collect| (LIST (IL:WINDOWPROP IL:\w 'IL:DOWINDOWCOMFN) (IL:WINDOWPROP IL:\w 'IL:WHEREATTACHED) (IL:WINDOWPROP IL:\w 'IL:PASSTOMAINCOMS))))) (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|do| (IL:DETACHWINDOW IL:\w)) (IL:SHAPEW WINDOW REGION) (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|as| IL:|spec| IL:|in| ATTACHMENT-SPECS IL:|do| (IL:ATTACHWINDOW IL:\w WINDOW (CAADR IL:|spec|) (CDADR IL:|spec|)) (IL:WINDOWPROP IL:\w 'IL:DOWINDOWCOMFN (CAR IL:|spec|)) (IL:WINDOWPROP IL:\w 'IL:PASSTOMAINCOMS (CADDR IL:|spec|)))))) (AND (NOT (IL:EQUAL (SLOT-VALUE SELF 'TITLE) (IL:WINDOWPROP WINDOW 'IL:TITLE))) (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE))))) (DEFMETHOD CREATE-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; "10-Apr-86 14:32") (IL:* IL:\;  "Create the Lisp window for this window but don't open it.") (LET ((WINDOW (IL:CREATEW (IL:CREATEREGION IL:LASTMOUSEX IL:LASTMOUSEY 25 25) (SLOT-VALUE SELF 'TITLE) NIL T))) (SETF (SLOT-VALUE SELF 'WINDOW) WINDOW) (SETUP-WINDOW SELF) WINDOW)) (DEFMETHOD SETUP-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; "10-Apr-86 14:32") (IL:* IL:\;  "Create the Lisp window for this window but don't open it.") (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) (IL:WINDOWPROP WINDOW 'WEB-EDITOR SELF) (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN) (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'WEB-WINDOW-BUTTON-EVENT-FN) (IL:WINDOWADDPROP WINDOW 'IL:AFTERMOVEFN 'WEB-WINDOW-AFTER-MOVE-FN) (IL:WINDOWADDPROP WINDOW 'IL:RESHAPEFN 'WEB-WINDOW-RESHAPE-FN) (IL:WINDOWADDPROP WINDOW 'IL:CLOSEFN 'WEB-WINDOW-CLOSE-FN) (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN)(IL:* IL:\;  "window should be invert so that links etc. can be erased") (IL:DSPOPERATION 'IL:INVERT WINDOW) (IL:* IL:\;  "kludge: because GRAPHER adds its own COPYBUTTONEVENTFN") (IL:WINDOWPROP WINDOW 'IL:COPYBUTTONEVENTFN NIL) (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE)) WINDOW)) (DEFMETHOD DETACH-LISP-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; " 8-Apr-87 17:25") (IL:* IL:|;;;| "Forget about the current lisp window") (LET ((VAL (SLOT-VALUE SELF 'WINDOW))) (IL:|if| (IL:WINDOWP VAL) IL:|then| (SETF (SLOT-VALUE SELF 'WINDOW) NIL) (IL:WINDOWPROP VAL 'WEB-EDITOR NIL) (IL:WINDOWPROP VAL 'IL:RIGHTBUTTONFN NIL) (IL:WINDOWPROP VAL 'IL:BUTTONEVENTFN NIL) NIL IL:|else| NIL))) (DEFMETHOD SHRINK ((SELF WEB-EDITOR) &OPTIONAL TOWHAT POS EXPANDFN) (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))) (IF (IL:WINDOWP WINDOW) (IL:SHRINKW WINDOW TOWHAT POS EXPANDFN)))) (DEFMETHOD SET-OUTER-REGION ((SELF WEB-EDITOR) REGION NO-UPDATE-FLG) (IL:* IL:\; "16-Apr-86 13:21") (IL:* IL:|;;;| "Make Loops Window have region parameters") (SETF (SLOT-VALUE SELF 'LEFT) (IL:|fetch| IL:LEFT IL:|of| REGION)) (SETF (SLOT-VALUE SELF 'BOTTOM) (IL:|fetch| IL:BOTTOM IL:|of| REGION)) (SETF (SLOT-VALUE SELF 'WIDTH) (IL:|fetch| IL:WIDTH IL:|of| REGION)) (SETF (SLOT-VALUE SELF 'HEIGHT) (IL:|fetch| IL:HEIGHT IL:|of| REGION)) (IL:|if| (NOT NO-UPDATE-FLG) IL:|then| (UPDATE SELF)) REGION) (DEFMETHOD SET-REGION ((SELF WEB-EDITOR) REGION &OPTIONAL NO-UPDATE-FLG) (IL:* IL:\; "16-Apr-86 13:22") (IL:* IL:|;;;| "Make Loops Window have region parameters") (SET-OUTER-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION) (IL:|fetch| IL:BOTTOM IL:|of| REGION) (IL:WIDTHIFWINDOW (IL:|fetch| IL:WIDTH IL:|of| REGION) (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:BORDER)) (IL:HEIGHTIFWINDOW (IL:|fetch| IL:HEIGHT IL:|of| REGION) (SLOT-VALUE SELF 'TITLE) (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:BORDER))) NO-UPDATE-FLG)) (DEFMETHOD MOVE ((SELF WEB-EDITOR) X-OR-POS &OPTIONAL Y) (IL:* IL:\; "11-Sep-86 13:24") (IL:* IL:|;;;| "Move the window") (MOVE1 SELF (OR X-OR-POS (LET* ((ENTIRE-REGION (IL:WINDOWREGION (SLOT-VALUE SELF 'WINDOW))) (POS (IL:GETBOXPOSITION (IL:|fetch| IL:WIDTH IL:|of| ENTIRE-REGION) (IL:|fetch| IL:HEIGHT IL:|of| ENTIRE-REGION) (IL:|fetch| IL:LEFT IL:|of| ENTIRE-REGION) (IL:|fetch| IL:BOTTOM IL:|of| ENTIRE-REGION))) ) (IL:|create| IL:POSITION IL:XCOORD IL:_ (IL:PLUS (IL:|fetch| IL:XCOORD IL:|of| POS) (IL:DIFFERENCE (SLOT-VALUE SELF 'LEFT) (IL:|fetch| IL:LEFT IL:|of| ENTIRE-REGION))) IL:YCOORD IL:_ (IL:PLUS (IL:|fetch| IL:YCOORD IL:|of| POS) (IL:DIFFERENCE (SLOT-VALUE SELF 'BOTTOM) (IL:|fetch| IL:BOTTOM IL:|of| ENTIRE-REGION))) ))) Y)) (DEFMETHOD MOVE1 ((SELF WEB-EDITOR) X-OR-POS &OPTIONAL Y) (IL:* IL:\; "13-Aug-86 19:10") (IL:* IL:|;;| "Move the window") (LET ((NEEDS-UPDATE? (NOT (IL:SUBREGIONP (IL:CONSTANT (IL:CREATEREGION 0 0 IL:SCREENWIDTH IL:SCREENHEIGHT)) (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:REGION))))) (PROG1 (IL:MOVEW (SLOT-VALUE SELF 'WINDOW) X-OR-POS Y) (IL:* IL:\;  "The left and right IVs are updated by the message AfterMove") (COND (NEEDS-UPDATE? (UPDATE SELF)))))) (DEFMETHOD AFTER-MOVE ((SELF WEB-EDITOR)) (IL:* IL:\; "10-Apr-86 16:10") (IL:* IL:|;;;| "The window has been moved. Update the left and bottom") (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:REGION))) (SETF (SLOT-VALUE SELF 'LEFT) (IL:|fetch| IL:LEFT IL:|of| REGION)) (SETF (SLOT-VALUE SELF 'BOTTOM) (IL:|fetch| IL:BOTTOM IL:|of| REGION)))) (DEFMETHOD AFTER-RESHAPE ((SELF WEB-EDITOR) OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION) (IL:* IL:\; "10-Apr-86 16:12") (IL:* IL:|;;;| "The window has been reshaped") (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:REGION))) (SETF (SLOT-VALUE SELF 'LEFT) (IL:|fetch| IL:LEFT IL:|of| REGION)) (SETF (SLOT-VALUE SELF 'BOTTOM) (IL:|fetch| IL:BOTTOM IL:|of| REGION)) (SETF (SLOT-VALUE SELF 'WIDTH) (IL:|fetch| IL:WIDTH IL:|of| REGION)) (SETF (SLOT-VALUE SELF 'HEIGHT) (IL:|fetch| IL:HEIGHT IL:|of| REGION)) (IL:RESHAPEBYREPAINTFN (SLOT-VALUE SELF 'WINDOW) OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION))) (DEFMETHOD SCROLL-WINDOW ((SELF WEB-EDITOR) DSP-X DSP-Y WINDOW-X WINDOW-Y) (IL:* IL:\; "10-Apr-86 14:58") (IL:* IL:|;;;| "scroll the window to set the point dspX,dspY in the given window position -- default is the lower left corner. If any x or y is a FIXP, it is treated as a absolute position. If FLOATP, it is treated as a relative position. Return the position of the new lower left corner.") (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) (VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW)) (EXTENT (IL:WINDOWPROP WINDOW 'IL:EXTENT))) (IL:* IL:\;  "figure out what to do with default and relative offsets") (IL:SETQ WINDOW-X (IL:|if| (NULL WINDOW-X) IL:|then| 0 IL:|elseif| (IL:FLOATP WINDOW-X) IL:|then| (IL:FIX (IL:TIMES WINDOW-X (IL:WINDOWPROP WINDOW 'IL:WIDTH))) IL:|else| WINDOW-X)) (IL:SETQ WINDOW-Y (IL:|if| (NULL WINDOW-Y) IL:|then| 0 IL:|elseif| (IL:FLOATP WINDOW-Y) IL:|then| (IL:FIX (IL:TIMES WINDOW-Y (IL:WINDOWPROP WINDOW 'IL:HEIGHT))) IL:|else| WINDOW-Y)) (IL:SETQ DSP-X (IL:|if| (NULL DSP-X) IL:|then| (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION) IL:|elseif| (IL:FLOATP DSP-X) IL:|then| (IL:FIX (IL:TIMES DSP-X (IL:|fetch| IL:WIDTH IL:|of| EXTENT))) IL:|else| DSP-X)) (IL:SETQ DSP-Y (IL:|if| (NULL DSP-Y) IL:|then| (IL:IMINUS (IL:|fetch| IL:BOTTOM IL:|of| VISIBLE-REGION)) IL:|elseif| (IL:FLOATP DSP-Y) IL:|then| (IL:FIX (IL:TIMES DSP-Y (IL:|fetch| IL:HEIGHT IL:|of| EXTENT))) IL:|else| DSP-Y)) (IL:SCROLLW WINDOW (IL:IPLUS WINDOW-X (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION ) DSP-X)) (IL:IPLUS WINDOW-Y (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| VISIBLE-REGION) DSP-Y))) (IL:* IL:\;  "return the resulting position") (IL:SETQ VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW)) (IL:|create| IL:POSITION IL:XCOORD IL:_ (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION) IL:YCOORD IL:_ (IL:|fetch| IL:BOTTOM IL:|of| VISIBLE-REGION)))) (DEFMETHOD CLEAR ((SELF WEB-EDITOR)) (IL:* IL:\;  "empty the window of active regions, return the window") (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) (IL:WINDOWPROP WINDOW 'IL:GRAPH NIL) (IL:CLEARW WINDOW) WINDOW)) (DEFMETHOD GET-PROMPT-WINDOW ((SELF WEB-EDITOR) &OPTIONAL LINES FONT-DEF) (IL:* IL:\; " 8-Apr-87 15:43") (IL:* IL:|;;| "Return the current prompt window") (LET ((W (IL:GETPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW) (OR LINES 2) (OR (IL:FONTCREATE FONT-DEF))))) (IF FONT-DEF (IL:DSPFONT (IL:FONTCREATE FONT-DEF) W)) W)) (DEFMETHOD REMOVE-PROMPT-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; " 8-Apr-87 15:43") (IL:REMOVEPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW))) (DEFMETHOD PROMPT-PRINT ((SELF WEB-EDITOR) PROMPT) (IL:* IL:\; "13-Aug-86 18:46") (IL:* IL:|;;| "Prints out a prompt in an attached prompt window") (IL:PRIN1 PROMPT (GET-PROMPT-WINDOW SELF))) (DEFMETHOD PROMPT-READ ((SELF WEB-EDITOR) MSG) (IL:* IL:\; "13-Aug-86 19:15") (IL:* IL:|;;| "Prompt the user for some input, using an attached prompt window") (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF))) (IL:CLEARW P-WINDOW) (PROG1 (IL:|PromptRead| MSG P-WINDOW T) (IL:CLEARW P-WINDOW) (IL:DETACHWINDOW P-WINDOW) (IL:CLOSEW P-WINDOW)))) (DEFMETHOD PROMPT-FOR-LIST ((SELF WEB-EDITOR) PROMPT-STR INITIAL-STRING) (IL:* IL:\; " 8-Apr-87 16:44") (IL:* IL:|;;;| "Prompt user in prompt window for a list of words.") (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF))) (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW) (IL:CLEARW P-WINDOW) (IL:TTYIN PROMPT-STR NIL NIL '(IL:NORAISE) NIL NIL INITIAL-STRING)))) (DEFMETHOD PROMPT-FOR-STRING ((SELF WEB-EDITOR) PROMPT-STR INITIAL-STR) (IL:* IL:\; "13-Aug-86 18:42") (IL:* IL:|;;;| "Prompt user in prompt window for a string.") (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF)) VALUE) (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW) (IL:CLEARW P-WINDOW) (SETQ VALUE (IL:TTYIN PROMPT-STR NIL NIL '(STRING IL:NORAISE) NIL NIL INITIAL-STR)) (IL:CLEARW P-WINDOW)) (REMOVE-PROMPT-WINDOW SELF) VALUE)) (DEFMETHOD PROMPT-FOR-WORD ((SELF WEB-EDITOR) &OPTIONAL PROMPT-STR INITIAL-WORD) (IL:* IL:\; " 8-Apr-87 16:43") (IL:* IL:|;;;| "Prompt user in prompt window for a word.") (CAR (PROMPT-FOR-LIST SELF PROMPT-STR INITIAL-WORD))) (DEFMACRO MOVE-DOWN-P () '(OR (IL:KEYDOWNP 'IL:MOVE) (IL:SHIFTDOWNP 'IL:CTRL))) (IL:DEFINEQ (WEB-WINDOW-AFTER-MOVE-FN + (LAMBDA (WINDOW) (IL:* IL:\; "Edited 13-Jul-87 15:59 by Rao") + (IL:* IL:\; "10-Apr-86 16:16") + +(IL:* IL:|;;;| "The SimpleWindow AFTERMOVEFN") + + (LET ((W (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) + (AND W (AFTER-MOVE W))))) (WEB-WINDOW-BUTTON-EVENT-FN + (LAMBDA (WINDOW) (IL:* IL:\; "Edited 13-Jul-87 13:38 by Rao") + (IL:* IL:\; "11-Sep-86 13:50") + (LET ((WINDOW-FOR-MENU (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) + (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) + (IL:TOTOPW WINDOW) + (BUTTON-EVENT-FN WINDOW-FOR-MENU)))) (WEB-WINDOW-RESHAPE-FN + (LAMBDA (WINDOW IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion|) + (IL:* IL:\; "Edited 12-Jun-87 15:56 by Rao") + (IL:* IL:\; " 9-May-86 10:07") + +(IL:* IL:|;;;| "The RESHAPEFN for a Window") + + (LET ((IL:\w (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) + (AND IL:\w (AFTER-RESHAPE IL:\w IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion| + ))))) (WEB-WINDOW-CLOSE-FN + (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 12-Jun-87 11:42 by Rao") + (IL:* IL:\; + "Remove link back to LoopsWindow") + (IL:WINDOWPROP WINDOW 'WEB-EDITOR NIL))) (IL:|PromptRead| + (IL:LAMBDA (PROMPT-STRING WINDOW SAME-LINE?) (IL:* IL:\; "Edited 20-Jul-87 16:20 by Rao") + (IL:* IL:\; + "Printout promptString in promptwindow and return value of expression read there") + (PROG (NEWVALUE) + (IL:RESETLST + (IL:RESETSAVE (IL:TTYDISPLAYSTREAM (OR WINDOW IL:PROMPTWINDOW))) + (IL:RESETSAVE (IL:TTY.PROCESS (IL:THIS.PROCESS))) + (IL:CLRPROMPT) + (IL:RESETSAVE (IL:PRINTLEVEL 4 3)) + (IL:|printout| T PROMPT-STRING) + (IL:|if| SAME-LINE? + IL:|then| (IL:|printout| T "> ") + IL:|else| (IL:|printout| T T "> ")) + (IL:CLEARBUF T T) (IL:* IL:\; + "clear tty buffer because it sometimes has stuff left.") + (IL:ALLOW.BUTTON.EVENTS) + (IL:SETQ NEWVALUE (CAR (IL:ERSETQ (IL:TTYINREAD T T))))) + (RETURN NEWVALUE)))) ) (IL:DEFINEQ (WEB-WINDOW-EXPAND-FN + (LAMBDA (WINDOW) (IL:* IL:\; "Edited 13-Nov-87 12:58 by Rao") + (IL:* IL:\; "19-Feb-85 13:58") + + (IL:* IL:|;;| "When a browser window is expanded, it should be recomputed") + + (LET ((SELF (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) + (RECOMPUTE-IN-PLACE SELF)))) ) (DEFUN WEB-WINDOW-ICON-FN (WINDOW ICON DUMMY) (LET NIL (OR ICON (IL:TITLEDICONW *WEB-EDITOR-TEMPLATE* (ICON-TITLE (IL:WINDOWPROP WINDOW 'WEB-EDITOR)) NIL '(0 . 0) T 'IL:BOTTOM (IL:CONSTANT (LIST (IL:CHARCODE "-") (IL:CHARCODE IL:SPACE) (IL:CHARCODE IL:EOL))))))) (IL:RPAQQ *WEB-EDITOR-ICON-BM* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@L@@@@@@@@@@AAH@@L@@@@@@@@@@A@L@@L@@@@@@@@@@A@F@@LOON@@@@@@OO@C@@LOON@@@@@@OO@AH@LOOO@@@@@@OO@@L@LOONH@@@@AOO@@F@LOOND@@@@BOOOOO@L@@@B@@@@DOOOHC@L@@@ACOOLH@@@@C@L@@@@KOOM@@@@@C@L@@@@GOON@@@@@C@L@@@@KOOM@@@@@C@L@@@ACOOLH@@@@C@LOOOB@@@@DOOOHC@LOOOD@@@@BOOOHC@LOOOH@@@@AOOOHC@LOOOD@@@@@OOOHC@LOOOB@@@@@OOOHC@L@@@ACOOO@@@@@C@L@@@@KOOO@@@@@C@L@@@@GOOO@@@@@C@L@@@@COOO@@@@@C@L@@@@COOO@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@ ) (IL:RPAQQ *WEB-EDITOR-ICON-MASK* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@ ) (DEFVAR *WEB-EDITOR-TEMPLATE* (IL:|create| IL:TITLEDICON IL:ICON IL:_ *WEB-EDITOR-ICON-BM* IL:MASK IL:_ *WEB-EDITOR-ICON-MASK* IL:TITLEREG IL:_ (IL:CREATEREGION 5 2 50 30))) (IL:RPAQ IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW) (IL:RPAQ WEB-STREAM IL:PROMPTWINDOW) (IL:* IL:\; "Layout and Display Engine") (IL:RPAQQ IL:|BrowserMargin| 0) (IL:RPAQQ IL:|MaxLatticeHeight| 750) (IL:RPAQQ IL:|MaxLatticeWidth| 900) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|) ) (IL:RPAQQ IL:GRAYSHADE1 1) (IL:RPAQQ IL:GRAYSHADE2 1025) (IL:RPAQQ IL:GRAYSHADE3 64510) (IL:RPAQQ IL:GRAYSHADE4 65534) (IL:DEFINEQ (TREE-ROOTS (IL:LAMBDA (NODE-LST) (IL:* IL:\;  "Edited 10-Jul-87 19:22 by Rao") (IL:* IL:\; "29-Sep-86 19:46") (IL:* IL:|;;| "Computes a minimal set of root nodes for a lattice --- those with no connections TO them in list of nodes, or a single node from a cycle of nodes.") (PROG ((ROOT-NODES (IL:LDIFFERENCE NODE-LST (IL:|for| IL:|node| IL:|in| NODE-LST IL:|join| (CHILD-NODES IL:|node| NODE-LST) ))) REACHABLE-NODES NOT-REACHABLE-NODES) (SETQ REACHABLE-NODES (IL:COPY ROOT-NODES)) (SETQ NOT-REACHABLE-NODES (IL:LDIFFERENCE NODE-LST REACHABLE-NODES)) (IL:* IL:\;  "recompute the nodes that can't be reached from the current rootNodes") IL:|RecomputeReachableNodes| (IL:* IL:|;;| "Compute the transitive closure of the set of reachableNodes --- updating the notReachableNodes at the same time") (IL:|for| IL:|node| IL:|in| REACHABLE-NODES IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| NODE-LST ) IL:|when| (IL:MEMB IL:|childNode| NOT-REACHABLE-NODES) IL:|do| (IL:* IL:|;;| "put the newly found reachable node at the end of the list, so we will find it later on during this iteration") (IL:NCONC1 REACHABLE-NODES IL:|childNode|) (SETQ NOT-REACHABLE-NODES (IL:DREMOVE IL:|childNode| NOT-REACHABLE-NODES)))) (IL:* IL:\;  "if we can reach all the nodes, fine...") (IL:|if| (NULL NOT-REACHABLE-NODES) IL:|then| (IL:* IL:\;  "Now need to prune down to a minimal set") (IL:|bind| (IL:|stable?| IL:_ NIL) IL:|until| IL:|stable?| IL:|do| (SETQ IL:|stable?| T) (IL:|for| IL:|node| IL:|in| ROOT-NODES IL:|bind| IL:|extraRoots| IL:|do| (SETQ IL:|extraRoots| (IL:DREMOVE IL:|node| (IL:INTERSECTION ROOT-NODES (REACHABLE-NODES! IL:|node| NODE-LST)))) (IL:|if| IL:|extraRoots| IL:|then| (SETQ IL:|stable?| NIL) (SETQ ROOT-NODES (IL:LDIFFERENCE ROOT-NODES IL:|extraRoots|)) (RETURN T)) IL:|finally| (RETURN NIL))) (IL:* IL:\;  "return the node ids, not the GRAPHNODES") (RETURN (IL:|for| IL:|node| IL:|in| ROOT-NODES IL:|collect| (IL:|fetch| IL:NODEID IL:|of| IL:|node|))) IL:|else| (IL:* IL:\;  "must be a cycle. Select the least prolific node in the cycle as the a new root node.") (IL:|push| ROOT-NODES (LET ((PROLIFIC-NODE (IL:|for| IL:|node| IL:|in| NOT-REACHABLE-NODES IL:|smallest| (IL:LENGTH (IL:|fetch| IL:TONODES IL:|of| IL:|node|)))) ) (SETQ NOT-REACHABLE-NODES (IL:DREMOVE PROLIFIC-NODE NOT-REACHABLE-NODES )) PROLIFIC-NODE)) (GO IL:|RecomputeReachableNodes|))))) (CHILD-NODES + (IL:LAMBDA (PARENT-NODE NODE-LIST) (IL:* IL:\; "Edited 10-Jul-87 19:23 by Rao") + (IL:* IL:\; " 8-Oct-85 14:15") + (IL:* IL:\; + "Find all GRAPHNODES that are immediatly reachable from this node") + (IL:|for| IL:|label| IL:|in| (IL:|fetch| IL:TONODES IL:|of| PARENT-NODE) + IL:|collect| (IL:|for| IL:|node| IL:|in| NODE-LIST + IL:|thereis| (EQ IL:|label| (IL:|fetch| IL:NODEID IL:|of| + IL:|node|)))))) (REACHABLE-NODES! + (IL:LAMBDA (IL:|root| IL:|nodeList|) (IL:* IL:\; "30-Sep-86 10:22") + (IL:* IL:\; IL:|Return| IL:\a + IL:|list| IL:|of| IL:|all| + IL:|nodes| IL:|that| IL:|are| + IL:|reachable| IL:|from| IL:|the| + IL:|root|) + (LET ((IL:|reachableNodes| (LIST IL:|root|))) + (IL:|for| IL:|node| IL:|in| IL:|reachableNodes| + IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| + IL:|nodeList|) + IL:|when| (NOT (IL:MEMB IL:|childNode| IL:|reachableNodes|)) + IL:|do| + + (IL:* IL:\; IL:|put| IL:|the| IL:|newly| IL:|found| IL:|reachable| IL:|node| + IL:|at| IL:|the| IL:|end| IL:|of| IL:|the| IL:|list,| IL:|so| IL:|we| IL:|will| + IL:|find| IL:|it| IL:|later| IL:|on| IL:|during| IL:|this| IL:|iteration|) + + (IL:NCONC1 IL:|reachableNodes| IL:|childNode|))) + IL:|reachableNodes|))) ) (DEFMETHOD DISPLAY-BROWSER ((SELF WEB-EDITOR)) (IL:* IL:\; "29-Sep-86 12:15") (IL:* IL:\; "New method template") (LET ((NODELST (AND (SLOT-VALUE SELF 'STARTING-LIST) (GET-NODE-LIST SELF (SLOT-VALUE SELF 'STARTING-LIST) (SLOT-VALUE SELF 'GOOD-LIST))))) (COND (NODELST (IL:SHOWGRAPH (IL:LAYOUTGRAPH NODELST (TREE-ROOTS NODELST) (SLOT-VALUE SELF 'GRAPH-FORMAT) (SLOT-VALUE SELF 'BROWSE-FONT)) (SLOT-VALUE SELF 'WINDOW) NIL NIL (SLOT-VALUE SELF 'TOP-ALIGN)) (IL:* IL:\;  "kludge to reset the window props") (SETUP-WINDOW SELF)) (T (CLEAR SELF))))) (DEFMETHOD BROWSER-OBJECTS ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "28-May-84 12:58") (IL:* IL:\;  "Return a list of all the objects shown in the browser") (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| 'WINDOW) 'IL:GRAPH)) IL:|when| (IL:NLISTP (CAR IL:|node|)) IL:|collect| (CAR IL:|node|))) (DEFMETHOD GET-NODE-LIST ((SELF WEB-EDITOR) BROWSE-LIST GOOD-LIST) (IL:* IL:\; "21-Mar-85 14:09") (IL:* IL:|;;| "Compute the node data structures of the tree starting at browseList. If goodList is given, only include elements of it. If goodList=T make it be browseList.") (DECLARE (IL:GLOBALVARS IL:WHITESHADE)) (COND ((EQ GOOD-LIST T) (IL:SETQ GOOD-LIST BROWSE-LIST))) (PROG (SUBS PAIR NODE (OLD-NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:GRAPH))) (OBJ-LIST (CONS))) (IL:* IL:|;;| "first make objList which is a list of pairs (object . objName). objName will be used as a title for a node in the browser. This structure will be replaced by a graphNode when it is processed. The nodeID of the graphNode will be the object, and the label will be the name.") (IL:|for| IL:|objOrName| IL:|in| BROWSE-LIST IL:|do| (AND (IL:SETQ PAIR (OBJ-NAME-PAIR SELF IL:|objOrName|)) (NOT (IL:FASSOC (CAR PAIR) (CAR OBJ-LIST))) (IL:TCONC OBJ-LIST PAIR))) (IL:* IL:|;;| "Now MAP ON list so pair can be replaced by graphNode") (IL:|for| PAIR IL:|name| IL:|obj| IL:|subObjs| IL:|on| (CAR OBJ-LIST) IL:|when| (IL:NLISTP (IL:SETQ IL:|name| (CDAR PAIR))) IL:|do| (IL:SETQ IL:|subObjs| (CONS)) (IL:|for| IL:|sub| IL:|objPair| IL:|obj1| IL:|in| (GET-SUBS SELF (IL:SETQ IL:|obj| (CAAR PAIR))) IL:|do| (IL:* IL:|;;| "ObjNamePair returns NIL for destroyed objects. include only members of goodList in subs if given. Add to objList only once") (IL:SETQ IL:|obj1| (COND ((EQ (CAR IL:|sub|) 'IL:|Link Parameters|) (CADR IL:|sub|)) (T IL:|sub|))) (COND ((IL:SETQ IL:|objPair| (OBJ-NAME-PAIR SELF IL:|obj1|)) (COND ((NOT (IL:FASSOC IL:|obj1| (CAR OBJ-LIST))) (IL:TCONC OBJ-LIST IL:|objPair|))) (IL:TCONC IL:|subObjs| IL:|sub|)))) (RPLACA PAIR (IL:SETQ NODE (OR (IL:FASSOC IL:|obj| OLD-NODES) (IL:|create| IL:GRAPHNODE IL:NODEID IL:_ IL:|obj| IL:NODEBORDER IL:_ (LIST (IL:ADD1 (SLOT-VALUE SELF 'BOX-LINE-WIDTH)) IL:WHITESHADE))))) (IL:|replace| IL:TONODES IL:|of| NODE IL:|with| (CAR IL:|subObjs|)) (IL:|replace| IL:NODELABEL IL:|of| NODE IL:|with| IL:|name|) (IL:|replace| IL:NODEFONT IL:|of| NODE IL:|with| (SLOT-VALUE SELF 'BROWSE-FONT)) (IL:|replace| IL:NODEWIDTH IL:|of| NODE IL:|with| NIL) (IL:|replace| IL:NODEHEIGHT IL:|of| NODE IL:|with| NIL)) (RETURN (CAR OBJ-LIST)))) (DEFMETHOD OBJ-NAME-PAIR ((IL:|self| WEB-EDITOR) IL:|obj|) (IL:* IL:|;;| "Make a pair (object . objName) where objName is label to be used in browser") (LET NIL (IL:|if| (NULL IL:|obj|) IL:|then| NIL IL:|elseif| (AND (SLOT-VALUE IL:|self| 'GOOD-LIST) (NOT (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'GOOD-LIST)))) IL:|then| NIL IL:|elseif| (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'BAD-LIST)) IL:|then| NIL IL:|else| (CONS IL:|obj| (GET-DISPLAY-LABEL IL:|self| IL:|obj|))))) (DEFMETHOD GRAPH-FITS ((|self| WEB-EDITOR)) (IL:* IL:\; "24-Apr-86 15:00") (IL:* IL:|;;;| "Tests if graph fits in region") (LET ((|window| (SLOT-VALUE |self| 'WINDOW))) (LET ((|width| 0) (|height| 0) (|region| (IL:WINDOWPROP |window| 'IL:REGION)) (|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP |window| 'IL:GRAPH))) ) (COND (|nodes| (IL:SETQ |width| (IL:WIDTHIFWINDOW (IL:IDIFFERENCE (IL:MAX/RIGHT |nodes|) (IL:MIN/LEFT |nodes|)) (IL:WINDOWPROP |window| 'IL:BORDER))) (IL:SETQ |height| (IL:HEIGHTIFWINDOW (IL:IDIFFERENCE (IL:MAX/TOP |nodes|) (IL:MIN/BOTTOM |nodes|)) (IL:WINDOWPROP |window| 'IL:TITLE) (IL:WINDOWPROP |window| 'IL:BORDER))))) (NOT (OR (IL:IGREATERP |width| (IL:|fetch| IL:WIDTH IL:|of| |region|)) (IL:IGREATERP |height| (IL:|fetch| IL:HEIGHT IL:|of| |region|))))))) (DEFMETHOD NODE-REGION ((IL:|self| WEB-EDITOR) IL:|object|) (IL:* IL:\; "10-Dec-84 18:26") (IL:* IL:|;;| "what region does the object occupy in the display stream?") (LET ((IL:|node| (IL:FASSOC (COND ((IL:LITATOM IL:|object|) (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|))) (T IL:|object|)) (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| 'WINDOW) 'IL:GRAPH))))) (IL:|if| IL:|node| IL:|then| (IL:|create| IL:REGION IL:LEFT IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:XCOORD IL:|of| (IL:|fetch| IL:NODEPOSITION IL:|of| IL:|node| )) (IL:IQUOTIENT (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|) 2)) IL:BOTTOM IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:YCOORD IL:|of| (IL:|fetch| IL:NODEPOSITION IL:|of| IL:|node|)) (IL:IQUOTIENT (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|) 2)) IL:WIDTH IL:_ (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|) IL:HEIGHT IL:_ (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|)) ))) (DEFMETHOD RECOMPUTE ((SELF WEB-EDITOR) &OPTIONAL DONT-RESHAPE-FLG) (IL:* IL:\; " 8-Apr-87 14:42") (IL:* IL:\;  "Recompute the browseGraph in the same window") (PROG ((GRAPH-FITS (GRAPH-FITS SELF))) (DISPLAY-BROWSER SELF) (COND ((OR DONT-RESHAPE-FLG (NULL GRAPH-FITS)) (IL:* IL:\;  "Dont Reshape or rescroll. Assume window wants to stay the same size") ) (T (SHAPE-TO-HOLD SELF)))) SELF) (DEFMETHOD RECOMPUTE-IN-PLACE ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "10-Dec-84 18:27") (IL:* IL:|;;;| "recompute the graph, maintaining the current position") (LET* ((IL:|visibleRegion| (IL:DSPCLIPPINGREGION NIL (SLOT-VALUE IL:|self| 'WINDOW))) (IL:\x (IL:|fetch| IL:LEFT IL:|of| IL:|visibleRegion|)) (IL:\y (IL:|fetch| IL:BOTTOM IL:|of| IL:|visibleRegion|))) (IL:* IL:\;  "if we want to RecomputeInPlace, we must want the window to be kept the same") (RECOMPUTE IL:|self| T) (IL:* IL:\;  "we had to save x and y because visibleRegion gets clobbered by Recompute! Suprise!") (SCROLL-WINDOW IL:|self| IL:\x IL:\y))) (DEFMETHOD RECOMPUTE-LABELS ((|self| WEB-EDITOR)) (IL:* IL:\; "27-Feb-85 11:27") (IL:* IL:\;  "recompute the graph, including the labels") (CLEAR-LABEL-CACHE |self| T) (RECOMPUTE |self|)) (DEFMETHOD RECOMPUTE-IF-OPEN ((WEB-EDITOR WEB-EDITOR)) (IL:* IL:\; "27-Aug-86 12:37") (IF (IL:OPENWP (SLOT-VALUE WEB-EDITOR 'WINDOW)) (RECOMPUTE WEB-EDITOR))) (DEFMETHOD CLEAR-LABEL-CACHE ((WEB-EDITOR WEB-EDITOR) OBJECTS) (IL:* IL:\; " 5-Dec-85 12:02") (LET (CACHED-LABEL) (IL:* IL:|;;| "Delete the cached label for these items") (COND ((EQ OBJECTS T) (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE) NIL)) (T (IF (ATOM OBJECTS) (SETQ OBJECTS (CONS OBJECTS))) (DOLIST (OBJ OBJECTS) (IF (SETQ CACHED-LABEL (IL:ASSOC OBJ (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE))) (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE) (IL:DREMOVE CACHED-LABEL (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE))))))))) (DEFMETHOD OBJECT-FROM-LABEL ((SELF WEB-EDITOR) LABEL) (IL:* IL:\; " 4-Jan-85 18:20") (IL:* IL:|;;| "What object has this label?") (LET ((OBJECT-NODE (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:GRAPH)) IL:|thereis| (IL:EQUAL LABEL (IL:|fetch| IL:NODELABEL IL:|of| IL:|node|))))) (IL:|if| (IL:NLISTP (CAR OBJECT-NODE)) IL:|then| (CAR OBJECT-NODE) IL:|else| NIL))) (DEFMETHOD CHANGE-FONT-SIZE ((WEB-EDITOR WEB-EDITOR) &OPTIONAL SIZE) (IL:* IL:\; "13-Dec-84 13:04") (IL:* IL:\;  "Change the font size from whatever it is to size") (WHEN (OR SIZE (SETQ SIZE (IL:MENU (IL:|create| IL:MENU IL:TITLE IL:_ "Select Desired Size" IL:CHANGEOFFSETFLG IL:_ T IL:ITEMS IL:_ '(("Abort" NIL) 8 10 12 16))))) (SETF (SLOT-VALUE WEB-EDITOR 'BROWSE-FONT) (IL:FONTCREATE `(,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FAMILY) ,SIZE ,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FACE)))) (IL:* IL:\;  "clear out the label cache!") (RECOMPUTE-LABELS WEB-EDITOR))) (DEFMETHOD CHANGE-FORMAT ((|self| WEB-EDITOR) &OPTIONAL |format|) (IL:* IL:\; "21-Apr-84 19:52") (IL:* IL:\;  "Change format between Lattice and Tree") (COND ((IL:LISTP |format|) (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT) |format|)) ((SETQ |format| (IL:MENU (IL:|create| IL:MENU IL:ITEMS IL:_ (SLOT-VALUE |self| 'GRAPH-FORMAT-CHOICES)))) (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT) |format|))) (RECOMPUTE |self|)) (DEFMETHOD CHANGE-MAX-LABEL-SIZE ((SELF WEB-EDITOR) NEW-MAX-WIDTH NEW-MAX-LINES) (IL:* IL:\; "13-Dec-84 13:05") (IL:* IL:\;  "change the max label dimensions and redisplay the nodes -- if new size is NULL, don't change") (IL:|if| NEW-MAX-LINES IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-LINES) NEW-MAX-LINES)) (IL:|if| NEW-MAX-WIDTH IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH) NEW-MAX-WIDTH)) (IL:* IL:\;  "clear out the label cache") (RECOMPUTE-LABELS SELF)) (DEFMETHOD SHAPE-TO-HOLD ((SELF WEB-EDITOR)) (IL:* IL:\; "13-Jan-87 16:52") (IL:* IL:|;;| "Shape the browse window to just hold the nodes with BrowserMargin to spare") (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) (REGION (IL:WINDOWPROP WINDOW 'IL:REGION)) (NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WINDOW 'IL:GRAPH))) (MIN-WIDTH (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE SELF 'TITLE) (IL:DSPFONT NIL IL:|WindowTitleDisplayStream|)))) (MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WINDOW))) LEFT BOTTOM HEIGHT WIDTH RIGHT TOP) (IF NODES (PROGN (SETQ LEFT (IL:MIN/LEFT NODES)) (SETQ BOTTOM (IL:MIN/BOTTOM NODES)) (SETQ RIGHT (IL:MAX/RIGHT NODES)) (SETQ TOP (IL:MAX/TOP NODES)) (SETQ WIDTH (IL:IMAX MIN-WIDTH (IL:IMIN IL:|MaxLatticeWidth| (IL:WIDTHIFWINDOW (IL:PLUS IL:|BrowserMargin| (IL:IDIFFERENCE RIGHT LEFT)) (IL:WINDOWPROP WINDOW 'IL:BORDER)))) ) (SETQ HEIGHT (IL:IMAX MIN-HEIGHT (IL:IMIN IL:|MaxLatticeHeight| (IL:PLUS IL:|BrowserMargin| (IL:IDIFFERENCE TOP BOTTOM))))) (UNLESS (AND (IL:EQP WIDTH (IL:|fetch| IL:WIDTH IL:|of| REGION)) (IL:EQP (IL:HEIGHTIFWINDOW HEIGHT (IL:WINDOWPROP WINDOW 'IL:TITLE) (IL:WINDOWPROP WINDOW 'IL:BORDER)) (IL:|fetch| IL:HEIGHT IL:|of| REGION))) (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION) (IL:|fetch| IL:BOTTOM IL:|of| REGION) WIDTH HEIGHT) NIL))) (IL:* IL:|;;| "ELSE") (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION) (IL:|fetch| IL:BOTTOM IL:|of| REGION) MIN-WIDTH MIN-HEIGHT))))) (DEFMETHOD GET-DISPLAY-LABEL ((SELF WEB-EDITOR) OBJECT) (IL:* IL:|;;;| "get the display label. use the cache if it provides the answer; if not, and maxLabelWidth is set, use it to compute the appropriate bit map and then cache the result.") (LET ((CACHED-LABEL (IL:ASSOC OBJECT (SLOT-VALUE SELF 'LABEL-CACHE)))) (IF CACHED-LABEL (CDR CACHED-LABEL) (LET ((NEW-LABEL (BOX-PRINT-STRING (GET-LABEL SELF OBJECT) (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH) (SLOT-VALUE SELF 'LABEL-MAX-LINES) (SLOT-VALUE SELF 'BROWSE-FONT)))) (IL:|if| (IL:LISTP NEW-LABEL) IL:|then| (IL:* IL:\;  "GRAPHER dies if the label is a list") (IL:SETQ NEW-LABEL (IL:MKSTRING NEW-LABEL))) (PUSH (CONS OBJECT NEW-LABEL) (SLOT-VALUE SELF 'LABEL-CACHE)) NEW-LABEL)))) (DEFMETHOD BOX-NODE ((SELF WEB-EDITOR) OBJECT &OPTIONAL KEEP-PREVIOUS-BOX) (IL:* IL:\; " 8-Apr-87 18:34") "Puts a box around the node in the graph representing the object" (IL:* IL:|;;|  "If there was a previously boxed node, remove the box from around it and set it to nil") (WHEN (AND (NOT KEEP-PREVIOUS-BOX) DESTINATION-BROWSER (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE)) (HIGHLIGHT-NODE DESTINATION-BROWSER (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE) (SLOT-VALUE SELF 'BOX-LINE-WIDTH) IL:WHITESHADE) (SETF (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE) NIL)) (SETQ DESTINATION-BROWSER SELF) (IL:* IL:\; "update the global") (HIGHLIGHT-NODE SELF OBJECT (SLOT-VALUE SELF 'BOX-LINE-WIDTH) IL:BLACKSHADE) (SETF (SLOT-VALUE SELF 'BOXED-NODE) OBJECT)) (DEFMETHOD UNMARK-NODES ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "10-Dec-84 12:27") (IL:* IL:\;  "clear the graph nodes, removing all shading and highlighting") (REMOVE-HIGHLIGHTS IL:|self|) (REMOVE-SHADING IL:|self|)) (DEFMETHOD HIGHLIGHT-NODE ((SELF WEB-EDITOR) OBJECT WIDTH SHADE) (IL:* IL:\; "13-Dec-85 15:16") (IL:* IL:|;;;| "highlight a node by surronding it with a shaded box") (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:GRAPH))))) (AND NODE (DISPLAY-NODE-HIGHTLIGHTS SELF NODE SHADE WIDTH)))) (DEFMETHOD SHADE-NODE ((IL:|self| WEB-EDITOR) IL:|object| IL:|shade|) (IL:* IL:\; "15-Jan-87 18:34") (IL:* IL:|;;| "shade the background of a node") (LET ((IL:|node| (IL:FASSOC (COND ((IL:LITATOM IL:|object|) (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|))) (T IL:|object|)) (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| 'WINDOW) 'IL:GRAPH))))) (IL:|if| IL:|node| IL:|then| (IL:|if| (IL:BITMAPP (IL:|fetch| IL:NODELABEL IL:|of| IL:|node| )) IL:|then| (IL:* IL:|;;| "Need to forget the old bitmap, in case it already has a shade blt'ed into it. This will fail if the GetDisplayLabel msg returns something different from the previous value, but what can you do?") (CLEAR-LABEL-CACHE IL:|self| IL:|object|) (LET ((IL:|newLabel| (GET-DISPLAY-LABEL IL:|self| IL:|object|))) (IL:|replace| IL:NODELABEL IL:|of| IL:|node| IL:|with| IL:|newLabel|) (IL:|if| (AND IL:|shade| (IL:BITMAPP IL:|newLabel|)) IL:|then| (IL:BITBLT NIL NIL NIL IL:|newLabel| NIL NIL NIL NIL 'IL:TEXTURE 'IL:PAINT IL:|shade|)))) (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:|shade|)))) (DEFMETHOD DISPLAY-NODE-HIGHTLIGHTS ((SELF WEB-EDITOR) NODE SHADE BOX-WIDTH) (IL:RESET/NODE/BORDER NODE (COND (SHADE (LIST BOX-WIDTH SHADE)) (T BOX-WIDTH)) (SLOT-VALUE SELF 'WINDOW))) (DEFMETHOD DISPLAY-NODE-SHADING ((SELF WEB-EDITOR) NODE SHADE) (IL:* IL:\; "13-Dec-85 15:13") (IL:* IL:\; "New method template") (IL:RESET/NODE/LABELSHADE NODE (OR SHADE IL:WHITESHADE) (SLOT-VALUE SELF 'WINDOW))) (DEFMETHOD REMOVE-HIGHLIGHTS ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "13-Dec-85 15:16") (IL:* IL:|;;;| "gets rid of all highlighting in the lattice") (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| 'WINDOW) 'IL:GRAPH)) IL:|do| (DISPLAY-NODE-HIGHTLIGHTS IL:|self| IL:|node| NIL)) (SETF (SLOT-VALUE IL:|self| 'BOXED-NODE) NIL)) (DEFMETHOD REMOVE-SHADING ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "13-Dec-85 15:14") (IL:* IL:|;;;| "gets rid of all shading in the lattice") (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| 'WINDOW) 'IL:GRAPH)) IL:|do| (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:WHITESHADE))) (DEFMETHOD FLASH-NODE ((IL:|self| WEB-EDITOR) IL:|node| IL:N IL:|flashTime| IL:|leaveFlipped?|) (IL:* IL:\; "12-Dec-84 16:09") (IL:* IL:\; "Flip node N times") (IL:SETQ IL:|node| (IL:FASSOC (COND ((IL:LITATOM IL:|node|) (IL:SETQ IL:|node| (IL:|GetObjectRec| IL:|node|))) (T IL:|node|)) (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| 'WINDOW) 'IL:GRAPH)))) (IL:|if| IL:|node| IL:|then| (IL:|for| IL:\i IL:|from| 1 IL:|to| (OR IL:N 3) IL:|do| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW)) (IL:DISMISS (OR IL:|flashTime| 300)) (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW)) (IL:DISMISS (OR IL:|flashTime| 300))) (IL:|if| IL:|leaveFlipped?| IL:|then| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW))))) (DEFMETHOD FLIP-NODE ((SELF WEB-EDITOR) OBJECT) (IL:* IL:\; "13-Dec-85 15:18") (IL:* IL:\;  "Inverts the video around the node in the graph representing the object") (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) 'IL:GRAPH))))) (AND NODE (DISPLAY-NODE-SHADING SELF NODE (IL:INVERTED/SHADE/FOR/GRAPHER (IL:|fetch| IL:NODELABELSHADE IL:|of| NODE)))))) (DEFMETHOD POSITION-NODE ((SELF WEB-EDITOR) OBJECT WINDOW-X WINDOW-Y) (IL:* IL:\; "10-Dec-84 18:24") (IL:* IL:|;;;| "scrolls the window so that the node is in the given position of the window. If windowX or windowY is a FLOATP, it it taken to be a window-relative postion; if a FIXP, it is a window-absolute position.") (LET ((REGION (NODE-REGION SELF OBJECT))) (IL:|if| REGION IL:|then| (SCROLL-WINDOW SELF (IL:|fetch| IL:LEFT IL:|of| REGION) (IL:|fetch| IL:BOTTOM IL:|of| REGION) WINDOW-X WINDOW-Y)))) (IL:DEFINEQ (BOX-PRINT-STRING + (IL:LAMBDA (STRING MAX-CHARS-WIDTH MAX-LINES FONT OLD-BITMAP) + (IL:* IL:\; "Edited 29-Jan-88 15:06 by Rao") + + (IL:* IL:|;;| + "return a bitmap containing the string, in the given font, with MAX-WIDTH at most width") + (IL:* IL:\; + "sizes of NULL or 0 mean no max size") + (IL:SETQ MAX-CHARS-WIDTH (OR MAX-CHARS-WIDTH 0)) + (IL:SETQ MAX-LINES (OR MAX-LINES 0)) + (IL:|if| (IL:ZEROP MAX-CHARS-WIDTH) + IL:|then| (IL:* IL:\; + "no max width, then just return the STRING") + STRING + IL:|else| + (PROG ((MAX-WIDTH (IL:ITIMES MAX-CHARS-WIDTH (IL:STRINGWIDTH "A" FONT))) + (NCHARS (IL:NCHARS STRING)) + (NLINES 0) + (SPOS 0) + (REGION (IL:CONSTANT (IL:|create| IL:REGION))) + (TRUE-MAX-WIDTH 0) + NEXTPOS DSP SUBSTR) + (IL:SETQ STRING (IL:MKSTRING STRING)) (IL:* IL:\; + "we need to find the size of the resultant bitmap") + IL:NEXTBREAK + (IL:|if| (IL:ILESSP SPOS NCHARS) + IL:|then| (IL:|add| NLINES 1) (IL:* IL:\; + "at least one character, even if exceed MAX-WIDTH") + (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING + (IL:SUBSTRING STRING (IL:ADD1 SPOS) + -1) + MAX-WIDTH FONT)))) + (IL:SETQ TRUE-MAX-WIDTH (IL:IMAX TRUE-MAX-WIDTH (IL:STRINGWIDTH + (IL:SUBSTRING STRING + (IL:ADD1 SPOS) + (IL:IPLUS SPOS NEXTPOS) + ) + FONT))) + (IL:|add| SPOS NEXTPOS) + (GO IL:NEXTBREAK)) + (IL:|if| (NOT (IL:ZEROP MAX-LINES)) + IL:|then| (IL:SETQ NLINES (IL:IMIN MAX-LINES NLINES))) + (IL:* IL:\; + "that we have the size, lets build it") + (IL:SETQ DSP (IL:DSPCREATE + (IL:|if| (AND OLD-BITMAP + (NOT (OR (IL:GREATERP TRUE-MAX-WIDTH (IL:BITMAPWIDTH + OLD-BITMAP)) + (IL:GREATERP (IL:ITIMES NLINES + (IL:FONTPROP FONT + 'IL:HEIGHT)) + (IL:BITMAPHEIGHT OLD-BITMAP))))) + IL:|then| OLD-BITMAP + IL:|else| (IL:BITMAPCREATE TRUE-MAX-WIDTH (IL:ITIMES + NLINES + (IL:FONTPROP FONT + 'IL:HEIGHT)))))) + (IL:DSPFONT FONT DSP) + (IL:DSPRESET DSP) + (IL:SETQ SPOS 0) + (IL:|replace| IL:LEFT IL:|of| REGION IL:|with| 0) + (IL:|replace| IL:WIDTH IL:|of| REGION IL:|with| TRUE-MAX-WIDTH) + (IL:|replace| IL:HEIGHT IL:|of| REGION IL:|with| (IL:FONTPROP FONT + 'IL:HEIGHT)) + (IL:|replace| IL:BOTTOM IL:|of| REGION IL:|with| (IL:ITIMES + NLINES + (IL:FONTPROP FONT + 'IL:HEIGHT))) + IL:NEXTPIECE + (IL:|add| NLINES -1) + (IL:|if| (IL:ILESSP SPOS NCHARS) + IL:|then| (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING + (IL:SUBSTRING STRING (IL:ADD1 SPOS) + -1) + TRUE-MAX-WIDTH FONT)))) + (IL:SETQ SUBSTR (IL:SUBSTRING STRING (IL:ADD1 SPOS) + (IL:IPLUS NEXTPOS SPOS))) + (IL:|replace| IL:BOTTOM IL:|of| REGION + IL:|with| (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| REGION) + (IL:|fetch| IL:HEIGHT IL:|of| REGION))) + (IL:|if| (AND (IL:ZEROP NLINES) + (IL:ILESSP (IL:IPLUS NEXTPOS SPOS) + NCHARS)) + IL:|then| (IL:* IL:\; "we need to abbreviate!") + (IL:CENTERPRINTINREGION (IL:CONCAT (IL:SUBSTRING SUBSTR 1 -3) + "...") + REGION DSP) + (GO IL:ALLDONE) + IL:|else| (IL:* IL:\; "out this piece") + (IL:CENTERPRINTINREGION SUBSTR REGION DSP) + (IL:|add| SPOS NEXTPOS) + (GO IL:NEXTPIECE))) + IL:ALLDONE + (RETURN (IL:DSPDESTINATION NIL DSP)))))) (BREAK-STRING-FOR-BOXING + (IL:LAMBDA (IL:MSG IL:WIDTH IL:FONT) (IL:* IL:\; "11-Dec-84 10:29") + + (IL:* IL:\; IL:|Stolen| IL:|from| IL:|the| IL:|function| IL:ICONW.FORMATLINE + IL:-- IL:|modified| IL:|to| IL:|try| IL:|to| IL:|break| IL:|at| "word" + IL:|boundaries,| IL:|whatever| IL:|they| IL:|are|) + + (IL:* IL:\; IL:\a IL:|list| IL:|of| IL:|the| IL:|char#| IL:|relative| IL:|to| + IL:|char| 1 IL:|of| IL:|where| IL:|to| IL:|break| IL:|next| IL:|line,| IL:|and| + IL:|how| IL:|much| IL:|space| IL:|was| LEFT IL:|over| + (IL:|for| IL:|centering| IL:&\c)) + + (COND + (IL:MSG (IL:* IL:\; IL:|there| IL:|really| + IL:|is| IL:\a IL:|title,| IL:|go| + IL:|ahead| IL:|and| IL:|format| + IL:|the| IL:|next| IL:|line.|) + (IL:|bind| (IL:TX IL:_ 0) + (IL:LASTB IL:_ 0) + (IL:CH IL:_ 0) + (IL:TMSG IL:_ (IL:OPENSTRINGSTREAM IL:MSG)) + (IL:MSGLEN IL:_ (IL:NCHARS IL:MSG)) IL:|for| IL:I IL:|from| 1 + IL:|by| 1 + IL:|do| (IL:* IL:\; IL:|thru| IL:|the| + IL:|characters| IL:|one| IL:|by| + IL:|one.|) + (COND + ((IL:IGREATERP IL:TX IL:WIDTH) (IL:* IL:\; IL:|past| IL:|the| + IL:|right| IL:|margin.| + IL:|Time| IL:|to| IL:|stop.|) + (IL:CLOSEF? IL:TMSG) + (RETURN (COND + ((IL:LISTP IL:LASTB) (IL:* IL:\; IL:|is| IL:\a IL:|space| + IL:|we| IL:|can| IL:|break| IL:|the| + IL:|line| IL:|at.| + IL:|Break| IL:|there.|) + IL:LASTB) + (T + + (IL:* IL:\; IL:|were| IL:|no| IL:|spaces| IL:|on| IL:|this| IL:|line.| + IL:|Break| IL:|after| IL:|the| IL:|last| IL:|character| IL:|that| IL:|did| + IL:|fit.|) + + (CONS (IL:IDIFFERENCE IL:I 2) + (IL:IDIFFERENCE IL:WIDTH (IL:IDIFFERENCE IL:TX + (IL:CHARWIDTH IL:CH + IL:FONT)))))))) + ((IL:EOFP IL:TMSG) (IL:* IL:\; IL:|was| IL:|the| + IL:|last| IL:|character.|) + (IL:CLOSEF? IL:TMSG) + (RETURN (CONS (IL:SUB1 IL:I) + (IL:IDIFFERENCE IL:WIDTH IL:TX)))) + (T (IL:* IL:\; IL:|at| IL:|the| + IL:|next| IL:|character.|) + (IL:SETQ IL:CH (IL:BIN IL:TMSG)) + (IL:SELCHARQ IL:CH + ((IL:SPACE IL:\. IL:\: IL:\; IL:\, / IL:\\ IL:* - IL:\#) + + (IL:* IL:\; IL:|where| IL:|word| IL:|breaks| IL:|are,| IL:|so| IL:|we| IL:|can| + IL:|back| IL:|up| IL:|and| IL:|split| IL:|lines| IL:|there| IL:|if| + IL:|possible.|) + + (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH IL:TX + )))) + (IL:CR (IL:* IL:\; IL:|forces| IL:\a + IL:|new| IL:|line.|) + (RETURN (CONS (IL:IMINUS IL:I) + (IL:IDIFFERENCE IL:WIDTH IL:TX)))) + (IL:|if| (AND (NOT (IL:U-CASEP (IL:CHARACTER IL:CH))) + (NOT (IL:EOFP IL:TMSG)) + (IL:U-CASEP (IL:PEEKC IL:TMSG))) + IL:|then| (IL:* IL:\; IL:|from| IL:|upper| + IL:|to| IL:|lower| IL:|case| IL:|is| + IL:|also| IL:\a IL:|word| IL:|break|) + (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH + IL:TX))))) + (IL:SETQ IL:TX (IL:IPLUS IL:TX (IL:CHARWIDTH IL:CH IL:FONT))))))) + (T (IL:* IL:\; IL:|isn't| IL:\a + IL:|title;| IL:|return| IL:\a + IL:|dummy| IL:|entry| IL:|for| + IL:|the| IL:|line| IL:|formatter.|) + (CONS 0 IL:WIDTH))))) (BOX-WINDOW-NODE + (IL:LAMBDA (IL:|nodeLabel| WINDOW) (IL:* IL:\; "Edited 29-Jan-88 11:31 by Rao") + (IL:* IL:\; " 7-Sep-84 14:36") + + (IL:* IL:|;;| "a box around the node with nodeLabel in the graph. A nodeLabel in browsers is an object. Does nothing if node not found.") + + (PROG (IL:|node| IL:|nodes|) + (COND + ((AND (IL:WINDOWP WINDOW) + (IL:SETQ IL:|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP + WINDOW + 'IL:GRAPH))) + (IL:SETQ IL:|node| (IL:FASSOC IL:|nodeLabel| IL:|nodes|))) + (IL:DRAWAREABOX (IL:GN/LEFT IL:|node|) + (IL:GN/BOTTOM IL:|node|) + (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|) + (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|) + 1 + 'IL:INVERT WINDOW)))))) ) (IL:* IL:\; "Button Events") (IL:DEFINEQ (FIND-SELECTED-NODE + (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 12-Nov-87 01:30 by Rao") + (IL:* IL:\; "10-Dec-84 17:53") + + (IL:* IL:|;;| "Used in BUTTONEVENTFN and gets called whenever cursor moves or button is down. Adapted from APPLYTOSELECTEDNODE in GRAPHER package; returns the selected item rather than applying a function on the inside of the button event fn.") + + (IL:* IL:|;;| + "Also this was modified to pop up the middle button menu on button down rather than button up.") + + (PROG ((LOOPS-WINDOW (IL:WINDOWPROP WINDOW 'WEB-EDITOR)) + (NODELST (IL:|fetch| (IL:GRAPH IL:GRAPHNODES) IL:|of| (IL:WINDOWPROP WINDOW + 'IL:GRAPH))) + (DS (IL:WINDOWPROP WINDOW 'IL:DSP)) + BUTTON OLDPOS REG NOW NEAR) (IL:* IL:\; + "note which button is down.") + (IL:* IL:\; + "get the region of this window.") + (IL:SETQ REG (IL:WINDOWPROP WINDOW 'IL:REGION)) + (IL:|until| (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE)) IL:|do| (IL:GETMOUSESTATE)) + (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:SETQ OLDPOS (IL:CURSORPOSITION NIL DS)))) + IL:FLIP + + + (IL:* IL:|;;| "This is kirk's quick hack to get middle button to bring up immediately.") + + (WHEN (IL:LASTMOUSESTATE IL:MIDDLE) + (RETURN (IL:|fetch| IL:NODEID IL:|of| NEAR))) + (AND NOW (IL:FLIPNODE NOW DS)) + (AND NEAR (IL:FLIPNODE NEAR DS)) + (IL:SETQ NOW NEAR) + IL:LP + (IL:* IL:\; + "wait for a button up or move out of region") + (IL:GETMOUSESTATE) + (COND + ((IL:LASTMOUSESTATE (AND (NOT IL:LEFT) + (NOT IL:MIDDLE))) (IL:* IL:\; + "left button up, process it.") + (AND NOW (IL:FLIPNODE NOW DS)) (IL:* IL:\; + "NOW node has been selected.") + (RETURN (IL:|fetch| IL:NODEID IL:|of| NOW))) + ((NOT (IL:INSIDE? (IL:WINDOWPROP WINDOW 'IL:REGION) + IL:LASTMOUSEX IL:LASTMOUSEY)) (IL:* IL:\; + "outside of region, return") + (AND NOW (IL:FLIPNODE NOW DS)) + (RETURN)) + ((EQ NOW (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:CURSORPOSITION NIL DS OLDPOS)))) + (GO IL:LP)) + (T (GO IL:FLIP)))))) ) (DEFMETHOD BUTTON-EVENT-FN ((SELF WEB-EDITOR)) (IL:* IL:\; " 2-Jan-86 16:41") (IL:* IL:\;  "Called when there is a button event in a Loops Window") (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) (OR (IL:ERSETQ (COND ((NULL (IL:INSIDEP (IL:DSPCLIPPINGREGION NIL WINDOW) (IL:LASTMOUSEX WINDOW) (IL:LASTMOUSEY WINDOW))) (TITLE-SELECTION SELF)) ((IL:MOUSESTATE IL:LEFT) (LEFT-SELECTION SELF)) ((IL:MOUSESTATE IL:MIDDLE) (MIDDLE-SELECTION SELF)) ((IL:MOUSESTATE IL:RIGHT) (RIGHT-SELECTION SELF))))))) (DEFMETHOD LEFT-SELECTION ((SELF WEB-EDITOR)) (IF (MOVE-DOWN-P) (IF (SLOT-VALUE SELF 'NODE-MOVER-P) (NODE-MOVE SELF) (NODE-MOVE-SHALLOW SELF)) (NODE-SELECTION SELF 'IL:LEFT))) (DEFMETHOD MIDDLE-SELECTION ((SELF WEB-EDITOR)) (IL:* IL:\; "15-May-85 19:04") (IL:* IL:|;;| "This function called from the GRAPHER package when a node is selected with the middle mouse button. If no node is selected then just returns.") (PROG (SELECTION OBJECT (WINDOW (SLOT-VALUE SELF 'WINDOW)) (WEB-EDITOR SELF)) (DECLARE (IL:SPECVARS OBJECT WEB-EDITOR)) (COND ((NULL (IL:SETQ OBJECT (FIND-SELECTED-NODE WINDOW))) (RETURN))) (SETF (SLOT-VALUE WEB-EDITOR 'LAST-SELECTED-OBJECT) OBJECT) (IL:GETMOUSESTATE) (FLIP-NODE SELF OBJECT) (IL:SETQ SELECTION (OR (NODE-ACTION SELF OBJECT 'IL:MIDDLE) (PROGN (FLIP-NODE SELF OBJECT) (RETURN NIL)))) (FLIP-NODE SELF OBJECT) (DO-SELECTED-COMMAND WEB-EDITOR SELECTION OBJECT))) (DEFMETHOD RIGHT-SELECTION ((SELF WEB-EDITOR)) (IL:* IL:\; "17-Apr-84 15:46") (IL:* IL:\;  "Do RightButtonItems on selection.") (LET* ((CHOICE (CHOICE-MENU SELF 'RIGHT-BUTTON-ITEMS))) (IF CHOICE (FUNCALL CHOICE SELF)))) (DEFMETHOD TITLE-SELECTION ((SELF WEB-EDITOR)) (IL:* IL:\; "17-Apr-84 15:35") (IL:* IL:|;;| " Do TitleItems if selected in title area. Replaces TitleSelection in Window because this one does evaluation in TTY process, and saves events on history") (LET* ((CHOICE (CHOICE-MENU SELF 'TITLE-ITEMS))) (IF CHOICE (FUNCALL CHOICE SELF)))) (DEFMETHOD NODE-SELECTION ((SELF WEB-EDITOR) BUTTON) (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) (OBJECT (FIND-SELECTED-NODE WINDOW))) (DECLARE (IL:SPECVARS OBJECT)) (IL:* IL:\; "SPECVARS for whenHeldFn") (IF (LISTP OBJECT) (SETQ OBJECT (CAR OBJECT))) (COND ((NOT (NULL OBJECT)) (SETF (SLOT-VALUE SELF 'LAST-SELECTED-OBJECT) OBJECT))) (IL:GETMOUSESTATE) (WHEN OBJECT (LET ((SELECTOR (NODE-ACTION SELF OBJECT BUTTON))) (COND (SELECTOR (DO-SELECTED-COMMAND SELF SELECTOR OBJECT))))))) (DEFMETHOD NODE-ACTION ((SELF WEB-EDITOR) NODE BUTTON) (IL:* IL:\; " 8-Apr-87 17:11") (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) (LET ((WINDOW-FOR-MENU SELF)) (IL:GETMOUSESTATE) (CHOICE-MENU SELF (IL:* IL:|;;| " A Hook for letting nodes tailor menu items.") (NODE-MENU-ITEMS NODE BUTTON)))) (DEFMETHOD NODE-MENU-ITEMS ((NODE WEB-NODE) BUTTON) (CASE BUTTON (IL:LEFT 'LEFT-BUTTON-ITEMS) (IL:MIDDLE 'MIDDLE-BUTTON-ITEMS))) (DEFMETHOD CHOICE-MENU ((SELF WEB-EDITOR) ITEM-CV) (IL:* IL:\; "29-Dec-85 13:54") (IL:* IL:|;;|  "Create a menu which allows subitems to be displayed. Cache it in the web-editor ") (LET (ITEMS MENU) (SETQ MENU (REST (ASSOC ITEM-CV (SLOT-VALUE SELF 'MENU-CACHE)))) (COND ((AND MENU (IL:TYPE? IL:MENU MENU)) (IL:MENU MENU)) ((NOT (LISTP (SETQ ITEMS (GET-MENU-ITEMS SELF ITEM-CV)))) ITEMS) (T (IL:SETQ MENU (IL:CREATE IL:MENU IL:ITEMS IL:_ ITEMS IL:MENUOFFSET IL:_ (IL:CREATEPOSITION -1 0) IL:WHENSELECTEDFN IL:_ 'WEB-MENU-WHENSELECTEDFN IL:WHENHELDFN IL:_ 'WINDOW-WHEN-HELD-FN IL:CHANGEOFFSETFLG IL:_ T IL:CENTERFLG IL:_ T)) (IL:* IL:\; "Cache menu if menus is T") (IF (SLOT-VALUE SELF 'CACHE-MENU-P) (SETF (SLOT-VALUE SELF 'MENU-CACHE) (ACONS ITEM-CV MENU (SLOT-VALUE SELF 'MENU-CACHE)))) (IL:MENU MENU))))) (DEFMETHOD DO-SELECTED-COMMAND ((WEB-EDITOR WEB-EDITOR) COMMAND OBJ &OPTIONAL NODE) (IL:* IL:\; "17-Sep-86 17:49") (IL:* IL:|;;| "Do the selected command or forwards it to the object") (IF COMMAND (IL:* IL:|;;| "Take care of being passed in a dummy node from browser in Lattice mode. --- Dummy nodes are indicated by having the object in a list") (LET ((ARGS (IF (IL:LISTP COMMAND) (CDR COMMAND) NIL)) (COMMAND (IF (IL:LISTP COMMAND) (CAR COMMAND) COMMAND)) (OBJ (IF (IL:LISTP OBJ) (CAR OBJ) OBJ))) (WHEN (IL:FMEMB COMMAND (SLOT-VALUE WEB-EDITOR 'LOCAL-COMMANDS)) (SETQ ARGS (CONS OBJ ARGS)) (SETQ OBJ WEB-EDITOR)) (IL:* IL:|;;|  "Grays out the node at the beginning of the command, and ungrays it when the command completes.") (SETQ NODE OBJ) (IF NODE (PROGN (SHADE-NODE WEB-EDITOR NODE IL:GRAYSHADE2) (IL:BLOCK 500) (SHADE-NODE WEB-EDITOR NODE IL:WHITESHADE) (APPLY COMMAND OBJ ARGS)) (APPLY COMMAND OBJ ARGS))))) (DEFMETHOD WHEN-MENU-ITEM-HELD ((SELF WEB-EDITOR) ITEM MENU KEY) (IL:* IL:\; " 8-Apr-87 17:13") (IL:* IL:|;;;| "What to do when the menu item is held") (IL:PROMPTPRINT (OR (COND ((IL:NLISTP ITEM) NIL) (T (CADDR ITEM))) "When released this item will be selected"))) (DEFMETHOD ITEM-MENU ((SELF WEB-EDITOR) ITEMS TITLE) (IL:* IL:\; "21-Apr-84 09:31") (IL:* IL:\;  "Create a simnple (one level) menu which will not overflow height of screen") (IL:|create| IL:MENU IL:ITEMS IL:_ ITEMS IL:MENUCOLUMNS IL:_ (IL:ADD1 (IL:IQUOTIENT (IL:ITIMES (IL:FONTHEIGHT IL:MENUFONT) (IL:LENGTH ITEMS)) 750)) IL:TITLE IL:_ TITLE IL:CHANGEOFFSETFLG IL:_ T)) (DEFMETHOD GET-MENU-ITEMS ((SELF WEB-EDITOR) ITEM-CV) (IL:* IL:\; "23-Oct-84 12:36") (IL:* IL:\; "Get item list for menu") (SLOT-VALUE SELF ITEM-CV)) (DEFMETHOD CLEAR-MENU-CACHE ((SELF WEB-EDITOR)) (IL:* IL:\; "11-Apr-86 14:46") (IL:* IL:\;  "Delete Menus saved on menus") (SETF (SLOT-VALUE SELF 'MENU-CACHE) NIL) SELF) (IL:DEFINEQ (WEB-MENU-WHENSELECTEDFN + (IL:LAMBDA (ITEM MENU BUTTON) (IL:* IL:\; "Edited 14-Jul-87 17:43 by Rao") + (IL:* IL:\; "13-DEC-83 21:03") + (PROG (SECOND-ELEMENT) + (RETURN (COND + ((IL:NLISTP ITEM) + ITEM) + ((IL:NLISTP (IL:SETQ SECOND-ELEMENT (CADR ITEM))) + SECOND-ELEMENT) + ((EQ (CAR SECOND-ELEMENT) + 'PROGN) + (IL:EVAL SECOND-ELEMENT)) + (T SECOND-ELEMENT)))))) (WINDOW-WHEN-HELD-FN + (LAMBDA (ITEM MENU KEY) (IL:* IL:\; "Edited 9-Jul-87 11:58 by Rao") + (IL:* IL:\; "29-Dec-85 15:28") + (IL:* IL:\; + "Send to window the message to respond to time out on menu") + (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) + (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY))) ) (IL:DEFINEQ (SUB-ITEM-SELECTION + (IL:LAMBDA (ITEM MENU BUTTON) (IL:* IL:\; "Edited 14-Jul-87 17:13 by Rao") + (IL:* IL:\; "13-DEC-83 21:03") + + (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button. For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu") + + (PROG (IT IT1) + (RETURN (COND + ((IL:NLISTP ITEM) + ITEM) + ((IL:NLISTP (IL:SETQ IT (CADR ITEM))) + IT) + ((EQ (IL:SETQ IT1 (CAR IT)) + 'QUOTE) + (CADR IT)) + ((EQ IT1 'PROGN) + (IL:EVAL IT)) + ((IL:LISTP IT1) + (IL:EVAL IT1)) + (T IT1)))))) (DUAL-SUB-ITEMS + (IL:LAMBDA (MENU ITEM) (IL:* IL:\; "Edited 14-Jul-87 17:14 by Rao") + (IL:* IL:\; "13-DEC-83 21:07") + + (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button. For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu") + + (PROG (IT IT1) + (RETURN (COND + ((OR (IL:NLISTP ITEM) + (IL:NLISTP (IL:SETQ IT (CADR ITEM))) + (EQ (IL:SETQ IT1 (CAR IT)) + 'QUOTE) + (EQ IT1 'PROGN) + (IL:NLISTP (IL:SETQ IT1 (CADR IT)))) + NIL) + (T IT1)))))) (WINDOW-WHEN-HELD-FN + (LAMBDA (ITEM MENU KEY) (IL:* IL:\; "Edited 9-Jul-87 11:58 by Rao") + (IL:* IL:\; "29-Dec-85 15:28") + (IL:* IL:\; + "Send to window the message to respond to time out on menu") + (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) + (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY))) (DO-MENU-METHOD + (IL:LAMBDA (OBJECT ITEMS) (IL:* IL:\; "Edited 14-Jul-87 17:15 by Rao") + (IL:* IL:\; "13-NOV-83 16:20") + (PROG ((SELECTOR (AND ITEMS (DUAL-MENU ITEMS)))) + (AND SELECTOR (RETURN (FUNCALL SELECTOR OBJECT)))))) (DUAL-MENU + (IL:LAMBDA (ITEMS WHEN-HELD-FN) (IL:* IL:\; "Edited 14-Jul-87 17:16 by Rao") + (IL:* IL:\; " 9-FEB-84 16:17") + (IL:* IL:\; + "and pops up a menu which allows differential selection on LEFT an middle buttons") + (IL:MENU (IL:|create| IL:MENU + IL:ITEMS IL:_ ITEMS + IL:WHENSELECTEDFN IL:_ 'SUB-ITEM-SELECTION + IL:SUBITEMFN IL:_ 'DUAL-SUB-ITEMS + IL:WHENHELDFN IL:_ WHEN-HELD-FN + IL:CHANGEOFFSETFLG IL:_ T)))) (DUAL-SELECTION + (IL:LAMBDA (ITEM MENU BUTTON) (IL:* IL:\; "Edited 14-Jul-87 17:28 by Rao") + (IL:* IL:\; "29-MAR-83 17:57") + + (IL:* IL:|;;| "MENU WHENSELECTEDFN which allows differential selection on LEFT and middle button. For such differential selection ITEM should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when ITEM is selected with middle, or midValue can be an itemList, which will be displayed in a subselection MENU") + + (PROG (IT IT1) + (RETURN (COND + ((IL:NLISTP ITEM) + ITEM) + ((IL:NLISTP (IL:SETQ IT (CADR ITEM))) + IT) + ((EQ (IL:SETQ IT1 (CAR IT)) + 'QUOTE) + (CADR IT)) + ((EQ IT1 'PROGN) + (IL:EVAL IT)) + ((EQ BUTTON 'IL:LEFT) + (COND + ((IL:LISTP IT1) + (IL:EVAL IT1)) + (T IT1))) + ((IL:NLISTP (IL:SETQ IT1 (CADR IT))) + IT1) + (T (DUAL-MENU IT1))))))) ) (IL:* IL:\; "Node Moving Protocol") (DEFMETHOD NODE-MOVE ((SELF WEB-EDITOR)) (LET ((OLD-REGIONS (MAKE-REG-ASSOC SELF)) NEW-REGIONS MOVED-PAIR NEW-FATHER CLOSEST-PAIR) (NODE-MOVE-SHALLOW SELF) (SETQ NEW-REGIONS (MAKE-REG-ASSOC SELF)) (SETQ MOVED-PAIR (IL:|for| |npair| IL:|in| NEW-REGIONS IL:|as| |opair| IL:|in| OLD-REGIONS IL:|thereis| (NOT (IL:EQUAL (CAR |opair|) (CAR |npair|))))) (WHEN (AND MOVED-PAIR (IL:* IL:|;;| "The moved guy has a parent") (SLOT-VALUE (CDR MOVED-PAIR) 'PARENT)) (IL:DREMOVE MOVED-PAIR NEW-REGIONS) (SETQ NEW-REGIONS (IL:* IL:|;;| "Collect the pairs that havn't changed.") (IL:|bind| (SCIONS-OF-MOVED IL:_ (SCIONS (CDR MOVED-PAIR))) IL:|for| PAIR IL:|in| NEW-REGIONS IL:|unless| (IL:MEMBER (CDR PAIR) SCIONS-OF-MOVED) IL:|collect| PAIR)) (SETQ CLOSEST-PAIR (IL:|bind| (\b IL:_ (IL:|fetch| IL:BOTTOM IL:|of| (CAR MOVED-PAIR))) (\l IL:_ (IL:|fetch| IL:LEFT IL:|of| (CAR MOVED-PAIR))) IL:|for| |pair| IL:|in| NEW-REGIONS IL:|smallest| (IL:PLUS (ABS (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| (CAR |pair|)) \b)) (ABS (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of| (CAR |pair|)) \l))))) (IL:* IL:|;;|  "Either make moved node a sibling or a child of the node it is now closest to.") (IL:|if| (IL:IGREATERP (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of| (CAR MOVED-PAIR)) (IL:|fetch| IL:LEFT IL:|of| (CAR CLOSEST-PAIR)) ) 15) IL:|then| (IL:SETQ NEW-FATHER (CDR CLOSEST-PAIR)) IL:|else| (IL:SETQ NEW-FATHER (OR (SLOT-VALUE (CDR CLOSEST-PAIR) 'PARENT) (CDR CLOSEST-PAIR)))) (MOVE-NODE (CDR MOVED-PAIR) NEW-FATHER) (REORDER-TREE SELF NEW-FATHER)) (RECOMPUTE SELF))) (DEFMETHOD NODE-MOVE-SHALLOW ((SELF WEB-EDITOR)) (IL:* IL:|;;| "Just moves the node graphically with no deep impact") (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) (IL:RESETLST (IL:RESETSAVE NIL (LIST (IL:FUNCTION IL:DSPOPERATION) (IL:DSPOPERATION 'IL:INVERT WINDOW) WINDOW)) (IL:GETMOUSESTATE) (IL:* IL:\; "Here to move a node.") (IL:DSPOPERATION 'IL:INVERT WINDOW) (IL:EDITMOVENODE WINDOW)))) (DEFMETHOD SCIONS ((SELF WEB-NODE)) (IL:* IL:\; "14-Nov-86 03:01") (IL:* IL:\; "Used by the Node Mover") (LET ((TO-LINKS (GET-TO-LINKS SELF))) (APPEND TO-LINKS (IL:|for| IL:|child| IL:|in| TO-LINKS IL:|join| (SCIONS IL:|child| ))))) (DEFMETHOD MAKE-REG-ASSOC ((SELF WEB-EDITOR)) (IL:* IL:\; "14-Nov-86 02:08") (IL:* IL:\; "Ho hum") (IL:|for| X IL:|in| (SLOT-VALUE SELF 'STARTING-LIST) IL:|collect| (CONS (NODE-REGION SELF X) X))) (DEFMETHOD REORDER-TREE ((SELF WEB-EDITOR) ROOT) (IL:* IL:\; "14-Nov-86 02:35") (LET ((CHILDREN (GET-TO-LINKS ROOT))) (IF CHILDREN (IL:SORT CHILDREN #'(IL:LAMBDA (C1 C2) (LET ((R1 (NODE-REGION SELF C1)) (R2 (NODE-REGION SELF C2))) (IL:LESSP (IL:|fetch| IL:BOTTOM IL:|of| R1) (IL:|fetch| IL:BOTTOM IL:|of| R2)))))))) (DEFMETHOD MOVE-NODE ((SELF WEB-NODE) NEW-PARENT) (IL:* IL:\; "29-Jan-87 17:55") (LET ((OLD-PARENT (SLOT-VALUE SELF 'PARENT))) (UNLESS (EQ OLD-PARENT NEW-PARENT) (SETF (SLOT-VALUE SELF 'PARENT) NEW-PARENT) (SETF (SLOT-VALUE OLD-PARENT 'TO-LINKS) (IL:DREMOVE SELF (SLOT-VALUE OLD-PARENT 'TO-LINKS))) (SETF (SLOT-VALUE NEW-PARENT 'TO-LINKS) (IL:NCONC1 (SLOT-VALUE NEW-PARENT 'TO-LINKS) SELF)) T))) (IL:* IL:\; "") (IL:* IL:|;;| "") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA WINDOW-WHEN-HELD-FN WINDOW-WHEN-HELD-FN WEB-WINDOW-EXPAND-FN WEB-WINDOW-RESHAPE-FN WEB-WINDOW-BUTTON-EVENT-FN WEB-WINDOW-AFTER-MOVE-FN) ) (IL:PUTPROPS IL:WEB-EDITOR IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1991 1993 2020)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (24230 24343 (MAKE-WEB-EDITOR 24230 . 24343)) (47205 50047 (WEB-WINDOW-AFTER-MOVE-FN 47218 . 47596) (WEB-WINDOW-BUTTON-EVENT-FN 47598 . 48041) (WEB-WINDOW-RESHAPE-FN 48043 . 48599) ( WEB-WINDOW-CLOSE-FN 48601 . 48951) (IL:|PromptRead| 48953 . 50045)) (50048 50481 (WEB-WINDOW-EXPAND-FN 50061 . 50479)) (50483 51064 (WEB-WINDOW-ICON-FN 50483 . 51064)) (54383 61996 (TREE-ROOTS 54396 . 59847) (CHILD-NODES 59849 . 60610) (REACHABLE-NODES! 60612 . 61994)) (91791 105199 (BOX-PRINT-STRING 91804 . 98266) (BREAK-STRING-FOR-BOXING 98268 . 104064) (BOX-WINDOW-NODE 104066 . 105197)) (105237 108279 (FIND-SELECTED-NODE 105250 . 108277)) (116826 117997 (WEB-MENU-WHENSELECTEDFN 116839 . 117469) (WINDOW-WHEN-HELD-FN 117471 . 117995)) (117998 123002 (SUB-ITEM-SELECTION 118011 . 119111) ( DUAL-SUB-ITEMS 119113 . 120122) (WINDOW-WHEN-HELD-FN 120124 . 120648) (DO-MENU-METHOD 120650 . 120990) (DUAL-MENU 120992 . 121687) (DUAL-SELECTION 121689 . 123000))))) IL:STOP \ No newline at end of file diff --git a/clos/3.5/WEB-EDITOR.DFASL b/clos/3.5/WEB-EDITOR.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..70a59b60ca57904c7a7ae9d8730344110c6ef436 GIT binary patch literal 99330 zcmeFa31D2skvIO1Ipjm~NEX5t#tg<7FdiF2U_(eiBWYxf=Xi={WZAJn$o9ZU9!riS zC*&eB5ON>_vayjNkih2Nd_-0f$Hs@qCfP402b*0IAiG(@x9i<(4%YdS%_f@!{i}ZU z-n=)`j6Ak%oc(_?XkNeW>gwZlS65Y6R}U&BYwM!^y6&ypIx?vqfA{vjZQJ|&w{`dU zd%L&yY)biWqj>*&>JyRoy}6|~)zf=pd(ZZ+ccwC%(l;g|>*|}sYeF~H8+9$QP&}Eq zu_Yc}dt)@5Xu7d3Y9wx~YiVw#_#0b8wSiE5IB7I5zv1fAgah-Yo>Y5ZYO}wgr(<*b zyO#Oi;IB_@N^RXpb-DVgtFKz-zk21HuDR+>*Ic)}v>}*?N_9>l)7WD}d$dcs75aC3 z_GcD{%F9(m&)^rIqNzi>2g(}4(NJA;D3}b@M~ym78G2yAw=|Iq#_NO4^?`7_sU^8| zXu!A9-`Bk@kV(BGmEpeHsu7Bz2M0 z(PcD+;@T|A;4xZ~gwjL78TH}j5Hf4?hIVm`w<%Z`39bqa?JA*6dNhqA2WGwrS(+U268nc;ZALNuULDwh=x*G1yNSSTUc-EVC%l2nd5 zENem6l!AmW5dcce+qcISS z2I`Dhj79)~%mzrzSQBavGz|^RN`{mCU6Y|0C6-4+4aq=lOEPK1t+=_daD6?2hY_uk5s2Fi-v6q`LV^t^_hz4szQR-z5Ct7N$pqb%1Dgk9%wWitEVwE|& zIb<}~Qw@{NA#N{MSK7X7CS#ow3r0fx@ysbnH4n$b$#5_lep@IT=aK3Vcs)($XmDLX zBASN=y!G^fn~il;sbGD**{!qUMlxJy7Bn!cIb;{hZ~XDhO3dI&coL1x)a^q9E`}Q# zaMwjcLBc(oMslnv8EB%^B=xZQN>j3)s$#x17|ryFXkZMKJ7TC#;rOats8;HUppduTlNg1Hl)lsC+jzpjHC$*!(4FR6E6o;D1X9?5=>l!(0U1Ko5O1@nn zLEShsP@0Wujs>ZvrHRI1Qz(!$0*ywL>ZD_g)*5R=Ru7iYi`hjyz-Q5v%1(-1+TKbY z>H{vOtMp(RJ2arv)T3XXh`Zc-=VNy9G@Toc+0)dV{XE-Tl;*bPBTXru#uQHkWr@+m zgew>&h!U!5z0n$I8b4`gW7<3LX?ri;+bvVj%d{^TjSAJ#!VP=hF0!oA0albK#a=$;A$@l@+>+eYs z$MKHT=H+)@da*gScMqsd{MqlK7XHf63eiY=)R(Wq_? zy@`q`si&o(&S+XENpAj#yn-YD2mw?wWyc2%#n*(JjW{!9PJj|lOs;F9wSHV}e5*3u z8{0GfHSIke?HedoYQ@wp1UHFpz z%QGEYQvOZtJt^TQH*N3fNpEJ@cU45yZ+uAp!vH(`6m$jxg z`r};rx=ed7HJf>jEG41IAQXhCB9CQW|E(g&^a0vd94Z6GG{jDg_YCNOo`Y zN13NI+iue$V!XyJ+7=F`=oYm@+{@B}iA%bbLq*`Y*-&#S&zoqn029(m5%Y@)T{)+L zMnhuz#!cLj9bLCe5jGQJA(8=m9IvkkP?o!y1jfPkSWwxvjQbWB1vhV|3M}(Cr)Xp$ z)Y!o>_|m=0%|b2i#X^^-VotWk0+Yhb`Xkb8g_G;Cfb-y_aZIz2xCLgSO|HrU&$ft% zVWr7M31F}uOwRidYqBC0^fX%?mO+5lXf+O$Jd>A4(F(#r-fToXK70 zEyYKr1W4|p^{zRzibzRbsF@5kNjlipygA*>(5}pzG&9)1#WFzN^ioMD`H6YO{2+&2pAFO#XV3uVxL>lSAh4 z_7m!dL2Dvm_9-vGcnKgc&_tmiFPIY-%Lx;K5cBUmnIO#2xFuo10%L9nEaJ|AdAu}8 z7X|E39B8nH*3N-y2ZSjLhKTtgLE45n&jDi&0cY}DM=}cmL_e&&#E8k)Y)-XrrjN%} zRNJWDm5w|lFOv{!XEON)ZeE2046r&7cy_7l1giPy5C9s zXso@5k|@F#YriAf-q+W$Db<)_#+Ksd*m12LoBPtVMpA4^qA66z4Fa-aC2S|?w_Vc(xMe8g;r_O=@cN>PQoY49FrPb9gw%gJQ{+$a1)dUd7&oi5%Pmg zP%Y#KlMWaD0ji3;U=x%Qd7*Ok6nR0;GgTR};967d!77ftpt)L(2_O?c#kiPiaN;z@ zwlK5Cl0hPsNzt-oag$h-ER9s*wr6!I6RN=9es)Vd7Hp2l49E*n)<_zP51N9z5YD*MpU7V*o!K{%P1rrzBFw7huS$%R^LL~ z4HkeotvRQ50ZpPZ>Oqt*%1yJXw2~ngr(~l{L>TIh(dqnjv=UYdv4w!_CkC>wdsBCY zw;p)?HYbDZmK2m&$}!|Xj)=}gqXi^8Poj>hF^*1|LUS238?<%@NO^12nQh3OZ8=*S zc_Hjwj@;yN16J05XFtdg_8`|WVz5eC$rf4@jMhXA+H)W!XuW|~8naELJpGSxF`VcDjx!e!R3!-m&fi_eJ zUS}nwDiVc9+R2-p-77qh*iv5K>3<9@qAt?fy#JLFnr3SA@{j<3edfR%id& zSnReoO?blxI-Df;!GbWAZ#7;%Wi^@-5(U!!f_80z-%tYstV*Y?dG=w8%xP5HEl232wKV3Pa*nD~&QW>FIVw&y2jKIO z?vwX`@AWHd3biad)mp|+HN)vw?*EmXvHyQ}Y4lW^7dh1ot4}pU_*64AonZ3yfZzrW-f0IRTWcKadMO+0`nVlT*}*Hb zLH$>D5X=@Z=+)U+?Wt@~eYYK~v4aq~kWKkcHdYzsN`DLQH*@f>5xj+ihY@V!;8%%* z$zw#v019(`o)N&dbMOlYZsOp>2moh{N5nco!Ae@gN5JDq| zdb(v`a0j@5mqqCQH6a{l^_a!!el?5J{nIQ?_unJPm2`g>LE!w~2y&;o|C(^l9Is;G z1en60(e5t+d?Uxoz~Sn;_u8m;*{JWgQGbX~&xYbgG$ZEb9Ou0oP}~9TcM+5;+1vuz zU1O%--G@{Z(uN@FzYamvU$}bIKhA|@^&DjQ$xs*#?l3Z-ked)h3*Lkvkc$8S5?zPI9>ltIA;>h93>|w z{8JX6>v;sZx~}JJ)KA-}zl)g>+LP=Rvn0;4KH*eP~XM>l#-la-tNOaVTZIU5ZF5C`E`4 zN|8^4Qm&;^=Gdih|Kp=eE3UHfFF_FaFShZE*arMU$$(!00OQyHK=@|~eurw2Q+}Jp zt^Xp6TmQE#ZvF2NWZb%tM#ioG4Pt@&YlPd=7~(AjjzpDpp^w}p`hFYN6E?0#5d<#z z9KiJ;;d18=JY7g4P~Bsr>b6mJ*r+xk2voOlwQ3DAfR1sbR7)lma2b^DdK)QFkoq#$ z)TVa2P3`m*HhP=d=}hfhtarDO+hk5Z4|yJBq&@_BuxWolkh@a*PXxL7+J7L(b=H2y z&4+fK<4|SoIFh-_noJp>I)+%F`Z|I@B}5FU4si2D32fsM$_8AYLoOajnoJU)eZWTh zVH>TGFQC1X&{moopfKX38Ns@Cd$elrLPiwQgCH=Af&vwW!HtFrzZC$$%*MX6otQaE zx?q)!QKk(J_0aS6Gorx3&W5-&_JfuHdgsYsAm}pV65uz5oE0DuMuRd z>Ms#wtm;n*Yeg>BSU8G-h1#nB3|Pji{v(3GD{Bz&e$B>v$i};$@H)-zIYkie0}v2? z9zh`7jUW)pS3^bRtD&Oz5W*QrqbWeP^sC}Fy7$}Ywj;=cK;4EQFbm-V<`%>PvwoOKA z=}Xa>v+k{a)2avcEgc$IP~T0a%#kX6D)rGE~(VW^uc7WUa{k zDxqyiIoQNanh17THlsfyMo|9SxIcUQ+I!es!{5EJlRhcik@L|Ss}z5(c2`oz${<#y7RRB9WSW?7fNqa#J%t;_#T7_0(O zDaNWl+3j!a&TIyb149FEh_#b>x`0u!J!E!IU%Gc|I~_krb#-sQJdJN~+rRYnq*DAXiJ}!Ace;!;{60n_1n08Y8jNGGqPbt9 zdCPC4pr>E=$Fr|H_>~4)9_)a;GH;Sfxm^F9MZ%D-XL4Wf&3%pLzEMv$r{e(*Y zO!l>gU$3|1gD77%GaDbxW`aB@LklVD0ad5z*saUS{xg51}TpDdY(}~P_N>axrB+Ve3g*72= z4yS+DnNF3N$>$QqhMQBUzcA?Z6}N=MFX49+|p4EBhk`KJ*oDqki_(riYk3@H4hKk0ov)Y~OtlRO~*=&7*0y+s}?<#DMz=F6j09x~TcALBRW zXVebar2`pRYZ4PlQwczH;~LaA$}f4>y%YvW#B9C0t91T#1pE|MCe(tNoYTCiGWaK{Ya~q+UjKA>FH(OgL=3Ue=|u$3fkc zU#bK*Cu=F-1k^5~*3Ya#Jw`Df-;hH>i?5UPDHB2dpSS*_4JxR&dNI|QRx_>zqS3Wa zsgN%96rXCnworE=9zB=0+nCB*RW#3~73{1P`1Tpse5%Hbj^0dQQ~RcLsz0ZvPDm@Z z>X!}eVSYvZZtJ20w{njkOh4VaXv_XXjTzVe!;Kkz|B=Rww*P1+?fZAO`RK2L{whZS z+g4>h=b6vy(RAAa`dc_!)3)&IjBarF&Bnqu|EM9ak9HdVXBFkdVEV3({`7-)?Nh#F zEQIOIG40rbwrYa2-m0Iz&sca&LEJIz=}6nW(HK=CPL(jK4d4DYpHX(at&-|v%M)iro;kr)4H#Ruj5@qO$Ezh^%kAg-eMc+tI-`Ioq+c_S5VE9L!NL!TA z2<7k#l1q>tLd5}}7!778 z4MqlP!kvhj%{?lKsKeoijOXZ{s5!9l@F{vZ#=spz155Lc^1MT+TvhUoZ4VC*Xd=|h zIQR?^F;io}uTVkg@8jSwrLYmY==s>~1=+4OamuH7{x+=%1nWpQmmu#8rn=x|PFzNb z=aF1ZcIWE?1Y~Ynghg+mygY}2{)+i5K2;;gIqDPKMr{`dKT0Tk%aLqwiiHKa}AR?kNoDvQB^*9=$-7rl<&NU6G1pydYQhO*&qsf%K;1S3F<9o3k@v+)|ns9wWCsPxqX99)dp4|DKB6#0IJ!bY)< z;P>p<&)C6xh-!JIaL~bJNa|_&?AnGJq53r^hI7n?L>bVOrQ0?mv5QP%SvUe|Qf}Q=&V5Dm#j%-}_O9F5` z3JYiRsEm`wU4v1DAK@z{SUov+d8LEGv27>z7@b5eYm=M9UIx&jj0>x#@=6Y;^m~)a zX_pfFRuVK9*r9=I^A6J@3I(gkdK&6tQVQcprr4*@_~pHHVJ5Xs>b?1~Ikv~wG zUZ>n~!{pNmsfDEv=U}lMLpZx4|E#)J`ow(^Rn#GeCDR`HHU(SYcMjfN*{^FE*y;A6^&IN5i7!&xMV6)Y#F(N@EvjBI~aiI?MRv4TJ|e+$6S8 z3IvCL;yIQt;ky{ySouGN;Iq79e-y!Qb5NF){t6EN2S;mI>0h#gV#$YC*re!pG3>_y z09HUY&k@W3F+`PH>>w5ck!7&0txs|NUu>@VI&V){(#fO!C{ULBZ{#dU*^XogQhWSP=P?DoYhuhpDX!e0<5$NjZEP=KW4N zi{&XS3^T_q4B9_VFAV2=VF4EPszbVdDhsQA&IT}-+xcAF7dcvcgnu5egYN?{ud!On zjuk~7VsAh!ugB)$V+3bpv#Gzz0;n(Bu_CZzmHs3E5FE4t&dJ)1MMe`NV^e~6uH&!d zuH)9I;7aGN<15Fn;~gC*UB8z()`dLo+??w}&awb?i=Hb(sioFBeF?48D{2k|4?0-L zr^Bl+99(@@cy;yDvSP0`SM02meqG*qbkbVs6P9UcmdO1lnRJuJ$a2f0gXK{lTZGU3 z>?}OKtu5fE_6QUs+9Qf`zGV^6OEZp9NJrC47L&xN7XibRw7hwiJ-JVL=2n{D%0=rBN5FtrR*XhXb?xJ;qx&~tu3NiK(cE39 z!;vGAXr*g3w&9Q*I;-@LMzY}rqmjd%on7xAqyKS6>rnJaG*UTpG=`aYC^E8A)WVOT zV5p?4tX(ZcnObR6KRi6Qglj53et}{%?HeDJT`$K@vR+Oy{0r=P@riQn9i+T9oovJE zljF8f+>E*?Z*0-75656@-o*#|wY5BXU2YD-3Q>KGgJDc*tbTsV?c(D;6fcI^veJDj z3!<7D;!4hWBS*_Zrch3HEWj?_7yNm znLc4dip&bg*F(#U-g!HDNr-p*Yuh(RJIIKTZ8Ce8b6amAd&oFhd9vA}c(+Pz=J+}` z6eLx8y>LL>ji#9^+WBq#_Oi0HGTSl@yKgS+9)6Xaj9aCJxioCWA(!a7LDpow)IW^) zu_E{0FlkP{DCSb-tjl*NG0rc`T2wio5PP1rI1)8h%4lL|7C6~s1s=Q2p7fcjVvp4|slye*4bnPXaTb<&0)!EZIY=_mslbB1W z3&$;ct{v0M-Z@|PGVTImBMYH!%uC3PB!9YiOES+I$B-@?^2vSbV%goy1Dh+1(rWr& z=H6)@*l}X;hMm#jOK+vYuN>h#x46}ZVyoj{rOi`ww>2iqpRAF2@a3+>jP4Q>U1t{C zN3HeLLRM_6i)=C0^}Evj=?#xZ#qQ*o=Qpx7O#N0OI$Q{{M`B0W1V~JQsz>90X)GL$ z#MQQWZQ{BDK&Bgu31Kb?db5Aj>g#5XWelhC}|%3RgD@8^tQ^KM&*v-wNx8IV!eh{PMsGq zsx(#Q9}OdiqA)m&DpdrF?7OB}F$***#4P*?-gLj2M_O$E&B$qSQ!yS9vH=gwW(QtQ z9q5yuD>|!a$;}OOx~QPQhIu}!SAg4@N3_}X9$HjO>G}h6w^|H$T<^eI$jpl?$N(G2 zK!z-e1&CuIHG_+BVa0Ht z*zrzI7ZwV^x1d4@iZ&EMg=1aI=tp}sTVoBPIqD`yYb1Dw4e(Yw2tiJ`u|H;G)$iNE z&)7keN4tW{d^<;LykGAU%{+5bt{62)PEPXMbvDc;z``*4?+K=?iB4zHkx)7%MP{K1 zj{bLwCP!=14-^S5PX|BgTFC(Hc&(Hi>5+FQ^lFH0*7Y|sV%OCioJ#<6tTe&Hn6-aL zHSXu&3)yODe~s9Wa_krF*oP7O0LR`%=w|Y{=9obyUF$fi*G_G>^FXTA1{nbEc(Zxd zauh5mBo(ZTYJz&Sa9!#rPZlO$J7e%s1EwuYl ztwH>Xfdp7;&0!|tT2dr4nKpMuKsz88<+TQ7|8kb*J;!(al$e~0$1yqTFQ%ECbIs&n zmB&wJer7(Fjw1EZ=?*}zKTOLzElInht7Bgs&6;aPbLH)bB}=<*8XCANug+|eaaLei z!S?FE@VrnL^Uselfp{%ZM~S9*1tTv2>H#}xkdkIgk~ppAbd%z;)>{1`W*W%Amk@-p z)Dyq}G4?|obY07^cO!Tm2hRze(4>O+b<%^I&MZB+)IkqO^vYfoF(q=acpN#gt$7)r47tR!;Oph`oe~Pko|^uCr^#5qbtaA4CM{e6dBTuvBD&Vp+HUCjeL*sDj+N z5d8aWHWfS;*kN^_9XnC$=jYC~1Fzd{=Q2-|bM&r`^RFH!jNnmxyaM zJ>fW?jbuRB2dLPtE2TUhHZc=GOl_6D38;Uh6dV)`i9YcJ7o=|FpPy3_-30(XT@tbH zrQXVkKcd80xY2`M982=|khh(a;V*c61yyVnqDDgUU7-Gd#o3hOoJ|yyAnvcTVsZkH zSBQ4U&n)eBnygN|!e>ep{IYQrT>bB93VzNhcyZPQ>!H*bX%xD-JIy;L#Jq_yecEK+ z^3d5FqHDgSZIe3J=0b+cCmVVN$f}noEl7rtw|@qiVp=JDn#3OCSP`x<*YzO=m`ML% zE%!5^SkDkYCK^+UI{<`|2$lI;n_Pgf$`PPHBg%nkmm~jeKC?8#soj>#Vy8qWmX4OF-tgZV}bO>Y+_sn{jD9Y<+ANu#xquj$q4oDA7M$Yog# zao+M&zrx&uAhehALesm9bNpG)(;k|qZuEm3XEECjg2N|SxC^o`*`AOX=eE@Z^H-k{WMp59 z`E};4?1Sn_?IVL4!AxpcNZS#F#d+Y5Px9p+_zP-)n#?G&_S2^QMKCLY-8(dJO(6+v zlA%fTM8}ZK+BusBR31_4(0+W}2*@5qpdq@7bwwKX?$w1HoQ2HL6~TL_Fb`k1W1qBx z%Mp}Abs%CI^vSPqv?!4eBgoopRgB?SNv&>0J{Z-v*}(=o2$^fDM)ivvM)mB{OR9oj zr{?&h{rxET!~E;IH^*Yk>@!ZmdAi)LlW3<|_g{d*;788Rv3UZt$?{rQvFtqcL?X6% zZCpXBvl3O#xcCa5LR9A}i|UY95Kx_E(^RK8s&h7v_5@WTDnt>~A~i}7M~*GS)+z`| zky_|eLl5;2=xi;5St|7K&_MoEbA<-!IQm15^m6GB9abGjfnf5rga@=5pdZc8L05=_ zxbIzD%7z=V8WYcjDCc=1fb(qB$xQ}&YQ@;YlyjQ6X+u2M5W|n}onH()r&F=sK zwKha6=!MK}NyI{)5?HagMr;PzK-xsng!D7s^qXIH}pg=UITg zTm#qO-fej9R4Ve7_$#Ik)^85U~1Xik>aB%idO# z4S$d=C;genvr@z6KQ_8$tN!PR1?ThcgG+jF9bP0@fk(`ilP#$nl zgX#W`Vh!(uLRbz*_L#C+G|LqoB6qI^Y0S9cb}B?hT#Z8zQ-4Nu!_71c>K*VPLTA28 z2{XxSgisTBHvu~XhDa4PuamN{&lA%^9n|7GHnsS)O+)0U*z3l_!1dWZ#GSzTq^E}J zNPe2e@imxvS`IBaWYZF^yXz|^N3-8aI!@Pi*(ro!gDo&|%^;d(`Nms;j-1rpn|i%P zJuG)`zn-QZ#Ziy5cx|k{PHjpNEQ9eck}P(OgK;9A$s59lrK)JKKT~r-g`mD zK^mTMjq|WFn`^3=THiNYQ{Qy0qHUj^`o&HCHrD#q$zJQ3*ZcCJg#4%8#~n&=On;&n zB#`WZDc`W|tIaazvnfE<+E2t38-Qtq*r+?Oh@RL1#88u24HkW%BD*bRnXCV(ka^)G z1D@!Q%uJy_wl2p<{<;I?i9Z%>3Xu26RUz`G!BLiqxtw1TWJ^ewrb`?=ymb@jQejT5 z+I8mT64+YSZpR#Fa;Ax)IfB*MSQVx|!T>#Q$L42zt^z=2`rqssmf9W|HF$A_OMd@{}srMBbCW#cA(KuL0Xnt96vWw%9iPo3)0STUke zx=$-k2KWW3u51frTo+HG^}flXx+_ercWj#K7Dsh&1=X#Wn;g#q*)7ig=1^K}8BGtn z$EuFhjm)ca>mRQZqZ^2EKkR(*uDbrtjh@l^k$Lr$SU)bYo)Sw&gO3N@`cN=Nswm2F zcW_5kB|nIJ0HpInW(0eKAq6Cv=F8Lf!V%P8KM^1N$#5jW3|KeEal!VC24ionF)PEyv z=FM&l^(?*0VjbO<-z+ABPW98P z7i3Kfh;B${b3H)(@M>zGSUF{NeHOrqu{2ayN)x8yQrxMZs*8q#%>@bG3KTZEgjs75 zJWIlSW}4s?NAS*~gjpP|6KiqHauDq1X!byeyQGkkDbJWGASuF9=m5`N>z_ku@c8Y<4Sf9e2~LsueXb3IG18speeRO{;^65jfSm3&*-xrCn>ZO; zQp_w}HGY;(yZ!&4;`To{7~GN3#J@LqfF)q6%j4k$C6B}oG}4S+I1n2!4=)9chF+T=C@g8@>fuQYW>sX?4RY*J#uT+Xt1#Z zi{QaV;a77XVeY@>dACLjRz@TCGH>_kvBWCR5+uD3?)h9RU?AZxE$2vea|u7(rN}+8 zQ#m^WkXeDFM^DGE;^h6Mt6#~dqFTou2G#~EmD);eRQkB_ zPvqzgbE5H>3;j#;Ax;04tE$5v!4_8hWl_~=b^ZJKnZy*IY%4J)s6T~3ZuXTh0x0w3ris+o5~Yz=>`YMzHw%Wxc=gu7Hx z=kRS11Q9oygW*I-xrXZKg}*x<$z^q!RC`xo`!+vchT6+DW_2V9ZS?GGHp;U}u zG?55WjCsa}ret$tOFZ(19Lr)yZ*n&9FylH^;+>8uPiO2pMH=%9@`so2c50({jdS$2 z6d1i}8pEDb7{jA;W$4p*@bGv>C%&~1AAOP*6gPNhIR>vD;R4mwAT#c@){tF@YOE!V z+aBeb$%ic3Yk?f(u}ee{+1F8Z@{G~H&@V%BDRwv9ZO*Z%vD;tyHh{TRx!y4#5w&Uj zC`4?Ehn?(7rlb#Vx5pbGI%qCATh5V08bMg)io8?3siOc{Y&Dt-FE?oV_~m$=HL&=) zj#;$#hZRQU8F*3(mbWw~1#=2hj#)P}Fxwgij6%g%P!rTAPC+Bvb2-3f*ImF*J@ql_ z*oxF0+vs9s*oy>c3nLzA5+MG1AadrIxSzihu6txp{{yoZFOCIi?<2s(duU*;^%{z= z2{#*YavhnZF+}&(=rk}iqnR_&ExwV^IxeIMeitdi#eAZq%}g|g8y}FR*j2tTi^_!$>wwvUmUvwr``{jZ53 z74F2F5soKA&9q`R?NGsExvm`F$(x7vlw4HqQk~MWbYOIDBN1~!Zp_}C62sPDq(H+ZlL#oY> z5C{2g1VgjVApGJ9idCS%GLAhJ@#Ng`ww7O~D)4T?)rtWuBFO@H? z3nuFtX%{}((o9sT&Sal77bVVK8jlj=_|}GKaFrF$-d^V{rM|5Th3KZ-U?P-Q3NCXT zrleu!&}DAFRmULIcIg-~YL7kx{d-8CiRaV$EIgl)o0{AQ@wU$6&9_9paW;RAPx3GU zyT%d>$9$M#<_4otqjkBQOJ5Ej90^Xlo6<_4=B{mNcn`3@g$)ioG?Yp9x=mtQn>e{)|v&^(+I}$}Vy%~>V5J}w6%38fv+ded)-RQp+zshW0HB2TH(1q80nV+-> zF`RlEWt{6IJSM@D#Jp5ZD@Ecb3XqUAk&vr`2ZDo*zPCCM%M6g=jDd)t@bIJ>5jx)m z%xTq}hFHaHLg!+qD7@*}5{s?V*|o|nToG8$@vX4RP{z>V`ki!#Fn!2cBS{|nFszj0 z8kt7u0e|WIp@%f;bKZ|TAC)+t-c0}12=bCvezm`^ds`rrdPgebVC8vX=~pyaqcRxB z>K1MG(Bp58sAKr2DDvz#pU;@jpP0`R=JR*v^N;59HS;-UJ^KaE*fZwyC+73S^brX+@Q0m%Yu$UtGKeLZ}DG)tu8NrslHx+N3ni<#8BLgg&J z;u7d4P*d%#DokS4E|y_fxb-HQLUrL_6iY)FS65x#BqZB>bjn+o_Np1s?~%Y3^WCMI zfj_)v2F4^n4H2<{9B`ChKY`-Y@&|sqUzt&l;_tozkGrnMV+S~ty@A2XB zZY(-#pY+e$ElJ}8Lwl-t+5JvU4G9_LKDFGZmHYI@Plde~s>90~)pFGpl}pPj4y}G@ zb!7hNj>y4?K1esP?-57DPd91@hW{1}V)?~hxwL`qTCXw65O>rlD_2Vl-zU8nD#JG$ zRDwFgs1THN7d*RGF89qgD)qMNoksPJ;pOCAIgXr93|AXv#yos_;Xe&C<)~4qQQqNi zdoNPv8a|CKY9Ic1e55B%$kIS6m&up=<``9an}4U_-!c3qwQV68Oz}SzINA4dH6Nz| zzz5i6^q+pc*N}_W2@CmhCVa!AMkVz{xms>4l6oCA7FEzihWo}YFZWd#iwB3BI@%V) zUv#;@lHEj0L#|cZE{_?POG{CI{Io3@nVV*KV+r1mco!-kG2jV$_!|@+{vvf$tXw^> z+*eiZJHOmF&sh4TvCL;Ir8>+vu2w7Bt{OF#4H?UgtCqAaClA+Gk%#N$ZOcZDrCQt4 z(c!;SwE4tqxVpMGr?h#*$dz5nGI>*gu3}uKryq~pme^n%E}}%*9lYF`;~@C;{Ly;D(}~tD8qgOp{+#j zx{?N)()I_cX$s{^q3%DTBfh)?M;5kIduB!J!wn7OdO2Pf;whJ602d2wq(vYu9TIDT z)Wf8K;K=oyu6~ezF3W-{|3RRhXehoa*+?nM=j@bEP>Od0`GStuu`6eVuSa$^o- zD3NXtiPgRxSnq|dz&*B_quCu`kfYsW*Kr>9y$tQ4dM}|7w)|camfLD%_GmN^9i-xk zun%M+cqDza+~m_fl&L3%jIy0ZS%1gTdt%y=;h)4w;;T3mCStPW z>3bsS>bD(a3UW}hquv)c4+vYyrs(Auy%0xFl!Oq=-uC$ZbXh_P5i91n1n4fDU>TK4Btu0#RmSIj>Zqo1o-7QGmN21`4Di#xca#QYsakO0h=`<}r=d`>yQ*OxF;9yi@bJE1k z@kKlly=}oxV*ztJZ3|WX!3XH#oTIUaV(}$M?un3Lk-JU*NL9&0;J>s%1E7JX=Livwh9&1JMoZFp{YBJ3WwsT%{Ov^ zQAQQ|Y~1jPWMxzt6=p~jKwlxH&AeDuTiGt7Y}hd7rPJxw#q^VIU6LkNu+8UIN9L|J zd=!#$?VE%^l2u6E9CwOk) z;8qT*eCdjuUsnFeL8v!8Aojn^!iv8az>1p(0T@LoSPi~{AeXH!M-a!Q^*3`^W9CtA zSQeJ@dBn0dMf)0n!BVcHiq464bZzlBwfD4dP4%UEdKsT=tYbwPMn>jP)yJ|K&yD|2 z=(M#DqC&zs(m_Gg>BIc%xjNTgN=JRQN6(CVPv<&gU11$)3Wf{I{@~Y%U!2Ut=T2*# zu{?ZE`xP$oP|;cR@EIh@`=KI*^^vQBMM5qR+Dn%f28(oiMLB#y^G4cg+dH|3d^P01 zXKIphNgO7GPxE{dTeve9MxM#LH+H(2EX?IOq>geBiby$C_yf!@5ShQSg8>Bl;c-)B z+DAC^2}CnxQU8{MB9d4)5rX5pZH48L^rzmUgwrGc? zH(WH$qZY@bp7UeFhdK{;9YsQziBE$6w1cnGJenB` z$5)8?4+FA40>1b_LmB^83qx{x}C;v@?F6ph`GnG}M4YlI*u&24};?CJZga1^f^= z6)Ak;0V@c~VzKt;FDNG=DDM;!&D}v(-k0!Gth`U(-LLa#5d>xNKT%LrE{25}vdECd z!YI>Zs5mloHd&a>*VLRC3WAPo)cT9%I2^Ka)%ua^$SD@w02BSlX#emMy=v?gnCXeU zBWOjjEsB#(A?70gIkJKyuOO4+p;b7wsn5kT{uxXJ%y?U^uii(LVfLz2p8>$;)FuWs z*%ZuusKG@^wvRE0KZK71890`6!i8Y&}|G8zx`O19=C|M1nQbwm}9f2S!Y26?@C@ z@Zf8OJUCH+`}3FD9=7O}a@?Sk*>PN!dyl%GTY~@NovV#Z<(H? z#ZA()D6^#x1v^fRETqXwCR`8kwY6D4ymxJ5T^+IdB_!~4eGXKmVjst}<# z$>5zR_BjZ}(16!8%)uQlGP+qGEhlGTKrAQVguQtM9E7c~mTj{q>{zGn8V4Y?0mcT~ zY6R8a0vJLejA$kHSv&R-4od7flo|(|TI)|)QloO5OoFX0<9d?Fb1AA0cQj{)8p#(4 zG&CDAp-BZqJBbj;rG|8gPHagvcXk#v~8ZroTZv8N8bunvWhLkx22h9D@3ZU}^8 zf<$xX@G3#ZB1U3=ZFND=iPoMe7eoaNe-8Vl+zOj!HVWl8tjAjA>r!cZ3&=Mh|s% zcD;X${)guGaO6lNS~+u6j)H8|XcPUeqV3js6TP6}`WBR)J?{uHg|BNN`b3vCL>zpH zbq|AScut-=OnaiQ7n05=ALrx93+W{toC#|uT|76yn6&deRR5A0gSTP11&{I;1leV$ z_69q4b~dQ~n1e2O1YL$$x$^)!+A!h~PgL3-MsXn^V7Y@WdhKC~RezI>RgVB0*GHU% zx}Y8U5MtT?xcYk7dTU(Jr{K<;%naPYjom$c{UtMJ<0KgQHk+GBWk{LtuTS-M^rSZX z6CLkPDdWt;#neZPeD-klHMt>AG(%svRK3b^coM}|V5r=EveTu5PE()k_#iJ4g3#?vCP6q4g9Vznex=!X^+^0b2rnH|T?$)!V6F>hb) z*t|2pC)q!kil9juGx=bXo4J3*qDf@tj{E$kj~*6jet1^R+($01HEB(j0tgRek)+_M z(um_j18>Z$!!2S=5v`DY)!fZlz63nfO0MJ9l6U?3WTWGq9eyRC;f2x!T#@>9o)|(O zp0IjXcb*=Y2HL_5up&je>88{$bL&`4Kx71X~J!D3cf5qNOj52=n;mx2u#s6Y*`CO8yxnK92S zG}lCu&$igGBlBvad_5E$u$d=vrfk}$eG(rx#N7^%XNAh&>J>b-)pz44%DmQ&uFc)= zOm_5TQuQ6Z+cNF%O7xL)gROccpx&#Whv$0=v1^k|=yG@7Gtl#RvWjzqt2l^)TpojvO*sE$#|Gg+I|7z(dygfZuTGg9|LPW=_7&Jw4&SW7tW z7k2W$a8Q;Gm^X+rPgq2*b)JKfsNV$&==8q~#D8x4iNa;>tX;*8)9Xla>&RK$RV?;+O4a(E5zS|wHYr+f z$G$J}>+Sdyro&GLElBy{a(5^}d^hNOqN3!hITDOI-SAc)jX|J}gFKIBk6nAch4v3l zGQ!8n!H$a`WaD8bPe+hE{aFr1K}NpK!5fHXmBb=KwKzhYko^k>Wpe?-vIjXhD7ro& zW1vCG?>Y7}Hh{S&!5+!9BuC5EH5Qo!Pt)utvNa))Z@g-!(QSm`DML{g8)P0Z3LLInuwy ze|qVzvMcin_4$YJI62<(s!tj}b5fD=uRIb8HId8X(3-H(k_ZqYT>C82Hs~2Bkoqm2 zt$s`dkhcFokV&L@ZkYju0tvy}2LL9V>Rvl&5Uk66y8e$CGI1sfKmR$xH}CHRmH@BjxT7SuQfOAqh))k6a}HEr+f^|$*scHiM|@9Ey&wb|d7PWjnwn!lq9;oE!Kx263(sck)} z-c(m#N7wC$mV*>TQ$c*mRGv!lRzQC_@!O*}o^sw8eX7Q{&dZ)!;;~?JL>vzmB(9fn znd6TieAA?+IDRn4Ja=Ge!3*8?G-+{yaGcF8#+v#9dR~2=27<+UlL4~h)WF20rlSKp zpjcnhCs}GPb1XHDBnm}Y9Gd!q^DVQBbaTN`k4-N)#Vt5(xHMb#dd~cv*~OB6do5C{ z*6*!})YW1ou+4D2D~ASF=B4(NjUuA?GSOwIPoVj|p zw?B`W32HA#tL3WMFLJcl&U}i4Vmq@7z#!Y*2!ge2w}Xv#@OlKNsK0emPZzlvVw`lY z%Bi~buAD!f>@mz^q5{{cC{Pi?8l$~6(WlgU9*Y73nLFEm`oagcmWPn<}Yrxb~r^rqW4r+C{|^nmL3 zIe00F%AVSAvNj6E-!FNB!PA6_ePH!-{0^!kq~@!bfgm-I3q2VIFt>`ZtGtjfy2<+r z?#_k3XKymJmM%zP8-W)nLJ>UJ#Xh0qj#MfNmJuRRys(Or3S>|TwYR=;7kg;Lo7xN{+>m!EUx6} zG{Gv4V4Y>Iq;_{*E%B`Vbwx_JIcFHXYla4H$jgcpH;4){B`zL(L_|P;$k!Ijv0zVN z$9sTgKsoN9TETGSO`^Fz)XcN`OPDuK)&$!9r#M<>_{RY8XU31L$>m3Ma9G~A5IssbKX1)n%k{v&P0!!r=I`0F(l62s#GySn z6nSEJZbUs?6E&64eB$PpGXLpNVPxW=Leoaxdq<%?w37@on(H!ha@A>Wp1!Zx)Atz; zidF$S17Y={GY}Q=GQjrx80<$JhB8>iswgZw_;gv&KMG(h=;zQV^h2noC_990zr&$3 zyaaW`vAffq?M`i>`58{OR2MVVUl>2tzdb$G&-qk8^#ga2C(=Gl^-huTG1aZ<{DDIH z!pX)_fw>H|piE#E=+#Ll@c$&A7aj5^2?_3$+Y}VObM{tf`0GnOtW`S; zD*mbK|8QFFYs9JV$moZ*9F9hQJve+PZyn_KaGq;3gB|SAy1}};y3}PbX&9YC*65b! z4-fa(vtQfdOm@U3GVRbS?kuENEHo2{>bS913J2lN>J@Q`+t7eYx6IDCEz{ncPIhcf zk)e4e)&7oDL#AWfw$$dEW;3hsL6Ra$8lvGQRt<2(T|me>0j-JByd<;4!ifaG*Kv~f zQ4Zc{L%}-J%a@~wF8~369i{Lm-vBJm5kH;Hrar(yQBaDFT>p8D;(Z(qRz(y3gjp30 zTOATB8=YWaUdzIY(W3}6qZ})I&sS`KzvQ3*Y(o&L%8hm~YzNkZVF;x6#lww zuYQ5?2^DyfgChN$Ys)=MksP;`-p|^0dR$L$h12WEHF?-6hsi`bo!2VQc@DS9NQC)j z$jRro^jt z)JCD-qf1eOohN97HV!u47j)};#7$6tx?-@#7ldI-9Tw^ziP=nNC*nHGubUwe8OcKzq$RTD`9n3)EiY~z!+Z(X;i1wcCR>ckUkz^AVN|y9$&SiVhKd>$F9JZY^RbOe zql!*wRPHdUj#4Ty6Q8T)n$0%m?KI}yS4(xP1(QN``%G=*SA&uM+C%jti{tf({dHT_ zPNV9hkvhEn$c!{y=hxpKw-V48z|aAay6gohK17Xn9*%X+8zl!Mar|n6jl)*{d83i7 zW6vMrHq&XAy^a>gtrk~Ni>uJ$Drzx97!^@zEuB4yX)#S@7bogVgo|5PYVgIk_eH3M za^!?s_%LUoGH7r1Vxw%!)<2=M(D!IT%$c2(k3c7pibB*b;c2Q9B9)t#Lx-CW~*3SN18nmXd+YyOiMzmu48QuN$9x;Z%1+|*1v&f&Ot&E_n} zfaUKw_%#Ca@SQI~Y;u2sFqNfbJ`rV0q1D==GYmOR!6u0CYcRZ_}tBG>1sRj_nZUR6mGMb zo;{hP{KQWGJ4&A=`K^;V3O3QbKVbHW=~IX@-}AtE07;aWB18?UTgEO_=Z& zO66GphK&D&+@-W3npu9L&9}?&4Zk&-dDDruid{ye6!-=-aT}I{b4bjZ96Kz$y zjH=Ch4csR_Z z9U8tqnkhZ;aA#Nwmje%=USy?QB~=?te?$U^-z^!fhP?Q6c+2w#_l?c%3|13?@NgH$ z607KLWX(-sSCU>}38B?BYC6S`yP!m}mS*j4nvQEVzKKl@(@jAH%QH`uxUN6o&Rv}{ z%ZK#Q(qm30mrN$_PdUZ)2YkVQ<6oLUEQBe4B3v{0D`$rayZ-mKkjKJAh)pq+f2VhM zQz#UvUvND8{Rf_49Zk9ruw8v$X`&C&ON6rsAbmnUxs%flR2Md}j!{}@C7p699 zSS)T-vBD0PdI_mAN(_T}k?{#!Wb9_^Te`oPE2Hf~FV4U{#(a@8N2>p-QHt4@=3UI* z-v~JWQZKq!Q5$B}HwRmTRC(I|zLI-lm34Ch+tGOGjjuxhi=f{ra`TW@!x&s^N`Z(7 zpfvjD=4|oQ*sXO0Rhcu#l=6hv40?`q-pb9(xR0Os#0PPm+34`A;q+=uo?GyH2oPJ2 zcb<4MqWYo_MQ!bMyDYI#}D1Od4_SC|Wyt z9rVz0WUq64MY>KD-UQ(FN{<_@<|`JecqnMCqr6aQ_0ILr%NmHNbs0AejhzFtqlVFx zpaqLLK|v&!bjwLU_2*RQardW73JnRqV@H980164^7c>Uum_@7zCRWgu_ALy8#jCER zIbk$g{3=KP0}q*SJQ1!B-Nf(Da`8C6sXW6$K{|pUDEgoTdnjKi9iEEOF#uW)X*KB- z@LS~pHA9KJj^9c=;6zGF7W12H*?f7JBh<@p`kibOreKb{uI1qO0dyS)AEB~*Oq@`d ze4YeW$C4QagO$txV_!1E9Nu7zmE&jbI&Ud65L!d4e4t@!4v>FoiW}?z8BSEzwk~`6 zR%)g~4)R);ZP|Zhb;h;-=xRDSM{MM3y2g+=*iPawJBg?6Bo4Z>ZJrz@p)=LUM>h@1 zldmE4)8C@enzlt^_c#1zV^Q1UQA1uI?KBoYt0*UgUw-heeacsiMNoSl(~d3RYY($; z)raph79CR%cT77RoqNA_g|sbn`2^yLEYW zd3mL=dLb)AH^zvE${r^B_5M5dU|v?Y$TjAka9{+B

y?($xsrVmz_6_2yLszGJxKB`snByo?5Sm}PoT$aA3S7Gv$>gOZsNscf7tG?SwMEYz(frPiiZ?wRm2vB}J=MSwmq-Goir zmV)+RD^Q!s?MY5J2qBycy*#~PRosTv*|R4B`2dHzelYT3`)%ZnMOuhi?%{hWRXDupt8;$jzs$)w?;?{SXJwiJgf|{(Dh3nfw== z*~#y8`Wg$@*GEHVX!`%!G5uM}*GgNL9KgbQF#UAvk}dlWH4-0mxRLmvBaOrb9qlA` zsMEm<3C~ky@;)|ClqOb%uV$}lTbSj6*jJ1pufzlSb9taI84GP5sG8ucx9X?wGZqpL z#Bs;8rz6C8#i$bOw#KN&t;t5&@ix|X8uQo@Iz5bv{cTl7wQxW_Vpm$C3|&DS5dJ7g zoDXwA6^4&FpllA|fH;jgpbF-I%p44I5G5=y7BUCaC>+q4->OcVz78K>9o@gdWF^vf zb@ZnPqq%#^hil5qD?}&JwwSC;j75Mp7K^r07?&DjF<2tH?Rqhik$Cf9>?7HfwC_+h zY%Gdc`I&ivc;Kzj%6V)n$93=uC07)3)H?atoIBA5jmZbxH$X(zIH>+Nm!3o&in`|QkKdnu ze@t3#as9EQP=B2M&b`yLk@Xox43w2JP$s=m`;XSLL)-TnPrdV77u(Cu;^}3l;IeZT zx9^KIV-|0Arq%hCqg<1-c^NVJ0&AS^uI3UT6A5-!BGPBu0x3Yr9nMv2*1xts*+j|SqR zVx{>Fk7Ze2uoMaVitT<`ULb`|Gzj=N&L`{169{5Gc>ps5%qw)wB9Y#LSct44J9r&} zkW)V*vG0|~MtLM8y#|j{x=kA^Nsd`SNqC%Dz#p7u0V}~Z;K#DEWUB!2qfo#oV8Ru) zv_~+RqY}gvxw;>WJ@`}hJ+83qY26;5!f0UA_`}Ae|pl3O!JjbL{&$*vdCEX zS(5IAM-zEmk>MdckLE37SWN??Qo=RKdwk>%>P5f_gYp#Xa;>fm-z=Pl;bqvg7UZoZ$U~dLcj06tMv4@R?tK(lC9iD5!84FGS`65R8B3T7d zrVu?XII{|x-g%jR1?tv7vHK#=C)}l>eIHYcWi!oQN436etonaRN-GnK2*-Ar3iCZ} zF6EPZrsZaizq0dTBTDaQ&#T%oj@Eb~)nq9~P;|e%6l>i8xQBx`0|jE2a}YOkhzzV< zzyLyB*%Oxf697O}{#69wY9H-DY3f5+Wa>Fw?eF1QXm^W(TZG6=miqGjMApY)xLj|2 zQ}L^^%pqac8>Z9{st?e`*0Er`uqW(m&}ozU!`Eh7B$xB?Jo3Jv zzB8!x(+!FARQrR6YxSMAYJcsKD2V~Z+P=sG45B0Vr=QGd?kT7_r5|3gI0T^lv(A{-@Zb0mBnV;`z2 zP#?V?r>I3Y1*rjohbW}B0vJ-m>+J&NE~meylJ^oD44zo-G&DPhYo|PgI{sb^lJw6z z4_2R^t+A7;v^Iv~VDG>k2O2|@_}7>9z~YhRsFqf0@yKj(JU^&E6eKgz{`A_x#(Th` zW6UvkoPQXdw0sgTWV2Aj3)`!gi{N&AtZe~htcGx2m9S2tFc79{z**7jjUet^6O(30| zj$r3J$$?dUQU*JpSf}}{erK^Rb1RJ#<)XC*8-v7dg%2dq>tg=(qb}{$f7tTk!N#W> z!<8kYtJfU}*V650jr3$Ti=V=V`5oZ}qm2i1Sgix$r^AiJXssp+!3K6ETw^w+D|E1+ zK(q8h7i_pWLxLQlK!c}2@bRe7TX_DYN4URT-kb1nqv2*7$JFRIP@~uBBUgsiwbJTcVNLZlnmr&E$G%40 z?u#(`f=@kYVYB_{89khYe(5CLaiPXq$dh-6*lv}4V+l90SE)luJF#CU1v>FW2~){8pjN7>MThd;)yEf|nj)kOb^z93J@P^27Z zoZ5JCu<)Fm#4RP4gh(!sU^qsg6Y}GIj3;B=3`J=1|8pSi)Cnpo=Ri>L1kaF+sWlWc zMYsjx)vJVd0}E#yds*SN*wKGh3xBUf!Y$z)3?m#kriX@ovz`qi0*OupF#5=dPK2yZ zgq^if(`X{>)Oqo{x(OkpY1#acj|Ya-N)+N&b8S3 zu1z>7>8d8&-P`u3bXab?_1TMV`<&Z;YzmJ&SuhKEQz^gYw%z;tjA5@( zZ7Dj<(C3-7LO{}ZtG*pyStwO9hGR|8!5ubz`s8B=j2mPA-;~$p7u>c}Zd;*`A1QTB zv=K-{Xv~{#`+OSDmVm|0SjIw@j3q^t!k6e}Xitbg;qh|9I*1Hz+xz@p!9w{p3P>`( zEhLILe*s8x$K|Dyt~m1*DsIf+{pI=mdAvAhS?^EZ`00rpwn|!?3)E2yj^vEVYCRLx z(3?ulMExfH3dW#4SC2j*EB~={G!NUf4srMm$o&J1ZkOn8jsz~~zXQHyCwGoWG6#H= zjx#TUv9;uf@;m8X9Gc^^n}04rc(tzU-&n`Qtz1QzI3G4!DPrXK&tyr1W)}bJm6L-T zm(^OQA8ygPoIBRkka8`8a@?B?A}B|sMcxs2;&B`vHcv{52{E?m@XP1Zz?)U%#F_;; z-v(nUh&B`CJ##le-wWDIkoSoRr-nFl#2l@+K%DhntV7-Z&2_36vu**_*Y3K`{mONK zIFqys=3EZYGosCiyzdrp8DL`{PISt==>p^osJ1SF;;(bN6>`=gkh467up0y9j6b^E z5^@H>zCg}uPblQ9(}SF0xWB7U=}XV@3q7tQkh8Qx&d&N(ybGtWHLIe4?rU{gv4&q} zbQh6q1Hf4(V1h_pj)fM-w%l}UO!|&ml33_4!&E;6hnNh?$Zikf{twlhN6zS(YSATy zx<}45+rsQW47l$$2Dx)qsH%y&GZmm!clKw_5*pu6NmO-bM;WEG{jeX+`_a1@r3}v5 zNke^zs&u=^X>S+r(>y5#vk48zitO1N^o}LF08v%VMWo893n9`dgknW6;j+8yL9?i) z?YbIw=vvHJ4bjgzY`t_g^&lXvnNBVSj={nwjUG$Nb=JPe9Y2P6_Ln_ zSNK;^JQ!Q|50CCi-BZYJYq&7s^2l45EG=J{To3nNAFw}+3<7%4%zR$YxIOdvW{*~p zaVL~LkEcAQoqj%3-k7!yurtnQPh@l7TRfgSo1+EMvoD@YoB8s4>}b)KY;35AUS2Mc zBmHtc;|cEoBWZzJd8qIslG>IQ$?Q-+T=BIKxcz@|F10hb|_2!kjcJ$p9=HdHV)Z(tTCijk@K?8<*=C@IBml1;qZoa zc_DWqU+AmM7D`yv>h znG^l)CW>PTFnHCz@B8c8bb!mJVn)ds0YkSpBxub`Vq}$yjtJm|RQ(&?rkQ|@IMb@k64nQKMP$&##on^gsk4_m%@()2!HePaMkRUM|3Y@#WRCA zyu}P|lOkZzZ*G)`b(*>&ZvUd&tH(AP`&O|eW)pdP}q16%3{ z_pVdkla<@kjS;sVOWR&0y&jIq9vItFL)=32hRZ9wJRo|DtH*-4dNdHd#p(4Bq~Svl zjVDo8aZJ_F@xop&+yGI$55G9X@pw%fkHbUL)mw<;n=S^$aqEX}+!x0o)7I|90VED_ zT+-kGlDx(jhCcRR(JkJ${tF@B%L^q9^8Iue)yYAMm+H~Imj1H6BIv{E7ak&WFNOXH zACdM;k^$!&2hyMP(%l%ma3So&6IVP{94rgs@KX`LTetfXlf*B#$L;;(xpGg{t=7@B z4WB&wl$TWQb-UoZ0>9i}dTzQK$_wtg!w~;(J}fS|FX24pPI#io7y8_|l*Z~|5;qUYS|E}frjwa+fY^jzS`p}QQ z;YZIi%Dm6}sV6i_<%(TYG2n@DCeCX4X6sjQYO;rauM^l(5hwkTe45E>PT3rt#ttoG~~!bL6p^BljPjnt2o-UiFGxUX{yha(P`Y7v%D< M&~Fj6?z(d2E1&?R1ONa4 literal 0 HcmV?d00001 diff --git a/clos/3.5/boot.dfasl b/clos/3.5/boot.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..5d47fd442479ad997074b94c7dfb7c49f1404b51 GIT binary patch literal 29368 zcmcJ24SXBNaqr!MUm`^c{LmLIORy|cvP{snY&rgj9e@BxfCO+90P5ReC=n81Q=}|W zwbdq!=vc9wuuUk(63-v8_u`_KBh-&&wGFcmmd;9!>UVnE;QPt_m3L2DhwIB_(0H~%fp$DS=NQ}Td zO`sRW^;9Gtjl@IKCnxJ;{@#$+?~R30VLdoKWwwMbZhtW7jr(Jvp!w0LL+*{Cc(Okc z@^**fp+qF$wL0$YPe$V1UbK`QWsJ`sxPTSJ8`8jHHtMo)e};es)>eJbqc z4|_GY;!@FSeTz=!M-Y^MqO+) zYpv5yYtv7=jKu)lEO3jEz};<1g#1x&X+CPzqt-I1RTe=@x#Ij!K)!~)R44mFfrvk9 zG%L>ok|z-gMiQYw%3C}@ZzP@yCE_So2P#@Qq9|*&`&yJdB^Wg=O1K5sF>b(6RURv5 ze0ow#>3DBIou!%djp}UplAttFOV}k6+&DaVV9(H?Cp+@CZEK45_!ayCfmRdwVcw|` z9!F(cB9u&lTKtLbq_zYjtMvEvMRzPhYDscOtW%E`W(zHAwbRc`x&wNwFA@bonb1^Z zF52CfN`(94y_<+2Zc3fa%!a4J6B)OMK)VZEsCJG)vKCGS1eNS;!7|mrCQ-wY4 zt$^H;45hlfC4E_H+<@*}3+=7kIFHu5BHR1>ga$np4K7s3NsGoZp~1~WgB3ueu>^!j z2*q+M1;AujRaik>Xk{|xj|csU;Jo!`)EV~x%8~;0IVu`%X~no3Wzgt-TvRB$WK~LE zYP&LzH# z-8V5&=wnF}MgzA~#qBf|xC%Ew4FVe@s@SVC)d}}13$7xgGN{wy) zXjI?k)l=b6!V3UN!ol6tlXk|I#nHN)Jj`1L!&VQCK4XiKFp@@!28nLP`=e2UhZO~; zu>d?OWYp2}F;*L!dG$A@A3HcWGUNpfnIq!mzTBs6$I{hyg7~%bk=|&XEM8+zC03HT z*tO}&#p~9^{DFk-?a~vm>B(m6)qw%E5#4GGZSMow6g4A@Kxt#H%RjQf?004}X3GGM zK5}D3@MdSJS0JFEW?Ky@C({hlGL$U8W_5>{a$SHDPlNnoqBM`^klV=TvB=7*nb*4)pYi6;sIPKH zkCtg|Js*BiipiAVk-ec7ZFW8Iw&0eTw zyRoJST%!eU!9gkiXo4#TP5GJ=n)2$~Lwo6$bxwKQ0WLRYK?|BgeUZNw@SRH*!TNX+ zzH@guLEUVEdY

rZ?A;;kRD?T}&jJk7%=J{=;oHw{vE_G=P!MhF_4}2-A7~L;NLz zFT2ii(ud?$P8D7`;YWVBwYAk;9T@76q$ayi* z@qPeqW+^14_j#kCts!iySnWm~eZ7rV9jykeJbJIjdu=G-Plmi*{zw#A>d$GRFcYS? zuNm*9$8mYw#Si6&@-XD_AylZsRvwB62aWf(p#7ym-CNjqFh*Y5w;Of0P?I|e{+50{ z6{5E-27Z+ZN=8w0NmTb2vmN@gVj--?5X=+sWSotOa%!0`-0_`9Vq^5cLSv}Naosl??mg?TdrJkhZT23;=Mmu+rom2`*<)?sHZ=HKAV9NKn zzzG0TzQIWXru>ned(KXtv6C-zk`S&uZ6}|Q$HY73?M`{zA`chZ&>(nM%Papr#lI)`_euW!Apaic-zQK*{e|qY zu7E!QimDP`&*ZQEEb)Ohx8xbQ!zlx_1I}_w+A2AZ8eq+Iz;fFnRzV^@rM%Op zo%PR#88`gHqSkKpLR5RVI?#}hYwCbIF9(l-rrwy|pt~dWRSq>bJa%(|tbTVZH#=DSl{k&6#IZI}l zySbHfckp9w9cnbqtAUfxB7CUp1|m&jHtMLu)!m|$FzQ@kye=thu-3G8FxW3P;bRS* zo1>u=77>V=^M4mJjxnm&`7JruFLJKml5_o?fncZ}2L?;2QaDjCnX4BWmHgv-PNs$N z`UGczE%1{B9ZqywiC!#^3>HUbpb39l@_NH>>+ak(y+IvV#$7Pd@M7wlvB)M z^<^5#uB|eM`ZA=cx_er0(p%a9?S$TvX&q<+Y`sB4E4fce(*f?6)qc!M#2NJZ!YdLa zxmkZqcJ{jv0jo?_R)r%IPr7-wHJSOe^IThU%9yN>GX{}!6%p0Qipj=4k>s~8`Xuu{^tr*3 z?JR;-3CO4DcuR>1{{5Osu78em8PTijuUM0nUvSHkx#kIH_0KN#e6OZn=(Lx-$)5+@ zDo93mgHaO=4lK*-Edwh+k*)Z<3V&DU^<}g+20SNq&vAVPrJvSYbGL##2R!%>1zM-| zRr=~Sls}=b2JNjvZICGeTcH73?qc}gp>*qn7A@-2TVyriD^p$ut*)R}?G`fw9@OMk z*PhhZ9@kr?)m1rNU!e}HMT_ddx}iIKmuHsi>#~=pGQY*3^tJjrBHd#QVAZs~TKBY} zgC}$kdbJw;lm6(f8d}SJoHzegv@W%q^c7J_Et3_)=pAT1skfRk!P7YY9`nUoThWSC z#^OW2F+7cbEBLpHe`^XDr0!ts1M85p7Ju9DcSBxZ_uKl~+( zLf?R_HX7(U4YhKAi3Vy>NdV}r!D9U-AD>X#9LB2Wt;AI3aU9xbB6<@~JV48rwp9Zg zX0Dg?2Ca2qV_x5&Z(Nzz+qhhAshQvs85t^(Nt4y}wv&3>L@uokYHM8 z%P$Djrd1jSoeN}v{w#W5W462s)RAXC#x3dmo?E4FuqjjW^fnER@mEYM zW^k>h*<}Ydpp;7eZvzFlOC$U_e5saaXvT|_%$7W=0U$j!CL| z8h;-TU(y7JS+g86@Ik|es+l|Wje5H|N=ll9fF;m`&JxX`BnpNvRn#-!T+95@105zp zIzUQ#OOL*8omye?+CN{RK)8m63;$P6PcEIe8xkKZ;kL^c;HBWrHs@_6)^W~wKRrGJ z-qS|v^=N22q;y-$ob;x2ld+qOm`@3=NvWq3&!T#LTfI1h1#w#;-*3f-)?^gY19gv; zOG$56LXUYV6N*l1^(Kg6i*HKmC_widQ9A9qt~c80;bKp85gCklKYhRiY0@u5uAoR&w7Ua-tu& zkMJf!T_N161wuf}{W5IQ3tuln=>k(})QQ~x$_-rOZ(I3stObp@zJxXlmtU0e`_u{9 zQ|VQXz}oa&^vk3Qamk1lM7lwJW4u0W86rhVR6Pmkx2Rng|} z-%c+d#YwMKH58Cw8D9R!TZ&Zr*frMDgQ z1|g$6PH#F_qVBUIw$hXw@vi&{e|m~`P3__|NHf+4svtEj9ilYKR*a6K86YFZG-00Kp@FLqWqCCgPzq!uCzVQ| zRIM=Hhllbr5cG07`Nwdr;f1n``G9w;KiUrgoJxELC7SIL#5x>bzf4~P{y1w77=}N9 z1tW|^`9sjhBD78NeyXpQz`cPA4dvST20qj>XL5jNg^fze6os`2YQ29)83~C-8yMVbI11ZH^w|nN@{J};Szn04@S0v!* zy8|!QK<0JL23|OLIzbeM&*jQ=HdU@;288;~Adbr*vSGq{R}_g^u;qLlk95@Nk2?9N{Y~J zKy*hR4$s&?E!ioF_DcDS7iE?dF(S&rk(W&e`shN#6%=Xgetu|Iz)v8i#8SAe5E1E3 z`LLH6)sIj^>yaE!AxFKyIqL7rV@Mtk8t*@1y#Fq$@h@DIH~61{-Bv(#vXS!th!|yu zqk|pN<^>e0rYmRgODgwyl&cBEV~ipx^50NIi*(V~Pa^38NJ_uRJn}k9KFi6~l>8_s zNnM~lN$q!;rQgT-YbgIwN-886Xb*~rlH#0ypd8(}g&wW)VJX+*Hr(=oHF4_oRE8x2 zm0DH*xd2`LS)q!`Ishr~cbrSzQoqef4<%o>t9^x%+$mMI7A`Pp7dUPgSk1X4m@Ah# zcY=~X;auvO@`j!KE+?sz%3t$jDSrmERFdL>=0&;40A8o$?{m=`DET{_WTneXC|<)l zOTnbM^ARQ$Mz->1FPFZqiyy0GgIn_s$=t+`)n0li6YKe{YArw3uHeTSxpaAxary=y zU|6bGE03Ai53re{O>id{=gIhn*uog&MD(Mck@RC@o&)Kz%;-=D+R@IE!2@4?sMm2N zhW)!z2?W-#(Lso8OM*NnaVAabe1_VUPBVzdsYjw^AtkJ+TV#^jt$eSQ&vT=;Q-=bj z!{T1uNF^Pky6u;bs;=Cq=#GZ%8qkc|&S1Ti{2{@%d#-*H?`FrYrRVBruBPYe#~r1r z94*71fV(6V3yjIku9@HGd1E6e<)>Gj`W45r!qH16F6x^yVWFjDI#l4>!Ymcybom}B ze`UfD)tgE*s(igTZx!WzxsYeWcFdacYT-MhjThN$aUR3|LUA51@6S@6J>$xAcsGk( z^^EVkdJJt_7$g4qgS-A$=!_}l{@B!CDj#P3Whaz^8OU-z$a4M*nTv8!G?g3frOTsU zZBB1EA7kCkRBn5W@?zQrz2Rb%#Jz!rlX}DPDC^4Q{qvims@Ok-y)(@$kpzNKRg4#M zOQUob6?vvdcekB8uDdg>J7;qriI_TH#r5~n-P=Hv+dFEuMT*I`fZSyDMw@?Cx0)2dmsXnEsd#5KKii~)M())xJdT=Q^o@}SPSloza4|@j3 zZyK-nl>KukJ#=JbXmDiAlifc;7pOz&y~Bft2KnZe%!27c_aHI=8b-R~$qrRDZj~MI z!#i;fS&xIHs)=N2>o5ljCdXnoss}$X!Ehzz@y3lkr4Ed;A;4F0Cx`wPnJS6gY zN=kcq=-gbbzt23`7q|Bk+H+j0x^O1N=2`+rt)Nz6@#1K;xugt?_sIC~lu|19evr};mrUPFjmCRr53{;7Z@f@_@p$Xy@MlgYPvRFa42Okq>5yT{ zKqT^M8MN}2OyjyzgqBmhE!5)dHMRJU)}7|pF<;SNcAv@0ATi7`aoX*c#2$B^?>oD? z8@k=TdY%fCL4F-Z!HZ0EFPfed6{!kzH-$anJ^H!)8gGV09R zKlMiA9urOKB{6YS{+ZQ%PoFdldE+LufEp(}h6pMboO8pV_M|q8Y{+^S6#_x7g zl)rP7d&a1z$7lHC^OXFAoRN-Ej{4H00PO-H!5GhPyqCyonfL~XTGGC=FzQyLD0GW` zJNOdAB%MVBa+aZgk&>r5nWH2#dF3Ta^7%nIk>QVjA(y^?5$3nI?vsbySHDFHYvo(h zlX$2P_{GX}3I9JXxmpql1S%d&Plhh=mNZ2VMvchYzza5v;JrJoBKT zVi|A{DLkIeBV$fb9svc>Wn}bGQW;K@C#|a`w`bJ#g^Q=)v@% z;iDZQT&k~u?}^c|bJ>`?#cRN}W4BmgD*eZ!(0KX&n#Udn07_NTKG$kFU;~Y@e8KkKjhz+ zU8?xBm^%VYLduw$vppLr&mjyXjV+L@io6O^)ejoC^c(FxSd1$zEI{Px?8FUDf#Dl< zvT!bJ;Fd44wq42dcB{PT>N6U|a_E0FF^=A}`1@s$L$OUFf4>YuaBSmcdR;I|B$V%< z6*mkYx1pn+5lGCCykU%ZXec`}c<89TsvuPldJYWkJv7>0W<5YmKRS8@-;a78CAoZT z)N?3(aCi{DdD$^p<%9FqR=Z~p-1vq@vm^WA$X6cfquJqMfO_OeR_r9lxE;v**`c)O zQChKRYG_oNAjXn@EPHs2AX@yOJY1YRvLjjI7aipbqyUSAQ!n$KeNF}=*RbN971>EL zHV=GH+H>S^df$;@>JqR)s}}xM>OS9;&+Qj8Hs14??3m{ER^)lp+b$aWd?th4b2iN8 zgO{}7C0zVHm`{aMCAGi#@HdCGzkEG{GiI2q+j#chFdAUZ=8#-#aQmHv8(%j>8QSHl z$RnbrPfxPJq;9m|1maw3ORhx*XshvU4SB_|m8+@wq!B}ap^GV4^}@b;8EtC*V2>V& zHyZ8LJ=~E~A%2|p5$%_)8T6<8pnZI=G%wIM86ArOs}cuLe^kWH(;{Zpnw+GI?yNxf zclyryUM0jl`%w5R&@7sEAgg>P?k=@%Cn13@8N)b0+d*V1FBXF35}w|C^9&0NH`~t8lteH1d>e>PiM|e440W)vYpl zjV7Bb$qbWCHcR_YxMEgzO!E|3Zn{fLng*O&4Ih}bM$*T?oVms-$EUZorDzI9l7R$n zLSeKHgVcZ?gb4e#7+d=zRN^-V% zzLb06&qZapq77_*0Xv5p;uZ@XDqKPqmde^|_D@q92`#cWpQGd%teoX+iE9bjw$B7# z#VBG3t&o_gcdmEZjSF zvHOPB9yZ3`$;HU}7pzFO?76ij^eroqs21f=Ukhd820yrjU@8ApO}}|twl9q6Xv%VOrZv$7uq^Mix`&aN9SnV=JQtPdb6S&U*z~H&;To0MHJlm6%L-o1b zGLcVrzrstVN6yOO^HC^^W3Er+?u%)znbk4N%4SV`I)1S3u`;sqG7>6jK@2nId?Mx2z;fMKs{KI8A^_sgHZEqp<` z9aWs#zQe`{Ugq%ZQ%}i5Weeztt7u z^~O$B8kvQuEIKI6ci!T4v;n!w*Nky`{H8I!)fkU(zSl<&Wv+%FFOn6I8bpI|_Gb+a zAGiveJ@YAb4VR^ruCjzLi~j#Gyv+pd$9D4jg|f;FCDk`aIOl^Kjr(qpRI}u>;m>Q+ zlQ-x?Lx>|WvL7dHIZ%!r^&rdzl;`BwAM2t^NaX}o(qeu5cqb&+-6olLUM-m~;>kQW zF?enP65mx!;&Z*{GZ&&D&%2{Up3x%m1Z{)FSNCe#uCux2j`Ju!T#R0bpU?eic&_(C z<~*&DyGzzcbUJFTkum_VMlQzA$1eZ?cbI>e_DuiY&)*t8FT~xe_6l)dh`tczaxo!p z@%|+Lf_I4!hl%PzYs7R9x&Ca zLifCD@fE+u1pK$$8&3W&N(zO)LP_<_hd5^e0{&yJ8KXK+NHWR~BGKg_(QF1PONXtv z*#6Ai5jY!Q1FFo0o|k)bYkSmp!-zh6JkIlUq4#6aSljt0FoV0{IDanpzh^%Hiz`tn z1jA6SL?9(%dif7O!I+j;D@wJ^lq~(QBh&#r%wdvA_cl=d(OJvVuYiSFTdL@cjqvp3 zA~x6~+-kQm3SMi3#cusgWc0hkG#*xC!2ebTwx)M1u% zMrr}(92Zw=67S?6(($~p0+8bKa5pWU6?6_XGDId+7Gn3>D=m!=5QY}ZKQAJq9<-O)SC&% z&gr_5KYikQRzwK|jUcTog5(?rpTHiQr~NlMEo^GH__LR1I?2wKE+~Do zNNFnlb*!E1dL$mgyhZc(2)d&6tWe#BS`v%La**Yzn!tJ7Iuk>(DjEPSf*QTE2SII; zecB;oJivILQ+Wr|2G!x|$yR8mSfe^dYALwP4j=WJwlh5V>@BN5`K)87op--hARA{XTiB0ztt`G<)(9g=Ajf8r-G{Q*%8C zI$k4F+204f5d2ol=o31P@m0pSD`Irq$;34Xt&Mj7^kjR8=)yAyLB~|24`qkQ!Fzw& zCL2@7-m!do@{V6xo;8Pq!^4An5L7HXa(HZzJ+q%jaGX=h!T$oh**H{LVkkzU`)ZL` z!5gV&@JUtqkszz0-{_c!uUlpOhtdZS$L#7*cGufgSrBU>V2!r#C)2~)&p(zPuK2kz z>>93+gHC$b^{t04e{#5D@a#nPtPsvj%7Ku=+G|&LiuS+rwOv!aCwj6BpxjFQ8oUYI z;b(19hUyPnx~1heLKVf*7#xtwP^N?Nm+Vo*w#;Zn)ikgPBX-0X-@z1lLImgu=49H$ zI?i;-`Ts@OPIagUrze*O1})-DGvO8(8W%T!u${CmZ_hgrF$9+iB|ozomMhwej!hfE zy>cyV&Z2(Ekv;1(?_X^YJGBUywJ1Riup!4C!MySFndJuSRvH^=vCh{LX5gXRYjl9E zX!oMiB_Zr?wztN&S=m6M!uup5+L_@J`U6;j2)bu6ee3eTYpL}`ov@IFkYzTMAzj6& zx%3aeOSuu0zc$|t+?(oI@Vy) zjazA>t`{^wBjpYBi513j-ZX^nIcc4OL0H-xAUGzeO14S_s)O)DPV7l|kM)rO3t#XW zb#h_!XBvg8Tgv(iXY>scODU=p+`E#gg8RCN5KYpvq@E~vOR?;*naR)(!t-e}>wOOT z0@-nY9a(aV<})emRajG48$WnII}cl^^0KxJjj1GJks*!NhKX6^lSN%3SIzGm<3%Qb zBH4vvs*6|71U@w5#^rzyY{O6P6PFa|QN%a^Qd@)!?66tu4d+Zlyo`IkAzsGqFvRPL zULI)p{B_Z7ZX6%nJ@m-9qdjttShdQX`=sKkp}E}%?VG3*ykfQGkPPRKpoXq!OcH_+ zL_%9M>Al@fZmQVJLz?5*0qRrCNz|v@lnL`Wkk(qGV~LO!7d#8YLvqVe-@|jp{<*L{ zWM3}&h2JhrjxuvSQ$3HLQRdWLg6s2whztIUQBwP`nW6in?mn(JQ2JyxcXynu3gg;E z-OUd7>`l#X_i&bN+O`Y``AsW@M=1LH+a#zNA09$y|;M-bJc&o@qB)wy% zE27Q8n+Dp3-j{oFD|%J9iTBtCz;m#|%>BSY#~^LqTN>5ch^h({x8E|mbR$9`PeQw^ zjuHPCg8sUqOSfwC*2tuI^4_wvP~z91G7#-md{F*_A#n1to&27i{8MB6F@BrlgQ9lg zW`3JcDyaG&O;5Jxd!Ko&wrgD0qrC7%Ke-#J3O`$)BK5mz47f$*J^r z!Euu^e$y<{8G@loh=~e(tjNLePL?dSze90#J67DIm`Z&c+p}2#N*J9o8ozgxs540CQ1E zm{8lXsUr4N%#T>8qQHmss!RdIc*hxRkrhlPS@{T^Wz#VVvpQNO^ekOFZso8<2DkK=s@XYjHR7R9R} zB4Q5GRrzeAs%=|4N9(sH-#gWdmHV8^FF@AEv%FB?ku6#&YBAiRfa%pR;Grn_aTbm- zcmof>FMRj$3*UYG*5zu%wrH{dqTc*R(DrlEwg_=p zKxeKDZCf{o6*kp7kz1)gs6x#q$HqdD-1oP&UC7MEreb7qyGy;;ONwS2I|J^xl#T0d zNg!;389Aisq~0`C-xG@q3Swu=tA-F*=9Mj1+8du+aFwb?dLx}o@ ztI23~H5;r|(0<(LD(u`E%ZqV6lHAePOr-G{CRtY9oi^^LoDUnUYdazuyb)VX?XZz8 zr8V|J7xf#rseXkZvFD1`Psv5b9rUPRXr`0Rx5ue%<>CSE!nfav;ku#e^7ltm&`C>F zCZp~)WVed^5ZAqWS3zBE`MHzDK)n>$1`!1A$VQzgvFAuL(^xPVu+@Yj0?)DgEPFR8 zWMigoFz%xcJ!N#X8u!&2_c25JE}Wb#i44o|&=g&RlYarWWB8rXu z@of=!m{SlOsAo1Z*?hba=(qJ*mECvV@s7<*xfH^0700>-5AH^==Td4FLhWWS-=|q* zizfCNR$GM_X^#J$*8?s>SI`@)iZyl@`z_;^Uo+YtmXf{lV5Nro3nnQtmSr`yQO6{% zr5-^}bJ;7GUL)gVe=j*3r??1;58J_zfH!9nOxVk)gI3d_VGKP~Tq0 z+%Ki1#WVL~(?T$1i$t%^hDR;~$wURD9~g#hp!di@4*Pvr10v*XRJn@-Iwbm{h=Z&% z4*spjXunRd!IxFQ2CMSbQ+y4jo@T=`^~zmTMpL}l#g}2o9ZDK%r13UbF?MtiB9t!~ z9ftwE5MucqMZ5iG+3m0NW2dLm$1p~wu70MhS?i2>b%T8!*ulOSIcHUyySjSkd!w)S zkRS+Kr%KFj!$wx1_s2Ot7JEw6)833@QGXzX5Y(0AlVBecy1Occfc|Zt(Ju7&ZyiQ^ zE#!b&QQIaG{vCCLjL%cM`Ehz1KdvMMfnlSAMKAS~$m6G(>#0{-(Vgl7D{KUTLBv{O zQlB>z4N;6?Q=Yi8(QyW?vd^HkIL*cSbc(kAOAeVVmpo6sQ9cJaA)k8Ir|p3O7_LF! zW~83>sV=dFdfunb@h1|hpA-ROb|UvTh3s?TNRQ8s$?`dP8#qpzb%={Wyq|29RayVv zMWfub_6WorimlCX=Q@oXj1`p29P_4-nYm0yc-}S&M1p z>+GG#rXU!S^K4&$nT=OFi=w0espT%RVC>pZJfX{+HxKX(H|1}Y?E5S)6lW1ukjSKa zZ@{E?NCResIlhl@OO|D`>!bn9UbQ*OGV@ot0h(g8yR2l2yfS-6-BNsPEd59!_;?0i z6MpAaaO3%QGbsp{yC^wv(Aa69q(NbJ`3u-CL-DEoeEQ*GIa=n^53|}+W3?x(Tsj@e zXlEimxn2FOta8ZIGGo5 z_7y&%E1wf{jPGUXoBHit^l;s`mET_5!fzY+2HVw6JfzVi8Rx~-y~r~Q;JC7`(qnM$^+J4CTC%~F)USGwEZ*oxRc5R2cQ$QEp{}#KQVyu?&s%7*pE$IfdC%a4>CyP1kH6Vg!TlooaOjNjxgam|r zsu7Eq%cnBF46V)Zdr%0G?d}XSXI&-sIbk^``7}`w^0Zt3z(%;YHG`@ZZvV{Yas@bC z&F-n_ak9BSmN^+#kA-_$3$=WXxOR5XMrKZ=ndRC8tbHu5Pg~Z!{AlaE@=u2myf7P| z|A9NAH?&gMVPnrj;7v^V3C3rsslkmb`we19i(w<5BF7Gj^TjtkA7!+@Lb&~~VEEmV z!(W-^SP$Nrf#9g-|}Yv0S5pxxiRKj^r2pAT{>7z^NCf37pNX z2(=kfF1deOZ^~`e5jAv$=)qPZA}9SXevG7ZB8#A0GtTEL3YnBewVS4~XD(~Q7J7mL z*ABE`pG53YG?M!?G+cTEPT|pF<%B4x%q73K-lj)fn_Ptt0jo?tMR+h{!#eS>7x_)_ z9gpz+ofQaC^qfD46JfftWU^d^%>-7<3hx!q0ef;Wh0clqjp5M<>3n*feXVEOvfB+7 zi(;@f(nO$|U^!0(JLAYEdBInMC$s>c z;FX>DhT?M8tIe%+s@#<%hS+ip8np_|Q3_4;_SCUMDE;<68!URE56Op#`}4RD?hB@TSVobNO5bkgG8th-qgcn{}fA%>KfespHdnz-#$NdHJzg5 zELr>Wm<_t@2%d--p_6I=e?y2&19kGe;t;8=f47XN!^hOYvZ3n*(k{^6*>2DFZ5MGVn`wRb z1>Cnpwez`)ESeEl#;EY0oXTH-_~r=nQXn1D<3PSC1hXt66=8R@lbFWnq@z`SPu4#r zKZH3%#8(PO$&~T~7Ij=%-hBR*vb3A2+#h2vX^!DKA%ZaU66=!Vz|pspWxm0}WQ&A^ zsaCV5r;64g@L(y4YOZQNI=EhWABdvgH?zg(Q|;-VY3BK+tipuP$O;5G)IdF6nEMHz z3Ox`sMAl8N*ekHkby1SSaFTaWG3%)). Returns the prototype instance of the +;;; method-class for that generic function. If there is no generic function by that name, this +;;; returns the default value, the prototype instance of the class STANDARD-METHOD. This default +;;; value is also returned if the spec names an ordinary function or even a macro. In effect, this +;;; leaves the signalling of the appropriate error until load time. NOTE that during bootstrapping, +;;; this function is allowed to return NIL. + + +(defun method-prototype-for-gf (name) + (let ((gf? (and (gboundp name) + (gdefinition name)))) + (cond ((neq *boot-state* 'complete) + nil) + ((or (null gf?) + (not (generic-function-p gf?))) + ; Someone else MIGHT error at load + ; time. + (class-prototype (find-class 'standard-method))) + (t (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method))))))) + +(defun expand-defmethod (proto-method name qualifiers lambda-list body env) + (when (listp name) (do-standard-defsetf-1 (cadr name))) + (multiple-value-bind (fn-form specializers doc plist) + (expand-defmethod-internal name qualifiers lambda-list body env) + `(load-defmethod + ',(if proto-method + (class-name (class-of proto-method)) + 'standard-method) + ',name + ',qualifiers + (list ,@(mapcar #'(lambda (specializer) + (if (and (consp specializer) + (eq (car specializer) 'eql)) + ``(eql ,,(cadr specializer)) + `',specializer)) + specializers)) + ',(specialized-lambda-list-lambda-list lambda-list) + ',doc + ',(getf plist :isl-cache-symbol) ;Paper over a bug in KCL by + ;passing the cache-symbol + ;here in addition to in the + ;plist. + ',plist + ,fn-form))) + +(defun + expand-defmethod-internal + (generic-function-name qualifiers specialized-lambda-list body env) + (declare (values fn-form specializers doc) + (ignore qualifiers)) + (when (listp generic-function-name) + (do-standard-defsetf-1 (cadr generic-function-name))) + (multiple-value-bind + (documentation declarations real-body) + (extract-declarations body) + (multiple-value-bind + (parameters lambda-list specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (let* + ((required-parameters (mapcar #'(lambda (r s) + (declare (ignore s)) + r) + parameters specializers)) + (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters + declarations generic-function-name specializers)) + (class-declarations + `(declare ,@(remove nil (mapcar #'(lambda (a s) + (and (symbolp s) + (neq s 't) + `(class ,a ,s))) + parameters specializers)))) + (method-lambda + + ;; Remove the documentation string and insert the appropriate class declarations. The + ;; documentation string is removed to make it easy for us to insert new declarations + ;; later, they will just go after the cadr of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's arguments to the code walk. + (let nil `(lambda ,lambda-list ,class-declarations ,@declarations (progn + ,@ + parameters-to-reference + ) + (block ,(if (listp generic-function-name) + (cadr generic-function-name) + generic-function-name) + ,@real-body)))) + (call-next-method-p nil) + ; flag indicating that call-next-method + ; should be in the method definition + (closurep nil) + ; flag indicating that + ; #'call-next-method was seen in the + ; body of a method + (next-method-p-p nil) + ; flag indicating that next-method-p + ; should be in the method definition + (save-original-args nil) + ; flag indicating whether or not the + ; original arguments to the method must + ; be preserved. This happens for two + ; reasons: - the method takes &mumble + ; args, so one of the lexical functions + ; might be used in a default value form + ; - call-next-method is used without + ; arguments at least once in the body + ; of the method + (original-args nil) + (applyp nil) + ; flag indicating whether or not the + ; method takes &mumble arguments. If it + ; does, it means call-next-method + ; without arguments must be APPLY'd to + ; original-args. If this gets set + ; true, save-original-args is set so as + ; well + (aux-bindings nil) + ; Suffice to say that &aux is one of + ; damndest things to have put in a + ; language. + (slots (mapcar #'list required-parameters)) + (plist nil) + (walked-lambda nil)) + (flet ((walk-function (form context env) + (cond ((not (eq context ':eval)) + form) + ((not (listp form)) + form) + ((eq (car form) + 'call-next-method) + (setq call-next-method-p 't) + (unless (cdr form) + (setq save-original-args t)) + form) + ((eq (car form) + 'next-method-p) + (setq next-method-p-p 't) + form) + ((and (eq (car form) + 'function) + (cond ((eq (cadr form) + 'call-next-method) + (setq call-next-method-p 't) + (setq save-original-args 't) + (setq closurep t) + form) + ((eq (cadr form) + 'next-method-p) + (setq next-method-p-p 't) + (setq closurep t) + form) + (t nil)))) + ((and (or (eq (car form) + 'slot-value) + (eq (car form) + 'set-slot-value)) + (symbolp (cadr form)) + (constantp (caddr form))) + (let ((parameter (can-optimize-access (cadr form) + required-parameters env))) + (if (null parameter) + form + (ecase (car form) + (slot-value (optimize-slot-value slots parameter form)) + (set-slot-value (optimize-set-slot-value slots parameter form))) +))) + (t form)))) + (setq walked-lambda (walk-form method-lambda env #'walk-function)) + + ;; Add &allow-other-keys to the lambda list as an interim way of implementing lambda list + ;; congruence rules. + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let* ((rll (reverse lambda-list)) + (aux (memq '&aux rll))) + (setq lambda-list (if aux + (progn (setf (cdr aux) + (cons '&allow-other-keys (cdr aux))) + (nreverse rll)) + (nconc (nreverse rll) + (list '&allow-other-keys)))))) + + ;; Scan the lambda list to determine whether this method takes &mumble arguments. If it + ;; does, we set applyp and save-original-args true. This is also the place where we + ;; construct the original arguments lambda list if there has to be one. + (dolist (p lambda-list) + (if (memq p lambda-list-keywords) + (if (eq p '&aux) + (progn (setq aux-bindings (cdr (memq '&aux lambda-list))) + (return nil)) + (progn (setq applyp t save-original-args t) + (push '&rest original-args) + (push (make-symbol "AMPERSAND-ARGS") + original-args) + (return nil))) + (push (make-symbol (symbol-name p)) + original-args))) + (setq original-args (if save-original-args + (nreverse original-args) + nil)) + (multiple-value-bind (ignore walked-declarations walked-lambda-body) + (extract-declarations (cddr walked-lambda)) + (declare (ignore ignore)) + (when (some #'cdr slots) + (setq slots (slot-name-lists-from-slots slots)) + (setq plist (list* :isl slots plist)) + (setq walked-lambda-body (add-pv-binding walked-lambda-body plist + required-parameters))) + (when (or next-method-p-p call-next-method-p) + (setq plist (list* :needs-next-methods-p 't plist))) + + +;;; changes are here... (mt) + + (let ((fn-body (if (or call-next-method-p next-method-p-p) + (add-lexical-functions-to-method-lambda + walked-declarations walked-lambda-body + `(lambda ,lambda-list ,@walked-declarations + ,.walked-lambda-body) + original-args lambda-list save-original-args applyp aux-bindings + call-next-method-p next-method-p-p closurep) + `(lambda ,lambda-list ,@walked-declarations ,.walked-lambda-body)) + )) + (values `#',fn-body specializers documentation plist)))))))) + +(defun + add-lexical-functions-to-method-lambda + (walked-declarations walked-lambda-body walked-lambda original-args lambda-list save-original-args + applyp aux-bindings call-next-method-p next-method-p-p closurep) + (cond + ((and (null closurep) + (null applyp) + (null save-original-args)) + + ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and all args are mandatory + ;; (else APPLYP would be true). + `(lambda ,lambda-list ,@walked-declarations + (let ((.next-method. (car *next-methods*)) + (.next-methods. (cdr *next-methods*))) + (macrolet ((call-next-method ,lambda-list '(if .next-method. + (let ((*next-methods* .next-methods.)) + (funcall .next-method. + ,@lambda-list)) + (error "No next method."))) + (next-method-p nil `(not (null .next-method.)))) + ,@walked-lambda-body)))) + ((and (null closurep) + (null applyp) + save-original-args) + + ;; OK to use MACROLET. CALL-NEXT-METHOD is sometimes called in the body with zero args, so we + ;; have to save the original args. + (if save-original-args + + ;; CALL-NEXT-METHOD is sometimes called with no args + `(lambda ,original-args + (let ((.next-method. (car *next-methods*)) + (.next-methods. (cdr *next-methods*))) + (macrolet ((call-next-method + (&rest cnm-args) + `(if .next-method. + (let ((*next-methods* .next-methods.)) + (funcall .next-method. ,@(if cnm-args + cnm-args + ',original-args))) + (error "No next method."))) + (next-method-p nil `(not (null .next-method.)))) + (let* (,@(mapcar #'list lambda-list original-args) + ,@aux-bindings) + ,@walked-declarations + ,@walked-lambda-body)))))) + ((and (null save-original-args) + (null applyp)) + + ;; We don't have to save the original arguments. In addition, this method doesn't take any + ;; &mumble arguments (this means that there is no way the lexical functions can be used inside of + ;; the default value form for an &mumble argument). We can expand this into a simple lambda + ;; expression with an FLET to define the lexical functions. + `(lambda ,lambda-list ,@walked-declarations + (let ((.next-method. (car *next-methods*)) + (.next-methods. (cdr *next-methods*))) + (flet (,@(and call-next-method-p '((call-next-method (&rest cnm-args) + (if .next-method. + (let ((*next-methods* .next-methods.)) + (apply .next-method. cnm-args)) + (error "No next method."))))) + ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.)))))) + ,@walked-lambda-body)))) + ((null applyp) + + ;; This method doesn't accept any &mumble arguments. But we do have to save the original + ;; arguments (this is because call-next-method is being called with no arguments). Have to be + ;; careful though, there may be multiple calls to call-next-method, all we know is that at least + ;; one of them is with no arguments. + `(lambda ,original-args + (let ((.next-method. (car *next-methods*)) + (.next-methods. (cdr *next-methods*))) + (flet (,@(and call-next-method-p + `((call-next-method (&rest cnm-args) + (if .next-method. + (let ((*next-methods* .next-methods.)) + (if cnm-args + (apply .next-method. cnm-args) + (funcall .next-method. ,@original-args))) + (error "No next method."))))) + ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.)))))) + (let* (,@(mapcar #'list (remtail lambda-list (memq '&aux lambda-list)) + original-args) + ,@aux-bindings) + ,@walked-declarations + ,@walked-lambda-body))))) + (t + + ;; This is the fully general case. We must allow for the lexical functions being used inside the + ;; default value forms of &mumble arguments, and if must allow for call-next-method being called + ;; with no arguments. + `(lambda + ,original-args + (let + ((.next-method. (car *next-methods*)) + (.next-methods. (cdr *next-methods*))) + (flet (,@(and call-next-method-p + `((call-next-method (&rest cnm-args) + (if .next-method. + (let ((*next-methods* .next-methods.)) + (if cnm-args + (apply .next-method. cnm-args) + (apply .next-method. ,@(remove '&rest original-args)))) + (error "No next method."))))) + ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.)))))) + (apply #',walked-lambda ,@(remove '&rest original-args)))))))) + +(defun make-parameter-references (specialized-lambda-list required-parameters declarations + generic-function-name specializers) + (flet ((ignoredp (symbol) + (dolist (decl (cdar declarations)) + (when (and (eq (car decl) + 'ignore) + (memq symbol (cdr decl))) + (return t))))) + (gathering ((references (collecting))) + (iterate ((s (list-elements specialized-lambda-list)) + (p (list-elements required-parameters))) + (progn p) + (cond ((not (listp s))) + ((ignoredp (car s)) + (warn "In defmethod ~S ~S, there is a~%~ + redundant ignore declaration for the parameter ~S." generic-function-name + specializers (car s))) + (t (gather (car s) + references))))))) + +(defvar *method-function-plist* (make-hash-table :test #'eq)) + +(defun method-function-plist (method-function) + (gethash method-function *method-function-plist*)) + +(defun |SETF CLOS METHOD-FUNCTION-PLIST| (val method-function) + (setf (gethash method-function *method-function-plist*) + val)) + +(defun method-function-get (method-function key) + (getf (method-function-plist method-function) + key)) + +(defun |SETF CLOS METHOD-FUNCTION-GET| (val method-function key) + (setf (getf (method-function-plist method-function) + key) + val)) + +(defun method-function-isl (method-function) + (method-function-get method-function :isl)) + +(defun method-function-needs-next-methods-p (method-function) + (method-function-get method-function :needs-next-methods-p)) + +(defun load-defmethod (class name quals specls ll doc isl-cache-symbol plist fn) + (when (listp name) + (do-standard-defsetf-1 (cadr name))) + (let ((method-spec (make-method-spec name quals specls))) + (record-definition 'method method-spec) + (setq fn (set-function-name fn method-spec)) + (load-defmethod-internal name quals specls ll doc isl-cache-symbol plist fn class))) + +(defun load-defmethod-internal (gf-spec qualifiers specializers lambda-list doc isl-cache-symbol + plist fn method-class) + (when (listp gf-spec) + (do-standard-defsetf-1 (cadr gf-spec))) + (when plist + (setq plist (copy-list plist)) + ; Do this to keep from affecting the + ; plist that is about to be dumped when + ; we are compiling. + (let ((uisl (getf plist :isl)) + (isl nil)) + (when uisl + (setq isl (intern-slot-name-lists uisl)) + (setf (getf plist :isl) + isl)) + (when isl-cache-symbol + (setf (getf plist :isl-cache-symbol) + isl-cache-symbol) + (set isl-cache-symbol isl))) + (setf (method-function-plist fn) + plist)) + (let ((method (add-named-method gf-spec qualifiers specializers lambda-list fn :documentation + doc :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers) + ,(load-truename))))) + (unless (or (eq method-class 'standard-method) + (eq (find-class method-class nil) + (class-of method))) + (format *error-output* "At the time the method with qualifiers ~:~S and~%~ + specializers ~:S on the generic function ~S~%~ + was compiled, the method-class for that generic function was~%~ + ~S. But, the method class is now ~S, this~%~ + may mean that this method was compiled improperly." qualifiers specializers gf-spec + method-class (class-name (class-of method)))) + method)) + +(defun make-method-spec (gf-spec qualifiers unparsed-specializers) + `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) + + ; Early generic-function support + + + +;;; + + +(defvar *early-generic-functions* nil) + +(defun ensure-generic-function (function-specifier &rest all-keys &key environment &allow-other-keys) + (declare (ignore environment)) + (let ((existing (and (gboundp function-specifier) + (gdefinition function-specifier)))) + (if (and existing (eq *boot-state* 'complete) + (null (generic-function-p existing))) + (generic-clobbers-function function-specifier) + (apply #'ensure-generic-function-using-class existing function-specifier all-keys)))) + +(defun generic-clobbers-function (function-specifier) + (error "~S already names an ordinary function or a macro,~%~ + you may want to replace it with a generic function, but doing so~%~ + will require that you decide what to do with the existing function~%~ + definition.~%~ + The CLOS-specific function MAKE-SPECIALIZABLE may be useful to you." + function-specifier)) + + +;;; This is the early definition of ensure-generic-function-using-class. The static-slots field of +;;; the funcallable instances used as early generic functions is used to store the early methods and +;;; early discriminator code for the early generic function. The static slots field of the fins +;;; contains a list whose: CAR - a list of the early methods on this early gf CADR - the +;;; early discriminator code for this method + + +(defun ensure-generic-function-using-class (existing spec &rest keys) + (declare (ignore keys)) + (if* existing existing (pushnew spec *early-generic-functions* :test #'equal) + (let ((fin (allocate-funcallable-instance-1))) + (setf (gdefinition spec) + fin) + (setf (fsc-instance-slots fin) + (list nil nil)) + fin))) + +(defun early-gf-p (x) + (and (fsc-instance-p x) + (listp (fsc-instance-slots x)))) + +(defmacro early-gf-methods (early-gf) + ; These are macros so that + `(car (fsc-instance-slots ,early-gf))) + + ; they can be setf'd. + + +(defmacro early-gf-discriminator-code (early-gf) + ; + `(cadr (fsc-instance-slots ,early-gf))) + + ; + + +(defmacro real-ensure-gf-internal (gf-class all-keys env) + `(progn (cond ((symbolp ,gf-class) + (setq ,gf-class (find-class ,gf-class t ,env))) + ((classp ,gf-class)) + (t (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ + class nor a symbol that names a class." ,gf-class))) + (remf ,all-keys :generic-function-class) + (remf ,all-keys :environment) + (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) + (unless (eq combin '.shes-not-there.) + (setf (getf ,all-keys :method-combination) + (find-method-combination (class-prototype ,gf-class) + (car combin) + (cdr combin))))))) + +(defun real-ensure-gf-using-class--generic-function (existing function-specifier &rest all-keys &key + environment (generic-function-class + 'standard-generic-function + gf-class-p) + &allow-other-keys) + (declare (ignore function-specifier)) + (real-ensure-gf-internal generic-function-class all-keys environment) + (unless (or (null gf-class-p) + (eq (class-of existing) + generic-function-class)) + (change-class existing generic-function-class)) + (apply #'reinitialize-instance existing all-keys)) + +(defun real-ensure-gf-using-class--null (existing function-specifier &rest all-keys &key environment + (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (ignore existing)) + (real-ensure-gf-internal generic-function-class all-keys environment) + (setf (gdefinition function-specifier) + (apply #'make-instance generic-function-class :name function-specifier all-keys))) + +(defun early-make-a-method (class qualifiers arglist specializers function doc &optional slot-name) + (let ((parsed nil) + (unparsed nil)) + + ;; Figure out whether we got class objects or class names as the specializers and set + ;; parsed and unparsed appropriately. If we got class objects, then we can compute + ;; unparsed, but if we got class names we don't try to compute parsed. Note that the use + ;; of not symbolp in this call to every should be read as 'classp' we can't use classp + ;; itself because it doesn't exist yet. + (if (every #'(lambda (s) + (not (symbolp s))) + specializers) + (setq parsed specializers unparsed (mapcar #'(lambda (s) + (if (eq s 't) + 't + (class-name s))) + specializers)) + (setq unparsed specializers parsed nil)) + (list :early-method ; This is an early method dammit! + function + ; Function is here for the benefit of + ; early-lookup-method. + parsed + ; The parsed specializers. This is + ; used by early-method-specializers to + ; cache the parse. Note that this only + ; comes into play when there is more + ; than one early method on an early gf. + (list class ; A list to which real-make-a-method + qualifiers + ; can be applied to make a real method + arglist + ; corresponding to this early one. + unparsed function doc slot-name)))) + +(defun real-make-a-method (class qualifiers lambda-list specializers function doc &optional slot-name + ) + + ;; Hmm what is this use of when buying me?? + (when (some #'(lambda (x) + (and (neq x 't) + (symbolp x))) + specializers) + (setq specializers (parse-specializers specializers))) + (make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers + specializers :function function :documentation doc :slot-name slot-name + :allow-other-keys t)) + +(defun early-method-function (early-method) + (cadr early-method)) + + +;;; Fetch the specializers of an early method. This is basically just a simple accessor except that +;;; when the second argument is t, this converts the specializers from symbols into class objects. +;;; The class objects are cached in the early method, this makes bootstrapping faster because the +;;; class objects only have to be computed once. NOTE: the second argument should only be passed as +;;; T by early-lookup-method. this is to implement the rule that only when there is more than one +;;; early method on a generic function is the conversion from class names to class objects done. the +;;; corresponds to the fact that we are only allowed to have one method on any generic function up +;;; until the time classes exist. + + +(defun early-method-specializers (early-method &optional objectsp) + (if (and (listp early-method) + (eq (car early-method) + :early-method)) + (cond ((eq objectsp 't) + (or (caddr early-method) + (setf (caddr early-method) + (mapcar #'find-class (cadddr (cadddr early-method)))))) + (t (cadddr (cadddr early-method)))) + (error "~S is not an early-method." early-method))) + +(defun early-method-qualifiers (early-method) + (cadr (cadddr early-method))) + +(defun early-add-named-method (generic-function-name qualifiers specializers arglist function &rest + options) + (declare (ignore options)) + (let* ((gf (ensure-generic-function generic-function-name)) + (existing (dolist (m (early-gf-methods gf)) + (when (and (equal (early-method-specializers m) + specializers) + (equal (early-method-qualifiers m) + qualifiers)) + (return m)))) + (new (make-a-method 'standard-method qualifiers arglist specializers function nil))) + (when existing (remove-method gf existing)) + (add-method gf new))) + + +;;; This is the early version of add-method. Later this will become a generic function. See +;;; fix-early-generic-functions which has special knowledge about add-method. + + +(defun add-method (generic-function method) + (when (not (fsc-instance-p generic-function)) + (error "Early add-method didn't get a funcallable instance.")) + (when (not (and (listp method) + (eq (car method) + :early-method))) + (error "Early add-method didn't get an early method.")) + (push method (early-gf-methods generic-function)) + (early-update-discriminator-code generic-function)) + + +;;; This is the early version of remove method. + + +(defun remove-method (generic-function method) + (when (not (fsc-instance-p generic-function)) + (error "Early remove-method didn't get a funcallable instance.")) + (when (not (and (listp method) + (eq (car method) + :early-method))) + (error "Early remove-method didn't get an early method.")) + (setf (early-gf-methods generic-function) + (remove method (early-gf-methods generic-function))) + (early-update-discriminator-code generic-function)) + + +;;; And the early version of get-method. + + +(defun get-method (generic-function qualifiers specializers &optional (errorp t)) + (if (early-gf-p generic-function) + (or (dolist (m (early-gf-methods generic-function)) + (when (and (or (equal (early-method-specializers m nil) + specializers) + (equal (early-method-specializers m 't) + specializers)) + (equal (early-method-qualifiers m) + qualifiers)) + (return m))) + (if errorp + (error "Can't get early method.") + nil)) + (real-get-method generic-function qualifiers specializers errorp))) + +(defun early-update-discriminator-code (generic-function) + (let* ((methods (early-gf-methods generic-function)) + (early-dfun (cond ((null methods) + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (error + "Called an early generic-function that ~ + has no methods?"))) + ((null (cdr methods)) + + ;; If there is only one method, just use that method's function. + ;; This corresponds to the important fact that early + ;; generic-functions with only one method always call that method + ;; when they are called. If there is more than one method, we have + ;; to install a simple little discriminator-code for this generic + ;; function. + (cadr (car methods))) + (t #'(lambda (&rest args) + (early-dfun methods args)))))) + (set-funcallable-instance-function generic-function early-dfun) + (setf (early-gf-discriminator-code generic-function) + early-dfun))) + +(defun early-get-cpl (object) + (bootstrap-get-slot 'std-class ; HMMM? should be CLOS-CLASS + (class-of object) + 'class-precedence-list)) + +(defun early-sort-methods (list args) + (if (null (cdr list)) + list + (sort list #'(lambda (specls-1 specls-2) + (iterate ((s1 (list-elements specls-1)) + (s2 (list-elements specls-2)) + (a (list-elements args))) + (cond ((eq s1 s2)) + ((eq s2 *the-class-t*) + (return t)) + ((eq s1 *the-class-t*) + (return nil)) + (t (return (memq s2 (memq s1 (early-get-cpl a)))))))) + :key + #'(lambda (em) + (early-method-specializers em t))))) + +(defun early-dfun (methods args) + (let ((primary nil) + (before nil) + (after nil) + (around nil)) + (dolist (method methods) + (let* ((specializers (early-method-specializers method t)) + (qualifiers (early-method-qualifiers method)) + (args args) + (specs specializers)) + (when (loop (when (or (null args) + (null specs)) + + + ;; If we are out of specs, then we must be in the optional, rest or + ;; keywords arguments. This method is applicable to these + ;; arguments. Return T. + (return t)) + (let ((arg (pop args)) + (spec (pop specs))) + (unless (or (eq spec *the-class-t*) + (memq spec (early-get-cpl arg))) + (return nil)))) + (cond ((null qualifiers) + (push method primary)) + ((equal qualifiers '(:before)) + (push method before)) + ((equal qualifiers '(:after)) + (push method after)) + ((equal qualifiers '(:around)) + (push method around)) + (t (error "Unrecognized qualifer in early method.")))))) + (setq primary (early-sort-methods primary args) + before + (early-sort-methods before args) + after + (early-sort-methods after args) + around + (early-sort-methods around args)) + (flet ((do-main-combined-method (arguments) + (dolist (m before) + (apply (cadr m) + arguments)) + (multiple-value-prog1 (let ((*next-methods* (mapcar #'car (cdr primary)))) + (apply (cadar primary) + arguments)) + (dolist (m after) + (apply (cadr m) + arguments))))) + (if (null around) + (do-main-combined-method args) + (let ((*next-methods* (append (mapcar #'cadr (cdr around)) + #'do-main-combined-method))) + (apply (caar around) + args)))))) + +(defun + fix-early-generic-functions + (&optional noisyp) + (allocate-instance (find-class 'standard-generic-function)) + ; Be sure this class has an instance. + (let* ((class (find-class 'standard-generic-function)) + (wrapper (class-wrapper class)) + (n-static-slots (class-no-of-instance-slots class)) + (default-initargs (default-initargs class nil)) + (*invalidate-discriminating-function-force-p* t)) + (flet ((fix-structure (gf) + (let ((static-slots (%allocate-static-slot-storage--class n-static-slots))) + (setf (fsc-instance-wrapper gf) + wrapper + (fsc-instance-slots gf) + static-slots)))) + (dolist (early-gf-spec *early-generic-functions*) + (when noisyp (format t "~&~S..." early-gf-spec)) + (let* ((early-gf (gdefinition early-gf-spec)) + (early-static-slots (fsc-instance-slots early-gf)) + (early-discriminator-code nil) + (early-methods nil) + (methods nil) + (aborted t)) + (flet ((trampoline (&rest args) + (apply early-discriminator-code args))) + (if (not (listp early-static-slots)) + (when noisyp (format t "already fixed?")) + (unwind-protect + (progn (setq early-discriminator-code ( + early-gf-discriminator-code + early-gf)) + (setq early-methods (early-gf-methods early-gf)) + (setf (gdefinition early-gf-spec) + #'trampoline) + (when noisyp (format t "trampoline...")) + (fix-structure early-gf) + (when noisyp (format t "fixed...")) + (apply #'initialize-instance early-gf :name early-gf-spec + default-initargs) + (dolist (early-method early-methods) + (destructuring-bind (class quals lambda-list specs fn + doc slot-name) + (cadddr early-method) + (setq specs (early-method-specializers + early-method t)) + (let ((method (real-make-a-method class quals + lambda-list specs fn doc + slot-name))) + (real-add-method early-gf method) + (push method methods) + (when noisyp (format t "m"))))) + (setf (slot-value early-gf 'name) + early-gf-spec) + (fixup-magic-generic-function early-gf-spec early-methods + early-gf (reverse methods)) + (setq aborted nil)) + (setf (gdefinition early-gf-spec) + early-gf) + (when noisyp (format t ".")) + (when aborted + (setf (fsc-instance-slots early-gf) + early-static-slots))))))) + (dolist (fns *early-functions*) + (setf (symbol-function (car fns)) + (symbol-function (caddr fns)))) + (dolist (fixup *generic-function-fixups*) + (let ((fspec (car fixup)) + (methods (cdr fixup)) + (gf (make-instance 'standard-generic-function))) + (set-function-name gf fspec) + (setf (generic-function-name gf) + fspec) + (dolist (method methods) + (destructuring-bind (lambda-list specializers method-fn-name) + method + (let* ((fn (if method-fn-name + (symbol-function method-fn-name) + (symbol-function fspec))) + (method (make-a-method 'standard-method nil lambda-list + specializers fn nil))) + (real-add-method gf method)))) + (setf (gdefinition fspec) + gf)))))) + + +;;; parse-defmethod is used by defmethod to parse the &rest argument into the 'real' arguments. +;;; This is where the syntax of defmethod is really implemented. + + +(defun parse-defmethod (cdr-of-form) + (declare (values name qualifiers specialized-lambda-list body)) + (let ((name (pop cdr-of-form)) + (qualifiers nil) + (spec-ll nil)) + (loop (if (and (car cdr-of-form) + (atom (car cdr-of-form))) + (push (pop cdr-of-form) + qualifiers) + (return (setq qualifiers (nreverse qualifiers))))) + (setq spec-ll (pop cdr-of-form)) + (values name qualifiers spec-ll cdr-of-form))) + +(defun parse-specializers (specializers) + (flet ((parse (spec) + (cond ((symbolp spec) + (or (find-class spec nil) + (error + "~S used as a specializer,~%~ + but is not the name of a class." spec))) + ((and (listp spec) + (eq (car spec) + 'eql) + (null (cddr spec))) + (make-instance 'eql-specializer :object (cadr spec)) + ; *EQL* spec + ) + (t (error "~S is not a legal specializer." spec))))) + (mapcar #'parse specializers))) + +(defun unparse-specializers (specializers-or-method) + (if (listp specializers-or-method) + (flet ((unparse (spec) + (cond ((classp spec) + (or (class-name spec) + spec)) + ((eql-specializer-p spec) + ; *EQL* + (eql-specializer-object spec) + ; (and (listp spec) (eq (car spec) + ; 'eql)) spec + ) + (t (error "~S is not a legal specializer." spec))))) + (mapcar #'unparse specializers-or-method)) + (unparse-specializers (method-specializers specializers-or-method)))) + +(defun parse-method-or-spec (spec &optional (errorp t)) + (declare (values generic-function method method-name)) + (let (gf method name temp) + (if (method-p spec) + (setq method spec gf (method-generic-function method) + temp + (and gf (generic-function-name gf)) + name + (if temp + (intern-function-name (make-method-spec temp (method-qualifiers method) + (unparse-specializers (method-specializers + method)))) + (make-symbol (format nil "~S" method)))) + (multiple-value-bind (gf-spec quals specls) + (parse-defmethod spec) + (and (setq gf (and (or errorp (gboundp gf-spec)) + (gdefinition gf-spec))) + (let ((nreq (compute-discriminating-function-arglist-info gf))) + (setq specls (append (parse-specializers specls) + (make-list (- nreq (length specls)) + :initial-element *the-class-t*))) + (and (setq method (get-method gf quals specls errorp)) + (setq name (intern-function-name (make-method-spec gf-spec + quals specls)))))))) + (values gf method name))) + +(defun specialized-lambda-list-parameters (specialized-lambda-list) + (multiple-value-bind (parameters ignore1 ignore2) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2)) + parameters)) + +(defun specialized-lambda-list-lambda-list (specialized-lambda-list) + (multiple-value-bind (ignore1 lambda-list ignore2) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2)) + lambda-list)) + +(defun specialized-lambda-list-specializers (specialized-lambda-list) + (multiple-value-bind (ignore1 ignore2 specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2)) + specializers)) + +(defun specialized-lambda-list-required-parameters (specialized-lambda-list) + (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2 ignore3)) + required-parameters)) + +(defun parse-specialized-lambda-list (arglist &optional post-keyword) + (declare (values parameters lambda-list specializers required-parameters)) + (let ((arg (car arglist))) + (cond ((null arglist) + (values nil nil nil nil)) + ((eq arg '&aux) + (values nil arglist nil)) + ((memq arg lambda-list-keywords) + (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) + + ;; Warn about non-standard lambda-list-keywords, but then go on to treat them + ;; like a standard lambda-list-keyword what with the warning its probably ok. + (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ + Assuming that the symbols following it are parameters,~%~ + and not allowing any parameter specializers to follow~%~ + to follow it." arg)) + + ;; When we are at a lambda-list-keyword, the parameters don't include the + ;; lambda-list-keyword; the lambda-list does include the lambda-list-keyword; and + ;; no specializers are allowed to follow the lambda-list-keywords (at least for + ;; now). + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) + t) + (values parameters (cons arg lambda-list) + nil nil))) + (post-keyword + + ;; After a lambda-list-keyword there can be no specializers. + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) + t) + (values (cons (if (listp arg) + (car arg) + arg) + parameters) + (cons arg lambda-list) + nil nil))) + (t (multiple-value-bind (parameters lambda-list specializers required) + (parse-specialized-lambda-list (cdr arglist)) + (values (cons (if (listp arg) + (car arg) + arg) + parameters) + (cons (if (listp arg) + (car arg) + arg) + lambda-list) + (cons (if (listp arg) + (cadr arg) + 't) + specializers) + (cons (if (listp arg) + (car arg) + arg) + required))))))) + +(eval-when (load eval) + (setq *boot-state* 'early)) + +(defmacro with-slots (slots instance &body body &environment env) + (let ((gensym (gensym)) + (specs (mapcar #'(lambda (ss) + (if (consp ss) + (list (car ss) + (variable-lexical-p (car ss) + env) + (cadr ss)) + (list ss (variable-lexical-p ss env) + ss))) + slots))) + (expand-with-slots specs body env gensym instance + #'(lambda (s) + `(slot-value ,gensym ',s))))) + +(defmacro with-accessors (slot-accessor-pairs instance &body body &environment env) + (let ((gensym (gensym)) + (specs (mapcar #'(lambda (ss) + (list (car ss) + (variable-lexical-p (car ss) + env) + (cadr ss))) + slot-accessor-pairs))) + (expand-with-slots specs body env gensym instance #'(lambda (a) + `(,a ,gensym))))) + +(defun expand-with-slots (specs body env gensym instance translate-fn) + `(let ((,gensym ,instance)) + ,@(and (symbolp instance) + `((declare (variable-rebinding ,gensym ,instance)))) + ,gensym + ,@(cdr (walk-form `(progn ,@body) + env + #'(lambda (f c e) + (expand-with-slots-internal specs f c translate-fn e)))))) + +(defun expand-with-slots-internal (specs form context translate-fn env) + (let ((entry nil)) + (cond ((not (eq context :eval)) + form) + ((symbolp form) + (if (and (setq entry (assoc form specs)) + (eq (cadr entry) + (variable-lexical-p form env))) + (funcall translate-fn (caddr entry)) + form)) + ((not (listp form)) + form) + ((member (car form) + '(setq setf)) + + ;; Have to be careful. We must only convert the form to a SETF form when we + ;; convert one of the 'logical' variables to a form Otherwise we will get looping + ;; in implementations where setf is a macro which expands into setq. + (let ((kind (car form))) + (labels ((scan-setf (tail) + (if (null tail) + nil + (walker::relist* tail + (if (and (setq entry (assoc (car tail) + specs)) + (eq (cadr entry) + (variable-lexical-p (car tail) + env))) + (progn (setq kind 'setf) + (funcall translate-fn (caddr entry))) + (car tail)) + (cadr tail) + (scan-setf (cddr tail)))))) + (let (new-tail) + (setq new-tail (scan-setf (cdr form))) + (walker::recons form kind new-tail))))) + ((eq (car form) + 'multiple-value-setq) + (let* ((vars (cadr form)) + (gensyms (mapcar #'(lambda (i) + (declare (ignore i)) + (gensym)) + vars))) + `(multiple-value-bind ,gensyms ,(caddr form) + . ,(reverse (mapcar #'(lambda (v g) + `(setf ,v ,g)) + vars gensyms))))) + (t form)))) diff --git a/clos/3.5/braid.dfasl b/clos/3.5/braid.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..2f7b7cc257a8625c5ba4c3a2696066bdbd5da732 GIT binary patch literal 14543 zcmd5jZEzdcad!uPf#L@UL6ihB5=2v!%m@@seT0!^8b|O*fcQ8X00mOA0)rIfg9H%_ zK}q$*mPpHrl?fsXl&Sw&bz7nPYRdL&;fN zDtT;nDrP$baNEZQgPy1MjHP0;ss8BfvFQ`B#FWw>^h^u}+NBf;#IoR(U3j_e(KRFwXAM8%VQ!@|tHU@Q!r)Fc(x!6IQFFAcM`ovb-E}J+r z8&B9C`0$5&x7vDpc0cf;-8*}`8;8W8mvyC3V`w%`HFnqrV^guClhFCzp5C6VP<8i? zox68#?{2*Fa`pwT;c*WB8S!J{vT4%;wz=etJrO$|OW-h%A|iV}T{kr5cZS@uKYM|n z=WDXhrR&{(`>5#jh{F=kXBX2|IHGJOo30uQN&$|$1h7^~40tE(POlgY+6Sc}x8F@X zkc!A(;5R!Sp&pdF(SS{kXI!QvW*qhSHE{-PV{O;n83wylqgv1N9Ix`wLHwVtXRZ20 zpJdnw{jHV)0XblXTov?Vun{uN!3p1h?6nuhCe%S2O_Fm^>oL|$2%> zCxfe6Lu=w55^9~r{i<+Zz`|C@d9+B3M;aSU8~K5?Da~{klpQfNdb3A^gE%y z*%x?^gBEn0zAhIf$~EQs-W$qIPsX#5>*Q}byaaB$yozORxi60RI^>0d4wCe z@4GwrDwy~hb%okibFaCr-lm#6VcIM>ZNafoDNvgCplWOe)cW$yf*gorUhFjVI4}%E zIPELTiEyF-BLJqQ9OE4Is@U^O>V2PvIqY;CAvsa(G?z++Ff~>)@lo$9pJ1JI2sRLf zmVo4w_e%D`u~9FqR7eV1)fU4lzzEVKCY*c#h3aW11Z1CG@(<#IZ8bm_hV-+2jjbuo zt^2wH6RzAE`J5-WZiFY;Ezd=-uk$8O^P@LLgzLGVkbqlp^HqgKucrq1LNm3vKgI%5 zL7aJK^~2DcYH@VbJF!K*&!V=}sWt(mz8SzZ0H!WoQrn?NPs3op?6`_cuH0~a&YfH5 zVy)kRMfSiVdvK9m!qwbQuDXawx#|AgNN$~*k=-1*=<#;mc*d((_g{Al*K$9(R@$F# z8VB`yUqPN8;vZ$B^NzF$Zzz$byg%b#$Zg~y=aZWVxAYP%l#goW{lXi$AEB82)d+}x zdtI6M8(@*^a1g56j7eH;ol#pOYVST6Yi&T-R0kO^k~d> zGT3dig%r>RQ_<2(-GC7x;n~l!gi%oL!aBOPMmU<#J7dvV@ zn2e>6&ynfm37Z1Hxuk6h&Yfd((APtUfHHpko;|{Dr$F1N8)5Y)l&cO{RCmU`kQ?Ur z(d6%^FUX=d<6X#Yl_02n>n~0&ex-sN{5uUN!W-jcfqS7sdg~5)qFWNyB3!_KASNGQxmjP?&j5Qp{RAC@f zpkhX{FBse+JLZ-aAIaTc$Odxj3)x_9B|C{7B#dOz(e5hRbs`nfu2Vw>K|NqFs8i|) zZ{P$?^o646mv)-LsW$H*36g_kNp1thQ!hEipkyBs-QKDWK+;BC3zB6lPL679!g6sr z(Wuk#wDw?VJd{m0fTlsq?ojgB^uey|1%o=PepHqeNsrY4+KQ_AnJ`8I9d#6 z!-KTnuEH_KaT6}uXko_+ELnuSdxEgn3A?`%>(O*GVGmSdeYXhykxID#4IeSZqn2e% z`S3u*oL3^2ylh^S%}>9^eT|P;7_v1lYq>Rfxs~buMR)GuV&0eAUd;P*n~Qm{T&M#P zYh@2)Ys3n?;!Cf}R=JgyGY`2n8uO8yt(f=bEDC|;H6?j?lSA@CMY8~Xf9;M7#$bUl zn4!OmvSmRr@ey-z2wDz?pyi+gTCS~_TTd-*j@Y1cRFhS2=OZ0?xm}2K@{uihxl@RA z@sX{0xl7<9-38J}k9%oxB)3uS@hx4Dn{sR99{FyxcS8%IEBID-Eyh@_hv=`)P1L`hXRF*NcTiK*c1eQezQ_)_7gwxRZj+l7+Rzc0^H#Y- zHpN*Hrnd(GYhYEo zA$tfZIsns17Sjq!rF3*_o?8yG_DjO#`P@KK;#UpnJOr&9_B<$z9&f=!Bq z33U*Y{VW+_$;R^9JqASqYZtR3M$)RWMT@B`3?^+YBH z0^$UM{tiGjUdcZka$)i7z|y*Dlj!xz==Ol6h6jODvKNjqBs#CQVlqkAxbO%nS+Jdk z5N3yh0gQ3XcOq-IKO_bGSloccAvxd^32TMo3eDq2PZmh{pF`^n)IV)OXq-HDsvf;` zT_^a@kdf)z3*i&w$E#`^CeNx4OrBCdj7dthVG>6M;aqwdOT#q zRkc+%)1yu!6&?`l-G1!89W6h5a3UCze0C9pDx~Wc_Y3tD&~yK!;&%Z*Ux2EO*f^dP z+WCU;ORD)4Q9XN{B}dd#2UxYBdP-ushZ$<8dTKKRY-E7d>M0`w7$})v4J-|hLsPY3 zaQ(p{Vj}XGI)jM4hzLmHU=blRgail*Brx)Rf(mbeMc%B*on7)u7_9;}!d`TE3nGC4 zFEzf1*la9}8-@?0NLRe&M{XTpP)Z;AuEf#9;8? z-#GP2Lz%mv3vB3plx$HNAg2iotN_?`&!>%#j)nrRF~6r*ppJfiJ9O+p7Stf6%+7At zZBDUT<1BIAW}YG)PEcs91#X;X(`D0^K^asmilt5kf?L3=-GzWg4Z~OMggL7h2Whvs zWU#4v0MN*E7VaQ|wd1NYbqA)d#+f0D(K{9`S}pl8Yy!TWA3|bIJ+={;lsqQYSPSLW z;%b#KRgL`SYkoN^^5TdYPjsCIluAc2*v!C`*MxX52o=RzK{;$9GiDjI0x(oj z9&W7!m|vtVFl+|dpI3%0TG2v9lJ{Z_@ZFyR8E?=Wn1*b+niK>$GI-u)(=DYCxIIV* zQ#RdLP+=H44I+)E(#8g;vIH;;v(UCBn*|(|0u2U9p%qkrkgnFim5~*Q>MsXXgA*Q- z1zbf=-3|$8B>c`d;rBm5vX)h1YW1gpx>rk#;zvMH4Pn$^h?Tz$Wg|6*2PuQ08V5Z@ z17eUbV=Wp9D?blqi(f_yt#AO5o@eJAcN)-5+JKqJ1L6n(mrtN-+z0ToNmGpj09sj? z$70x80w!I6S;aK_D4Z_RpoHcS8xHQc8n$$*v7RREJSb7hywXg`+c>4Qut8c#a6kb# zL^4+~!dnM+2aN*cM9_30IJzYd7gm$Sb5^Kc;5!ReCawoE<^F-PKP&;hUJ3Y%O28|X zfKTZGAJZ3Rq061cnDJ-brhA2qe+uJ(=rmmENWrQym0pcv9^~0PoP{0}|F@^~%>?uX zHx>Swk?q!F9?)aj^%yfN;PsNu;?~*BIxk<-Q{2VhO;6oRAN}^~=U$qwq;Ei3;F`Vz zf>5g|jN11}VQ{tB(lgZFw-S`RwU3fF2PpYY7bSmhrR2Mna?Q%`B9rtVNUlGs$;P`+ zQj<&ceK+-fiQv1;5Y(DsBB&LZ2>uuA024tC!$eTSFcH)+OazxMsVAYs9~2AsEVO6f zUTwfh`+eD6%R8KU60W24v0Zj96cl(tA%e!2?4!J;T*R6AQ||3)H(|Im{|mxyfD9iZ zVHYhNbLl4nC5Jv(j7S}H{TdBU@aRcP(WhWp77w&PQrz#*Kc#|JSJpz6m#t-Er@~Uk z`Lr^xJP&s5R9zmv5T+E=DF{)XFjT>!Y$W4f!ov#Uu4UnCc0^%_fYwAX+-13|u%iAv z$JI8psi#_~(mdO53+Qt54-x3wnC(%mm~0_8ieC-=Xeu6z;40&71LD!lV|E8SN0-1& zqmU>dxu2^^O#YF$q8G<~56E?19INw}P^aJ}Akht?KZn`RBZ?W1K`j3%p`OF+SwMla z$ZmBJfM;|Opc)f^Z$NzEz8$^SGJt9vE$~3c+f%5I1=YAiwQi%<&bLyMDW1HvA^8?) zlivkfvK9|rxK)Qa#w#8;P|IBp?INA&AXaUIPO%BP1G^RvY{o!$UTgN80TJw=p3yU- z1CVdSP7-(S4rO(K|0VzpgHilTCB=6t0pF;s^3_U;FI7@}x{~6Yo`O#QLN90an25gK zUOmRC$B?$${8>)~%wAoGBSh{J0N z8qasY1E<08|haZpwS8u?X`eASTVq zvWaofN@iA4WHXDVnlYLxn>@;h-y=6!Wi#`Q$&-J9Gt|R$nY$`y31g5e;1;AoJwa3a zfqHQ3S%8rY@?Rm8dj~&1pzLYPz6HG2p@T!20q7MLz%naxXsNg zc%|jI#vm^qc7K!OK$@S9&nquFAV|z{w}snn^U6fVZDP&t%Z!viZDMR;z00~F46Dt3 z(2JGJ))u>C*aCqYlT-GMy1f#HN$IhOg;;IF&NpD_xNtsze=la!A8^t`g@ZAOT^x!s_Y3z&PHTpqa-oXZUxr3#P z;ih?IA6%uZDwIw0%KnV!bl42=%*g35c+)r&3=Nob(9(ST(Tw*DYx(klyKvmU=qcj} zkmy1nvl?5Vb2q=`XGd)c^#ys}8W!?!HU*yGmoO5@mkE8v%{n19SSz*=9e z{t0c%?%I~}9ZoNtF2SuxEnD7E)U#dgB@Nh2!b^%=t zt;Zx)cP$#_?~3RI*b?> zr9yyGtrtwbknE%9Cm2!UULU1{lQ|&Tm(JrULFZEt4LdvuNgpL1htL|C0E(iZD?@n; z*T`7vC@K2~q=x;87iVhATpsQEDWoQ}WD5H7Mm^Pkj{>GRrj<#jOhTi$Ex%0q|6+qq(o>-^X~?hHma z*VDYg(P0n3BP)2f8ggNQ-O<9kDkF<{oMBgEXV_ii8Pu1$dn9;0Lj&Ga%NTRj?rfUx z-w7WZ7C{|wdMXC*qlJ?}2xkiS?cqeWGR5vOkC=~Ph=Thw;$S*I(5{6%@2_a!%^BYSDKRCSfg@hq`HGb{10^Wpf+Vbwpc2?9a1FZ$~ z^ofOwy$8kxUAl@bn${r$zGM*AKm z=u{-cvU318$zA_ef%#1QPU^x~)dm=cF`i1;r=n9zY~G|EssTt#5Ud(dE~Th3Sjbdk zqRI|WC}9wWmp}l&m=F}*0kz)nwQA++Li8$ij7rxQqU>ojm98&Dua|H)7NR#wrJD=U zn}w2*GPf3@w+fKz_!|q+HwvX%d_jFW3LhQBgb;Y-wF4Z{$6%H@dMMQjfFoBT_#`S( zbp>B!nG=R9_%z3y5Uxbl=MTd}sKb$V_;tXqQ>(f~OS`mmE4<6;hF?$K5$PcVHk0d@ zdm_E?riY3z9hQ5)S#)jA!{f4Ba!=8}!G~1Ek~PwrhX+%)IfC96peV12bm8+Kc$2jr z`T}o)+OI^~W!q09o%kxN>+lt5S?-cMu0*!TTbDAq!NYRbjv+ZdrCGtL{iK!g{AR6^d93~ zfX7|M0k-|7;r^c+7sNsfQq8OIB&t=mzMco)0D-io@)}JQjWAMJE9){+p`6siNMU)G zlN!oNy+jIvQATNj_K%bk`lz^+an1Xv3QW?nDu>If_*pkCL4T~>io zuIhw8?t!qQ7Bpq7SqQI@npuHg?gHiM2;?b3%cHr`(upr%!rC);U=*xJ<$;%%O{075 z>>-#PUz<}b#&CqVWRd3KQkMDc2o-)@gbG(nSvm`NBA6^f`FEg|RdB-l#K43dT62m{ zc$DIE2SM@I5!u-d*b+NQFnnv6LNJHnTEmAZ77P(5DDY^r3O}RlMa)u=iEqGcj-VKY z63$T8gxP(V<<4VvBSE)ec4aZk|EiSzIc0l*fM<>h(()Z80ydur<^HEg%l!-|u}kue zh9*k>G19z4G%sTI`=#v5rR>KkYn-E`o*BNi?5Wja2!Y%McKEI6Ba+50N}AhLD>HR2 za$HCDLKR4b!5#FXDRY5MDEqQGGf^d~z?~528Hq*+{1Ok@cG?pU)bux9O@t8cw?^(X2p8?{Vaps`+R+}Fi#+!}~< z?&#dT9q_MRy>>NTy5r7UZ@Y8dZS|ECFAg5}RP6HLUm5-QJ%j!JHG#f8dxQDTPj}{N zrn{+P@Y(*-#@1vwtEZBK$CSfL@!%Kw%k^ZiMGH4;8>5Occ(mU~lNuZt?Dw^1qG^xk z%P8}Aer9h+@6KRY3&*0tbhMG{x#4lo+K{?g8HuUND1+eq=()POIw#viS^D#PjB>BX zqZ$f;7(Av9_E#)lp3uVSRIo9XP7Lo1RW33GJSuWdOFgQQw?wO)Npun~gx=h34w1pzR~2^Zqk#b;7%`zWM}yq4q5{TpEz;DQ$!ZPp zsPukK0T*JR=3qG0n#}SrHOz%Pl+I*jK3k_2;Oc7lOeqG9D!`eu(_!We6-M(8|$wJ&}FH3#3Fhf>b&u2c0Qg(Sd|--RY=t&TH{%r1%eiD zjRvV=O&MODw@J^&Qmxq_V=vv>lFeW-gjfXm@S>_W4jv=kR_-?9+)*l%4Ys5*dKTh8 zD1wK@722-3#fZ;NxGb>Q!;NszVtUr7aJM41XjF`?#1>v_9RkFn6%DCKJ0vwd2pr{R zMn3NXBIY=`c_8Lz^5p%@Dmzra$4j!la%E#WYA)8yO0ZLZ4Zv*E(t&~s1#3a1pm!;T zoy!X~rhy-MbylOSxB)9M(n1?bDNr7cYkEShBS}N+yTaHGu>(o}h5nLEOEj#5cegVa zmTioh@{X8U(L-5=aPz5;$JA4`F?A$1s&}6mYieFJuFK{YQ+h6r#Po&ZA^tXGW2)SbUdbRp+y-BEgH}HokqaE7trnZ7Cna9?Lly$4Of0o2=*$#r0%SM>6ui{y@m#-oJQsVv z#xqW7hQG!Wt5G-26NwXh!^3RFG;o9fXDiT!XD7crk{i_r^v834Ws5S_q$*pL^Ktb; z_qM9>hNvs7=6rc;|CK@y2nGDtccHF^f`s5gB4 zlX&Vd)jTOVDK&2{eU3CuRgHSp-V z$PG7FWACpHX^@}5bDf}))Rek>$L{SrI|5z3fyu-JDrn~{AD2* zNkW;~V^Yf}vQ@J9lC_FmAXa7zr)oM$TLy z$A?)jnidFZ3=qnJ85anzu%!Q(LzzjEzLX|ui}<>gBnzhNp5^^gOWx1e$|d}1$E{}J zPpW1r5d^m(90$>S7V~Z zpjVZJP-$V5sn8hRL^_S_u7co{b-{Budo{o4yok{X>>TZ1pz~r2M}wJoDw_#f!=Y*p z_Sj5D%DHV37Z_!X^hyiBMm-vj5T-qqp$BLtjAm$LB)l%*&!yn|vh6KVr37G?ir$k- zDl)0lqBG7*MmIamJ_#u^tCiNJ0h-bsYyCM{{FbdoFjr=|WS_#nI$goLe3}>3JfqT!^dZ zlJ{{ZmreyIb=yob&+PF+>^VKTVq~Z}nX79b9*QL7o%@d_hnAb^ZB@roRYSE_&VMxJ zf7;A^yC%o&6Wkkbn&T%YJ{99EZ`hV_RjL4;OQ>IkaOGplzb9RU^z~$fFfK1N#OY1&(=*W=p5~HMLY0QZWw4_q3+6 z(Z{8T1|1zdR>WP2f;G(P5&j+J-?2QOgk-V3R!6x@qKkw;nMI`SxMSWlQ|P6?+Y zYgRNTwyS(g6VU*p+|y?A<&&O2%ngUym<3I1$P5j2f@g}taKe4)DvVZ*i z0h;(IWY}2lTocQzfuW^M%K0XBG%?bAzPab(SmK;6gMG0(6hAvY^fRpiGHVMkdltQf z+Jvvh8`@%Gofj#jIZ_CgDp{Lrh}})11=kv%VuQ_#%o)Rb_;FU}$LU)kKuS{$nH221a7(P>SJqd`gUkd) zY!Aobm^yvMloPPrBCD)t8q~s71rLF>Nid7)*>>iw17e@s3=V4ti^cr9vPBT}LQGec z5MyKLM#1|fciH?LBd5th(H80J(y3Y@!l^}E#{?OF#+7a|**H|Vlu9i{s&tQWV25#F z6VG8)5|b>qfKTCgvysbd2s5=7W?;((-jg^UW?_sm$^xkLyFCR`%x5PhqVif)*4J=P zcl)|wQQWkzWA9%06!&%ZJ+!YEPRa-O?b#jZLn#{-517@kQ+4(3@9XG=-SGaw{$-bW zt*iIb9r>=E^$nAVvfj*lo~GeF!%U=VGDWpwmBjTV&bXEjsy45N@+vO}#v`Xp^u_VA zOA3@Fqwy&FWxalE4!-E-mh2p$p)?bY>gaW&@faDUz46pWyhx6Zh1QtjeQD9saMr=0 z0@LT0pj{Dg&xd*@PHohV=GDVJ!wu{F16_x6rxwNXYQq$$e)?1cgV>H*CU!2U$MhIO zyj=15L)t*k;qHsv=1N_CPP*!O%iUSeMR#|6ZdbCZ$Gr}VlCU7WX-dl3#tUdG!RyiA#N_izKmCJ91u5)2I8p)2PhB@?5TAZ!YqIp3X_80hxL z5*LTN;}Zk9KkAO>eN3o{=VCBIy*oVgJuUWb&qcr15IXa&$!{GnIlE+D5ucgibD=3h z-dQ_{8X+!&*G5*?0?dh~vFh^EfaM)#w1P=Bb`M9Omp19|zxUG6Dy^yE;+cCxXU@gq zfVzpHZkhx&sjWkQ6X}^a7LL8^#~)@O2<p1M_8hoj6cE|=ZDcQyN*-HDX!630&_m3b4i0!!o>~pvUtT= zW9E@!{5#ISCKC3k1q8IzhCw)igtg!^w*;+-gk-AnVNi1pFDDq?^i1~Cz{C7V)b?+u zqZ?5gO&euC^91M zA6tkz=2oL@K9BNv6+a#$4`7j=j6^rXXy~GJa+Z`<4lqR+=fh4CD>8%?*>gU3p_%J& zqrWKUI1<^j#D7AELUTI=GJ%Tuih zD@l{XIp&mY{_zx@qi_yN!R^#kH+phnn*)RF_UvPe|ilarN;Fk&j zbGp&E9~nWsT?~WC*CO5u*!wBeyX2ECklg%Tp3q?`j%y9k_)-$yvH^UCl0D1|2PwJJ zN#4)NLsZ(%$n%_A{Nj{e<1f%C`TuS5Ph)NK7p5c;R zl$1l`!=E*l@ySJbm`^Us!>!cB^L8V*eB@*NSWqoF(SIMQMGIvkmX=pva|@--l}E|d z-11RM-onYpC|SqJBa~dg$;TSjrQqTXf8+d+a_uzRK!`c2YYW7Q~?k_pX zQ~nYsX?V|3X|NwJs`@RxlIuXO7^)Qlmy%MV@#6`$wkl7^LG%d`0aa;DhgAR?kw)GC z(TOtb3)bKWW=0i`e7{C5%=!wm#pCc>_OMPA3yy?d2!xfzsuox?O08i@ zg^6wony~@|yEh1FRo)131+OI>A4b^{p2U~t%EQ-8PtVv*XjawGs>dnN!)m$+g>~e~ zg+Bo6EY51Fh(zY-OgkfvAlQE6V76g-`FwD>tCF zl<^&;Gl-!4YwWC1zE*?E+UPxTH<^N|h9(5!8D)gg>dBSp-*+!n*aWf;Fh*H3mD?n6 z%I{);zG3=?Db$Zngi6O?|J~%ih9|w3k19C?C?blpFV`8^zqfNo7Y-qZaIkqa6S!%2 zXJ1FKu<&LHf0)OrO=C10j#-(s*}q1oLRpgafiCN z=Itb1*f{3^EW4T;8!ikKU?%Qh=5q7ku3dAEUuMpe+g=XMuC|qxkS87{{7KJw6A7o5 z&VT~5-E&sEhh}JZS){lo?_!I~&8-p|z6s>eLg9oE6T_k4G&;j;u5&>#&H)W^{bquZCibww{2CnZ7zAtsqAx-IVZVYUb%;qb~dC+@DBCXXdIvi zo17IM^=2tqA`jW#xkBVSYdW$Yvles79!B{M52J{(!j&>{PQLE6yCChp<&?bQBnO@3 zQE7L?DLLRIdz|DpCplFGThEoJF-c{OlU(5>ujPrtvrA2AqMrZDN!A@i+n@<}{*FsI z`Ck|?&znxkUr7nu(-m&>=T7CzPV&pr?vI?3CyZtLC1(=sKFQr957}=X{-m)?NOW3G zLZ`*n_lS_^bUgr6zl|NjW>t1bs9%I?PXX`(2uCY z4?8dI<>V+e*ol{_=%s>bE1Rj9fGsQ*+v6C$=u&&jsXGsqdSsE%d_BKF7iH81N32lE z+cq#BStRGFblfTZ4k!8TZ*p>k8XTvN2t>Q10eR&Seq8vBovR~*$9$5dU(Xn)&+#u)7vimES7%>v`$Jv%zF=2x(6ofoyV_v? zif~8ojeUWgdjcJS{dq)R?(5ve7fSkaUHb#1Z}c79+sRzJ9QPTLXmPN!FVMAnZ@zPP zXD@DpP)Cbq(~)xf%pfVN%(@5n?*Op-`&{5EOU=6deLJVr)m}9OH_tG_k{No3f{A$j zuD)RBZu~sh*|#HS0d)m$4R2p|{Mx*g5h(7s7O*iWLS1|{6m8GGnklu8r$#Ms)4Yjr z9wx(I;1ITS)$pLH`zoochZ2QE~?juBzlbkt;IngE`&5| zB@}GUob@Ja@$*cLJ(aQU-9T;U`kyJJq+>|_j|&i(w8Tew7h!8F7DxAd;}I`4_x!-4 zRN|CR(|J^@pA}XYtfWO{-kB*tECo3*Vy9~`6K;QH;kLA%7psX~GiT!0%$XQAbCYoV zE5`A>sbkLu&A;-hjL!eWzkh!jq;iA5orKUbnFFDete@h=Wva)uL_>M(x1K>yLzkmP1eRuFhw_g)II3s`m22Gmf6Mvb zoGy%)uoo3hH~afcxAt;V`={AXP1ObF0??~i_2cQ%L7z!<{|ARTHmsehWy&-Z24a|H zR!D~G0rV~l+%$w4#0H%VVp-{AeelK^`1ys@QnMgPiD{$=af{Ex;B-tx$3HSJ!u}DD zyRPcY4QUNwEZ9mwKzG>aEtO6pB_^MgOf~vXaTb-vb-Hxcm~?qF@ERMx5tR+Qw=*jA z0_*A#Mxo{5$M71i++bBmFO2q;p`J?+hM$KQ?^64K{zNG6yEM?_hvS)wk@a6Xn)mth z#U{)PRHzn?X^`rrO@>HS*6!WsZCX@e2J7hZZ{cXPQC4ilVOn{!FO#4d*>^cjyBQd?y5mb;OWXn{tz)_j{{QC#Zf zozI!GYT))sb-W8#jiHzB>%`^ePj~LDry&!pW=MMgBMFwLgwJWAHx^mcS#E(y$SB{a z!3LRzuYHY0+wyQK9)}$eWpt0DM2FNsFbu{eAs0zyad9+5^F7+H=+0bjl%f*pkbCpG z29?*v#;yu$><6d>0&@nhZ>Kk#Ejp~}*}QNWyqJ6>yl^vN%9%CgsQxonhc>>XIp8N~ z<}fskU_z7IZ9;Kk7T^#!dy}cGHC}i!Jd??W(JL%mAf$>Ho3yzDRkm}8kR(%?1u!HBHjKnKD(-NZd>W<(91zF} zi4QX41B=s9oXC@h@iqVz>63|4m`-=(ki25a>7tPo&_)JWZVjnf5OBG2#A;x!s4`YTEbs*@e7IL%1Pr392>EDv z&cM?F_w~uHd>&_aOCkpH5Rp^Fq7_%B+R(|!-y@a)ZEP7Xn-#)U-7L*BdWC;qv}gs$ zWa2kd$)pzu7lK=P>o;ga>jpEl1St2m2MsN}(HcQLg2*6YA^*$Y`UrXx)0dl1!TZ+KS?yJ6asa3-oN8&eH&FtX z0SCNC`_*iU;C3$(8q|wh&@8`$;XQi~(!JLGdth z#thGeiR`85V2oXyO;K3R0`6rak_v$*E5{aiysKXhpWbCWD9gA-t`1!& z^9GzIm+i`IhgC%=twhjYGSi65nAUpX9g-((>Xv9#CI}FL0DNG+PGt$r-jo$n(7(Y% z{~AOI_U?bMbKeIc0TVJ{p-oV4MF@JA6_#T_Af4a1o07zMm&JHtQ)b@+baOp)#c6P@ z(9kTT)TMmBS!&%@!Pf&gP-}|f4<3=o-p|p+sCH#ErrzuF^3WZ$oLm#&gCn11CjD?l zvpC5RE|WtPOb$URiI}`$`!ZO;41D5C>q#faf=>qZiNkCx}y%fxO7Fjn2qWg`Xs>oNnc%P zfS;b@C)67%j6@Okks^a*57gC6zIFV|7Ju~Ub*xvT_t6`EnD!TA(QBn!eZ^UorM%JXd$`C`FY2H#GB&hpdnd zgm2JyB8nKP!c1F>3YbX%k%6(RGsMaZysEsPz5@sM>zT1bbb-C_3j*xqrL(+mlNN8r zwRL{iiA~_16$;xZqXzO_Ai5Avxo8?gB|XX|7VR zbR>uHjN3y>JLa=^AonDNUMxPfLLWtbjN&q`8)!b#)Lh3%(zCUyYGVLjQ^9v6NZ!DR zUMY}RpZcLlcpCrn5Z>S=OhrCkR05?ii)*qbLHJWPz9_b433By5&892wqf9AvJ}Biq z1S3whSB>cs_QkH`@mxrQVTawj_r4I)?C4@d6h|8!?=F8#LAj84A(5P^$+jwmBi>X< z5(K=Z<~a>Ls_a`!iNh;Yw9V>?@-lPIS+Bol98;&^D4p9ta zg?#hJs=1bmT-GNXXILUAhgifZbTwPp?btq;;je=&lR1kqXnvF`r0Go*h)v(zAWAMa zDS91ZjBbTZ4iVEZ#K)srChAosxY>zVRvHl}6IROvcJUa|pp^F>6G|GAS-}rO7T{5k zRqf*iINrb?!Pw;AG*99e8Mt;u*iGG{-b+c}xYo^^0>1IXQ?Ph&D=d5tweJI^LB^`_ z&_L+%RMm-OIFk38?~Ql)aSh&EN^oG747182(R;L1b;kkI_c6j0Cq5-0*fK9z_P-() z+R7mvgs9=*E9X-oriQ?0YNg{E8df~bAfTpF61&tl$mkx!e(3cu8{!dow0(3>v;e~DzO3KwF2 zZ1;Mt)d1g{VT9&_cIS{&&H)5>uqH2jQkAALo~m7pj0JwsDwn>b;TNW;RCY}#j82+i>Nm8gfL@QyC_d`0O zPqQ6Ry^V>pHwYH6rrp;FX28VRItGmo&EB(BoDpcxdeP532f|~a?g?5#5DW~DW3t51 zlQ*aWh`uR8h+W#=aZxa2jF&fHj8)DUC+w++wEVP)uLc)gmNjP3%Q?X&28C8}! zp2vBOc^k+d$796$6I@WzI-u(W1U(4m{h88uPZ;D^M z5Ypop&uptoB+rh=doG?E`p*sBXSU)KC=&xcM^JEY11@+n0(or|9Ooc?co#CaC?Ddp zrk@(*k#(el_Gq5xOo{XvM0yCo)ZVijCu=)I!6+-WOOp4#u2(MgDa7e=neh2}7c>`x;{9lStHZua5bpA^b zrSEd%cST;A!x9HvY4c;3Bt9343u6@i&EG3ECDr{RsWg^UZJVlGs$#pPhN-xlBI=mM z4d=SgC*rt@mGdX8mH%gEDi&<`YlL>w9hRYAm=|TCc$E<7rsDNa#VXb-&IkC9wQ6yQ zeF1B-zNL!m{tzEYNxikyC`OS_i30_@?fvyiD%A7VB=j?WI{R6iZOv(DsofxP@yrFB z2a`AtB0}NbQJ&P#ab?xooGnP-_3bhxM3WK=I^L3lQ-0daC%-*c;_sj87w4Y-lp(%UwgO?A11qdnSQvx27)e zg1z=$%00zQ`sND_VY~Wp&Oq1bdAXwc?Ez3^0Z=hM^wjiAbzqiDwU}`8mqcOD>-2NZ z2;FP!j~IDAaw&&+^O7a(zD067A7FjU=@py+Jk>b?IHbvb!}|=0uM{+5(!8ebGqx8G z0)@}7VhQmcMVHKR-1)QUe7@N^s1~&Ovscoh?2STLB|&oITL0U2#K7zOEMpt zoViWp3}f84oGt4<$;3p?$bidt3gSx%@EPTd@ao;tltmJUn9L-Qp0xzhFQy12GOkRP zNS0kiHuPfKeqe2amdwekKXoM8R#myr5*4L|*V)Q#VaA^>O;si7g7#{ByVNun4CFqK zE2_3Adfuvu1##OHA2`M5P5;^@s$O-aArH%AZzI7^HE4L}HUr_F;-m z?)*>D`5LoxM{Gho*)}RWVUwD;e1U74vzDp5Zf1mU<=YYO4NlEurH|Ij4k zE)4yzMm2vj!JKx0f1ebYy+<;lTAMYZTAMYj(D?eKnd}3Pafa8;S1|p5`5M79>lk90 z-ZSp$J>#BU-)t<5zCPJ_|Cqb(lZ{t!*5^jkGwuxI>{)(8kocJFpYmSYLE(7b_%FYI zwr%82q^q`1a^?{Kw%yK;J)+LPWbK|$^X?g{@n|(_7=8zGPZW=5TV2*Tc21PyE8C`X zqTJNyE9@<>#}YSHcpJ`Y{QBv5VC{upvD2|2>g4F~hQ}o_O)t!1)4wQwikE!OHb+iR z`vVa?-5=7H(^(rTwhj`lR)m)$9rO4L%CA(x&z&+KBB@gQ<=@f;MQUwn5V9 zcGgLa#oq8gkEWjY-y6ss!54v^({r?AH^ttlnmF1ubWKz9gwdVn_-oI^(@o9q@yBUu zb=|TdQER=6e=Ygl^VY<3U5q`u)d+ph<>bU}()nzc%ha7yf&WIyDEAREJm0c5$P<)1 zj%fyL0~dyPvD+dHg0Q=>m9f>m%#I10VTV9hvM+G2PY6#|Tv?|(u@_BS+yIz!1ZEKt zZXV_At;;T9%}X?kdtVGS+2!Kd0=*;nV0&B(M}duLk1D*nl|vTTuSQIIf7LYd6o|7U4zr#}El65@hTi=ie(hC$!s55kTiV5*x9o#AWr=c=gJRVwEN6zt;`GL@u(ggTV7s>O z`wYhSKYF9K@5k5k&}aGg$Fkd+nb{e&ecxZqeY_=8F^$@MWSzkqCJn`QC+zlpA&RV& z6AM6;fB8DlJE8*#%> +;;; +;;; For now, understand that as far as most of this code goes, a cache has +;;; two important properties. The first is the number of wrappers used as +;;; keys in each cache line. Throughout this code, this value is always +;;; called NKEYS. The second is whether or not the cache lines of a cache +;;; store a value. Throughout this code, this always called VALUEP. +;;; +;;; Depending on these values, there are three kinds of caches. +;;; +;;; NKEYS = 1, VALUEP = NIL +;;; +;;; In this kind of cache, each line is 1 word long. No cache locking is +;;; needed since all read's in the cache are a single value. Nevertheless +;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will +;;; not get a first probe hit. +;;; +;;; To keep the code simpler, a cache lock count does appear in location 0 +;;; of these caches, that count is incremented whenever data is written to +;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to +;;; do locking when reading the cache. +;;; +;;; +;;; NKEYS = 1, VALUEP = T +;;; +;;; In this kind of cache, each line is 2 words long. Cache locking must +;;; be done to ensure the synchronization of cache reads. Line 0 of the +;;; cache (location 0) is reserved for the cache lock count. Location 1 +;;; of the cache is unused (in effect wasted). +;;; +;;; NKEYS > 1 +;;; +;;; In this kind of cache, the 0 word of the cache holds the lock count. +;;; The 1 word of the cache is line 0. Line 0 of these caches is not +;;; reserved. +;;; +;;; This is done because in this sort of cache, the overhead of doing the +;;; cache probe is high enough that the 1+ required to offset the location +;;; is not a significant cost. In addition, because of the larger line +;;; sizes, the space that would be wasted by reserving line 0 to hold the +;;; lock count is more significant. +;;; + + +;;; +;;; Caches +;;; +;;; A cache is essentially just a vector. The use of the individual `words' +;;; in the vector depends on particular properties of the cache as described +;;; above. +;;; +;;; This defines an abstraction for caches in terms of their most obvious +;;; implementation as simple vectors. But, please notice that part of the +;;; implementation of this abstraction, is the function lap-out-cache-ref. +;;; This means that most port-specific modifications to the implementation +;;; of caches will require corresponding port-specific modifications to the +;;; lap code assembler. +;;; +(defmacro cache-ref (cache location) + `(svref (the simple-vector ,cache) (the fixnum ,location))) + +(defun emit-cache-ref (cache-operand location-operand) + (operand :iref cache-operand location-operand)) + + +(defun cache-size (cache) + (array-dimension (the simple-vector cache) 0)) + +(defun allocate-cache (size) + (make-array size :adjustable nil)) + +(defmacro cache-lock-count (cache) + `(cache-ref ,cache 0)) + +(defun flush-cache-internal (cache) + (without-interrupts + (fill (the simple-vector cache) nil) + (setf (cache-lock-count cache) 0)) + cache) + +(defmacro modify-cache (cache &body body) + `(without-interrupts + (multiple-value-prog1 + (progn ,@body) + (let ((old-count (cache-lock-count ,cache))) + (setf (cache-lock-count ,cache) + (if (= old-count most-positive-fixnum) 1 (1+ old-count))))))) + + + +;;; +;;; Some facilities for allocation and freeing caches as they are needed. +;;; This is done on the assumption that a better port of CLOS will arrange +;;; to cons these all the same static area. Given that, the fact that +;;; CLOS tries to reuse them should be a win. +;;; +(defvar *free-caches* (make-hash-table :size 16)) + +;;; +;;; Return a cache that has had flush-cache-internal called on it. This +;;; returns a cache of exactly the size requested, it won't ever return a +;;; larger cache. +;;; +(defun get-cache (size) + (let ((entry (gethash size *free-caches*))) + (without-interrupts + (cond ((null entry) + (setf (gethash size *free-caches*) (cons 0 nil)) + (get-cache size)) + ((null (cdr entry)) + (incf (car entry)) + (flush-cache-internal (allocate-cache size))) + (t + (let ((cache (cdr entry))) + (setf (cdr entry) (cache-ref cache 0)) + (flush-cache-internal cache))))))) + +(defun free-cache (cache) + (let ((entry (gethash (cache-size cache) *free-caches*))) + (without-interrupts + (if (null entry) + (error "Attempt to free a cache not allocated by GET-CACHE.") + (let ((thread (cdr entry))) + (loop (unless thread (return)) + (when (eq thread cache) (error "Freeing a cache twice.")) + (setq thread (cache-ref thread 0))) + (flush-cache-internal cache) ;Help the GC + (setf (cache-ref cache 0) (cdr entry)) + (setf (cdr entry) cache) + nil))))) + +;;; +;;; This is just for debugging and analysis. It shows the state of the free +;;; cache resource. +;;; +(defun show-free-caches () + (let ((elements ())) + (maphash #'(lambda (s e) (push (list s e) elements)) *free-caches*) + (setq elements (sort elements #'< :key #'car)) + (dolist (e elements) + (let* ((size (car e)) + (entry (cadr e)) + (allocated (car entry)) + (head (cdr entry)) + (free 0)) + (loop (when (null head) (return t)) + (setq head (cache-ref head 0)) + (incf free)) + (format t + "~&There ~4D are caches of size ~4D. (~D free ~3D%)" + allocated + size + free + (floor (* 100 (/ free (float allocated))))))))) + + +;;; +;;; Wrapper cache numbers +;;; + +;;; +;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero +;;; bits wrapper cache numbers will have. +;;; +;;; The value of this constant is the number of wrapper cache numbers which +;;; can be added and still be certain the result will be a fixnum. This is +;;; used by all the code that computes primary cache locations from multiple +;;; wrappers. +;;; +;;; The value of this constant is used to derive the next two which are the +;;; forms of this constant which it is more convenient for the runtime code +;;; to use. +;;; +(eval-when (compile load eval) + +(defconstant wrapper-cache-number-adds-ok 4) + +(defconstant wrapper-cache-number-length + (- (integer-length most-positive-fixnum) + wrapper-cache-number-adds-ok)) + +(defconstant wrapper-cache-number-mask + (1- (expt 2 wrapper-cache-number-length))) + + +(defvar *get-wrapper-cache-number* (make-random-state)) + +(defun get-wrapper-cache-number () + (let ((n 0)) + (loop + (setq n + (logand wrapper-cache-number-mask + (random most-positive-fixnum *get-wrapper-cache-number*))) + (unless (zerop n) (return n))))) + + +(unless (> wrapper-cache-number-length 8) + (error "In this implementation of Common Lisp, fixnums are so small that~@ + wrapper cache numbers end up being only ~D bits long. This does~@ + not actually keep CLOS from running, but it may degrade cache~@ + performance.~@ + You may want to consider changing the value of the constant~@ + WRAPPER-CACHE-NUMBER-ADDS-OK."))) + + +;;; +;;; wrappers themselves +;;; +;;; This caching algorithm requires that wrappers have more than one wrapper +;;; cache number. You should think of these multiple numbers as being in +;;; columns. That is, for a given cache, the same column of wrapper cache +;;; numbers will be used. +;;; +;;; If at some point the cache distribution of a cache gets bad, the cache +;;; can be rehashed by switching to a different column. +;;; +;;; The columns are referred to by field number which is that number which, +;;; when used as a second argument to wrapper-ref, will return that column +;;; of wrapper cache number. +;;; +;;; This code is written to allow flexibility as to how many wrapper cache +;;; numbers will be in each wrapper, and where they will be located. It is +;;; also set up to allow port specific modifications to `pack' the wrapper +;;; cache numbers on machines where the addressing modes make that a good +;;; idea. +;;; +(eval-when (compile load eval) +(defconstant wrapper-layout + '(number + number + number + number + number + number + number + number + state + instance-slots-layout + class-slots + class)) +) + +(eval-when (compile load eval) + +(defun wrapper-field (type) + (position type wrapper-layout)) + +(defun next-wrapper-field (field-number) + (position (nth field-number wrapper-layout) + wrapper-layout + :start (1+ field-number))) + +);eval-when + +(defmacro wrapper-ref (wrapper n) + `(svref ,wrapper ,n)) + +(defun emit-wrapper-ref (wrapper-operand field-operand) + (operand :iref wrapper-operand field-operand)) + + +(defmacro wrapper-state (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'state))) + +(defmacro wrapper-instance-slots-layout (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) + +(defmacro wrapper-class-slots (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) + +(defmacro wrapper-class (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'class))) + + +(defmacro make-wrapper-internal () + `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) + ,@(gathering1 (collecting) + (iterate ((i (interval :from 0)) + (desc (list-elements wrapper-layout))) + (ecase desc + (number + (gather1 `(setf (wrapper-ref wrapper ,i) + (get-wrapper-cache-number)))) + ((state instance-slots-layout class-slots class))))) + (setf (wrapper-state wrapper) 't) + wrapper)) + +(defun make-wrapper (class) + (let ((wrapper (make-wrapper-internal))) + (setf (wrapper-class wrapper) class) + wrapper)) + +;;; +;;; The wrapper cache machinery provides general mechanism for trapping on +;;; the next access to any instance of a given class. This mechanism is +;;; used to implement the updating of instances when the class is redefined +;;; (make-instances-obsolete). The same mechanism is also used to update +;;; generic function caches when there is a change to the supers of a class. +;;; +;;; Basically, a given wrapper can be valid or invalid. If it is invalid, +;;; it means that any attempt to do a wrapper cache lookup using the wrapper +;;; should trap. Also, methods on slot-value-using-class check the wrapper +;;; validity as well. This is done by calling check-wrapper-validity. +;;; + +(defun invalid-wrapper-p (wrapper) + (neq (wrapper-state wrapper) 't)) + +(defvar *previous-nwrappers* (make-hash-table)) + +(defun invalidate-wrapper (owrapper state nwrapper) + (ecase state + ((flush obsolete) + (let ((new-previous ())) + ;; + ;; First off, a previous call to invalidate-wrapper may have recorded + ;; owrapper as an nwrapper to update to. Since owrapper is about to + ;; be invalid, it no longer makes sense to update to it. + ;; + ;; We go back and change the previously invalidated wrappers so that + ;; they will now update directly to nwrapper. This corresponds to a + ;; kind of transitivity of wrapper updates. + ;; + (dolist (previous (gethash owrapper *previous-nwrappers*)) + (when (eq state 'obsolete) + (setf (car previous) 'obsolete)) + (setf (cadr previous) nwrapper) + (push previous new-previous)) + + (iterate ((type (list-elements wrapper-layout)) + (i (interval :from 0))) + (when (eq type 'number) (setf (wrapper-ref owrapper i) 0))) + (push (setf (wrapper-state owrapper) (list state nwrapper)) + new-previous) + + (setf (gethash owrapper *previous-nwrappers*) () + (gethash nwrapper *previous-nwrappers*) new-previous))))) + +(defun check-wrapper-validity (instance) + (let* ((owrapper (wrapper-of instance)) + (state (wrapper-state owrapper))) + (if (eq state 't) + owrapper + (let ((nwrapper + (ecase (car state) + (flush + (flush-cache-trap owrapper (cadr state) instance)) + (obsolete + (obsolete-instance-trap owrapper (cadr state) instance))))) + ;; + ;; This little bit of error checking is superfluous. It only + ;; checks to see whether the person who implemented the trap + ;; handling screwed up. Since that person is hacking internal + ;; CLOS code, and is not a user, this should be needless. Also, + ;; since this directly slows down instance update and generic + ;; function cache refilling, feel free to take it out sometime + ;; soon. + ;; + (cond ((neq nwrapper (wrapper-of instance)) + (error "Wrapper returned from trap not wrapper of instance.")) + ((invalid-wrapper-p nwrapper) + (error "Wrapper returned from trap invalid."))) + nwrapper)))) + + + +(defun compute-line-size (nelements) (expt 2 (ceiling (log nelements 2)))) + +(defun compute-cache-parameters (nkeys valuep nlines-or-cache) + (declare (values cache-mask actual-size line-size nlines)) + (flet ((compute-mask (cache-size line-size) + (logxor (1- cache-size) (1- line-size)))) + (if (= nkeys 1) + (let* ((line-size (if valuep 2 1)) + (cache-size (if (numberp nlines-or-cache) + (* line-size + (expt 2 (ceiling (log nlines-or-cache 2)))) + (cache-size nlines-or-cache)))) + (values (compute-mask cache-size line-size) + cache-size + line-size + (/ cache-size line-size))) + (let* ((line-size (compute-line-size (+ nkeys (if valuep 1 0)))) + (cache-size (if (numberp nlines-or-cache) + (* line-size + (expt 2 (ceiling (log nlines-or-cache 2)))) + (1- (cache-size nlines-or-cache))))) + (values (compute-mask cache-size line-size) + (1+ cache-size) + line-size + (/ cache-size line-size)))))) + + + +;;; +;;; The various implementations of computing a primary cache location from +;;; wrappers. Because some implementations of this must run fast there are +;;; several implementations of the same algorithm. +;;; +;;; The algorithm is: +;;; +;;; SUM over the wrapper cache numbers, +;;; ENSURING that the result is a fixnum +;;; MASK the result against the mask argument. +;;; +;;; + +;;; +;;; COMPUTE-PRIMARY-CACHE-LOCATION +;;; +;;; The basic functional version. This is used by the cache miss code to +;;; compute the primary location of an entry. +;;; +(defun compute-primary-cache-location (field mask wrappers) + (if (not (consp wrappers)) + (logand mask (wrapper-ref wrappers field)) + (let ((location 0)) + (iterate ((wrapper (list-elements wrappers)) + (i (interval :from 0))) + ;; + ;; First add the cache number of this wrapper to location. + ;; + (let ((wrapper-cache-number (wrapper-ref wrapper field))) + (if (zerop wrapper-cache-number) + (return-from compute-primary-cache-location 0) + (setq location (+ location wrapper-cache-number)))) + ;; + ;; Then, if we are working with lots of wrappers, deal with + ;; the wrapper-cache-number-mask stuff. + ;; + (when (and (not (zerop i)) + (zerop (mod i wrapper-cache-number-adds-ok))) + (setq location + (logand location wrapper-cache-number-mask)))) + (1+ (logand mask location))))) + +;;; +;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION +;;; +;;; This version is called on a cache line. It fetches the wrappers from +;;; the cache line and determines the primary location. Various parts of +;;; the cache filling code call this to determine whether it is appropriate +;;; to displace a given cache entry. +;;; +;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol +;;; invalid to suggest to its caller that it would be provident to blow away +;;; the cache line in question. +;;; +(defun compute-primary-cache-location-from-location (field cache location mask nkeys) + (let ((result 0)) + (dotimes (i nkeys) + (let* ((wrapper (cache-ref cache (+ i location))) + (wcn (wrapper-ref wrapper field))) + (setq result (+ result wcn))) + (when (and (not (zerop i)) + (zerop (mod i wrapper-cache-number-adds-ok))) + (setq result (logand result wrapper-cache-number-mask))) + ) + (if (= nkeys 1) + (logand mask result) + (1+ (logand mask result))))) + +(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no) + (with-lap-registers ((mask index)) + (let ((field wrapper-cache-no)) + (flatten-lap + (opcode :move (operand :cvar 'mask) mask) + (opcode :move (operand :cvar 'field) field) + (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) + (opcode :move (operand :ilogand wrapper-cache-no mask) primary))))) + +(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label) + (with-lap-registers ((field index) + (mask index)) + (let ((add-wrapper-cache-numbers + (flatten-lap + (gathering1 (flattening-lap) + (iterate ((wrapper (list-elements wrappers)) + (i (interval :from 1))) + (gather1 + (with-lap-registers ((wrapper-cache-no index)) + (flatten-lap + (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) + (opcode :izerop wrapper-cache-no miss-label) + (opcode :move (operand :i+ primary wrapper-cache-no) primary) + (when (zerop (mod i wrapper-cache-number-adds-ok)) + (opcode :move (operand :ilogand primary mask) primary)))))))))) + (flatten-lap + (opcode :move (operand :constant 0) primary) + (opcode :move (operand :cvar 'field) field) + (opcode :move (operand :cvar 'mask) mask) + add-wrapper-cache-numbers + (opcode :move (operand :ilogand primary mask) primary) + (opcode :move (operand :i1+ primary) primary))))) + + + +;;; +;;; NIL means nothing so far, no actual arg info has NILs +;;; in the metatype +;;; CLASS seen all sorts of metaclasses +;;; (specifically, more than one of the next 4 values) +;;; T means everything so far is the class T +;;; STANDARD-CLASS seen only standard classes +;;; BUILT-IN-CLASS seen only built in classes +;;; STRUCTURE-CLASS seen only structure classes +;;; +(defun raise-metatype (metatype new-specializer) + (let ((standard (find-class 'standard-class)) + (fsc (find-class 'funcallable-standard-class)) +; (structure (find-class 'structure-class)) + (built-in (find-class 'built-in-class))) + (flet ((specializer->metatype (x) + (let ((meta-specializer + (if (and (eq *boot-state* 'complete) + (eql-specializer-p x)) + (class-of (class-of (eql-specializer-object x))) + (class-of x)))) + (cond ((eq x *the-class-t*) t) + ((*subtypep meta-specializer standard) 'standard-instance) + ((*subtypep meta-specializer fsc) 'standard-instance) +; ((*subtypep meta-specializer structure) 'structure-instance) + ((*subtypep meta-specializer built-in) 'built-in-instance) + (t (error "CLOS can not handle the specializer ~S (meta-specializer ~S)." + new-specializer meta-specializer)))))) + ;; + ;; We implement the following table. The notation is + ;; that X and Y are distinct meta specializer names. + ;; + ;; NIL ===> + ;; X X ===> X + ;; X Y ===> CLASS + ;; + (let ((new-metatype (specializer->metatype new-specializer))) + (cond ((null metatype) new-metatype) + ((eq metatype new-metatype) new-metatype) + (t 'class)))))) + + +(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot) + (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper"))) + (with-lap-registers ((arg t)) + (ecase metatype + (standard-instance + (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) + (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) + (flatten-lap + (opcode :move (operand :arg argument) arg) + (opcode :std-instance-p arg get-std-inst-wrapper) ;is it a std wrapper? + (opcode :fsc-instance-p arg get-fsc-inst-wrapper) ;is it a fsc wrapper? + (opcode :go miss-label) + (opcode :label get-fsc-inst-wrapper) + (opcode :move (operand :fsc-wrapper arg) dest) ;get fsc wrapper + (and slot + (opcode :move (operand :fsc-slots arg) slot)) + (opcode :go exit-emit-fetch-wrapper) + (opcode :label get-std-inst-wrapper) + (opcode :move (operand :std-wrapper arg) dest) ;get std wrapper + (and slot + (opcode :move (operand :std-slots arg) slot)) + (opcode :label exit-emit-fetch-wrapper)))) + + (class + (when slot (error "Can't do a slot reg for this metatype.")) + (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) + (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")) + (get-built-in-wrapper (make-symbol "get-built-in-wrapper"))) + (flatten-lap + (opcode :move (operand :arg argument) arg) + (opcode :std-instance-p arg get-std-inst-wrapper) + (opcode :fsc-instance-p arg get-fsc-inst-wrapper) + (opcode :built-in-instance-p arg get-built-in-wrapper) + ;; If the code falls through the checks above, there is a serious problem + (opcode :label get-fsc-inst-wrapper) + (opcode :move (operand :fsc-wrapper arg) dest) + (opcode :go exit-emit-fetch-wrapper) + (opcode :label get-built-in-wrapper) + (opcode :move (operand :built-in-wrapper arg) dest) + (opcode :go exit-emit-fetch-wrapper) + (opcode :label get-std-inst-wrapper) + (opcode :move (operand :std-wrapper arg) dest) + (opcode :label exit-emit-fetch-wrapper)))) + (structure-instance + (when slot (error "Can't do a slot reg for this metatype.")) + (error "Not yet implemented")) + (built-in-instance + (when slot (error "Can't do a slot reg for this metatype.")) + (let ((get-built-in-wrapper (make-symbol "get-built-in-wrapper"))) + (flatten-lap + (opcode :move (operand :arg argument) arg) + (opcode :built-in-instance-p arg get-built-in-wrapper) + (opcode :go miss-label) + (opcode :label get-built-in-wrapper) + (opcode :move (operand :built-in-wrapper arg) dest)))))))) + + +;;; +;;; Some support stuff for getting a hold of symbols that we need when +;;; building the discriminator codes. Its ok for these to be interned +;;; symbols because we don't capture any user code in the scope in which +;;; these symbols are bound. +;;; + +(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) + +(defun dfun-arg-symbol (arg-number) + (or (nth arg-number (the list *dfun-arg-symbols*)) + (intern (format nil ".ARG~A." arg-number) *the-clos-package*))) + +(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) + +(defun slot-vector-symbol (arg-number) + (or (nth arg-number (the list *slot-vector-symbols*)) + (intern (format nil ".SLOTS~A." arg-number) *the-clos-package*))) + +(defun make-dfun-lambda-list (metatypes applyp) + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i))) + (when applyp + (gather1 '&rest) + (gather1 '.dfun-rest-arg.)))) + +(defun make-dlap-lambda-list (metatypes applyp) + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i))) + (when applyp + (gather1 '&rest)))) + +(defun make-dfun-call (metatypes applyp fn-variable) + (let ((required + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i)))))) + (if applyp + `(apply ,fn-variable ,@required .dfun-rest-arg.) + `(funcall ,fn-variable ,@required)))) + + +;;; +;;; Here is where we actually fill, recache and expand caches. +;;; +;;; The function FILL-CACHE is the ONLY external entrypoint into this code. +;;; It returns 4 values: +;;; a wrapper field number +;;; a cache +;;; a mask +;;; an absolute cache size (the size of the actual vector) +;;; +;;; +(defun fill-cache (field cache nkeys valuep limit-fn wrappers value) + (declare (values field cache mask size)) + (fill-cache-internal field cache nkeys valuep limit-fn wrappers value)) + +(defun default-limit-fn (nlines) + (case nlines + ((1 2 4) 1) + ((8 16) 4) + (otherwise 6))) + + +;;; +;;; Its too bad Common Lisp compilers freak out when you have a defun with +;;; a lot of LABELS in it. If I could do that I could make this code much +;;; easier to read and work with. +;;; +;;; Ahh Scheme... +;;; +;;; In the absence of that, the following little macro makes the code that +;;; follows a little bit more reasonable. I would like to add that having +;;; to practically write my own compiler in order to get just this simple +;;; thing is something of a drag. +;;; +(eval-when (compile load eval) + +(proclaim '(special *nkeys* *valuep* *limit-fn*)) + +;;; This patch avoids a bug in the ENVCALL instruction. Lookup of free +;;; variables under ENVCALL always results in nil. In particular, the +;;; compiler generates such code for flet and friends. Therefore, some +;;; macros must be defined at top-level. + +;(defmacro cache () '.cache.) +;(defmacro nkeys () '*nkeys*) +;(defmacro valuep () '*valuep*) +;(defmacro limit-fn () '*limit-fn*) +;(defmacro line-size () '.line-size.) +;(defmacro mask () '.mask.) +;(defmacro size () '.size.) +;(defmacro nlines () '.nlines.) +;(defmacro line-reserved-p (line) +; `(and (= (nkeys) 1) +; (= ,line 0))) +;(defmacro line-location (line) +; `(and (null (line-reserved-p ,line)) +; (if (= (nkeys) 1) +; (* ,line (line-size)) +; (1+ (* ,line (line-size)))))) +;(defmacro location-line (location) +; `(if (= (nkeys) 1) +; (/ ,location (line-size)) +; (/ (1- ,location) (line-size)))) +;end patch + +(defvar *local-cache-functions* + `((cache () .cache.) + (nkeys () *nkeys*) + (valuep () *valuep*) + (limit-fn () *limit-fn*) + (line-size () .line-size.) + (mask () .mask.) + (size () .size.) + (nlines () .nlines.) + ;; + ;; Return T IFF this cache location is reserved. The only time + ;; this is true is for line number 0 of an nkeys=1 cache. + ;; + (line-reserved-p (line) + (and (= (nkeys) 1) + (= line 0))) + ;; + ;; Given a line number, return the cache location. This is the + ;; value that is the second argument to cache-ref. Basically, + ;; this deals with the offset of nkeys>1 caches and multiplies + ;; by line size. This returns nil if the line is reserved. + ;; + (line-location (line) + (and (null (line-reserved-p line)) + (if (= (nkeys) 1) + (* line (line-size)) + (1+ (* line (line-size)))))) + ;; + ;; Given a cache location, return the line. This is the inverse + ;; of LINE-LOCATION. + ;; + (location-line (location) + (if (= (nkeys) 1) + (/ location (line-size)) + (/ (1- location) (line-size)))) + ;; + ;; Given a line number, return the wrappers stored at that line. + ;; As usual, if nkeys=1, this returns a single value. Only when + ;; nkeys>1 does it return a list. An error is signalled if the + ;; line is reserved. + ;; + (line-wrappers (line) + (when (line-reserved-p line) (error "Line is reserved.")) + (let ((location (line-location line))) + (if (= (nkeys) 1) + (cache-ref (cache) location) + (gathering1 (collecting) + (dotimes (i (nkeys)) + (gather1 (cache-ref (cache) (+ location i)))))))) + ;; + ;; Given a line number, return the value stored at that line. + ;; If valuep is NIL, this returns NIL. As with line-wrappers, + ;; an error is signalled if the line is reserved. + ;; + (line-value (line) + (when (line-reserved-p line) (error "Line is reserved.")) + (and (valuep) + (cache-ref (cache) (+ (line-location line) (nkeys))))) + ;; + ;; Given a line number, return true IFF that line has data in + ;; it. The state of the wrappers stored in the line is not + ;; checked. An error is signalled if line is reserved. + (line-full-p (line) + (when (line-reserved-p line) (error "Line is reserved.")) + (not (null (cache-ref (cache) (line-location line))))) + ;; + ;; Given a line number, return true IFF the line is full and + ;; there are no invalid wrappers in the line, and the line's + ;; wrappers are different from wrappers. + ;; An error is signalled if the line is reserved. + ;; + (line-valid-p (line wrappers) + (when (line-reserved-p line) (error "Line is reserved.")) + (let ((loc (line-location line))) + (dotimes (i (nkeys) t) + (let ((wrapper (cache-ref (cache) (+ loc i)))) + (when (or (null wrapper) +;*** (numberp wrapper) + ;Think of this as an optimized: + ; (and (zerop i) + ; (= (nkeys) 1) + ; (null (valuep)) + ; (numberp wrapper)) + (invalid-wrapper-p wrapper)) + (return nil)))))) + ;; + ;; How many unreserved lines separate line-1 and line-2. + ;; + (line-separation (line-1 line-2) + (let ((diff (- line-2 line-1))) + (cond ((zerop diff) diff) + ((plusp diff) diff) + (t + (if (line-reserved-p 0) + (1- (+ (- (nlines) line-1) line-2)) + (+ (- (nlines) line-1) line-2)))))) + ;; + ;; Given a cache line, get the next cache line. This will not + ;; return a reserved line. + ;; + (next-line (line) + (if (= line (1- (nlines))) + (if (line-reserved-p 0) 1 0) + (1+ line))) + ;; + ;; Given a line which has a valid entry in it, this will return + ;; the primary cache line of the wrappers in that line. We just + ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an + ;; easier packaging up of the call to it. + ;; + (line-primary (field line) + (location-line + (compute-primary-cache-location-from-location + field (cache) (line-location line) (mask) (nkeys)))) + ;; + ;; + (fill-line (line wrappers value) + (when (line-reserved-p line) + (error "Attempt to fill a reserved line.")) + (let ((loc (line-location line))) + (cond ((= (nkeys) 1) + (setf (cache-ref (cache) loc) wrappers) + (when (valuep) (setf (cache-ref (cache) (1+ loc)) value))) + (t + (iterate ((i (interval :from 0)) + (w (list-elements wrappers))) + (setf (cache-ref (cache) (+ loc i)) w)) + (when (valuep) (setf (cache-ref (cache) (+ loc (nkeys))) value)))))) + ;; + ;; Blindly copy the contents of one cache line to another. The + ;; contents of the line are overwritten, so whatever was in + ;; there should already have been moved out. + ;; + ;; For convenience in debugging, this also clears out the from + ;; location after it has been copied. + ;; + (copy-line (from to) + (if (line-reserved-p to) + (error "Copying something into a reserved cache line.") + (let ((from-loc (line-location from)) + (to-loc (line-location to))) + (modify-cache (cache) + (dotimes (i (line-size)) + (setf (cache-ref (cache) (+ to-loc i)) + (cache-ref (cache) (+ from-loc i))) + (setf (cache-ref (cache) (+ from-loc i)) + nil)))))) + ;; + ;; + ;; + (transfer-line (from-cache from-line to-cache to-line) + (if (line-reserved-p to-line) + (error "transfering something into a reserved cache line.") + (let ((from-loc (line-location from-line)) + (to-loc (line-location to-line))) + (modify-cache to-cache + (dotimes (i (line-size)) + (setf (cache-ref to-cache (+ to-loc i)) + (cache-ref from-cache (+ from-loc i)))))))) + )) + +(defmacro with-local-cache-functions ((cache) &body body &environment env) + `(let ((.cache. ,cache)) + (declare (type simple-vector .cache.)) + (multiple-value-bind (.mask. .size. .line-size. .nlines.) + (compute-cache-parameters *nkeys* *valuep* .cache.) + (declare (type fixnum .mask. .size. .line-size. .nlines.)) + (progn .mask. .size. .line-size. .nlines.) + (labels ,(mapcar #'(lambda (fn) (assq fn *local-cache-functions*)) + (pickup-local-cache-functions body env)) + ,@body)))) + +(defun pickup-local-cache-functions (body env) + (let ((functions ()) + (possible-functions (mapcar #'car *local-cache-functions*))) + (labels ((walk-function (form context env) + (declare (ignore env)) + (when (and (eq context :eval) + (consp form) + (symbolp (car form))) + (let ((name (car form))) + (when (and (not (memq name functions)) + (memq name possible-functions)) + (pushnew name functions) + (walk (cddr (assq name *local-cache-functions*)))))) + form) + (walk (body) + (walk-form `(progn . ,body) env #'walk-function))) + (walk body) + functions))) + +) + + +;;; +;;; returns 4 values, +;;; It tries to re-adjust the cache every time it makes a new fill. The +;;; intuition here is that we want uniformity in the number of probes needed to +;;; find an entry. Furthermore, adjusting has the nice property of throwing out +;;; any entries that are invalid. +;;; +(defun fill-cache-internal (field cache nkeys valuep limit-fn wrappers value) + (let ((*nkeys* nkeys) + (*valuep* valuep) + (*limit-fn* limit-fn)) + (with-local-cache-functions (cache) + (flet ((4-values-please (f c) + (multiple-value-bind (mask size) + (compute-cache-parameters *nkeys* *valuep* c) + (values f c mask size)))) + (let ((easy-fill-p (fill-cache-p nil field cache wrappers value))) + (if easy-fill-p + (4-values-please field cache) + (multiple-value-bind (adj-field adj-cache) + (adjust-cache field cache wrappers value) + (if adj-field + (4-values-please adj-field adj-cache) + (multiple-value-bind (exp-field exp-cache) + (expand-cache field cache wrappers value) + (4-values-please exp-field exp-cache)))))))))) + +;;; +;;; returns T or NIL +;;; +(defun fill-cache-p (forcep field cache wrappers value) + (with-local-cache-functions (cache) + (let* ((primary (location-line (compute-primary-cache-location field (mask) wrappers)))) + (multiple-value-bind (free emptyp) + (find-free-cache-line primary field cache wrappers) + (when (or forcep emptyp) (fill-line free wrappers value) t))))) + +(defun fill-cache-from-cache-p (forcep field cache from-cache from-line) + (with-local-cache-functions (from-cache) + (let ((primary (line-primary field from-line))) + (multiple-value-bind (free emptyp) + (find-free-cache-line primary field cache) + (when (or forcep emptyp) + (transfer-line from-cache from-line cache free) + t))))) + +(defun entry-in-cache-p (field cache wrappers value) + (declare (ignore field value)) + (with-local-cache-functions (cache) + (dotimes (i (nlines)) + (unless (line-reserved-p i) + (when (equal (line-wrappers i) wrappers) (return t)))))) + +;;; +;;; Returns NIL or (values ) +;;; +;;; This is only called when it isn't possible to put the entry in the cache +;;; the easy way. That is, this function assumes that FILL-CACHE-P has been +;;; called as returned NIL. +;;; +;;; If this returns NIL, it means that it wasn't possible to find a wrapper +;;; field for which all of the entries could be put in the cache (within the +;;; limit). +;;; +(defun adjust-cache (field cache wrappers value) + (with-local-cache-functions (cache) + (let ((ncache (get-cache (size)))) + (do ((nfield field (next-wrapper-field nfield))) + ((null nfield) (free-cache ncache) nil) + (labels ((try-one-fill-from-line (line) + (fill-cache-from-cache-p nil nfield ncache cache line)) + (try-one-fill (wrappers value) + (fill-cache-p nil nfield ncache wrappers value))) + (if (and (dotimes (i (nlines) t) + (when (and (null (line-reserved-p i)) + (line-valid-p i wrappers)) + (unless (try-one-fill-from-line i) (return nil)))) + (try-one-fill wrappers value)) + (return (values nfield ncache)) + (flush-cache-internal ncache))))))) + + +;;; +;;; returns: (values ) +;;; +(defun expand-cache (field cache wrappers value) + (declare (values field cache) (ignore field)) + (with-local-cache-functions (cache) + (multiple-value-bind (ignore size) + (compute-cache-parameters (nkeys) (valuep) (* (nlines) 2)) + (let* ((ncache (get-cache size)) + (nfield (wrapper-field 'number))) + (labels ((do-one-fill-from-line (line) + (unless (fill-cache-from-cache-p nil nfield ncache cache line) + (do-one-fill (line-wrappers line) (line-value line)))) + (do-one-fill (wrappers value) + (multiple-value-bind (adj-field adj-cache) + (adjust-cache nfield ncache wrappers value) + (if adj-field + (setq nfield adj-field ncache adj-cache) + (fill-cache-p t nfield ncache wrappers value)))) + (try-one-fill (wrappers value) + (fill-cache-p nil nfield ncache wrappers value))) + (dotimes (i (nlines)) + (when (and (null (line-reserved-p i)) + (line-valid-p i wrappers)) + (do-one-fill-from-line i))) + (unless (try-one-fill wrappers value) + (do-one-fill wrappers value)) + (values nfield ncache)))))) + + +;;; +;;; This is the heart of the cache filling mechanism. It implements the decisions +;;; about where entries are placed. +;;; +;;; Find a line in the cache at which a new entry can be inserted. +;;; +;;; +;;; is in fact empty? +;;; +(defun find-free-cache-line (primary field cache &optional wrappers) + (declare (values line empty?)) + (with-local-cache-functions (cache) + (let ((limit (funcall (limit-fn) (nlines))) + (wrappedp nil)) + (when (line-reserved-p primary) (setq primary (next-line primary))) + (labels (;; + ;; Try to find a free line starting at . + ;; is the primary line of the entry we are finding a free + ;; line for, it is used to compute the seperations. + ;; + (find-free (p s) + (do* ((line s (next-line line)) + (nsep (line-separation p s) (1+ nsep))) + (()) + (if (null (line-valid-p line wrappers)) ;If this line is empty or + (return (values line t)) ;invalid, just use it. + + (let ((osep (line-separation (line-primary field line) line))) + (if (and wrappedp (>= line primary)) + ;; + ;; have gone all the way around the cache, time to quit + ;; + (return (values line nil)) + + (when (cond ((or (= nsep limit)) t) + ((= nsep osep) (zerop (random 2))) + ((> nsep osep) t) + (t nil)) + ;; + ;; Try to displace what is in this line so that we + ;; can use the line. + ;; + (return (values line (displace line))))))) + + (if (= line (1- (nlines))) (setq wrappedp t)))) + ;; + ;; Given a line, attempt to free up that line by moving its + ;; contents elsewhere. Returns nil when it wasn't possible to + ;; move the contents of the line without dumping something on + ;; the floor. + ;; + (displace (line) + (if (= line (1- (nlines))) (setq wrappedp t)) + (multiple-value-bind (dline dempty?) + (find-free (line-primary field line) (next-line line)) + (when dempty? (copy-line line dline) t)))) + + (find-free primary primary))))) diff --git a/clos/3.5/clos-env-internal.DFASL b/clos/3.5/clos-env-internal.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..6daa5de088bffca48c35192e614da5efb6468d3f GIT binary patch literal 2992 zcma)8OK;m&78d1q)3oxmcG@Y5-g#h>2Bu)kPMgSqD@LMh#xkjplH=@#mac6k6v>j5 zT{j3Y=wm0KP2IHAAo(BDZo25knbiz1?N8`B|G@JdQkLbo0V2Z^dC%j1=R4<~b04P0 zH;NTjbX%TfbDz2G&})Zm%k^2{w*3ZYTUclJOUCMh>-B*9!IJ5>ojqx%vE+Ts}9KJztiLN`md!tn6E{*#ax^ zMq-qk&CSlhG=Js8{FR05`J*S%cj>>lDSWp3U+3s)a#DzwC+H=UN(<4W&TD0*A{TX8 zs>!8_R!pa&uR58_Mom&nl3o%OwOX%Tjyjn+7P_8j^IdKeaji65L|=Et%XPI_Q#3U? z5dM*V7Y;KexvZ$NNPb~n)-v!otW{+-eGUerTD=CBqj;PsDY_gRr{9VWhOshMm5Qs< zvK)1WkT6mKuu@IBQRyuSQD^kN+P3WnDMXq2(@B7FU~!Z`#g7+~7^BW)?m6TENxDM> zSjYhI7~oWOtvd7$UZyCcqO7h1dQH|37=lo^ zjIW`^#l@&|@$$=kVA!4RUWhu^QKsI$Z*A{{>{8=>zkqFI$6df z+h(y^zY7r^y;{Z8_V_-D2U66`=aJ!adVZgr3hmGjUG} zP3~K}*ld@xJ=eb%uuU^S-L^f~dEOWfJnpxw5QR<1oPE}`g3z}%+XVLPb~t!v+_&06 z2!Jim-e-GOxWh~YXnLM)HOx(%&bnjKxiLZEGAL#(-`@|re1;pKEXj%>>&5YA`mQ2Ls^N-s+ zAbPM#z>#TyvwY^5tzK?jkn3(?*BBYMc>}yTRs-Q#pt;#Z4F#~y_woFZG3uBt*QvO! z7vS0To0emSuHV6(x3UVSaYLZ~W0EYS6IM;LLhvA%>SVVeo$6 z(aGs3Go!t|4eC&)!3>pOi#tdg9hM%cK|Cj{mgfU-Pf91o4qQeP!fo-B5N@)UJMJ%` zbqX!|$#_XFRwP}{$IqHtD{9p{P{QjlwJ-d>xhAcm`J(TlfhoGC(zxnUQ|eAbETA8~ zcbi`XdXxf{%8uE%m(+2br)(CHjC5&-SLJo7Qb6yk!d-VUI!I%2gnS#(H=QBrMlpIA zb%v=69=lIdzx!Jar=rB|&`e0ASJ_1I5u@}{_BsEQM+dLK-^B6oAfFSMImJ~`zEvU5 zlN++GZHNG{rl}&$TBy8{s8qGMH;ZLmT9doli6CAO0bD7G)mSiQv7%Tfg1os3Z~>bsdAR=OZ?H^Nbj&>1yXN zeWGvEQRff2tD@B27SZJAuI3kV`S}kXb^d(6x^kydUwd$!e8!iIQzI$6IG1|dtzrO9 z6-LINNF(Fl7Y+sKP{?O?@R#aV(e%^th@-@Hgbn=Pp|M9pbNcs&W+oMNUdQCFt1Jl< zc_4#$iCwVvML2=r<%)~iErrf@j)ufpNz4|kQLZ|vdE6+8Xw5B9k7zaLlZ^vz#?v4@Wy z6>k3LX)0#FK6EOa@#BI>@U6q&TXzBQ->JVpdlUoxg1$$e4g<*gi-FvR;VXqv@`8<0 z-P@;C$9nab66mOAp07J1abv&(v9s|)4_&%8e3{hCtAlsO-?<4w^SDgto;2ROP8lgd ipw=)&2c3GAt}L(A;(DAsGi9;e*w3kd(yj+bNB;*pmA5MZ literal 0 HcmV?d00001 diff --git a/clos/3.5/clos-env-internal.lisp b/clos/3.5/clos-env-internal.lisp new file mode 100644 index 00000000..6d720032 --- /dev/null +++ b/clos/3.5/clos-env-internal.lisp @@ -0,0 +1,260 @@ +(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL") +(il:filecreated "28-Aug-87 18:42:36" il:{phylum}clos-env-internal.\;1 8356 + + il:|changes| il:|to:| (il:vars il:clos-env-internalcoms) + (il:props (il:clos-env-internal il:makefile-environment)) + (il:functions stack-eql stack-pointer-frame stack-frame-valid-p + stack-frame-fn-header stack-frame-pc fnheader-debugging-info + stack-frame-name compiled-closure-fnheader compiled-closure-env) +) + + +; Copyright (c) 1987 by Xerox Corporation. All rights reserved. + +(il:prettycomprint il:clos-env-internalcoms) + +(il:rpaqq il:clos-env-internalcoms ( + +(il:* il:|;;;| "***************************************") + + + +(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") + + + +(il:* il:|;;;| "") + + + +(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws.") + + + +(il:* il:|;;;| " ") + + + +(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification.") + + + +(il:* il:|;;;| " ") + + + +(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:") + + + +(il:* il:|;;;| " CommonLoops Coordinator") + + + +(il:* il:|;;;| " Xerox Artifical Intelligence Systems") + + + +(il:* il:|;;;| " 2400 Hanover St.") + + + +(il:* il:|;;;| " Palo Alto, CA 94303") + + + +(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") + + + +(il:* il:|;;;| "") + + + +(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") + + + +(il:* il:|;;;| " *************************************************************************") + + + +(il:* il:|;;;| "") + + (il:declare\: il:dontcopy (il:prop il:makefile-environment + il:clos-env-internal)) + (il:* il:\; + "We're off to hack the system...") + + (il:declare\: il:eval@compile il:dontcopy (il:files clos::abc) + + + (il:* il:|;;| "The Deltas and The East and The Freeze") +) + (il:functions stack-eql stack-pointer-frame stack-frame-valid-p + stack-frame-fn-header stack-frame-pc + fnheader-debugging-info stack-frame-name + compiled-closure-fnheader compiled-closure-env))) + + + +(il:* il:|;;;| "***************************************") + + + + +(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") + + + + +(il:* il:|;;;| "") + + + + +(il:* il:|;;;| +"Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws." +) + + + + +(il:* il:|;;;| " ") + + + + +(il:* il:|;;;| +"This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification." +) + + + + +(il:* il:|;;;| " ") + + + + +(il:* il:|;;;| +"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:" +) + + + + +(il:* il:|;;;| " CommonLoops Coordinator") + + + + +(il:* il:|;;;| " Xerox Artifical Intelligence Systems") + + + + +(il:* il:|;;;| " 2400 Hanover St.") + + + + +(il:* il:|;;;| " Palo Alto, CA 94303") + + + + +(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") + + + + +(il:* il:|;;;| "") + + + + +(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") + + + + +(il:* il:|;;;| " *************************************************************************") + + + + +(il:* il:|;;;| "") + +(il:declare\: il:dontcopy + +(il:putprops il:clos-env-internal il:makefile-environment (:package "XCL" :readtable "XCL")) +) + + + +(il:* il:\; "We're off to hack the system...") + +(il:declare\: il:eval@compile il:dontcopy +(il:filesload clos::abc) +) + +(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x) + (il:stackp y) + (eql (il:fetch (il:stackp il:edfxp + ) + il:of x) + (il:fetch (il:stackp il:edfxp + ) + il:of y)))) + + +(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer)) + + +(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame))) + + +(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame)) + + +(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame)) + + +(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc) + il:of fnheader)) + (name-table-words + (let ((size (il:fetch (il:fnheader il:ntsize) + il:of fnheader))) + (if (zerop size) + il:wordsperquad + (* size 2)))) + (past-name-table-in-words (+ (il:fetch (il:fnheader + + il:overheadwords + ) + il:of fnheader) + name-table-words))) + (and (= (- start-pc (* il:bytesperword + past-name-table-in-words)) + il:bytespercell) + + (il:* il:|;;| "It's got a debugging-info list.") + + (il:\\getbaseptr fnheader + past-name-table-in-words)))) + + +(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame)) + + +(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of| + closure)) + + +(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure)) + +(il:putprops il:clos-env-internal il:copyright ("Xerox Corporation" 1987)) +(il:declare\: il:dontcopy + (il:filemap (nil))) +il:stop diff --git a/clos/3.5/clos-env.DFASL b/clos/3.5/clos-env.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..c0562b23c01292b7cedd00ca73174bf3c99acb47 GIT binary patch literal 42337 zcmeHwdwg8gb?!N5W+YjbWLcJFS;+Q)u>r*+Y=Z#KQt?|CYXi-t4Ay+t%h(Y)fQQbF!(kJ(9?z zH+3dr-J9aEbjPNqcrv}IsWX*A_@>^0!QoKf{+sIu`iBo(wXQVnDZ6*5uVM#7*KepVZ3(C2+N4~zmZ5%TyENF` z*Q=SSGfR86|@T{>_u0a${nwd|hy4@IYvw@8-S%>Fz#> zn7DtesHHQ}l!+x16GzNZvtZ)BvEo=F)DdoK3vZ4Xra3X@m!26Y(p=WTGK(ea^ltg( z5B=qa&p_tVx=bY19!rGdp;)qRVr=31S=A03reWBo)MhQ2cyO$!InvURiX}3I$X(Eq zOtptIRs|wT85)wxJ5!NTgp@ZW+dE?MNOLaGv?j*3+_w5ENfU}BwqRHf+&a|1J3A7* zu=gUuGI-Oi!P`oM&c7{v`w#XZ)zE>#p`MZc!Tt5YV0d64$UMWrp*{@w&3!xTZ(C)2 z(4G$<_U|{072OS$#&qgq6o{3v3>3Yz}%B1sng zZKXBck6-_^6hqim8qrE?FP+g)c|J?IVb8Y=!$-hO9Pv+#ncaZLyw%AL8Jlo?VyqyY zNkzi#6JvqqNJl2>?*&9Ewl_KOsn3D&3Iwlc54S}^EwOk!)R6>eBdJibGt<$T327N? zCk~I5D0q{Nt&yh8#JDret5Ip8Ch9O3+9g&OfKZ2KMo(GVH#pc`{$$y?Jq=~kIXpW& zR$kYc=!zwpLmjDP24&Yt;RWff=}e>@LvI4-3Y|s+3FL1quzB4TSFH7)kILt73CBAl z=@6z=W-+=_xV?RgxXTe&y*ZMZ*%9eaEU~%JUJ7u>(bNhwk2o1U<)1HOAgEu~G|<V+_ zCBp5IX1f|SZEM(hNyF*G4U?BP_{Iedf(<5XK0Q_0V3`v6aD!!yXYcBNPxkigXm$dj zgwklXo8L#H{5W9`sjoZ>R0s*298>^!3Z04rDKvLMdTV=QG9JoJ+Zb9_u{n~6q+(6^ zz)*)>-E6OWE7BLXG$uO}%^e$%u1Wxyj$~Tggwi3q+N?xMzr+}ZbamMo1-3^r(PT6G zpJxBxmY*5nsfz^C&;?`hB0Y=6GhIx+b}0n6nD7#asGnE5%dz!eRr1^)xxXnT1}C-C0WUc0&l!9bo_ zFw!LG&0FozT7gu1xB~@6-y&!SNQv88jjT)RP7a7>^LK7j{Qd$?gy+ zQ#&GMAvhN~3iD-~OMokD6h$6tFwyrbfh#o)pe5Fc2K+1=Z@oR%TCIi)JD5`VZPyqcOK5?hhLX_+#1Q zSpYx!L~Qc%sJXrW^x^)=+Bng9BJN=GXm&h)XPn8Ok3G=Zw)(_-+Ojp!)7)ZIqZ=;!=oYNr@hq9sP1$!lL7m@yR!6tJbz zi6;Q)#Y*YU7;%XgL|*9N!L^;?c&sHBNnyAp?jgy025@yUNc=eBmpFN6C({z{CUHtM zB@<2SCC8n>pm}VKkgHq8*OctoN-YOt`P97E17CeBV~tOBCJLg z2b4ct+47XP3KOR@5uBqEhXpXp0mg+OJfR#*6_#0M2_KT@OicS~bN40;uYuhN)Ez&WfH5bwAP&Jw4t~ zj+tJApMLNN_+)EzVppUh?a3{XP$m_Q#j$RMGHFtJox=j}I0`oGgN63Nv%>Wph3lNi z&l1RAndSB_tH9oE+DU=m-q(U(Pf($^Cb+x*<~{}R?!NtfL;by>T?hB~3Zq0|uknDo z^lb-w2KsmPgF{{u?AgDQQ9VPuLnF5y=o{wbtLg}+(%?hRn4KIUvq2dNo$%)QrVk_Z z4z%90^38XUT_&bAAK>?6He>>D6gGBd#EtZ4g;cFVYVMZI1*&%ls5&}&hKBn*y>+@j zL=5cTznf9JcZCE66)JOpqcjhWdcxxza767LnGl%Vxq%{drOlo*MJKDda>~OMdEOE-ioKIa&h7@VQkm7d+ zLz>7jq=^u#K+bGU4gN;6XRO2baW0*RJs)dDA#K}^w<=d#F&%@O*(-w{ckOiS#GXC- zfA3ZNp~RY+8^S<_ItnD^k3lp1 zAaI@H`7n@So-?mvEnRk12Vx750qIxR>wMrEB-!VM&LAk<8P7=8Xe8d;l8~5_h?&t7X(ynZOZ`PSU*W3)ez7i`u z7S-5z?9gPjc>)VO0n|#8I32T&PyRi^*!dI6J-40^{<#&%zYGhyhxn2!-e9e^&#$(N z4YLAE{B7Z&u@|+>!RFely?m{Gq3O3T0zh}$CF|_BoOOzv>r9c?Mox4#Pp@+%MIdme z&Xpl-rbjp<4r2erz4RG0I!9xIASDv1l*XYlAm<(`qqL*%?FT?rLL_l$ApTsG+CXOoiLFbP0*NUj{>|%+$F~xkkXZ<))NWciz zZz0AQn8cW`5*xQ@Y~M>b9P44 zFuo0pxKnkq?15OatY$RU=4R5$r6seAM=l_?;L3+F6uIdQZnfn6^V`EssiY7?>}eO} zyx7IZQptp{F9i*leg)jVCa!|B%-Q)kvI*JHlHj$eF3Zb=z0A7el0(LaIWCX z2k5>}obQua4ZbZco)O`(Jopusz%o#n=xs(m>7x)L{h0_O0rz&Myy1H z5BmoRUT$xYPq`cG%R7yKmrglQaD*^OZ2SxJ7(a9qe%D?n5r3l*UvMM-jLxSe@=wv` zib!`yIFXiZN^X0o%%3LIKC-lt#6q1q(Y9XUy0r(gi?WHz($ySo2}su-Jo0ZZ@)g<{h$wL8{e_$>yyr z?O92hm>63MlDBiPZ#cMra6}nCP?DbBp}~4da0SX@@;?&aI;Ui~jr(K>&uEIo{KDBV z2}F{~4iUE8H)h3JvB@DqRrVJ zX>xF9->&}s{lY+7`4Fo5&3m z-o6?*OPmVM>OH#d5OLoIEN6uf2Vqb;g7&WY@GhcQU?wsa$WFKj{I9TI>DBDxi7I>d zLUk4J^I;u;6V}>^BLU27oiZuzSUg@?HX($R4`x-mDHWq&i$y#KK;*Kiyeoaq#8|Ao zXRoqgxj1P?5KBxD0Z!N&2g2aU`XNCb=5_!Ks3gJ6O>ydCS0Dp_6bt9-hL!w!sUb`Nl7O=Q%w=9V+qJp zQ#rXrq&WsYFu~>QEy@8u+|bYA9&P9rdD5fNaAQ+*DYn0mwMLIe$7AIU4k`V%Wf%cR z4g!$-1upm~hzqpBiLoN719FKpcqs>}zGWCt0kv>J^%4(vF1G+rlcWi0tei3A(I+Zrzj>5Kfva|BAWGSB@?RGb!?qD1i!B8jav; z!FF*7PlI88fTFprhhvi$y+PUB)Wtdm6yz=QNHZX;b%sU9CX2ltc61bxd`R;QSigP6 zkpx#mpd*q}&d3r01(Rpn8qL{h{Ka1|z!T%E25+Lt*E%WuptawPz-1MXQH z)ONFo_%ennt*wwS*{x^AnN?@Qnf#cdusN~jr-C*0v0-5uhx%O1A;rWI$}RmPSr0oY zICKq>Xptidfp~<61tIViGT8*Q^X_nICr9=0QC|sz$d)U)rE}^QH@N%RcetLZcGs=@ zvKR%v%5)w-1m^$rY}!5BA5+RRxsuqz@-)ePvjZ5%AD7fm)7j}p5#4%=HGIqL@DdH5 z-NEiZ$Sx7sYoBivC)@DsS{A?nw);ph4NMj8{JCQlYz|6Ao=v{P0YkG@3>lVW_ zDV^@me_EhR_qDB2Pg^~W@XY<$12(%8{}+?K!N#!#vvHuS%!Q^RL777SEbW`!HBXr= zOtIf1)?)^xa!(w!KIta<@7ZD)|2p|C`;|KG?u8|7)VXWe7etRH9dp_8(_rnh{WQe>POM#rOvvgPJh3xep@ z@zz6=Ys~9}0h+2*xh}JC5jl;6@3xq!3yz%R{-qoozGV3PU{On;q7dn5+blbmv@d{= z1s&K=XSRZA#)b zP?*1AsYRp|skU&sDH={}jxPR&W_3MMhRo=Q@{B##OLTKe}Z=GtHPde@v$g zTHvd6N)3U}h?6x0K0&9nI`Dv-_V--p9@p8)v@%kGYuwPXywm?LuJZ@3^UJRDgzNl$ z*ZB@{nhWsbKS*b}INJzz|0N7rC?OP3nib+ahoRDJKc$g`yYFWNw(lDfX$XXUpL3mm zOs9at_fa|p6h3yEpzyt)!1mq3NCCEQuj{;lQ1+$tvzZYBY#-Za2(W$UY2*?{vLcI4 zsmS_;I9ZY9Vv5C)FeI(@Og@|SZa3|2HXb?n*-H{Y zZQBl(St|**xy3ir$?QTQ3(^r0kV~RVMM1;UN)g&g_{DDK^U=0iR~Q`135sVmaRo|R z)#Me=q&h-Zh6Bw@T2rm~gQ;Ne4_hJ1Hdb zGa34MH^FC+eZB)6ImMBbFS->y3k>lmpn@pj&%m=Fzar+brto8KaUVkGmx#0oVp~dW zMSn4(0x+Jv6xt|+%W7UKR;UDsEqg!mFPf1bs}qXTyzfEY0u7M%kVI>bc_R(u=^i z#c2rf3VaidkZIzmfwA7emjtjb`I-@Tip8v#ywB2ki8%j&PJwZN%LkzuxSOFh5_+eb z?HzP3lhA{7E*IwkH$fk&U+%(U2BnzMmK&KTDA})bvq$K>R6?(CL+f3qu8T7H1IwkS zvsK`f#0R)ekVXV5nR$ccnCCi`2Azjc|Eu}Z{r^noN(ucZI?os9|H^0ce}~Rh68hJ4 zt`?_asZ`MvqIJ-C<{mOZ;pcV}YGYvzo0(8%DCg>SJ&P`Rn zj?86JXq8))&U~rLN7mky2KfGk2^ji)Ixm(`;xl{WQ)({g=~Gsl&QD5OPEg;+nT??z zM)PC>I!!xsiuxWw3R!%;DO|+lWbwV51zs*S4!LD3{8-IahF&2F+T8?=u2TUZlhk(+ zLj`!gWp08}adN);iqN8YXpyRpu?5y|5mxR_S8vp>S;$6YxBiaKE5+$jM9Za!mhvMq zTdhyI*`7k-RkK+NZxu=%uaazvV8S(6A8<=}ADs-n!wpqjW44=6#X>pVa2OVE>DM!d zPzbBr&8)z?T0$>J=4I}f%pextg4Q#)&+qY(%K32q(0{JWb}% z{0Y-BtJSwieWfyn&Qw>hr*jkBRB&!W5e7G%oXUpIUn$s7B$Vom zFS2HaDwUH7ZcMTg3Up(=ErKgp76<^d^%3C~oA4Tpj zpdH&)`A6;&saz+d(VW!tEIHV0q^PO(aDyd>tP^9)+=IfyyV51P_YR3|Lap&k=t+`mo438Gkt2K=Ixi8~~4oBhSB~*Lzr{U_rrvAZ2jQ zj?9NBu>26pIRO|zslF7|FKn=!lROFhK$LPT^Q`AlJG^m~7NGjzZv(9J;Qb8(jnUIeKB{_0reGe>%2Y!FKvrIwNBa zu=Ql%=I6%$GKOuK7^^))*WO*M1!a7%fhImE1?ZY`k2t?1 zd58_Z7w8mh@KwA?Y_NXvUxN);Rhqn*V4ccg!p6BV!Fth)36^MR?^m@Q5)D^{*gUDa z8`n=YwztJ!%tDzs3%%j&j*98TlgYBl)d{_s27j__B3YiSSdHlSiE{3aawJYzFHU}g z=P9Gv8y;>?ykUxngdU3Mz3@=53#6dbQEksLYS$sG7?K7@k<6~%NF>;~)D9KeD=l82 zz=&FH=;;N{4U03o+NKw}*xuKto4kURzoX(8ja~n_cCr>tIp4j8)Ex3&5^}@k%2koQ zQs~+Oy@rwJJ?v_w=T`7PeTFu0h8n+|IYY^TeJeMiHrY+kozuH9G7*hGlb9v~{0&S( zO(+x4IKeze#mS8)C!msV<5)3*i~ij%k2>y;zA=DbsAi$e-Kr8TgIv@o0I&adqc!SeN(bl;_MQOQwq4Y?42@n`V{a zhBEM~B%Og$Tq2zbCz^1Z^>x%3MRp2U%wRXA{yEeZ%_f1uIjVpb+}Sg7a37S=$fgY5 zw5P9kM77P%!l-%rv6G=TTQq2@n@uaM3%byBX+;MpAMW8N_Th$BRsIp|SQ% zo;V#(W;_>jiCe1; zxu(qfnbkQ3In|vzM~CEwGD~ploDIZpA^R*Kx|Qax!4i^7@_n6MtkZ&(bF?4_QeNy0 zC-lnq>^A&xW*fZq3lIwA7JRacjaZs*#F-^K%~*0~GcvJE9QX_zng#NoA4aw`x>~io-vE5H8#}+xP`Ym_uiH7hPsbE*rmDEX{zWk_uZi*#mXhQP+toK?H;% znoPE#flz=J7dA;abHwSL>zfzpjx>eWu3fv1k!5+Wgso>-MgRVhzM%uS<{6T#xaGeU z;n>c*;kYP*TRX151=ng2QtF0ifTt(~uv#Qr;3jK~C!5+3R5>e1lZs)KWGJ!)=d0*x zv2+kC98R#1BY^8p@vVmh7EQ7gid@ODfPyp_S=bAqh{W80slO;oRMk}>&+(n(%1O>Z zQjCmepX?!JR;gWFWN#J8$k>wD{^0{y0dtpOb+db0n55<+uvKUlwzt(XBuWUiNrh-q zwYN!}PXDoX`6}$W`*#lB61=&;53b$8w+q((%HbKU#e$-i9CaDroOnpsIMWa+x()VX z!j)DdZpe03leIb0RXrKG5$TK-*PYahbBK(?O|pS2v#z^#I{y5OE3+rtUTBNs%4~aY zHDR@#dE}zQ;q3D)w5z6O;ljei@%`qF*p#%MGFnghxdCbYZDql97QaQ)u&;5-Kj35V z^-99}^}@+?SM9=c=X=P%-kfg@O)qNKgviN4i#SZ#n&;Vq+Y1+&+2a-3n(;R9X^_BC znp08-;)2x{8-;Y8U27E!3Nr}QBNMSiL291Z%IJ>5R)Qttwy>@#oN0=N^g30jqe=1= zBBG=&5tsW{E%ESX2@{2|1$Cl36cIx}VdxvwS)2niOUNXV+E*f}(|scyLxTtUhDL5} zhXEj8DaY*sUm3sWgTXt?WGL~0&(O^en6=kf;|m1`zJt2ToprveJ{5ubL6aQj8ec&~ zfy~fImv}!3FVHj+PBnJ&ZpTxSQMBFwk$4z}a>UM$q&U#sO5zAD{gut=L*u)Y%ALaJ1a%g4(1=1o7XW|uA(^2I?rBa zncm$vZeVX*d)Wf%Ej1e~Iju6L0Q~^5SA2g6pW-q`P1bGWBN8t%R5^7v9)Pa^G#LTn zr8LgsK9j4obqx=DtxY`LwKkC>ur_TIfLog)$XrZuY#d8LJOuB2AWA)lE}gy*{*nyl zP%fYf0SmSZW^~oJ#A6-e@=LXUgwZuOUCmM(R`L_(nrbyM{*j3>Yg15Cz8AZ`3@&Kn zv<&93hQ;&)?3Kw?8(7@9sV^ui(Lu3aR=)>qHZOZ;U}7mE3n#DQ?C-lJD2sscA}D=s zQ)sV7K+fut%vLBo0NK=1lwFIsRovH6glgehr$@jE@0eKW8oXr~n=dK;=AHqV@dCj{ zd$9e))u5fc19f7S#Tz*#G`=)3cCC|JE}rv>I|ylicqR6f)soT(g5_tB?)#l0qa>7J_Zo1BUKNva4@J_g6dpo~m{n59fA|oVn%t z3ugIjL>Se~;z(Qw_;}!C-B5yx=d*jNXKGi==#(-f(v5W{EvHHbWKClgb#-z%clcm$ zRtLJSu4ZDa5}_P+xoUjVAWn3Hb#=zRnX7#!i9TJf%#PMmO^#^GWY2Ltgwk=(YmfV$VY#51S?80MFbDPsFk^6z4 z^vU5E?k`6YEr~Qy@NS=(mwkXE^TCo9ZNv~>9WC+AWPd(|Yz0kGXkT&_epI~aOdBq< z3$Wh{ZxOr+_|sGXu*P-CJ>0-b#zXuZ7H$*v5RtGwBI+l`-wIpRm`b)q65{P|tn>Ns^TorfyCCPf{r*=m zlT{dxfqPE2zm9lwxr#S=;yecqp_y|@I<31!(%ID3J1Bm`Qrb5j!+o#JF8afZmN-R#f)`hI7pNj}-jpsh1$0;PB7Kiiz4Y=#hrcBV8 zQQ)2_I(4DqI}d}n9I_E?{$sewfH7!EhaeXT$tC)B+FM(KB#Yc6;ijfYI-N|V#hj$v z=fD*b7`|#2>y)Sq)=Tx`{j564R9jCgVSU;xoH$aA{8ope`O_HjN}6z(l}*en072s6 zMlgge32}3^S9hVbSDmoqN|LEQe{(n^q71)a>*y$?^s~whREYkWaRY1$u{X^GaH4u!kpDJC4|B= zPc}PhSVClFLKCHf8d*8JXz4E}@r#E>#hB+Ab?2ex)P3}fCQGGDW|x}-u#*et`MTUl zi&@_bq8@@7uRIv&f~A{>X#_f=5FNu64vg#bYa6qOElJ=TtV2j%syfOsrWi=^HHA|Q zo#yWs4~+_tYGyalGw@C;pB+6k%JY8frBVEo(qQ^Ghq!P9w$Sp&9z23*J)5zf!SX3& z?MY6u<>nvHqvP129#yY>@&i`FF`zZzOSI`cZ?^~hiMYBGdJmXOC{c1Nl~ozokdLjZPlk+sRZC#Rx7|=f<1xR#B1C_ zvzEKe%3P!X^;4b62Yiw>P*D!s19zf$=Sd#>Fx*@jWD|SH)Cv3NC`^uFi(s_YvdlMD zJDGCS?&AtPXRYk&PY$7U!)mcha8UU{1|3ITt# zpP#;*H|mW4ahxl94!ai2nimC)toaAj-LrnMN`1O%`+*9De&DlnCI#P!{cPvRu)y|t zEMZZXc42mxX8V&B zr4%4ZF_ja^s$}(Ql={A8HS{j3P)D-DvQXXRV`}9ScHmAPeRXR)%#KA>^7Fhx^@M(? z(gD?u7n9|@uevB%PND;i4t{+v&e_VCWm+bI-TDIPmD9hyx&BqPzj7GTSU{sj6hV?T zJIZbpgs=U`UCA=EeDX&uHCd&DxufPtvSxC9vYOT!YY!)D-+WR%a)hT1Z&){r`y`M-{Br8{=L3br90g{T7Nd7X~b@bJNcpIwLF_5vSnBH@; zb?-M`XirwZGCn!NLfWJJaK4?^W(C`wMwT7UPA+0}oYn6rlje?3s%em*q}VJ#jvdg{&BD2_-t)8+qf)`V<#( z3DOH?)*4CflZ6Wk+dTB6`j?Me&u`j2h%leX7YS`?N%>s~rLfnMicIdOt?$5T{2LQ| zTbw_o^IPKle7*!@3;>z$QFncZMEQ!c`q`qNW=&6RCF^@s;Vohtn6!Hc(6%qgZL#VzjJOmsYF0v6}1a8*dxdHA+aZ z)cRk0sl~#dh;%u!KLL#{yHdSaDlT@af0K2i18;7bM}5$%5}gHd68{<1Q9XIAc%)}H z1a~|8`>3sThe(vi3T^^U?Hzs_J@aygMu&IM@4p##eq$3e(0BcRAr5h_EC&1nGH4I0 zoCwb_h|g3x(a-IYdT2c{CGUoO2JO9pYXi9HK-SBh2eNsdeD=Efdj4n(>%T6&GL4EG zJ7aM*|8M1ZZ0Asn6X0*z9*W<51vvIagRN%@+WB>O;P0qN<=e{`_$?|iAgyNfwV)Rj zIRp)xIfW@mWnC87Z37_myUhnv4g}|cmDe=_dbbpKBL+(@#aVSo|JpUBGs#qhHI;<{-Ec#rv#()Y*GUJQeVQDs zl2_+;e#Z8t2o#OGHMKkE+v-$#-khD&eVwy`mVrgZmWe%8liD)TeS+^M6ykU4h8ey9 zc6yz-3GzDICLPaw3u@+U0oATh^P&dT7j{`4r|vzdI|t(#{T90JhzFo&feGY;gjnX$ z5yLEk9%?YyB7!&qeA%3J%l=Ewf>Ay86%AqU(7w%6Ez~0B?y8z5U=Kx#w}Fi(E9#M@ zbw9=6UQ5GBc^KkU=ab{T^19smrn~L8 zp9-J6WPnY3Dkkr4@L0rmiz59kK1dGh+I#l*?3VLKu|2Ox8oiLy_Z&FT*Mm2n)a3N= z2!xc?BKml6%m-<*P=Z`5)6gju0ZXA^Af8nq{BNPg<>GJ#Tezr4Vku_8U_2$x+%vifkc`u6N(y}3gRA>ZEp;i#$GO$~&-pTo&2>}M=woBZ?c zsWmF)XJRw!NOm+#k0GXYXEr@~OAcJBiBCZ8sOqZy`QfhGL&+-oTV*~IxehLIEkeG_yqB`iixM5AP6m&o8p!6b-Wof!_DiuaDc>yaIlnOV;y6gB3My@nm zv4xqSI!m5E$c4d@Zny)bi4Egim_9U8XNl?JTyaz%sPmNp=gZoA-rl%Z6k)phcaCIz z3uGQ_hX}sCKH1Xjlaq$hymY<=CO$Y9-c#mt$(E3+V)QJeDk)&V(`~U1xfg5xt7M0o zn#Kr4lF)x-84rl_d#+RTVhY2}%`%@PO3WdZG{#`PsUsSRZH{ug^*<0;-V}{AwOuUf zE{?Usj;^GBQEGy6%*>iT=@u`V8KqFFmFL6qx--}!pc0+ZZs5C_OMc8D#24xrqiE}x z`#{agQjyJKR67yr&fpA|iSLle8>EV^STl4mTHMk^CO=>M!8l17W2T42NvSkRJM34> z?p0KQSQnLUd<2sm0>SD4R0riL7lNl2LAZ(UbhtAuIwb_J@lP!LaTIR+B@!*r?nRol zNojfRYe`cw9>=+{hm47G2+taPckn2}XUiU@u&V{yM$PF8Y3eT#P>MJ0aJV54m*|TL z=8q9ttf4U+%Spn&MHRJqtik1!L}v&ubYzkVsxYc7+eeuFm6SOnP6{}V&;obV#mYn> zx+e!K63u-*6eh!Q>QPD1eMkbE<}JjM_rnuN($Jpv`X@r49zukmYfYKH&iI(gC7xR)HRZ<3-!W89RKcVYRxsF7sh^ds&H zT0Tb*=mm@-yA1A}D-DXA!Rz{^otSb0V{i-#Nog3id)B$=?0mot>S81;GIy&BhJg_C2<<-|`D%x|eGeG7Q zeJ}=5-0?d_5V!T1Q~tSeM=FX0Qht@E{AA^0_i7a?IGvvSpGRLUfiT;mN{jDKJmCen z`tGuHe!kZtTjYD6RnGADTe^w58~0!&-8~N9IObCoBuaUFPcC-P%fb1bNw>u&nOP?# z(5#fXRB%Pkym{Dxb4k&0q7)l%Nl{xIr{GX!76e--Dk*s}n(?`ODF$sN_+FAypJMAi zEzSqTX^Ak-xP#6ko9&eHM zq$~!WRm+Y>fv*oJJ2K65dw;m+^wf%|!=V_&)vb?2V`j`EhXIXw2!)x3O1(W$on3DJ8OA-0J%zpnAO7=Bj{7AkKy)p z2rp}f(yS6>p?bRVemSZMHVA@bl9^;j*D5#*x3}Oev}6ZI$@e%x4X<&vO1iFH*;YFa1X*Zh*hxEniNW}Q?O9CN)$P`ama zcw-(96PzwVlgIoVo7xk(U3T*piTo^DROU2D1*f=P zFA?&b3XF`hrHIg-rxSNVx}kAU2hsFLQ8b=ZCBsrLB5f&z=&uc;ks;sTN$9;uT1}${ zap)z2r3rb2=eMxokM|=@u}lg@{~jq_ym&f;^Fe3AOHG0mE#5DKm_~uq z9<+3EUH5ZYJ=x45KJhD?LrW%hH4o2q`K#C9^&ok0RFnOU(kkoSVlro`=fpjy7@$zo ze$?B=dW>IX<&OYcBNsOkfkop(&KzJ^ri)tM&6;^p01|%0LQw(+<0W04flE<&I=}(B} z3$#?^1{7rPkf`Y3%XG(0Ao@$FJLJqPNQE?z)4>gt+akF4Miy4I3pR*05CG()z=X-9 zwmJtLQiQZbpZuwlxtD+aC`V&{D+&AsPGzDDEw>-oEG0s}CFXsR?^%dM6HijgvQrN+ z5#LEkrU2FbH=-6}h4WhJLnNz{m3m?MLHgdq-{a8}(HLYoty_=9`YTJOqxcdjA$D=y zwRqKKhWzDN>_jYzdp@lsuDS^OvF*;QG+46l&YR4!c)(`dt?OOD&sEX*z}1Asz4Ekn z?wMtiLF2xa(toN|&2PrD3j$;A2I(j;s(ob_8;CR6gqPaZ-P0okmq5yq3X2@q;lKv=R<*3m{f| z$g$oJhDIkb%XbTIx^BQN0q^Vb!>&A+oYmMEn_4f2;`$i>*?4-$SrbnbaWk&C1(ZAvQZJ=3tnKfrK zs#nw9plL2w-+J}w(z#fd&c&s66YM<5fw^%^**$An*LlZogkK(a>^g7nbI(Ty{Lh_? z4)~sXAv$0^_u?LGKlfnQxkvOYu-9W+NKN%y?R;w>Nv*~I<isZ%K=?N4xBSW$Rm$EPrlC zd9v(>J1S*&T)pQxR0&CN#dABVk~OEtC!6*p%U>Oz?2L1xjD2Z^{KuX-S&86H_?EwV z{|DS0_un`9*LxUu-T?J&{wnF@kV22MhT7zEMVUcGN?J$lT;*{jx!n?A!0R? zl{;Zm7svKIcfHim{@nGN%&DOrHSBR~V0q>72io?=%c!N!jk*8Q8Mj!@m=X(3mE>S$ z#L17`MK}Yc&&c8 zee;J!KxKXvBpaf^Lg%8T-Na2hRF(Y*^~KV0t}d3nn^_y6Cwo6`bf)7DMAS$><1R&U z#z&n+1kyFg9%Lw;8(^|sfj0C*#6Yp2^L-@l5Wq8N7h95IJ7J zx#}U9c6JN{v*5W&lY3rl29jAZc3=fLUE^-pU6;mwpo*V+9ah0CcGl>zLT8zU0?u6P zu>tmh3#m2CVq4|c!W+B~nYZfP>z*3a4xgTC(S7pqFfOm;q##pu>N=sRTk&}Ioyq`V zsnRIt=vEWtuc}lwq}>Uuv$$bzRA(bwB+HWLPT3i=5!Xo0gjK0>x*d3Q0Vg7Sm(V#w zSJr?20J~Ya+aA1@u2t-@e^s+!;tV#q$qtKHVKLV>97%V82^Px=NjZ;LioYt$-sU0Sl;xAL{p#Dl~ zCHPmFH(`j`g+|;O%MBump9un9;D_Dv8BoC0IzgIGaW=-!a$l+1(Q~zK($PECpm)o& zp{)=1H#Ee~H~skm?cJ;Q>G-zZRNC8We-A(lzq%{86?66C4s*&z&mU-qu- zd$PA@N3#&OeZ!Mv8>63Bbff#^z|I#MUflPpwgjtb&IVYL%8xrL4<{?{YTv^PPtf?h zr!85Q>kv`!L&;1gD9e8d z+ujS+4x5adiL1&p{O|Pm@iMB^dMkdcdMv>iU39w1Z6A(Kz9p&zMm3Q&l6VKrh4JX! zo`B;GF%jCA>jr;9DOl{ZuENzh%@Mrp3WcgjI;Y}~CD?OSIlo(nmJv0a3R;0(OI@O` z%K@%vcnA<=KoNfR}7n2x3|Gh@cc`g_}?gE}hL> zL#0eRe3`vIgjl@6q?O=nSBt(-K+N`bP&}N|r#`G;I*bXEhXr2M7O*H*-dgPOjOo&T zhp0m7&8J>NZZS#{>xsF{+~rl6L|aoz-6Q&OFl6i)6N>OQ;fx#lz|d4jX7+`8Zj+3Pz`)TV3yer#j4$ud4@c7YvOF2TAl$qqmd3SHM?c#Rmus4`J@Pecc>H8;>}2R) zbTDvZgZi$buj*nUdU9M;2M6AfWUGCC<+<)JK=9(3 zxDZQhiQuj%(Z#yKKPWp8ADQD+^V#oWeV>l65#)oIM>V1y1XCVS#bu@)*%}tka;NX+Y*7-BESsuKmSt-oii&;xWsRRa zM}1B^yhSC;A4`@)Sd~xfDN2a7XsIo%!xH0&&G0^aXQqxYd}*FgWyme~H%25_AkaS{ zgjPV&BtEfhRFwwr0SN?@C~?dt`fr4kM1P27eO8=DkP><-u>@F$IDRGU4n}`&P*e4) zPc*Dbnqes_ciPXLzyGt*T*d3cn*K6=zHqVn<|ErY7~4-#0ZWPTDT9*8KZfY#BB{^D zHS!BDf)yM5im8X-)$#*%Qu9IzYSnPdwN>2{x`AD4mAh1|=GvNGD<=WP^@=l%p1J~1 z!(Yu-y+i_QRw*@jiLElLbcv{F#K9)63wl77N3Qqld*c(Lr9R$IUi%Hpkzj7BkO195>g)&JQDlYZf?nuAM`|BGZX{il{Q@QaoFoHBgx zkU?vc@wp;5K5}AX>IF5&4CCZ#b1O&aoNW`WbS#~|M^9dA(lxyW(_)wL8}9N_lgYnQ zO;Bm~-S{`*XC_bj*YnS=Z+80MJsyL^1>6kaiA~|Y1h1friseAoE2u38V45HXn@tt# z&XkE*xdoI;LGolp1@A{ETS6kN5Q}c%3H9Zveg;VwINLiuG>YR+E#z6ml#B5X)fDww z$oxalE5F!^loFnlR^-+r-b;5XoM45tn0W+gN^)r=qgL@gp?g@0I_0chNv64eShATL zNixl|qiDua>ORGe@T9ob- zI~y4k3v-S4j|CuhhTshj(Hu=lxyKw{z>jj>GP(Nue>wVg$KnKIr4Tjz^H*>*@a*kQ?%#$x0@^Yt`H7YQuQS2L^hH&q%> zPwpFA)DG(;u?{?qq1qIJSOmn6`1@ln;pcglK$2K8PGV@B5xRl{PUUqSEirv##NDOJ z!&h=$Wpsd^-RF5LcjvI7GaOUo1-&CSRdETKpk8C zAGmk3kd1Zr0I~t*ep?>&$@jz?>2_tVOE&^Y-#daF`}HOIk?S_+MRA@#fQvScNJb0+ ziOt-RTX*#j^uc0k-`lGd0tGn|D4ETT0%-w((}cNUu%0kjH}}Xrnav%Ob2yoZyF_8d zQ2b){UogJgrSOD7?()%`2|RFk%NduC&Q&;2AQiYu;cykCgkzVE1VfvGeK?a=yKz0e zy|9=FVC?RLnKiY)CRStBni@U;O#Q48zv`?b&Q6}a#}(cYXUExHvEMU$$Til}*E23! z`B!OQbn<8z&-yETiG(Q>=kxj8+fYtz6nMcky zUjx+^m#@~|P+;qmKY`0I+!%*I=OF4{r4{6Qj~W|t?lbGr=Fh4}1GOGyCfpjjS<(%Qk)v5l|TgPK}IUx`7?XG)MkCGVac5D>Nh*piL0bA38(JT@- zAWNkGIjc+9K6xa?Q18q{lk$uOXcr(Q#8ExwrIOwFxKAGb#S2`SXek^;=?JWhi8W;w z-fY%Sj9nNT80g#GGvF956}nt^U{`-g>2!z$sP0NAxH}+iWY!(}yNsXg2l=_&!Tzsf zm*^O{1kww3w~G~!8^#lNwo{I7w>#%&C+=x)tvP{%8l;*0+cqY>5zRJgk@!7v$u*&3 zxf`=0s9%*M_ z9~1MqC(tK3c-#}%B~B_W1)6VRwU=$Odq`nE_htr8L{VHrx%a_NLk^UM+8KITf0|+d zRUQl+K%I_2)Y2YDmF diff 0) + (setq specializers (nconc (copy-list specializers) + (make-list diff :initial-element 't))))) + (make-full-method-name (generic-function-name + (method-generic-function method)) + (method-qualifiers method) + specializers))) + +(defun make-full-method-name (generic-function-name qualifiers arg-types) + "Return the full name of a method, given the generic-function name, the method +qualifiers, and the arg-types" + ;; The name of the method is: + ;; ( .. + ;; (..)) + (labels ((remove-trailing-ts (l) + (if (null l) + nil + (let ((tail (remove-trailing-ts (cdr l)))) + (if (null tail) + (if (eq (car l) 't) + nil + (list (car l))) + (if (eq l tail) + l + (cons (car l) tail))))))) + `(,generic-function-name ,@qualifiers + ,(remove-trailing-ts arg-types)))) + +(defun parse-full-method-name (method-name) + "Parse the method name, returning the gf-name, the qualifiers, and the +arg-types." + (values (first method-name) + (butlast (rest method-name)) + (car (last method-name)))) + +(defun prompt-for-full-method-name (gf-name &optional has-def-p) + "Prompt the user for the full name of a method on the given generic function name" + (let ((method-names (generic-function-method-names gf-name has-def-p))) + (cond ((null method-names) + nil) + ((null (cdr method-names)) + (car method-names)) + (t (il:menu + (il:create + il:menu il:items il:_ ;If HAS-DEF-P, include only + ; those methods that have a + ; symbolic def'n that we can + ; find + (remove-if #'null + (mapcar #'(lambda (m) + (if (or (not has-def-p) + (il:hasdef m 'methods)) + `(,(with-output-to-string (s) + (dolist (x m) + (format s "~A " x)) + s) + ',m) + nil)) + method-names)) + il:title il:_ "Which method?")))))) + + +;;; Converting generic defining macros into DEFDEFINER macros + +(defmacro make-defdefiner (definer-name definer-type type-description &body + definer-options) + "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE" + (let ((old-definer-macro-name (intern (string-append definer-name + " old definition") + (symbol-package definer-name))) + (old-definer-macro-expander (intern (string-append definer-name + " old expander") + (symbol-package definer-name)))) + `(progn + ;; First, move the current defining function off to some safe + ;; place + (unmake-defdefiner ',definer-name) + (cond ((not (fboundp ',definer-name)) + (error "~A has no definition!" ',definer-name)) + ((fboundp ',old-definer-macro-name)) + ((macro-function ',definer-name) + ; We have to move the macro + ; expansion function as well, + ; so it won't get clobbered + ; when the original macro is + ; redefined. See AR 7410. + (let* ((expansion-function (macro-function ',definer-name))) + (setf (symbol-function ',old-definer-macro-expander) + (loop (if (symbolp expansion-function) + (setq expansion-function + (symbol-function expansion-function)) + (return expansion-function)))) + (setf (macro-function ',old-definer-macro-name) + ',old-definer-macro-expander) + (setf (get ',definer-name 'make-defdefiner) expansion-function))) + (t (error "~A does not name a macro." ',definer-name))) + ;; Make sure the type is defined + (xcl:def-define-type ,definer-type ,type-description) + ;; Now redefine the definer, using DEFEDFINER and the original def'n + (xcl:defdefiner ,(if definer-options + (cons definer-name definer-options) + definer-name) + ,definer-type (&body b) `(,',old-definer-macro-name ,@,'b))))) + +(defun unmake-defdefiner (definer-name) + (let ((old-expander (get definer-name 'make-defdefiner))) + (when old-expander + (setf (macro-function definer-name old-expander)) + (remprop definer-name 'make-defdefiner)))) + + +;;; For tricking ED into being able to use just the generic-function-name +;;; instead of the full method name + +(defun source-manager-method-edit-fn (name type source editcoms options) + "Edit a method of the given name" + (let ((full-name (if (gf-named name) + ;If given the name of a + ; generic-function, try to get + ; the full method name + (prompt-for-full-method-name name t) + ; Otherwise it should name the + ; method + name))) + (when (not (null full-name)) + (il:default.editdef full-name type source editcoms options)) + (or full-name name))) ;Return the name + +(defun source-manager-method-hasdef-fn (name type &optional source) + "Is there a method defined with the given name?" + (cond ((not (eq type 'methods)) nil) + ((or (symbolp name) + (and (consp name) + (eq (first name) 'setf) + (symbolp (second name)) + (null (cddr name)))) + ;; If passed in the name of a generic-function, pretend that + ;; there is a method by that name if there is a generic function + ;; by that name, and there is a method whose source we can find. + (if (and (not (null (gf-named name))) + (find-if #'(lambda (m) + (il:hasdef m type source)) + (generic-function-method-names name t))) + name + nil)) + ((and (consp name) (>= (length name) 2)) + ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*)) + (when (il:getdef name type source '(il:nocopy il:noerror)) + name)) + (t + ;; Nothing else can name a method + nil))) + +;;; Initialize the CLOS env + +(defun initialize-clos-env nil + "Initialize the Medley CLOS environment" + ;; Set up SourceManager DEFDEFINERS for classes and methods. + ;; + ;; Make sure to define methods before classes, so that (IL:FILES?) will build + ;; filecoms that have classes before methods. + (unless (il:hasdef 'methods 'il:filepkgtype) + (make-defdefiner defmethod methods "methods" + (:name (lambda (form) + (multiple-value-bind (name qualifiers arglist) + (parse-defmethod (cdr form)) + (make-full-method-name name qualifiers + (specialized-lambda-list-specializers + arglist))))) + (:undefiner + (lambda (method-name) + (multiple-value-bind + (name qualifiers arg-types) + (parse-full-method-name method-name) + (let* ((gf (gf-named name)) + (method (when gf + (get-method gf qualifiers + (mapcar #'find-class + arg-types))))) + (when method (remove-method gf method)))))))) + ;; Include support for DEFGENERIC, if that is defined + (unless (or (not (fboundp 'defgeneric)) + (il:hasdef 'generic-functions 'il:filepkgtype)) + (make-defdefiner defgeneric generic-functions "generic-function definitions")) + ;; DEFCLASS FileManager stuff + (unless (il:hasdef 'classes 'il:filepkgtype) + (make-defdefiner defclass classes "class definitions" + (:undefiner (lambda (name) + (when (find-class name t) + (setf (find-class name) nil))))) + ;; CLASSES "include" TYPES. + (il:filepkgcom 'classes 'il:contents + #'(lambda (com name type &optional reason) + (declare (ignore name reason)) + (if (member type '(il:types classes) :test #'eq) + (cdr com) + nil)))) + ;; Set up the hooks so that ED can be handed the name of a generic function, + ;; and end up editing a method instead + (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn + 'il:hasdef 'source-manager-method-hasdef-fn) + ;; Set up the inspect macro. The right way to do this is to + ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now... + (push '((il:function clos-object-p) . \\internal-inspect-object) + il:inspectmacros) + ;; Unmark any SourceManager changes caused by this loadup + (dolist (com (il:filepkgchanges)) + (dolist (name (cdr com)) + (when (and (symbolp name) + (eq (symbol-package name) (find-package "CLOS"))) + (il:unmarkaschanged name (car com)))))) + +(eval-when (eval load) + (initialize-clos-env)) + + +;;; Inspecting CLOS objects + +(defun clos-object-p (x) + "Is the datum a CLOS object?" + (or (std-instance-p x) + (fsc-instance-p x))) + +(defun \\internal-inspect-object (x type where) + (inspect-object x type where)) + +(defun \\internal-inspect-slot-names (x) + (inspect-slot-names x)) + +(defun \\internal-inspect-slot-value (x slot-name) + (inspect-slot-value x slot-name)) + +(defun \\internal-inspect-setf-slot-value (x slot-name value) + (inspect-setf-slot-value x slot-name value)) + +(defun \\internal-inspect-slot-name-command (slot-name x window) + (inspect-slot-name-command slot-name x window)) + +(defun \\internal-inspect-title (x y) + (inspect-title x y)) + +(defmethod inspect-object (x type where) + "Open an insect window on the object x" + (il:inspectw.create x '\\internal-inspect-slot-names + '\\internal-inspect-slot-value + '\\internal-inspect-setf-slot-value + '\\internal-inspect-slot-name-command nil nil + '\\internal-inspect-title nil where + #'(lambda (n v) ;Same effect as NIL, but avoids bug in + (declare (ignore v)) ; INSPECTW.CREATE + n))) + +(defmethod inspect-slot-names (x) + "Return a list of names of slots of the object that should be shown in the +inspector" + (mapcar #'(lambda (slotd) (slot-value slotd 'name)) + (slots-to-inspect (class-of x) x))) + +(defmethod inspect-slot-value (x slot-name) + (cond ((not (slot-exists-p x slot-name)) "** no such slot **") + ((not (slot-boundp x slot-name)) "** slot not bound **") + (t (slot-value x slot-name)))) + +(defmethod inspect-setf-slot-value (x slot-name value) + "Used by the inspector to set the value fo a slot" + ;; Make this UNDO-able + (il:undosave `(inspect-setf-slot-value ,x ,slot-name + ,(slot-value x slot-name))) + ;; Then change the value + (setf (slot-value x slot-name) value)) + +(defmethod inspect-slot-name-command (slot-name x window) + "Allows the user to select a menu item to change a slot value in an inspect +window" + ;; This code is a very slightly hacked version of the system function + ;; DEFAULT.INSPECTW.PROPCOMMANDFN. We have to do this because the + ;; standard version makes some nasty assumptions about + ;; structure-objects that are not true for CLOS objects. + (declare (special il:|SetPropertyMenu|)) + (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu) + il:|SetPropertyMenu|) + (t (il:setq il:|SetPropertyMenu| + (il:|create| il:menu il:items il:_ + '((set 'set + "Allows a new value to be entered" + ))))))) + (set + ;; The user want to set the value + (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name + window)) + il:newvalue il:pwindow) + (il:ttydisplaystream (il:setq il:pwindow + (il:getpromptwindow window 3))) + (il:clearbuf t t) + (il:resetlst + (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window) + (list 'il:\\itemw.flipitem + il:oldvalueitem window)) + (il:resetsave (il:tty.process (il:this.process))) + (il:resetsave (il:printlevel 4 3)) + (il:|printout| t "Enter the new " + slot-name " for " x t + "The expression read will be EVALuated." + t "> ") + (il:setq il:newvalue (il:lispx (il:lispxread t t) + '>)) + ; clear tty buffer because it + ; sometimes has stuff left. + (il:clearbuf t t)) + (il:closew il:pwindow) + (return (il:inspectw.replace window slot-name il:newvalue))))))) + +(defmethod inspect-title (x window) + "Return the title to use in an inspect window viewing x" + (format nil "Inspecting a ~A" (class-name (class-of x)))) + +(defmethod inspect-title ((x standard-class) window) + (format nil "Inspecting the class ~A" (class-name x))) + + +;;; Debugger support for CLOS + + +(il:filesload clos-env-internal) + +;; Non-CLOS specific changes to the debugger + +;; Redefining the standard INTERESTING-FRAME-P function. Now functions can be +;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP +;; property. + +(dolist (fn '(si::*unwind-protect* il:*env* + evalhook xcl::nohook xcl::undohook + xcl::execa0001 xcl::execa0001a0002 + xcl::|interpret-UNDOABLY| + cl::|interpret-IF| cl::|interpret-FLET| + cl::|interpret-LET| cl::|interpret-LETA0001| + cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001| + il:do-event il:eval-input + apply t)) + (setf (get fn 'xcl::uninterestingp) t)) + +(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg) + "Return TRUE iff the frame should be visible for a short backtrace." + (declare (special il:openfns)) + (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos))) + (typecase xcl::name + (symbol (case xcl::name + (il:*env* + ;; *ENV* is used by ENVEVAL etc. + nil) + (il:errorset + (or (<= (il:stknargs xcl::pos) 1) + (not (eq (il:stkarg 2 xcl::pos nil) + 'il:internal)))) + (il:eval + (or (<= (il:stknargs xcl::pos) 1) + (not (eq (il:stkarg 2 xcl::pos nil) + 'xcl::internal)))) + (il:apply + (or (<= (il:stknargs xcl::pos) 2) + (not (il:stkarg 3 xcl::pos nil)))) + (otherwise + (cond ((get xcl::name 'xcl::uninterestingp) + ;; Explicitly declared uninteresting. + nil) + ((eq (il:chcon1 xcl::name) (char-code #\\)) + ;; Implicitly declared uninteresting by starting the + ;; name with a "\". + nil) + ((or (member xcl::name il:openfns :test #'eq) + (eq xcl::name 'funcall)) + ;;The function won't be seen when compiled, so only show + ;;it if INTERPFLG it true + xcl::interpflg) + (t + ;; Interesting by default. + t))))) + (cons (case (car xcl::name) + (:broken t) + (otherwise nil))) + (otherwise nil)))) + +(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p) + + +(eval-when (eval compile) + (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name)))) + + +;; Change the frame inspector to open up lexical environments + + ;; Since the DEFSTRUCT is going to build the accessors in the package that is + ;; current at read-time, and we want the accessors to reside in the IL + ;; package, we have got to make sure that the defstruct happens when the + ;; package is IL. + +(in-package "IL") + +(cl:defstruct (frame-prop-name (:type cl:list)) + (label-fn 'nill) + (value-fn + (function + (lambda (prop-name framespec) + (frame-prop-name-data prop-name)))) + (setf-fn 'nill) + (inspect-fn + (function + (lambda (value prop-name framespec window) + (default.inspectw.valuecommandfn value prop-name (car framespec) window)))) + (data nil)) + +(cl:in-package "CLOS") + +(defun il:debugger-stack-frame-prop-names (il:framespec) + ;; Frame prop-names are structures of the form + ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA) + (let ((il:pos (car il:framespec)) + (il:backtrace-item (cadr il:framespec))) + (il:if (eq 'eval (il:stkname il:pos)) + il:then + (let ((il:expression (il:stkarg 1 il:pos)) + (il:environment (il:stkarg 2 il:pos))) + `(,(il:make-frame-prop-name :inspect-fn + (il:function + (il:lambda (il:value il:prop-name il:framespec il:window) + (il:inspect/as/function il:value (car il:framespec) il:window))) + :data il:expression) + ,(il:make-frame-prop-name :data "ENVIRONMENT") + ,@(il:for il:aspect il:in + `((,(and il:environment (il:environment-vars il:environment)) + "vars") + (,(and il:environment (il:environment-functions il:environment)) + "functions") + (,(and il:environment (il:environment-blocks il:environment)) + "blocks") + (,(and il:environment (il:environment-tagbodies il:environment)) + "tag bodies")) + il:bind il:group-name il:p-list + il:eachtime (il:setq il:group-name (cadr il:aspect)) + (il:setq il:p-list (car il:aspect)) + il:when (not (null il:p-list)) + il:join + `(,(il:make-frame-prop-name :data il:group-name) + ,@(il:for il:p il:on il:p-list il:by cddr il:collect + (il:make-frame-prop-name :label-fn + (il:function (il:lambda (il:prop-name il:framespec) + (car (il:frame-prop-name-data il:prop-name)))) + :value-fn + (il:function (il:lambda (il:prop-name il:framespec) + (cadr (il:frame-prop-name-data il:prop-name)))) + :setf-fn + (il:function (il:lambda (il:prop-name il:framespec il:new-value) + (il:change (cadr (il:frame-prop-name-data + il:prop-name)) + il:new-value))) + :data il:p)))))) + il:else + (flet ((il:build-name (&key il:arg-name il:arg-number) + (il:make-frame-prop-name :label-fn + (il:function (il:lambda (il:prop-name il:framespec) + (car (il:frame-prop-name-data il:prop-name)))) + :value-fn + (il:function (il:lambda (il:prop-name il:framespec) + (il:stkarg (cadr (il:frame-prop-name-data + il:prop-name)) + (car il:framespec)))) + :setf-fn + (il:function (il:lambda (il:prop-name il:framespec il:new-value) + (il:setstkarg (cadr (il:frame-prop-name-data + il:prop-name)) + (car il:framespec) + il:new-value))) + :data + (list il:arg-name il:arg-number)))) + (let ((il:nargs (il:stknargs il:pos t)) + (il:nargs1 (il:stknargs il:pos)) + (il:fnname (il:stkname il:pos)) + il:argname + (il:arglist)) + (and (il:litatom il:fnname) + (il:ccodep il:fnname) + (il:setq il:arglist (il:listp (il:smartarglist il:fnname)))) + `(,(il:make-frame-prop-name :inspect-fn + (il:function (il:lambda (il:value il:prop-name il:framespec + il:window) + (il:inspect/as/function il:value + (car il:framespec) + il:window))) + :data + (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item)) + ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect + (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist)) + lambda-list-keywords) + il:do + (il:setq il:mode il:argname)) + (il:build-name :arg-name + (or (il:stkargname il:i il:pos) + ; special + (if (case il:mode + ((nil &optional) il:argname) + (t nil)) + (string il:argname) + (il:concat "arg " (- il:i 1)))) + :arg-number il:i))) + ,@(let* ((il:novalue "No value") + (il:slots (il:for il:pvar il:from 0 il:as il:i il:from + (il:add1 il:nargs1) + il:to il:nargs il:by 1 il:when + (and (il:neq il:novalue (il:stkarg il:i il:pos + il:novalue)) + (or (il:setq il:argname (il:stkargname + il:i il:pos)) + (il:setq il:argname (il:concat + "local " + il:pvar))) + ) + il:collect + (il:build-name :arg-name il:argname + :arg-number il:i)))) + (and il:slots (cons (il:make-frame-prop-name :data "locals") + il:slots))))))))) + +(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name) + (il:apply* (il:frame-prop-name-value-fn il:prop-name) + il:prop-name il:framespec)) + +(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue) + (il:apply* (il:frame-prop-name-setf-fn il:prop-name) + il:prop-name il:framespec il:newvalue)) + +(defun il:debugger-stack-frame-value-command (il:datum il:prop-name + il:framespec il:window) + (il:apply* (il:frame-prop-name-inspect-fn il:prop-name) + il:datum il:prop-name il:framespec il:window)) + +(defun il:debugger-stack-frame-title (il:framespec &optional il:window) + (declare (ignore il:window)) + (il:concat (il:stkname (car il:framespec)) " Frame")) + +(defun il:debugger-stack-frame-property (il:prop-name il:framespec) + (il:apply* (il:frame-prop-name-label-fn il:prop-name) + il:prop-name il:framespec)) + +;; Teaching the debugger that there are other file-manager types that can +;; appear on the stack + +(defvar xcl::*function-types* '(il:fns il:functions) + "Manager types that can appear on the stack") + +;; Redefine a couple of system functions to use the above stuff + +#+Xerox-Lyric +(progn + +(defun il:attach-backtrace-menu (&optional (il:ttywindow + (il:wfromds (il:ttydisplaystream))) + il:skip) + (let ((il:bkmenu (il:|create| il:menu + il:items il:_ + (il:collect-backtrace-items il:ttywindow il:skip) + il:whenselectedfn il:_ + (il:function il:backtrace-item-selected) + il:whenheldfn il:_ + #'(il:lambda (il:item il:menu il:button) + (declare (ignore il:item il:menu)) + (case il:button + (il:left (il:promptprint + "Open a frame inspector on this stack frame" + )) + (il:middle (il:promptprint + "Inspect/Edit this function")) + )) + il:menuoutlinesize il:_ 0 + il:menufont il:_ il:backtracefont + il:menucolumns il:_ 1)) + (il:ttyregion (il:windowprop il:ttywindow 'il:region)) + il:btw) + (cond + ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow) + il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu)) + (eql (il:|fetch| (il:menu il:whenselectedfn) + il:|of| (car il:btw)) + (il:function il:backtrace-item-selected))) + il:|do| + (return il:atw))) + (il:deletemenu (car (il:windowprop il:btw 'il:menu)) + nil il:btw) + (il:windowprop il:btw 'il:extent nil) + (il:clearw il:btw)) + ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region) + (il:widthifwindow (il:imin (il:|fetch| (il:menu + il:imagewidth + ) + il:|of| il:bkmenu) + il:|MaxBkMenuWidth|)) + (il:|fetch| (il:region il:height) il:|of| il:ttyregion + ) + 'il:left))) + (il:attachwindow il:btw il:ttywindow (cond + ((il:igreaterp (il:|fetch| (il:region il:left) + il:|of| (il:windowprop + il:btw + 'il:region)) + (il:|fetch| (il:region il:left) + il:|of| il:ttyregion)) + 'il:right) + (t 'il:left)) + nil + 'il:localclose) + (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process)) + + )) + (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position + il:xcoord il:_ 0 + il:ycoord il:_ (il:idifference (il:windowprop + il:btw + 'il:height) + (il:|fetch| (il:menu il:imageheight + ) il:|of| + il:bkmenu + )))))) + +(defun il:backtrace-item-selected (il:item il:menu il:button) + (il:resetlst + (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow + (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item) + + )) + (cond + ((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu)) + (il:menudeselect il:olditem il:menu) + )) + (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu) + 'il:mainwindow)) + (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position)) + (il:setq il:pos (il:stknth (- il:framespecn) + il:bkpos)) + (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos))) + (and il:lp (il:stknth 0 il:pos il:lp))) + (il:menuselect il:item il:menu) + (if (eq il:button 'il:middle) + (progn + + + (il:resetsave nil (list 'il:relstk il:pos)) + (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name) + il:|of| il:item) + il:pos il:ttywindow)) + (progn + + + (il:setq il:framewindow + (xcl:with-profile (il:process.eval + (il:windowprop il:ttywindow 'il:process) + '(let ((il:profile (xcl:copy-profile (xcl:find-profile + "READ-PRINT")))) + (setf (xcl::profile-entry-value ' + xcl:*eval-function* il:profile) + xcl:*eval-function*) + (xcl:save-profile il:profile)) + t) + (il:inspectw.create (list il:pos il:item) + 'il:debugger-stack-frame-prop-names + 'il:debugger-stack-frame-fetchfn + 'il:debugger-stack-frame-storefn nil ' + il:debugger-stack-frame-value-command nil ' + il:debugger-stack-frame-title nil ( + il:make-frame-inspect-window + il:ttywindow) + 'il:debugger-stack-frame-property))) + (cond + ((not (il:windowprop il:framewindow 'il:mainwindow)) + (il:attachwindow il:framewindow il:ttywindow + (cond + ((il:igreaterp (il:|fetch| (il:region il:bottom) + il:|of| (il:windowprop il:framewindow + 'il:region)) + (il:|fetch| (il:region il:bottom) + il:|of| (il:windowprop il:ttywindow 'il:region))) + 'il:top) + (t 'il:bottom)) + nil + 'il:localclose) + (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow + )))))) + (return)))) + +(defun il:collect-backtrace-items (xcl::tty-window xcl::skip) + (let* ((xcl::items (cons nil nil)) + (xcl::items-tail xcl::items)) + (macrolet ((xcl::collect-item (xcl::new-item) + `(progn (setf (rest xcl::items-tail) + (cons ,xcl::new-item nil)) + (pop xcl::items-tail)))) + (let* ((xcl::filter-fn (cond + ((null xcl::skip) + #'xcl:true) + ((eq xcl::skip t) + il:*short-backtrace-filter*) + (t xcl::skip))) + (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window ' + il:stack-position))) + (xcl::next-frame xcl::top-frame) + (xcl::frame-number 0) + xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label) + (loop (when (null xcl::next-frame) + (return)) + (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed + xcl::use-frame xcl::label) + (funcall xcl::filter-fn xcl::next-frame)) + (when (null xcl::last-frame-consumed) + + (setf xcl::last-frame-consumed xcl::next-frame)) + (when xcl::interesting-p + (when (null xcl::use-frame) + (setf xcl::use-frame xcl::last-frame-consumed)) + + (when (null xcl::label) + (setf xcl::label (il:stkname xcl::use-frame)) + (if (member xcl::label '(eval il:eval il:apply apply) + :test + 'eq) + (setf xcl::label (il:stkarg 1 xcl::use-frame)))) + + (loop (cond + ((not (typep xcl::next-frame 'il:stackp)) + (error "~%Use-frame ~S not found" xcl::use-frame)) + ((xcl::stack-eql xcl::next-frame xcl::use-frame) + (return)) + (t (incf xcl::frame-number) + (setf xcl::next-frame (il:stknth -1 xcl::next-frame + xcl::next-frame))))) + + (xcl::collect-item (il:|create| il:bkmenuitem + il:label il:_ (let ((*print-level* 2) + (*print-length* 3) + (*print-escape* t) + (*print-gensym* t) + (*print-pretty* nil) + (*print-circle* nil) + (*print-radix* 10) + (*print-array* nil) + (il:*print-structure* + nil)) + (prin1-to-string + xcl::label)) + il:bkmenuinfo il:_ xcl::frame-number + il:frame-name il:_ xcl::label))) + + (loop (cond + ((not (typep xcl::next-frame 'il:stackp)) + (error "~%Last-frame-consumed ~S not found" + xcl::last-frame-consumed)) + ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed + ) + (incf xcl::frame-number) + (setf xcl::next-frame (il:stknth -1 xcl::next-frame + + xcl::next-frame))) + (return))))))) + (rest xcl::items))) + +) +#+Xerox-Medley +(progn + +(defun dbg::attach-backtrace-menu (&optional tty-window skip) + (declare (special il:\\term.ofd il:backtracefont)) + (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream)))) + (prog (btw bkmenu + (tty-region (il:windowprop tty-window 'il:region)) + ;; And, for the FORMAT below... + (*print-level* 2) + (*print-length* 3) + (*print-escape* t) + (*print-gensym* t) + (*print-pretty* nil) + (*print-circle* nil) + (*print-radix* 10) + (*print-array* nil) + (il:*print-structure* nil)) + (setq bkmenu + (il:|create| il:menu + il:items il:_ (dbg::collect-backtrace-items tty-window skip) + il:whenselectedfn il:_ 'dbg::backtrace-item-selected + il:menuoutlinesize il:_ 0 + il:menufont il:_ il:backtracefont + il:menucolumns il:_ 1 + il:whenheldfn il:_ + #'(il:lambda (item menu button) + (declare (ignore item menu)) + (case button + (il:left + (il:promptprint + "Open a frame inspector on this stack frame")) + (il:middle + (il:promptprint "Inspect/Edit this function")))))) + (cond ((setq btw + (dolist (atw (il:attachedwindows tty-window)) + ;; Test for an attached window that has a backtrace menu in + ;; it. + (when (and (setq btw (il:windowprop atw 'il:menu)) + (eq (il:|fetch| (il:menu il:whenselectedfn) + il:|of| (car btw)) + 'dbg::backtrace-item-selected)) + (return atw)))) + ;; If there is alread a backtrace window, delete the old menu from + ;; it. + (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw) + (il:windowprop btw 'il:extent nil) + (il:clearw btw)) + ((setq btw + (il:createw (dbg::region-next-to + (il:windowprop tty-window 'il:region) + (il:widthifwindow + (il:imin (il:|fetch| (il:menu il:imagewidth) + il:|of| bkmenu) + il:|MaxBkMenuWidth|)) + (il:|fetch| (il:region il:height) + il:|of| tty-region) + :left))) + ; put bt window at left of TTY + ; window unless ttywindow is + ; near left edge. + (il:attachwindow btw tty-window + (if (il:igreaterp (il:|fetch| (il:region il:left) + il:|of| + (il:windowprop btw + 'il:region)) + (il:|fetch| (il:region il:left) + il:|of| tty-region)) + 'il:right + 'il:left) + nil + 'il:localclose) + ;; So that button clicks will switch the TTY + (il:windowprop btw 'il:process + (il:windowprop tty-window 'il:process)))) + (il:addmenu bkmenu btw (il:|create| il:position + il:xcoord il:_ 0 + il:ycoord il:_ (- (il:windowprop btw 'il:height) + (il:|fetch| (il:menu + il:imageheight) + il:|of| bkmenu)))) + ;; IL:ADDMENU sets up buttoneventfn for window that we don't + ;; want. We want to catch middle button events before the menu + ;; handler, so that we can pop up edit/inspect menu for the frame + ;; currently selected. So replace the buttoneventfn, and can + ;; nuke the cursorin and cursormoved guys, cause don't need them. + (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn) + (il:windowprop btw 'il:cursorinfn nil) + (il:windowprop btw 'il:cursormovedfn nil))) + +(defun dbg::collect-backtrace-items (tty-window skip) + (xcl:with-collection + ;; + ;; There are a number of possibilities for the values returned by the + ;; filter-fn. + ;; + ;; (1) INTERESTING-P is false, and the other values are all NIL. This + ;; is the simple case where the stack frame NEXT-POS should be ignored + ;; completly, and processing should continue with the next frame. + ;; + ;; (2) INTERESTING-P is true, and the other values are all NIL. This + ;; is the simple case where the stack frame NEXT-POS should appear in + ;; the backtrace as is, and processing should continue with the next + ;; frame. + ;; + ;; [Note that these two cases take care of old values of the + ;; filter-fn.] + ;; + ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack + ;; frame. In that case, ignore all stack frames from NEXT-POS to + ;; LAST-FRAME-CONSUMED, inclusive. + ;; + ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack + ;; frame. In this case, the backtrace should include a single entry + ;; coresponding to the frame USE-FRAME (which defaults to + ;; LAST-FRAME-CONSUMED), and processing should continue with the next + ;; frame after LAST-FRAME-CONSUMED. If LABEL is non-NIL, it will be + ;; the label that appears in the backtrace menu; otherwise the name of + ;; USE-FRAME will be used (or the form being EVALed if the frame is an + ;; EVAL frame). + ;; + (let* ((filter (cond ((null skip) #'xcl:true) + ((eq skip t) il:*short-backtrace-filter*) + (t skip))) + (top-frame (il:stknth 0 (il:getwindowprop tty-window + 'dbg::stack-position))) + (next-frame top-frame) + (frame-number 0) + interestingp last-frame-consumed frame-to-use label-to-use) + (loop (when (null next-frame) (return)) + ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED, + ;; FRAME-TO-USE, and LABEL-TO-USE + (multiple-value-setq (interestingp last-frame-consumed + frame-to-use label-to-use) + (funcall filter next-frame)) + (when (null last-frame-consumed) + (setf last-frame-consumed next-frame)) + (when interestingp + (when (null frame-to-use) + (setf frame-to-use last-frame-consumed)) + (when (null label-to-use) + (setf label-to-use (il:stkname frame-to-use)) + (if (member label-to-use '(eval il:eval il:apply apply) + :test 'eq) + (setf label-to-use (il:stkarg 1 frame-to-use)))) + + ;; Walk the stack until we find the frame to use + (loop (cond ((not (typep next-frame 'il:stackp)) + (error "~%Use-frame ~S not found" frame-to-use)) + ((xcl::stack-eql next-frame frame-to-use) + (return)) + (t (incf frame-number) + (setf next-frame + (il:stknth -1 next-frame next-frame))))) + + ;; Add the menu item to the list under construction + (xcl:collect (il:|create| il:bkmenuitem + il:label il:_ (let ((*print-level* 2) + (*print-length* 3) + (*print-escape* t) + (*print-gensym* t) + (*print-pretty* nil) + (*print-circle* nil) + (*print-radix* 10) + (*print-array* nil) + (il:*print-structure* nil)) + (prin1-to-string label-to-use)) + il:bkmenuinfo il:_ frame-number + il:frame-name il:_ label-to-use))) + + ;; Update NEXT-POS + (loop (cond ((not (typep next-frame 'il:stackp)) + (error "~%Last-frame-consumed ~S not found" + last-frame-consumed)) + ((prog1 + (xcl::stack-eql next-frame last-frame-consumed) + (incf frame-number) + (setf next-frame (il:stknth -1 next-frame + next-frame))) + (return)))))))) + +(defun dbg::backtrace-menu-buttoneventfn (window &aux menu) + (setq menu (car (il:listp (il:windowprop window 'il:menu)))) + (unless (or (il:lastmousestate il:up) (null menu)) + (il:totopw window) + (cond ((il:lastmousestate il:middle) + ;; look for a selected frame in this menu, and then pop up + ;; the editor invoke menu for that frame. don't change the + ;; selection, just present the edit menu. + (let* ((selection (il:menu.handler menu + (il:windowprop window 'il:dsp))) + (tty-window (il:windowprop window 'il:mainwindow)) + (last-pos (il:windowprop tty-window 'dbg::lastpos))) + + ;; don't have to worry about releasing POS because we + ;; only look at it here (nobody here hangs on to it) + ;; and we will be around for less time than LASTPOS. + ;; The debugger is responsible for releasing LASTPOS. + (il:inspect/as/function (cond + ((and selection + (il:|fetch| (il:bkmenuitem il:frame-name) + il:|of| (car selection)))) + ((and (symbolp (il:stkname last-pos)) + (il:getd (il:stkname last-pos))) + (il:stkname last-pos)) + (t 'il:nill)) + last-pos tty-window))) + (t (let ((selection (il:menu.handler menu + (il:windowprop window 'il:dsp)))) + (when selection + (il:doselecteditem menu (car selection) (cdr selection)))))))) + +;; This function isn't really redefined, but it needs to be recomiled since we +;; changed the def'n of the BKMENUITEM record. + +(defun dbg::backtrace-item-selected (item menu button) + ;;When a frame name is selected in the backtrace menu, this is the function + ;;that gets called. + (declare (special il:brkenv) (ignore button)) + (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item)) + (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow)) + (bkpos (il:windowprop tty-window 'dbg::stack-position)) + (pos (il:stknth (- frame-spec) bkpos))) + (let ((lp (il:windowprop tty-window 'dbg::lastpos))) + (and lp (il:stknth 0 pos lp))) + ;; change the item selected from OLDITEM to ITEM. Only do this on left + ;; buttons now. Middle just pops up the edit menu, doesn't select. -woz + (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu))) + (when old-item (il:menudeselect old-item menu)) + (il:menuselect item menu)) + ;; Change the lexical environment so it is the one in effect as of this + ;; frame. + (il:process.eval (il:windowprop tty-window (quote dbg::process)) + `(setq il:brkenv ',(il:find-lexical-environment pos)) + t) + (let ((frame-window (xcl:with-profile + (il:process.eval (il:windowprop tty-window + 'il:process) + `(let ((profile (xcl:copy-profile + (xcl:find-profile + "READ-PRINT")))) + (setf + (xcl::profile-entry-value + 'xcl:*eval-function* profile) + xcl:*eval-function*) + (xcl:save-profile profile)) + t) + (il:inspectw.create pos + #'(lambda (pos) + (dbg::stack-frame-properties pos t)) + 'dbg::stack-frame-fetchfn + 'dbg::stack-frame-storefn + nil + 'dbg::stack-frame-value-command + nil + (format nil "~S Frame" (il:stkname pos)) + nil (dbg::make-frame-inspect-window + tty-window) + 'dbg::stack-frame-property)))) + (when (not (il:windowprop frame-window 'il:mainwindow)) + (il:attachwindow frame-window tty-window + (if (> (il:|fetch| (il:region il:bottom) il:|of| + (il:windowprop frame-window 'il:region)) + (il:|fetch| (il:region il:bottom) il:|of| + (il:windowprop tty-window 'il:region))) + 'il:top 'il:bottom) + nil 'il:localclose) + (il:windowaddprop frame-window 'il:closefn 'il:detachwindow))))) + +) ;end of Xerox-Medley + +(defun il:select.fns.editor (&optional function) + ;; gives the user a menu choice of editors. + (il:menu (il:|create| il:menu + il:items il:_ (cond ((il:ccodep function) + '((il:|InspectCode| 'il:inspectcode + "Shows the compiled code.") + (il:|DisplayEdit| 'ed + "Edit it with the display editor") + (il:|TtyEdit| 'il:ef + "Edit it with the standard editor"))) + ((il:closure-p function) + '((il:|Inspect| 'inspect + "Inspect this object"))) + (t '((il:|DisplayEdit| 'ed + "Edit it with the display editor") + (il:|TtyEdit| 'il:ef + "Edit it with the standard editor")))) + il:centerflg il:_ t))) + +;; + + +;; CLOS specific extensions to the debugger + + +;; There are some new things that act as functions, and that we want to be +;; able to edit from a backtrace window + +(pushnew 'methods xcl::*function-types*) + +(eval-when (eval compile load) + (unless (generic-function-p (symbol-function 'il:inspect/as/function)) + (make-specializable 'il:inspect/as/function))) + +(defmethod il:inspect/as/function (name stack-pointer debugger-window) + ;; Calls an editor on function NAME. STKP and WINDOW are the stack pointer + ;; and window of the break in which this inspect command was called. + (declare (ignore debugger-window)) + (let ((editor (il:select.fns.editor name))) + (case editor + ((nil) + ;; No editor chosen, so don't do anything + nil) + (il:inspectcode + ;; Inspect the compiled code + (let ((frame (xcl::stack-pointer-frame stack-pointer))) + (if (and (il:stackp stack-pointer) + (xcl::stack-frame-valid-p frame)) + (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame))) + (cond ((eq (il:\\get-compiled-code-base name) + code-base) + name) + (t + ;; Function executing in this frame is not + ;; the one in the definition cell of its + ;; name, so fetch the real code. Have to + ;; pass a CCODEP + (il:make-compiled-closure code-base)))) + nil nil nil (xcl::stack-frame-pc frame)) + (il:inspectcode name)))) + (ed + ;; Use the standard editor. + ;; This used to take care to apply the editor in the debugger + ;; process, so forms evaluated in the editor happen in the + ;; context of the break. But that doesn't count for much any + ;; more, now that lexical variables are the way to go. Better to + ;; use the LEX debugger command (thank you, Herbie) and + ;; shift-select pieces of code from the editor into the debugger + ;; window. + (ed name `(,@xcl::*function-types* :display))) + (otherwise (funcall editor name))))) + +(defmethod il:inspect/as/function ((name standard-object) stkp window) + (when (il:menu (il:|create| il:menu + il:items il:_ '(("Inspect" t "Inspect this object")))) + (inspect name))) + +(defmethod il:inspect/as/function ((x standard-method) stkp window) + (let* ((generic-function-name (slot-value (slot-value x 'generic-function) + 'name)) + (method-name (full-method-name x)) + (editor (il:select.fns.editor method-name))) + (il:allow.button.events) + (case editor + (ed (ed method-name '(:display methods))) + (il:inspectcode (il:inspectcode (slot-value x 'function))) + ((nil) nil) + (otherwise (funcall editor method-name))))) + +;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods +;; and generic-functions on the stack. + +(defun interesting-frame-p (stack-pos &optional interp-flag) + ;; Return up to four values: INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and + ;; LABEL. See the function IL:COLLECT-BACKTRACE-ITEMS for a full description + ;; of how these values are used. + (labels + ((function-matches-frame-p (function frame) + "Is the function being called in this frame?" + (let* ((frame-name (il:stkname frame)) + (code-being-run (cond + ((typep frame-name 'il:closure) + frame-name) + ((and (consp frame-name) + (eq 'il:\\interpreter + (xcl::stack-frame-name + (il:\\stackargptr frame)))) + frame-name) + (t (xcl::stack-frame-fn-header + (il:\\stackargptr frame)))))) + (or (eq function code-being-run) + (and (typep function 'il:compiled-closure) + (eq (xcl::compiled-closure-fnheader function) + code-being-run))))) + (generic-function-from-frame (frame) + "If this the frame of a generic function return the gf, otherwise + return NIL." + ;; Generic functions are implemented as compiled closures. On the + ;; stack, we only see the fnheader for the the closure. This could + ;; be a discriminator code, or in the default method only case it + ;; will be the actual method function. To tell if this is a generic + ;; function frame, we have to check very carefully to see if the + ;; right stuff is on the stack. Specifically, the closure's ccode, + ;; and the first local variable has to be a ptrhunk big enough to be + ;; a FIN environment, and fin-env-fin of that ptrhunk has to point + ;; to a generic function whose ccode and environment match. + (let ((n-args (il:stknargs frame)) + (env nil) + (gf nil)) + (if (and ;; is there at least one local? + (> (il:stknargs frame t) n-args) + ;; and does the local contain something that might be + ;; the closure environment of a funcallable instance? + (setf env (il:stkarg (1+ n-args) frame)) + ;; and does the local contain something that might be + ;; the closure environment of a funcallable instance? + (typep env *fin-env-type*) + (setf gf (fin-env-fin env)) + ;; whose fin-env-fin points to a generic function? + (generic-function-p gf) + ;; whose environment is the same as env? + (eq (xcl::compiled-closure-env gf) env) + ;; and whose code is the same as the code for this + ;; frame? + (function-matches-frame-p gf frame)) + gf + nil)))) + (let ((frame-name (il:stkname stack-pos))) + ;; See if there is a generic-function on the stack at this + ;; location. + (let ((gf (generic-function-from-frame stack-pos))) + (when gf + (return-from interesting-frame-p (values t stack-pos stack-pos gf)))) + ;; See if this is an interpreted method. The method body is + ;; wrapped in a (BLOCK ...). We look for an + ;; interpreted call to BLOCK whose block-name is the name of + ;; generic-function. + (when (and (eq frame-name 'eval) + (consp (il:stkarg 1 stack-pos)) + (eq (first (il:stkarg 1 stack-pos)) 'block) + (symbolp (second (il:stkarg 1 stack-pos))) + (fboundp (second (il:stkarg 1 stack-pos))) + (generic-function-p + (symbol-function (second (il:stkarg 1 stack-pos))))) + (let* ((form (il:stkarg 1 stack-pos)) + (block-name (second form)) + (generic-function (symbol-function block-name)) + (methods (generic-function-methods (symbol-function block-name)))) + ;; If this is really a method being called from a + ;; generic-function, the g-f should be no more than a + ;; few(?) frames up the stack. Check for the method call + ;; by looking for a call to APPLY, where the function + ;; being applied is the code in one of the methods. + (do ((i 100 (1- i)) + (previous-pos stack-pos current-pos) + (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos)) + (found-method nil) + (method-pos)) + ((or (null current-pos) (<= i 0)) nil) + (cond ((equalp generic-function + (generic-function-from-frame current-pos)) + (if found-method + (return-from interesting-frame-p + (values t previous-pos method-pos found-method)) + (return))) + (found-method nil) + ((eq (il:stkname current-pos) 'apply) + (dolist (method methods) + (when (eq (method-function method) + (il:stkarg 1 current-pos)) + (setq method-pos current-pos) + (setq found-method method) + (return)))))))) + ;; Try to handle compiled methods + (when (and (symbolp frame-name) + (not (fboundp frame-name)) + (eq (il:chcon1 frame-name) + (il:charcode il:\()) + (or (string-equal "(method " (symbol-name frame-name) + :start2 0 :end2 13) + (string-equal "(method " (symbol-name frame-name) + :start2 0 :end2 12) + (string-equal "(method " (symbol-name frame-name) + :start2 0 :end2 8))) + ;; Looks like a name that CLOS consed up. See if there is a + ;; GF nearby up the stack. If there is, use it to help + ;; determine which method we have. + (do ((i 30 (1- i)) + (current-pos (il:stknth -1 stack-pos) + (il:stknth -1 current-pos)) + (gf)) + ((or (null current-pos) + (<= i 0)) + nil) + (setq gf (generic-function-from-frame current-pos)) + (when gf + (dolist (method (generic-function-methods gf)) + (when (function-matches-frame-p (method-function method) + stack-pos) + (return-from interesting-frame-p + (values t stack-pos stack-pos method)))) + (return)))) + ;; If we haven't already returned, use the default method. + (xcl::interesting-frame-p stack-pos interp-flag)))) + + +(setq il:*short-backtrace-filter* 'interesting-frame-p) + +;;; Support for undo + + (defun undoable-setf-slot-value (object slot-name new-value) + (if (slot-boundp object slot-name) + (il:undosave (list 'undoable-setf-slot-value + object slot-name (slot-value object slot-name))) + (il:undosave (list 'slot-makunbound object slot-name))) + (setf (slot-value object slot-name) new-value)) + + (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value) + + +;;; Support for ?= and friends + +;; The arglists for generic-functions are built using gensyms, and don't reflect +;; any keywords (they are all included in an &REST arg). Rather then use the +;; arglist in the code, we use the one that CLOS kindly keeps in the generic-function. + +(xcl:advise-function 'il:smartarglist + '(if (and il:explainflg + (symbolp il:fn) + (fboundp il:fn) + (generic-function-p (symbol-function il:fn))) + (generic-function-pretty-arglist (symbol-function il:fn)) + (xcl:inner)) + :when :around :priority :last) + +(setf (get 'defclass 'il:argnames) + '(nil (class-name (#\{ superclass-name #\} #\*) + (#\{ slot-specifier #\} #\*) + #\{ slot-option #\} #\*))) + +(setf (get 'defmethod 'il:argnames) + '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\* + specialized-lambda-list #\{ declaration #\| doc-string #\} #\* + #\{ form #\} #\*))) + +;;; Prettyprinting support, the result of Harley Davis. + +;; Support the standard Prettyprinter. This is really minimal right now. If +;; anybody wants to fix this, I'd be happy to include their code. In fact, +;; there is almost no support for Commonlisp in the standard Prettyprinter, so +;; the field is wide open to hackers with time on their hands. + + +(setf (get 'defmethod :definition-print-template) ;Not quite right, since it + '(:name :arglist :body)) ; doesn't handle qualifiers, + ; but it will have to do. + +(defun defclass-prettyprint (form) + (let ((left (il:dspxposition)) + (char-width (il:charwidth (il:charcode x) *standard-output*))) + (xcl:destructuring-bind (defclass name supers slots . options) form + (princ "(") + (prin1 defclass) + (princ " ") + (prin1 name) + (princ " ") + (if (null supers) + (princ "()") ;Print "()" instead of "nil" + (il:sequential.prettyprint (list supers) (il:dspxposition))) + (if (null slots) + (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*) + (princ "()")) + (il:sequential.prettyprint (list slots) (+ left (* 4 char-width)))) + (when options + (il:sequential.prettyprint options (+ left (* 2 char-width)))) + (princ ")") + nil))) + +(let ((pprint-macro (assoc 'defclass il:prettyprintmacros))) + (if (null pprint-macro) + (push (cons 'defclass 'defclass-prettyprint) + il:prettyprintmacros) + (setf (cdr pprint-macro) 'defclass-prettyprint))) + +(defun binder-prettyprint (form) + ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS + ;; that are of the form (fn (var ...) form &rest body). + ;; This code is far from correct, but it's better than nothing. + (if (and (consp form) + (not (null (cdddr form)))) + ;; I have no idea what I'm doing here. Seems I can copy and edit somebody + ;; elses code without understanding it. + (let ((body-indent (+ (il:dspxposition) + (* 2 (il:charwidth (il:charcode x) + *standard-output*)))) + (form-indent (+ (il:dspxposition) + (* 4 (il:charwidth (il:charcode x) + *standard-output*))))) + (princ "(") + (prin1 (first form)) + (princ " ") + (il:superprint (second form) form nil *standard-output*) + (il:sequential.prettyprint (list (third form)) form-indent) + (il:sequential.prettyprint (cdddr form) body-indent) + (princ ")") + nil) ;Return NIL to indicate that we did + ; the printing + t)) ;Return true to use default printing + + +(dolist (fn '(multiple-value-bind with-accessors with-slots)) + (let ((pprint-macro (assoc fn 'il:prettyprintmacros))) + (if (null pprint-macro) + (push (cons fn 'binder-prettyprint) + il:prettyprintmacros) + (setf (cdr pprint-macro) 'binder-prettyprint)))) + + + +;; SEdit has its own prettyprinter, so we need to support that too. This is due +;; to Harley Davis. Really. + +(push (cons :slot-spec + '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0) + (sedit::set-indent . 1) + (sedit::next-inline? 1 break sedit::from-indent . 1) + (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0)) + ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0) + (sedit::set-indent . 1) + (sedit::next-inline? 1 break sedit::from-indent . 1) + (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0)))) + sedit:*indent-alist*) + +(setf (sedit:get-format :slot-spec) + '(:indent :slot-spec :inline t)) + +(setf (sedit:get-format :slot-spec-list) + '(:indent :binding-list :args (:slot-spec) :inline nil)) + +(setf (sedit:get-format 'defclass) + '(:indent ((2) 1) + :args (:keyword nil nil :slot-spec-list nil) + :sublists (4))) + +(setf (sedit:get-format 'defmethod) + '(:indent ((2)) + :args (:keyword nil :lambda-list nil) + :sublists (3))) + +(setf (sedit:get-format 'defgeneric) 'defun) + +(setf (sedit:get-format 'generic-flet) 'flet) + +(setf (sedit:get-format 'generic-labels) 'flet) + +(setf (sedit:get-format 'call-next-method) + '(:indent (1) :args (:keyword nil))) + +(setf (sedit:get-format 'symbol-macrolet) 'let) + +(setf (sedit:get-format 'with-accessors) + '(:indent ((1) 1) + :args (:keyword :binding-list nil) + :sublists (2) + :miser :never)) + +(setf (sedit:get-format 'with-slots) 'with-accessors) + +(setf (sedit:get-format 'make-instance) + '(:indent ((1)) + :args (:keyword nil :slot-spec-list))) + +(setf (sedit:get-format '*make-instance) 'make-instance) + +;;; PrettyFileIndex stuff, the product of Harley Davis. + +(defvar *pfi-class-type* '(class defclass pfi-class-namer)) + +(defvar *pfi-method-type* '(method defmethod pfi-method-namer) + "Handles method for prettyfileindex") + +(defvar *pfi-index-accessors* nil + "t -> each slot accessor gets a listing in the index.") + +(defvar *pfi-method-index* :group + ":group, :separate, :both, or nil") + +(defun pfi-add-class-type () + (pushnew *pfi-class-type* il:*pfi-types*)) + +(defun pfi-add-method-type () + (pushnew *pfi-method-type* il:*pfi-types*)) + +(defun pfi-class-namer (expression entry) + (let ((class-name (second expression))) + ;; Following adds all slot readers/writers/accessors as separate entries in + ;; the index. Probably a mistake. + (if *pfi-index-accessors* + (let ((slot-list (fourth expression)) + (accessor-names nil)) + (labels ((add-accessor (method-index name-index) + (push (case *pfi-method-index* + (:group method-index) + (:separate name-index) + ((t :both) (list method-index name-index)) + ((nil) nil) + (otherwise (error "Illegal value for *pfi-method-index*: ~S" + *pfi-method-index*))) + accessor-names)) + (add-reader (reader-name) + (add-accessor `(method (,reader-name (,class-name))) + `(,reader-name (,class-name)))) + (add-writer (writer-name) + (add-accessor `(method ((setf ,writer-name) (t ,class-name))) + `((setf ,writer-name) (t ,class-name))))) + (dolist (slot-def slot-list) + (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args)) + (slot-arg (first rest-slot-args) (first rest-slot-args))) + ((null rest-slot-args)) + (case slot-arg + (:reader (add-reader (second rest-slot-args))) + (:writer (add-writer (second rest-slot-args))) + (:accessor (add-reader (second rest-slot-args)) + (add-writer (second rest-slot-args))) + (otherwise nil)))) + (cons `(class (,class-name)) accessor-names))) + class-name))) + +(defun pfi-method-namer (expression entry) + (let ((method-name (second expression)) + (specializers nil) + (qualifiers nil) + lambda-list) + (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers)) + (qualifier (first rest-qualifiers) (first rest-qualifiers))) + ((listp qualifier) (setq lambda-list qualifier) + (setq qualifiers (reverse qualifiers)) qualifiers) + (push qualifier qualifiers)) + (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list)) + (arg (first rest-lambda-list) (first rest-lambda-list))) + ((or (member arg lambda-list-keywords) (null rest-lambda-list)) + (setq specializers (reverse specializers))) + (push (if (listp arg) (second arg) t) specializers)) + (let ((method-index `(method (,method-name ,@qualifiers ,specializers))) + (name-index `(,method-name ,@qualifiers ,specializers))) + (case *pfi-method-index* + (:group method-index) + (:separate name-index) + ((t :both) (list method-index name-index)) + ((nil) nil) + (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*)))))) + +(defun pfi-install-clos () + (pfi-add-method-type) + (pfi-add-class-type)) + +(eval-when (eval load) + (when (boundp (quote il:*pfi-types*)) + (pfi-install-clos)) + ) diff --git a/clos/3.5/combin.dfasl b/clos/3.5/combin.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..5013db78c56c4198c53188f81bb2eada6591f4f8 GIT binary patch literal 6934 zcmd@ZTWlQFb?(@)vySboW0R!gB%TlwNXQsFB+!^(cDy_Gj(7IK&Tg>7BigLj%!2K; z`~X>PqYx66R*S%SvA2*4XvIfSD-($-P6BSJP?evmQc=~aEp1Vysvo7O{pd#(rRSWx zFMHPnKKj*FGWUJ%d7pcZ=cTnnUQ6|6#wXKbsVOxxJ2N>uqmE{#)alIZR5GQG!o2!5 zpB?zdq4;!aYPvTuH9PTaYAosW+JRwT)I4nT`oi9L&a|Qe((ARtcCR-c zjlz6yGBbWGJ<&Oqo}PT5yU8wtoSaG}W>O<+Y&JDLl9=18?mM6k&Q7G%?t=%r_p06Z z_U!NO={nfi)UVr?K&Eh{e=1EU_N%^BGBth-(BId!uL}+x?Ad=`PghrG)6I*y3sU2g z68v2FaZ9NhTboqY^|#55xc_Ndax^!f z=Jx0Wxi}~BhP9F;a|Z0sos~gO14hV*n%)vGv$g%W8qzK9 zf)moe;Y8zr5i5cd)4v5dueXPTePOG(g4=%%+nebEAIMVk>Q)}kJFswDX~EKieLh_S zm5&L4--h+|E3|;S#$oo36|-8%Fnl(AhhllPv9$V)KWhd-ho5ukl)*+c6 z!Q4il(XYp?m=-hanC1_oS7C?NxU>{l15+U6b(t}2k%;lKL{UKJ5^0dp$K*Iyv1?a+p4&o2?nIXVH zh#a{@*GV_{L2#yQ8*z#}jPMZD9h&#MouurRYS2$^-!ou^`*f?)ErLmdts&JQW>CAs zdQ`pTW(IO5w{SvkK`rYG$3wmdI_R~LXxMA%W{@@V9&pj%HeSls+Y!TSg4y>-KbA;4@ z;>KX1TPqXNz@nb^P(aRk^6?mAbJQctmmc)UOvEa`24lA9 zTyd^C*UUEu7q*$jm1~3N0@kjprz}T#^ol7jF8moNc9$J>XiOYJZQKCf){g0+GPk>? z(wVRn=#oi^V}=gvmRX1c8VQvA_SS+2t-7P!S@Q?Mae`}}l(zw$ zjU@z7x$Z1Q`OgIi#7Y!g;Z4quq8rYhgsB_VZdad8OsmPn*cc=fkjYG^M^fsHlTt_K zCKBW6q&l6=(|7Awigqqhlk*XwS(wPZ$ban!?5juCJCyKz1Wk%-I%xD!b zKnH}*eB{hWQXMl271F8V1pp3ldNMVUno1|DfGOUJuYq{1GP~H_3GW_wTs*`lLGE2& zUb@Pj{DV$Jd&03y!rKc1S#?)6DbH1t^4*nEUKMC{Ni(+Ef&V*c&!M#OUC~xe`SC%) znw``RcKKnyaOdzG(!JCx%{iqpga`5a-)+V#s*z1M0_|Ujpb~mzWHi+yE0a+4sF6UPTle5g!>31! zKE2HP$+NfIx1usKEft^Mm@TqLF~CqXH|g2pg~S2p55Ro071n(kcn+a9Vga*_rosZe z)NM#uM@R+Ed{s1VYR;+%CWgseID#J2#_=GGn+mlha#A>J0L--oQp7bL*jS7CFs?rU z>+Oa0D$ZCO*$lfjRBE_b+yIM>kth@pv~b@bRCdI46HKpP0hv}Hv4#4P88TyNN`Qp) zS0v?;s0n#AjsJk-sG3{Vt0YM-^K3RaDF*! z1eCXE%j>x1YzfATB^b{O7{|fdiDSZQU(W!%<|1i%Nj*h-b0#(13tQSMIff;RUfS_$ zJ2l_mC`NVEe2-DXscI9>Wz`tOzUi67#7JUlq)N=~1k{-Z&jmv#RTinO=!*xD_)>bX zRK6!)P%59pcSd_D0#&Lv7Mw)l4h1JU=*?y8>==kCSpN_(s16GWdhA{xd>d&4R8q7k z*ibmA#r!xZm6+}(GT-hH4c0%DD!j@oH+QwchD}vApb~Rey?`Rs_T;jxcNctA%3&m9NLOE`$$8E%Y$04jUz`Gi9;4?@Hcxj+OP=o65PpCi;*mF4gq%is+jy^1m z&g1A^tW})Js#VZiW{g7Pa)q<6;Mo@nqaV!(Og7P@$V8jg>~K8lh4+y;WI`rD$neKN z)HUfZAgHnzFB^iJq=-P14RKc&0-@T`Eu>um}BCa9mit=K9OJ02M1um&H6JPV3)CBMmW_tBLtB^|A4QN{bKzoKYBjm&3 zPlaA#_ZqA~aDlR|P0{0BTKX85-VnQz)co-=(Zod)63uNO`Ifw`KOBdguipef+|>x@ z*%|=7=HYlaMu7jrk0Q{&@B}u$;~m&s7tLFuc@+;(u8(UMVAK|b+Oin|Y9OJE8yYTl zf1P*S4*{=Ek76-zH+0wN{SYkMak9?<$7{#{fB{oGLm72)Dm|W<4pqw2 qj@uYNq+gOjwdc;(5Q)DA3iIp*3&uKn1&2Yyckr(7;Neei-uy3~^Ep}o literal 0 HcmV?d00001 diff --git a/clos/3.5/combin.lisp b/clos/3.5/combin.lisp new file mode 100644 index 00000000..f76ba815 --- /dev/null +++ b/clos/3.5/combin.lisp @@ -0,0 +1,254 @@ +;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; + +(in-package 'clos) + +(defun make-effective-method-function (generic-function form) + (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn)) + (if (and (listp form) + (eq (car form) 'call-method) + (method-p (cadr form)) + (every #'method-p (caddr form))) + ;; + ;; The effective method is just a call to call-method. This opens up + ;; the possibility of just using the method function of the method as + ;; as the effective method function. + ;; + ;; But we have to be careful. If that method function will ask for + ;; the next methods we have to provide them. We do not look to see + ;; if there are next methods, we look at whether the method function + ;; asks about them. If it does, we must tell it whether there are + ;; or aren't to prevent the leaky next methods bug. + ;; + (let* ((method-function (method-function (cadr form))) + (arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info))) + (if (not (method-function-needs-next-methods-p method-function)) + method-function + (let ((next-method-functions (mapcar #'method-function (caddr form)))) + (name-function + (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) + (let ((*next-methods* .next-method-functions.)) + ,(make-dfun-call metatypes applyp '.method-function.))) + #'default-test-converter ;This could be optimized by making + ;the interface from here to the + ;walker more clear so that the + ;form wouldn't get walked at all. + #'(lambda (form) + (if (memq form '(.next-method-functions. .method-function.)) + (values form (list form)) + form)) + #'(lambda (form) + (cond ((eq form '.next-method-functions.) + (list next-method-functions)) + ((eq form '.method-function.) + (list method-function))))))))) + ;; + ;; We have some sort of `real' effective method. Go off and get a + ;; compiled function for it. Most of the real hair here is done by + ;; the GET-FUNCTION mechanism. + ;; + (name-function (make-effective-method-function-internal generic-function form))))) + +(defvar *global-effective-method-gensyms* ()) +(defvar *rebound-effective-method-gensyms*) + +(defun get-effective-method-gensym () + (or (pop *rebound-effective-method-gensyms*) + (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-"))) + (push new *global-effective-method-gensyms*) + new))) + +(eval-when (load) + (let ((*rebound-effective-method-gensyms* ())) + (dotimes (i 10) (get-effective-method-gensym)))) + +(defun make-effective-method-function-internal (generic-function effective-method) + (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) + (arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info))) + (labels ((test-converter (form) + (if (and (consp form) (eq (car form) 'call-method)) + '.call-method. + (default-test-converter form))) + (code-converter (form) + (if (and (consp form) (eq (car form) 'call-method)) + ;; + ;; We have a `call' to CALL-METHOD. There may or may not be next methods + ;; and the two cases are a little different. It controls how many gensyms + ;; we will generate. + ;; + (let ((gensyms + (if (cddr form) + (list (get-effective-method-gensym) + (get-effective-method-gensym)) + (list (get-effective-method-gensym) + ())))) + (values `(let ((*next-methods* ,(cadr gensyms))) + ,(make-dfun-call metatypes applyp (car gensyms))) + gensyms)) + (default-code-converter form))) + (constant-converter (form) + (if (and (consp form) (eq (car form) 'call-method)) + (if (cddr form) + (list (check-for-make-method (cadr form)) + (mapcar #'check-for-make-method (caddr form))) + (list (check-for-make-method (cadr form)) + ())) + (default-constant-converter form))) + (check-for-make-method (effective-method) + (cond ((method-p effective-method) + (method-function effective-method)) + ((and (listp effective-method) + (eq (car effective-method) 'make-method)) + (make-effective-method-function generic-function + (make-progn (cadr effective-method)))) + (t + (error "Effective-method form is malformed."))))) + (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method) + #'test-converter + #'code-converter + #'constant-converter)))) + + + +(defvar *invalid-method-error* + #'(lambda (&rest args) + (declare (ignore args)) + (error + "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ + of a method combination function (inside the body of~%~ + DEFINE-METHOD-COMBINATION or a method on the generic~%~ + function COMPUTE-EFFECTIVE-METHOD)."))) + +(defvar *method-combination-error* + #'(lambda (&rest args) + (declare (ignore args)) + (error + "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ + of a method combination function (inside the body of~%~ + DEFINE-METHOD-COMBINATION or a method on the generic~%~ + function COMPUTE-EFFECTIVE-METHOD)."))) + +;(defmethod compute-effective-method :around ;issue with magic +; ((generic-function generic-function) ;generic functions +; (method-combination method-combination) +; applicable-methods) +; (declare (ignore applicable-methods)) +; (flet ((real-invalid-method-error (method format-string &rest args) +; (declare (ignore method)) +; (apply #'error format-string args)) +; (real-method-combination-error (format-string &rest args) +; (apply #'error format-string args))) +; (let ((*invalid-method-error* #'real-invalid-method-error) +; (*method-combination-error* #'real-method-combination-error)) +; (call-next-method)))) + +(defun invalid-method-error (&rest args) + (declare (arglist method format-string &rest format-arguments)) + (apply *invalid-method-error* args)) + +(defun method-combination-error (&rest args) + (declare (arglist format-string &rest format-arguments)) + (apply *method-combination-error* args)) + + + +;;; +;;; The STANDARD method combination type. This is coded by hand (rather than +;;; with define-method-combination) for bootstrapping and efficiency reasons. +;;; Note that the definition of the find-method-combination-method appears in +;;; the file defcombin.lisp, this is because EQL methods can't appear in the +;;; bootstrap. +;;; +;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION +;;; classes has to appear here for this reason. This code must conform to +;;; the code in the file defcombin, look there for more details. +;;; + +(defclass method-combination () ()) + +(define-gf-predicate method-combination-p method-combination) + +(defclass standard-method-combination + (definition-source-mixin method-combination) + ((type :reader method-combination-type + :initarg :type) + (documentation :reader method-combination-documentation + :initarg :documentation) + (options :reader method-combination-options + :initarg :options))) + +(defmethod print-object ((mc method-combination) stream) + (printing-random-thing (mc stream) + (format stream + "Method-Combination ~S ~S" + (method-combination-type mc) + (method-combination-options mc)))) + +(eval-when (load eval) + (setq *standard-method-combination* + (make-instance 'standard-method-combination + :type 'standard + :documentation "The standard method combination." + :options ()))) + +;This definition appears in defcombin.lisp. +; +;(defmethod find-method-combination ((generic-function generic-function) +; (type (eql 'standard)) +; options) +; (when options +; (method-combination-error +; "The method combination type STANDARD accepts no options.")) +; *standard-method-combination*) + +(defun make-call-methods (methods) + (mapcar #'(lambda (method) `(call-method ,method ())) methods)) + +(defmethod compute-effective-method ((generic-function generic-function) + (combin standard-method-combination) + applicable-methods) + (let ((before ()) + (primary ()) + (after ()) + (around ())) + (dolist (m applicable-methods) + (let ((qualifiers (method-qualifiers m))) + (cond ((member ':before qualifiers) (push m before)) + ((member ':after qualifiers) (push m after)) + ((member ':around qualifiers) (push m around)) + (t + (push m primary))))) + (setq before (reverse before) + after (reverse after) + primary (reverse primary) + around (reverse around)) + (cond ((null primary) + `(error "No primary method for the generic function ~S." ',generic-function)) + ((and (null before) (null after) (null around)) + ;; + ;; By returning a single call-method `form' here we enable an important + ;; implementation-specific optimization. + ;; + `(call-method ,(first primary) ,(rest primary))) + (t + (let ((main-effective-method + (if (or before after (rest primary)) + `(multiple-value-prog1 + (progn ,@(make-call-methods before) + (call-method ,(first primary) ,(rest primary))) + ,@(make-call-methods (reverse after))) + `(call-method ,(first primary) ())))) + (if around + `(call-method ,(first around) + (,@(rest around) (make-method ,main-effective-method))) + main-effective-method)))))) + diff --git a/clos/3.5/compat.dfasl b/clos/3.5/compat.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..6d244268017f75d0ea99926bbb6e6eee89823d1c GIT binary patch literal 321 zcmYk1VM~Kh7=^DeVnxD!!utcZG2K?o;=;IUn5M%!V|_GtR|7ZYszpT54-jevaS8gZ zrbW>E;r(z9&*7XMYA=WbB-y0vm~lvoJS}oqB^Y;{m^dEAB=G%O$5EXh=KXk`r6-C^|0PG9g*jWo zykOZfeCUEYhVx>}K$%RGE+|87q-eu&UpA-I`7QH@n0)<1j6i1*+g#W6)qy&wp@}v+ z(gw$Ux%v_x=oyJK-Pbki8(wQQS#OXim6ig)Q*+7mD3f#vpQ bQ({lg3`r7iWvkgFcA{(r)bJ7dY**DctB7OW literal 0 HcmV?d00001 diff --git a/clos/3.5/compat.lisp b/clos/3.5/compat.lisp new file mode 100644 index 00000000..ca390f84 --- /dev/null +++ b/clos/3.5/compat.lisp @@ -0,0 +1,11 @@ +;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp; -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; + +(in-package 'clos) + +() diff --git a/clos/3.5/construct.dfasl b/clos/3.5/construct.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..83a5b7ef02aede8b5768b2b0674c83a53d087b72 GIT binary patch literal 22819 zcmeHv4|r79b?4ltKOjJ25VDX5A;vNYEHg4-{0G~MH5v`fNHg=~nGr%5TNW^Q1VSPR z>`mfe#OE}&qkKkSJM$8gE>72R?8X^GOF@6oZqxm`WRtdAd(&;=Zo5fZH(sZ~ahxVi zUG{g*d2iku{Q>OS`|W<;^1;0O?%#9IJ?GrtIrlz>U9-0YBHlp%-hDm2sr}ymg9r8< zJmB5czu!C1e{lbfly?{My`OGQw0`EU_JP#?feqdJ5B5Er>fMpvkZA2}j)yk~H#F;k z_GmDcOl)Y6g|}>ogcEHW0uep2AqA^jJ+c?(g9i z>%7gW9jU$BF@v?M*RDpR^>?hh^^VoIG?ZRCk$KiN??D&-l+cgcl^Jrc@gC^k=j%;9 zl1(nJi8!Dt}Wrj0Dh3$!8 z+~s->dDo==?Y{25oxbMa#(*A6B;)OYq#ox=T>Dv9ZKJkDoeODO)o6>hO^rvi^R3}% zjOm#tL>Y5txm=o|FmmR&mKmD2Y+2MFi0i(MdOVsLT4=onW1GWqJx1Kts%h}xmNtK^ zdD7rU$s!P6642W^eOQeo#vnG-F&p@24h=hDzxUJoT>2pfEy7%QcyIossGMm$ta&rf z49#k5PqxMNwz)_zOazk~eJ0H&8w)E@FxwyB6!S-ei3K3HEWbaaq}Z6Fj74g3=6Dg9 zO7${BMS+Mvk;n|qjrgNY&3>K%rc+cG42p12%*QN` zfXH7prg?^E)92D7fzk9>D>HjITivS0B|RD)3qRcwsT+ALlJ;ypm;LMTxzNkZhQ`Uv zvDxHLdpz=&^ZZSAQ4^0qrJTn-NhN7OCHRxevMX>_qt!6P{qT>KMWb@1FcKkuQ#eps zL`#7;`oqh{X}8OmU+i)fnsQW_8Jfeq^a*24{^s#@XhEXAtt}D`Hv5RLU}mC(IQUbn z*21X2HRwy~ZN5lwb1=fPXmIKOM5&ic9U|`w=*>ajreG`>_d^2`QuRNgs)Gv297E=8 zAx++u?-3Iol}@p4K8W6f;^G|G5C>lCzqF7$_dxP9s3B+hYl&N@9949E*fw!I;qyM#gMt2mj z=T}M3K{^dg&){Z%gz}GMhCBhwUcwF^N_hMF4|sd~yLYB`Hr$>Wx^HJ{SI(fK0vRyx z_Eb;bgWert$9H;HB0u#|cke;6tT&((l~RWqOTBr2cJy`+4A1~Q17396(}w||L^nZ+ zT1^Goa_UxxK>9C!In)$rW}7w9T% z7fBEybvqWpl-tV5BFg!&5c4NV-0YxHzuu_7*;vtFtXzU+y>{}lLdYRWF@MA;SzxS~ zXRItRd@k+o%+Lcfb5&S>l{{qzPsiBhnIT%Y}c-)Eq5UHjehMWm+!$r$BaFEAcC)=vP?70v)7vqLb z^5*mw;7SR5sjiH(`=N441I%iP;irJ_dLSVpEjuP3|a`R9nRORRtz7j8fEv*+%X+3#Y zd_($}fxpz%cciOYXIInPLE-Kzw4a#bL7?$4b%ITX@g(*a!e_=-$~2H^Z0$vTW9Q)q z=|%65!KT<=qvS>^IcjniFpZeAz)6!Sx(tOYFo<&#WzHET*iUL2{er3*8(D$nr75>X z41lfzbBibd^mB{=Tu6e12Q5Ki6$n^LlkpO|_Btv$*U3#}5;c|(@s?qf%r$xmCtPP0 zS<(>(aQDXo!CZZV$RyBwpKW@?wDmyWS=ZC)bf3$$l+zWiQl6IsQeQ=F!rBYgPI5+w z6&A|w0Ig+~k-$zF(wmKv8;nPb?=U*op=^G0FcFA{n}R;QsU;Xl8YMSTZcf&%Ci9F= zQiyqNaqNG&y2>DN7%bE=&8>c(hq*kmNNK=lNsXj|p<7O7eJyIdMH`8Zw!FmEWzJ^i zSm^0+Yu&lWTGO7+v)R`|wk=%T+r4-D&Tel{pLfb^VK7NGmgYHR`W5?w@aLEiv}Fv^ANbo1@*mgoWTr?t`0ofJWQd&&gHZ{+&C$ zeFxb?#BQ4EP3=wf9T;f9K*WM0f`Pj8c0%;U`>?f{Hym1iC=WpK)_HLMe)NQfJ5$~R zpWK%sEJd5`q`Epb@crI>{R0C%+u=~>stAY?TxWZ~E*UmO-! zkNT1!da;35SnB>8dE91fU1{`QYpkd+R?dpq zEw@#^k&}M@6=yFXiVj#ylJnd6=Ww?y*VXj2W-#wlfvZ{yVoI49%MuwSMODVOa^nHo z%#1!|bc#K~s7l!cI)GTtE^#SK#+B_8*Zoi}KcF4#q52=ha;9gtvTQeRnb~d@(bD|J zc$6N0DvuM!qy5ICw-}Euq|CoDI_dF!aJ`lp9*Mx`+}fG9d6@;lxNNZhjTd~7+P#8y zC5dDXOHkg6Mt~k)wQC*bq1YV1=hL0utn+9(0kde*fzow^>O zu?reTW;4g8j00tAtToJ8<0xy5FcA|`TKeVoc4DWd5LE2aj$FbYW{YXQjKzQv6yqqY zHwKo%*cSN_{ODXj!K`i3%@iw}2MVjmWV9#qIB#MZ@K5t_mnRfjm27KE#zXC~*0sdh zH(?}2vi=xzTi57s3b3zyw$Yzv`a8eaD07++pLwD&WEyvQPBO<+=A@Cep^;=h2=Gj@ zI63bCrqRZn#SI{pz}ZIMB+sIbd&}1FL)1!Y#K(Z`L*eJM_KCX&IZONBE-w+8wT_U`Okf%th( z-%f8nns~V9K-$~ay_Yt7j<4rn1#|Zale^6FKO+QmEJvDAGWcNTS%pQ=7I)O1eE^H$ z0^d4n_na9G^%kBP3-uP984vYpXU^~LDx28d<;K5q{HvJYx?Pp#v&wvWCemHi_*XO0 z*j4i_>TWoDmtNE5ozUg=%e!^&w_UD_!|5YEhto%oyy`lw*RW@MLAy}h8jK{7l*Tf-MahI zaJD@{wafRs-o^ir)GLs^0Z;d(qhGLF9DOSL{oPzv+pD3=>|aPL>GT|rP_5UX?Y2;( zpJnEpJ;ggOGsVH|4fdQaJHvko?>=*Hk@`wY>zRAmI+|P>ZXIe2@8%rV`B6VAZlj8k zGu!eiM)E6i*$P&XvDW8W`Bki)ThiD!?>mpqx@wBlv#}Pv<_{*GvWAM8FfZbE6)a%k z`9>a~n_@v0sL6oNvLH^xT};BZkVL+1v(Fz01QQ8gGVX6<1y?^Ib4j)mHWC%p_X)K& z2O|j5((9ix9Y3Vx3wF|n-mU>OjQZo9KJ*&!2SPz#G)!@i3L1_KZxJHV33xHomSPw4 z@|BRXf5ctBNy*pkX6gLHY)uJsfr|DGE3a`FTv z@3)gdJ9#TnLfgHK%~09(q||ss9^2)S;KxsB`!1^wM%$8|zRhsV^mx5dayys3wOSrx z$lr3g?uYKf11bn7BBc1(La6t@JB&Ox@=Q*N;pU=mBnabn7@a;b3+gxj-z@yUV;06l z#aE2`qf3UPM^w*w*#wtNhLgiw^TZB$+#nAGiBydv8p5k*dF1Z&4h?HWQM0OghcUBbRS6h| z%+OK18t+`8RZd$Vzia%YC7Mj&%|*n7y2zaQ-AeK`ancl16Z z0T4?|9K1%wT;rO;N~4k@;MHh8V=FptXD0IwqZZP!JK!xX7E-gs?i+(Coe>#}*=~A>i^y`UU`o`{!N6|g(VL7%X9bPUMxMmWckpBE7Jdv` zZnaS-a~v$}{33`amTa8jM8lKK_oi8I;93_7;qrO`C-UdoB6d zp$mnf3&o)ev$+S>^-~q;J}1* zc9giSZo1092y9Jt|vp5dP{!z#S8_34h^?n`@n__s16|O=MOC^GX>kyVWPkTFO#t8D%YdbD& znbDvi;)P_zT`sy)Wd>}VH-50uwz1GmzV>63XzfhdiRTdC0{H=8pZt zR|3^Y535JGg-xx=sbm55PMkVixQvH;!p)D-xja~?*l1Bg`%7v`W~k;+-JxbLN0d?n ztGtx9Pe}%Frw6oEG=~#x(56s#qa);dRpf24$tzec~pMwwP&B>Y8ohT)Rahy;UnmqH2X42mKrU*{>lZ1M55!WK}2B}`z6c^mRGfl zpkKk-tD1crc9$1_N3jJlRf;EB>fl3?W=@Ct*V{9nvLia@T|Z^sGgeoSbaU4AJc*v^ z=IWEV?wvf>y{ve3F7(}S`MnO?6t;QSGq#bIO^dIVr$ZXR-R?R#;+sj2&h)9#2I{+%WK z@|S*rE{8v_Iz!bbd)$Ot-f1#>0G`>ZIGgJJOmw>rXED>LCM{mY7KUF=<#MinOnJdgwCGJD86pr8ONPFWX=`PL`A5b11V~Sd?~TW za<3SI_;C|SLgOSg8V&qQhLsb-;LhHXGeCFdR|81_KZ~3>_IxV2i!hyP+9Vf&bo+l{0*bIpB_c0bL9I}YpiuAz_FSh+d0Zj^G zn$YgNMgxD4NTsX54c?R{!qGO|M->*$MNR>Nq4crQY^Em>yypXct+NFBEFr_`CPaJ? z2&3hP3M;0oZG{NW3tGECAwu8{dj%QNTx+cbAsU1YeQkOIp#}&QZvf!BN{F^XhuKhu zaDQ<3c>28c9Zo~5f@-vCqk7pGofk*4;udeI$K2eLNPyxi-}HJ0LlWj?$z4 z^Xc)}aBMJ}R^wJAtOY@^G>+Z%@?(1WV75VZRjBC2Q#E>prf>?cmys!`BvbIXUP-0^ zlhw=lB>PYFvaYgIi=uiNvL_(#>s>=)_6N{2f*DFP!GY^}J8wX&|y+bY4hg@5ck z$0t!D0$2?SvNThWg%@i$duz*>Bu63=`{WP{-5#f0CiT!X={=OD zHk|2b6qXG6mHd{xEPkQ8$jwk--e*r{4@4C-2Fj_s&qtk+XFI=3Hu}?>Z2HKyfCTQ) z&W+`WGHJt{(0S`K5vb!BtK+uO>`*H=;|1ht%lx@Rix+sITvKU(48i}1MU*1KN)&qq zZF9e29nVtoCq_Npf1hv0lzkh6Nrb}@Tc+z;rL=!1>^zDYRL1=sxlpjr3=ZpPKwrP9 zCH$G3s)E25wzVfhlt-s{vl{TpT6@sETS1491-Jr21boxjMUUs?@kP{~+mPELq`vF7 zkUOWria(o~gFK0M9^%IjKEaPS9;AUgLc!Q}G^uWwtgQCtgHG&IykhYM=$k=YIV9_7 zl&nWGhklKcbw&qWm-m=@Vt={_URYm=Eyv&sqX^rFdDEr|`5Ls;QbLakGoma~*n?(dccVH3%P}tBbi3*N-XbdXj$r(5ggpLgz*J zo;i*?p-6hIiRFy3k3MjAijR4guil}?+`a&kNbKYja5Bn}VRywB&A4TB0yk$aqHCe#IVIk&-rxFT{QLqDgA z>OHICB~)CPtC(XwsCa~`U@s%No=x{Aqv5UiN`p9Egu4d8W*U`bKH-O*>2&qdnKDcP z7L944Z4mE;v36b(9`Nu13bhePk+E=j8 z@>X*&c)YP0kP(1STtu9few7YiV~S2r1sRqLGAuWdA;G>kc$49uyvBqwgMgH2+_y~A z<;%+FUv<5#S1MfW)B%P8HmgyjS2{PuNyTVY6+_)>nSfqh{iWT!v9=G zuU^_LD{1k&>X=>y%DSkeqX#dLv*RTTaEf90OOVqKV00$4^i5FXkco}=6 z$2}G@`gB>F56W>~JOx9r*EF3cP(^xP1k&c4fl~|evwhayB+DnCX^wT zEtE7+X?845A^HT}kkyWHStlhUlvD)Uw411!wa-xoZx8BKO7hXWIz>r72~?*kN#A<7 zB_3mfHu&I7nED6q_iL!7-ryvGM0M1-jUHluX;8)I`-&0dn_TGnA32I#UpMO0{PtaO zBv%MU_51~u`a0P_Z9T#{_#i+&pQIi?Vf5kQ`p-rmZ*uC_0u_GE5uV?n?p(M+z|Zpx zN3{E>pGV-Nlp^kvHgC0%XEeLXACCC+_9TKl?EUho`C&$%izqNnw-_RpC@~t9`?udS z>vPxY(=?dY&A&93>(3>F{NJe;?s7K}#Q%-yR>&WFy4?GTiz)cm_)*h%Pqr7rsY#y6 z$LK(9u^pu=IZ!v+L^>U)>71k&ufj=UzbWS>Y1?78J`OKQzyZrRV>?zi*AL+(ksPSE zC7}9K0Y?8om(i8PS_s~nj@3Jqd{G>lXXJ5|TmSq~e!TlBe!SDqk00#j#~Tmu;}`ex z<30LzW>F5_PDZtxjD`(H!+NgzE7LVWWZIIx>Ae%K{ZIMM2!F@E!U+x)0AU{Zr)JtL z3x7%YHV6E<&|XU@S* zUBZh60UMTI89o1=Ia_TNk%v#=#UWwPe9|go(ER1RvL|UUb6^`ZGaZCmDWOcHe30G= z2XpD|R;%?n(0!*XWjZF>-FZFO_;x>cI2HGPhVu#cO7DVuMTXw{xKXaQop#G#{{_^CwBDfRg9EQtu_;kdw_@-c~&3Os|T}76oI#@2z_>=R})&!zDZv;F{}k9 z7I0J!1h&J^;1C3v;P6>sT7-Z>0pKiQbb_@6ngPNph$!I0il*w*JK3u0UMFeIdW}Vz zB&d-WKsXJ+s@ERVYX`GlMd|8@z6_+*5=v&$ycUY}+SFMn@j(;CisztL9@8si^r8(E#A8Y{IHD_}dLUgq3A3)OUopSdW{2LgNi z9nt{z+eu>IYbS4@q~J7$H5&a_8bT2xG$mdqAvE<}V|ED^`y&&JX?xg|YkL@r{X6P*G8X#^ z^0X}<1dCBG+5_l`6VzVu>4S-YDZ}+ATy~NG*QzT;t4pZhJSL{PTu1N^WhAvkI zUtISif?Sir)&Gak7P*ZCujpx|trrPOYtKW|J`T9Gf)-m`3W))dqXFbFGu$#U7Q?My za_bKVw^A%-YfRK-#)7%OUu`ftDEhn9DP7Y-s++j}Kk>ar^^1IDMF>LGIuQh1k&g&j z{dXEykk$VkXl9)SaTtxL_j2guZmS>{x4Qza`PdQ6^MqjLIhWSPFfUmcX3LBi=E;u{ z!vxGDVZtzaIpddd?6&5yuU2^`A;NT@R7TyDKe@QYjU3&8@yD*_7!>HL~PeiZ~In9?euz1Yc~ZQf@+(Re&n)C0#YAZ_}%#o`)C;f>3%5j``IhR0*`gTJ(XUKxofiPJL@NeUAA z4;B)6Ns!1(j6~Smu#pHKifMmFGraS|BN1-TW?XxXCrlZNL60+oZ@xJ)T*95#zC^>n Ie(BQx2BkbPTL1t6 literal 0 HcmV?d00001 diff --git a/clos/3.5/construct.lisp b/clos/3.5/construct.lisp new file mode 100644 index 00000000..7d740475 --- /dev/null +++ b/clos/3.5/construct.lisp @@ -0,0 +1,1090 @@ +;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; +;;; +;;; This file defines the defconstructor and other make-instance optimization +;;; mechanisms. +;;; + +(in-package 'clos) + +;;; +;;; defconstructor is used to define special purpose functions which just +;;; call make-instance with a symbol as the first argument. The semantics +;;; of defconstructor is that it is equivalent to defining a function which +;;; just calls make-instance. The purpose of defconstructor is to provide +;;; CLOS with a way of noticing these calls to make-instance so that it can +;;; optimize them. Specific ports of CLOS could just have their compiler +;;; spot these calls to make-instance and then call this code. Having the +;;; special defconstructor facility is the best we can do portably. +;;; +;;; +;;; A call to defconstructor like: +;;; +;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r) +;;; +;;; Is equivalent to a defun like: +;;; +;;; (defun make-foo (a b &rest r) +;;; (make-instance 'foo 'a a ':mumble b 'baz r)) +;;; +;;; Calls like the following are also legal: +;;; +;;; (defconstructor make-foo foo ()) +;;; (defconstructor make-bar bar () :x *x* :y *y*) +;;; (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c)) +;;; +;;; +;;; The general idea of this implementation is that the expansion of the +;;; defconstructor form includes the creation of closure generators which +;;; can be called to create constructor code for the class. The ways that +;;; a constructor can be optimized depends not only on the defconstructor +;;; form, but also on the state of the class and the generic functions in +;;; the initialization protocol. Because of this, the determination of the +;;; form of constructor code to be used is a two part process. +;;; +;;; At compile time, make-constructor-code-generators looks at the actual +;;; defconstructor form and makes a list of appropriate constructor code +;;; generators. All that is really taken into account here is whether +;;; any initargs are supplied in the call to make-instance, and whether +;;; any of those are constant. +;;; +;;; At constructor code generation time (see note about lazy evaluation) +;;; compute-constructor-code calls each of the constructor code generators +;;; to try to get code for this constructor. Each generator looks at the +;;; state of the class and initialization protocol generic functions and +;;; decides whether its type of code is appropriate. This depends on things +;;; like whether there are any applicable methods on initialize-instance, +;;; whether class slots are affected by initialization etc. +;;; +;;; +;;; Constructor objects are funcallable instances, the protocol followed to +;;; to compute the constructor code for them is quite similar to the protocol +;;; followed to compute the discriminator code for a generic function. When +;;; the constructor is first loaded, we install as its code a function which +;;; will compute the actual constructor code the first time it is called. +;;; +;;; If there is an update to the class structure which might invalidate the +;;; optimized constructor, the special lazy constructor installer is put back +;;; so that it can compute the appropriate constructor when it is called. +;;; This is the same kind of lazy evaluation update strategy used elswhere +;;; in CLOS. +;;; +;;; To allow for flexibility in the CLOS implementation and to allow CLOS users +;;; to specialize this constructor facility for their own metaclasses, there +;;; is an internal protocol followed by the code which loads and installs +;;; the constructors. This is documented in the comments in the code. +;;; +;;; This code is also designed so that one of its levels, can be used to +;;; implement optimization of calls to make-instance which can't go through +;;; the defconstructor facility. This has not been implemented yet, but the +;;; hooks are there. +;;; +;;; + +(defmacro defconstructor + (name class lambda-list &rest initialization-arguments) + (expand-defconstructor class + name + lambda-list + (copy-list initialization-arguments))) + +(defun expand-defconstructor (class-name name lambda-list supplied-initargs) + (let ((class (find-class class-name nil)) + (supplied-initarg-names + (gathering1 (collecting) + (iterate ((name (*list-elements supplied-initargs :by #'cddr))) + (gather1 name))))) + (when (null class) + (error "defconstructor form being compiled (or evaluated) before~@ + class ~S is defined." + class-name)) + `(progn + ;; In order to avoid undefined function warnings, we want to tell + ;; the compile time environment that a function with this name and + ;; this argument list has been defined. The portable way to do this + ;; is with defun. + (proclaim '(notinline ,name)) + (defun ,name ,lambda-list + (declare (ignore ,@(specialized-lambda-list-parameters lambda-list))) + (error "Constructor ~S not loaded." ',name)) + + ,(make-top-level-form `(defconstructor ,name) + '(load eval) + `(load-constructor + ',class-name + ',(class-name (class-of class)) + ',name + ',supplied-initarg-names + ;; make-constructor-code-generators is called to return a list + ;; of constructor code generators. The actual interpretation + ;; of this list is left to compute-constructor-code, but the + ;; general idea is that it should be an plist where the keys + ;; name a kind of constructor code and the values are generator + ;; functions which return the actual constructor code. The + ;; constructor code is usually a closures over the arguments + ;; to the generator. + ,(make-constructor-code-generators class + name + lambda-list + supplied-initarg-names + supplied-initargs)))))) + +(defun load-constructor (class-name metaclass-name constructor-name + supplied-initarg-names code-generators) + (let ((class (find-class class-name nil))) + (cond ((null class) + (error "defconstructor form being loaded (or evaluated) before~@ + class ~S is defined." + class-name)) + ((neq (class-name (class-of class)) metaclass-name) + (error "When defconstructor ~S was compiled, the metaclass of the~@ + class ~S was ~S. The metaclass is now ~S.~@ + The constructor must be recompiled." + constructor-name + class-name + metaclass-name + (class-name (class-of class)))) + (t + (load-constructor-internal class + constructor-name + supplied-initarg-names + code-generators) + constructor-name)))) + +;;; +;;; The actual constructor objects. +;;; +(defclass constructor () + ((class ;The class with which this + :initarg :class ;constructor is associated. + :reader constructor-class) ;The actual class object, + ;not the class name. + ; + (name ;The name of this constructor. + :initform nil ;This is the symbol in whose + :initarg :name ;function cell the constructor + :reader constructor-name) ;usually sits. Of course, this + ;is optional. defconstructor + ;makes named constructors, but + ;it is possible to manipulate + ;anonymous constructors also. + ; + (code-type ;The type of code currently in + :initform nil ;use by this constructor. This + :accessor constructor-code-type) ;is mostly for debugging and + ;analysis purposes. + ;The lazy installer sets this + ;to LAZY. The most basic and + ;least optimized type of code + ;is called FALLBACK. + ; + (supplied-initarg-names ;The names of the initargs this + :initarg :supplied-initarg-names ;constructor supplies when it + :reader ;"calls" make-instance. + constructor-supplied-initarg-names) ; + ; + (code-generators ;Generators for the different + :initarg :code-generators ;types of code this constructor + :reader constructor-code-generators)) ;could use. + (:metaclass funcallable-standard-class)) + + +;;; +;;; Because the value in the code-type slot should always correspond to the +;;; funcallable-instance-function of the constructor, this function should +;;; always be used to set the both at the same time. +;;; +(defun set-constructor-code (constructor code type) + (set-funcallable-instance-function constructor code) + (set-function-name constructor (constructor-name constructor)) + (setf (constructor-code-type constructor) type)) + + +(defmethod print-object ((constructor constructor) stream) + (printing-random-thing (constructor stream) + (format stream + "~S ~S (~S)" + (or (class-name (class-of constructor)) "Constructor") + (or (constructor-name constructor) "Anonymous") + (constructor-code-type constructor)))) + +(defmethod describe-object ((constructor constructor) stream) + (format stream + "~S is a constructor for the class ~S.~%~ + The current code type is ~S.~%~ + Other possible code types are ~S." + constructor (constructor-class constructor) + (constructor-code-type constructor) + (gathering1 (collecting) + (doplist (key val) (constructor-code-generators constructor) + (gather1 key))))) + +;;; +;;; I am not in a hairy enough mood to make this implementation be metacircular +;;; enough that it can support a defconstructor for constructor objects. +;;; +(defun make-constructor (class name supplied-initarg-names code-generators) + (make-instance 'constructor + :class class + :name name + :supplied-initarg-names supplied-initarg-names + :code-generators code-generators)) + +; This definition actually appears in std-class.lisp. +;(defmethod class-constructors ((class std-class)) +; (with-slots (plist) class (getf plist 'constructors))) + +(defmethod add-constructor ((class std-class) + (constructor constructor)) + (with-slots (plist) class + (pushnew constructor (getf plist 'constructors)))) + +(defmethod remove-constructor ((class std-class) + (constructor constructor)) + (with-slots (plist) class + (setf (getf plist 'constructors) + (delete constructor (getf plist 'constructors))))) + +(defmethod get-constructor ((class std-class) name &optional (error-p t)) + (or (dolist (c (class-constructors class)) + (when (eq (constructor-name c) name) (return c))) + (if error-p + (error "Couldn't find a constructor with name ~S for class ~S." + name class) + ()))) + +;;; +;;; This is called to actually load a defconstructor constructor. It must +;;; install the lazy installer in the function cell of the constructor name, +;;; and also add this constructor to the list of constructors the class has. +;;; +(defmethod load-constructor-internal + ((class std-class) name initargs generators) + (let ((constructor (make-constructor class name initargs generators)) + (old (get-constructor class name nil))) + (when old (remove-constructor class old)) + (install-lazy-constructor-installer constructor) + (add-constructor class constructor) + (setf (symbol-function name) constructor))) + +(defmethod install-lazy-constructor-installer ((constructor constructor)) + (let ((class (constructor-class constructor))) + (set-constructor-code constructor + #'(lambda (&rest args) + (multiple-value-bind (code type) + (compute-constructor-code class constructor) + (prog1 (apply code args) + (set-constructor-code constructor + code + type)))) + 'lazy))) + +;;; +;;; The interface to keeping the constructors updated. +;;; +;;; add-method and remove-method (for standard-generic-function and -method), +;;; promise to call maybe-update-constructors on the generic function and +;;; the method. +;;; +;;; The class update code promises to call update-constructors whenever the +;;; class is changed. That is, whenever the supers, slots or options change. +;;; If user defined classes of constructor needs to be updated in more than +;;; these circumstances, they should use the dependent updating mechanism to +;;; make sure update-constructors is called. +;;; +;;; Bootstrapping concerns force the definitions of maybe-update-constructors +;;; and update-constructors to be in the file std-class. For clarity, they +;;; also appear below. Be sure to keep the definition here and there in sync. +;;; +;(defvar *initialization-generic-functions* +; (list #'make-instance +; #'default-initargs +; #'allocate-instance +; #'initialize-instance +; #'shared-initialize)) +; +;(defmethod maybe-update-constructors +; ((generic-function generic-function) +; (method method)) +; (when (memq generic-function *initialization-generic-functions*) +; (labels ((recurse (class) +; (update-constructors class) +; (dolist (subclass (class-direct-subclasses class)) +; (recurse subclass)))) +; (when (classp (car (method-specializers method))) +; (recurse (car (method-specializers method))))))) +; +;(defmethod update-constructors ((class std-class)) +; (dolist (cons (class-constructors class)) +; (install-lazy-constructor-installer cons))) +; +;(defmethod update-constructors ((class class)) +; ()) + + + +;;; +;;; Here is the actual smarts for making the code generators and then trying +;;; each generator to get constructor code. This extensible mechanism allows +;;; new kinds of constructor code types to be added. A programmer defining a +;;; specialization of the constructor class can either use this mechanism to +;;; define new code types, or can override this mechanism by overriding the +;;; methods on make-constructor-code-generators and compute-constructor-code. +;;; +;;; The function defined by define-constructor-code-type will receive the +;;; class object, and the 4 original arguments to defconstructor. It can +;;; return a constructor code generator, or return nil if this type of code +;;; is determined to not be appropriate after looking at the defconstructor +;;; arguments. +;;; +;;; When compute-constructor-code is called, it first performs basic checks +;;; to make sure that the basic assumptions common to all the code types are +;;; valid. (For details see method definition). If any of the tests fail, +;;; the fallback constructor code type is used. If none of the tests fail, +;;; the constructor code generators are called in order. They receive 5 +;;; arguments: +;;; +;;; CLASS the class the constructor is making instances of +;;; WRAPPER that class's wrapper +;;; DEFAULTS the result of calling class-default-initargs on class +;;; INITIALIZE the applicable methods on initialize-instance +;;; SHARED the applicable methosd on shared-initialize +;;; +;;; The first code generator to return code is used. The code generators are +;;; called in reverse order of definition, so define-constructor-code-type +;;; forms which define better code should appear after ones that define less +;;; good code. The fallback code type appears first. Note that redefining a +;;; code type does not change its position in the list. To do that, define +;;; a new type at the end with the behavior. +;;; + +(defvar *constructor-code-types* ()) + +(defmacro define-constructor-code-type (type arglist &body body) + (let ((fn-name (intern (format nil + "CONSTRUCTOR-CODE-GENERATOR ~A ~A" + (package-name (symbol-package type)) + (symbol-name type)) + *the-clos-package*))) + `(progn + (defun ,fn-name ,arglist .,body) + (load-define-constructor-code-type ',type ',fn-name)))) + +(defun load-define-constructor-code-type (type generator) + (let ((old-entry (assq type *constructor-code-types*))) + (if old-entry + (setf (cadr old-entry) generator) + (push (list type generator) *constructor-code-types*)) + type)) + +(defmethod make-constructor-code-generators + ((class std-class) + name lambda-list supplied-initarg-names supplied-initargs) + (cons 'list + (gathering1 (collecting) + (dolist (entry *constructor-code-types*) + (let ((generator + (funcall (cadr entry) class name lambda-list + supplied-initarg-names + supplied-initargs))) + (when generator + (gather1 `',(car entry)) + (gather1 generator))))))) + +(defmethod compute-constructor-code ((class std-class) + (constructor constructor)) + (let* ((proto (class-prototype class)) + (wrapper (class-wrapper class)) + (defaults (class-default-initargs class)) + (make + (compute-applicable-methods #'make-instance (list class))) + (supplied-initarg-names + (constructor-supplied-initarg-names constructor)) + (default + (compute-applicable-methods #'default-initargs + (list class supplied-initarg-names))) ;? + (allocate + (compute-applicable-methods #'allocate-instance (list class))) + (initialize + (compute-applicable-methods #'initialize-instance (list proto))) + (shared + (compute-applicable-methods #'shared-initialize (list proto t))) + (code-generators + (constructor-code-generators constructor)) + (code-generators + (constructor-code-generators constructor))) + (flet ((call-code-generator (generator) + (when (null generator) + (unless (setq generator (getf code-generators 'fallback)) + (error "No FALLBACK generator?"))) + (funcall generator class wrapper defaults initialize shared))) + (if (or (cdr make) + (cdr default) + (cdr allocate) + (check-initargs class + supplied-initarg-names + defaults + (append initialize shared))) + ;; These are basic shared assumptions, if one of the + ;; has been violated, we have to resort to the fallback + ;; case. Any of these assumptions could be moved out + ;; of here and into the individual code types if there + ;; was a need to do so. + (values (call-code-generator nil) 'fallback) + ;; Otherwise try all the generators until one produces + ;; code for us. + (doplist (type generator) code-generators + (let ((code (call-code-generator generator))) + (when code (return (values code type))))))))) + +;;; +;;; The facilities are useful for debugging, and to measure the performance +;;; boost from constructors. +;;; + +(defun map-constructors (fn) + (let ((nclasses 0) + (nconstructors 0)) + (labels ((recurse (class) + (incf nclasses) + (dolist (constructor (class-constructors class)) + (incf nconstructors) + (funcall fn constructor)) + (dolist (subclass (class-direct-subclasses class)) + (recurse subclass)))) + (recurse (find-class 't)) + (values nclasses nconstructors)))) + +(defun reset-constructors () + (multiple-value-bind (nclass ncons) + (map-constructors #'install-lazy-constructor-installer ) + (format t "~&~D classes, ~D constructors." nclass ncons))) + +(defun disable-constructors () + (multiple-value-bind (nclass ncons) + (map-constructors + #'(lambda (c) + (let ((gen (getf (constructor-code-generators c) 'fallback))) + (if (null gen) + (error "No fallback constructor for ~S." c) + (set-constructor-code c + (funcall gen + (constructor-class c) + () () () ()) + 'fallback))))) + (format t "~&~D classes, ~D constructors." nclass ncons))) + +(defun enable-constructors () + (reset-constructors)) + + +;;; +;;; Helper functions and utilities that are shared by all of the code types +;;; and by the main compute-constructor-code method as well. +;;; + +(defvar *standard-initialize-instance-method* + (get-method #'initialize-instance + () + (list *the-class-standard-object*))) + +(defvar *standard-shared-initialize-method* + (get-method #'shared-initialize + () + (list *the-class-standard-object* *the-class-t*))) + +(defun non-clos-initialize-instance-methods-p (methods) + (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*)) + methods)) + +(defun non-clos-shared-initialize-methods-p (methods) + (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*)) + methods)) + +(defun non-clos-or-after-initialize-instance-methods-p (methods) + (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*) + (equal '(:after) (method-qualifiers m)))) + methods)) + +(defun non-clos-or-after-shared-initialize-methods-p (methods) + (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*) + (equal '(:after) (method-qualifiers m)))) + methods)) + + +;;; +;;; if initargs are valid return nil, otherwise return t. +;;; +(defun check-initargs (class supplied-initarg-names defaults methods) + (let ((legal (apply #'append + (mapcar #'slotd-initargs (class-slots class))))) + ;; Add to the set of slot-filling initargs the set of + ;; initargs that are accepted by the methods. If at + ;; any point we come across &allow-other-keys, we can + ;; just quit. + (dolist (method methods) + (multiple-value-bind (keys allow-other-keys) + (function-keywords method) + (when allow-other-keys + (return-from check-initargs nil)) + (setq legal (append keys legal)))) + ;; Now check the supplied-initarg-names and the default initargs + ;; against the total set that we know are legal. + (dolist (key supplied-initarg-names) + (unless (memq key legal) + (return-from check-initargs t))) + (dolist (default defaults) + (unless (memq (car default) legal) + (return-from check-initargs t))))) + + +;;; +;;; This returns two values. The first is a vector which can be used as the +;;; initial value of the slots vector for the instance. The first is a symbol +;;; describing the initforms this class has. +;;; +;;; If the first value is: +;;; +;;; :unsupplied no slot has an initform +;;; :constants all slots have either a constant initform +;;; or no initform at all +;;; t there is at least one non-constant initform +;;; +(defun compute-constant-vector (class) + (declare (values constants flag)) + (let* ((wrapper (class-wrapper class)) + (layout (wrapper-instance-slots-layout wrapper)) + (flag :unsupplied) + (constants ())) + (dolist (slotd (class-slots class)) + (let ((name (slotd-name slotd)) + (initform (slotd-initform slotd)) + (initfn (slotd-initfunction slotd))) + (cond ((null (memq name layout))) + ((or (eq initform *slotd-unsupplied*) + (null initfn)) + (push (cons name *slot-unbound*) constants)) + ((constantp initform) + (push (cons name (eval initform)) constants) + (when (eq flag ':unsupplied) (setq flag ':constants))) + (t + (push (cons name *slot-unbound*) constants) + (setq flag 't))))) + (values + (apply #'vector + (mapcar #'cdr + (sort constants #'(lambda (x y) + (memq (car y) + (memq (car x) layout)))))) + flag))) + +(defmacro copy-constant-vector (constants) + `(copy-seq (the simple-vector ,constants))) + + +;;; +;;; This takes a class and a list of initarg-names, and returns an alist +;;; indicating the positions of the slots those initargs may fill. The +;;; order of the initarg-names argument is important of course, since we +;;; have to respect the rules about the leftmost initarg that fills a slot +;;; having precedence. This function allows initarg names to appear twice +;;; in the list, it only considers the first appearance. +;;; +(defun compute-initarg-positions (class initarg-names) + (let* ((layout (wrapper-instance-slots-layout (class-wrapper class))) + (positions + (gathering1 (collecting) + (iterate ((slot-name (list-elements layout)) + (position (interval :from 0))) + (gather1 (cons slot-name position))))) + (slot-initargs + (mapcar #'(lambda (slotd) + (list (slotd-initargs slotd) + (or (cdr (assq (slotd-name slotd) positions)) + ':class))) + (class-slots class)))) + ;; Go through each of the initargs, and figure out what position + ;; it fills by replacing the entries in slot-initargs it fills. + (dolist (initarg initarg-names) + (dolist (slot-entry slot-initargs) + (let ((slot-initargs (car slot-entry))) + (when (and (listp slot-initargs) + (not (null slot-initargs)) + (memq initarg slot-initargs)) + (setf (car slot-entry) initarg))))) + (gathering1 (collecting) + (dolist (initarg initarg-names) + (let ((positions (gathering1 (collecting) + (dolist (slot-entry slot-initargs) + (when (eq (car slot-entry) initarg) + (gather1 (cadr slot-entry))))))) + (when positions + (gather1 (cons initarg positions)))))))) + + +;;; +;;; The FALLBACK case allows anything. This always works, and always appears +;;; as the last of the generators for a constructor. It does a full call to +;;; make-instance. +;;; + +(define-constructor-code-type fallback + (class name arglist supplied-initarg-names supplied-initargs) + (declare (ignore name supplied-initarg-names)) + `(function + (lambda (&rest ignore) + (declare (ignore ignore)) + (function + (lambda ,arglist + (make-instance + ',(class-name class) + ,@(gathering1 (collecting) + (iterate ((tail (*list-tails supplied-initargs :by #'cddr))) + (gather1 `',(car tail)) + (gather1 (cadr tail)))))))))) + +;;; +;;; The GENERAL case allows: +;;; constant, unsupplied or non-constant initforms +;;; constant or non-constant default initargs +;;; supplied initargs +;;; slot-filling initargs +;;; :after methods on shared-initialize and initialize-instance +;;; +(define-constructor-code-type general + (class name arglist supplied-initarg-names supplied-initargs) + (declare (ignore name)) + (let ((raw-allocator (raw-instance-allocator class)) + (slots-fetcher (slots-fetcher class)) + (wrapper-fetcher (wrapper-fetcher class))) + `(function + (lambda (class .wrapper. defaults init shared) + (multiple-value-bind (.constants. + .constant-initargs. + .initfns-initargs-and-positions. + .supplied-initarg-positions. + .shared-initfns. + .initfns.) + (general-generator-internal class + defaults + init + shared + ',supplied-initarg-names + ',supplied-initargs) + .supplied-initarg-positions. + (when (and .constants. + (null (non-clos-or-after-initialize-instance-methods-p + init)) + (null (non-clos-or-after-shared-initialize-methods-p + shared))) + (function + (lambda ,arglist + (declare (optimize (speed 3) (safety 0))) + (let ((.instance. (,raw-allocator)) + (.slots. (copy-constant-vector .constants.)) + (.positions. .supplied-initarg-positions.) + (.initargs. .constant-initargs.)) + .positions. + + (setf (,slots-fetcher .instance.) .slots.) + (setf (,wrapper-fetcher .instance.) .wrapper.) + + (dolist (entry .initfns-initargs-and-positions.) + (let ((val (funcall (car entry))) + (initarg (cadr entry))) + (when initarg + (push val .initargs.) + (push initarg .initargs.)) + (dolist (pos (cddr entry)) + (setf (%svref .slots. pos) val)))) + + ,@(gathering1 (collecting) + (doplist (initarg value) supplied-initargs + (unless (constantp value) + (gather1 `(let ((.value. ,value)) + (push .value. .initargs.) + (push ',initarg .initargs.) + (dolist (.p. (pop .positions.)) + (setf (%svref .slots. .p.) + .value.))))))) + + (dolist (fn .shared-initfns.) + (apply fn .instance. t .initargs.)) + (dolist (fn .initfns.) + (apply fn .instance. .initargs.)) + + .instance.))))))))) + +(defun general-generator-internal + (class defaults init shared supplied-initarg-names supplied-initargs) + (flet ((bail-out () (return-from general-generator-internal nil))) + (let* ((constants (compute-constant-vector class)) + (layout (wrapper-instance-slots-layout (class-wrapper class))) + (initarg-positions + (compute-initarg-positions class + (append supplied-initarg-names + (mapcar #'car defaults)))) + (initfns-initargs-and-positions ()) + (supplied-initarg-positions ()) + (constant-initargs ()) + (used-positions ())) + + ;; + ;; Go through each of the supplied initargs for three reasons. + ;; + ;; - If it fills a class slot, bail out. + ;; - If its a constant form, fill the constant vector. + ;; - Otherwise remember the positions no two initargs + ;; will try to fill the same position, since compute + ;; initarg positions already took care of that, but + ;; we do need to know what initforms will and won't + ;; be needed. + ;; + (doplist (initarg val) supplied-initargs + (let ((positions (cdr (assq initarg initarg-positions)))) + (cond ((memq :class positions) (bail-out)) + ((constantp val) + (setq val (eval val)) + (push val constant-initargs) + (push initarg constant-initargs) + (dolist (pos positions) (setf (svref constants pos) val))) + (t + (push positions supplied-initarg-positions))) + (setq used-positions (append positions used-positions)))) + ;; + ;; Go through each of the default initargs, for three reasons. + ;; + ;; - If it fills a class slot, bail out. + ;; - If it is a constant, and it does fill a slot, put that + ;; into the constant vector. + ;; - If it isn't a constant, record its initfn and position. + ;; + (dolist (default defaults) + (let* ((name (car default)) + (initfn (cadr default)) + (form (caddr default)) + (value ()) + (positions (cdr (assq name initarg-positions)))) + (unless (memq name supplied-initarg-names) + (cond ((memq :class positions) (bail-out)) + ((constantp form) + (setq value (eval form)) + (push value constant-initargs) + (push name constant-initargs) + (dolist (pos positions) + (setf (svref constants pos) value))) + (t + (push (list* initfn name positions) + initfns-initargs-and-positions))) + (setq used-positions (append positions used-positions))))) + ;; + ;; Go through each of the slot initforms: + ;; + ;; - If its position has already been filled, do nothing. + ;; The initfn won't need to be called, and the slot won't + ;; need to be touched. + ;; - If it is a class slot, and has an initform, bail out. + ;; - If its a constant or unsupplied, ignore it, it is + ;; already in the constant vector. + ;; - Otherwise, record its initfn and position + ;; + (dolist (slotd (class-slots class)) + (let* ((alloc (slotd-allocation slotd)) + (name (slotd-name slotd)) + (form (slotd-initform slotd)) + (initfn (slotd-initfunction slotd)) + (position (position name layout))) + (cond ((neq alloc :instance) + (unless (or (eq form *slotd-unsupplied*) + (null initfn)) + (bail-out))) + ((member position used-positions)) + ((or (constantp form) + (eq form *slotd-unsupplied*))) + (t + (push (list initfn nil position) + initfns-initargs-and-positions))))) + + (values constants + constant-initargs + (nreverse initfns-initargs-and-positions) + (nreverse supplied-initarg-positions) + (mapcar #'method-function + (remove *standard-shared-initialize-method* shared)) + (mapcar #'method-function + (remove *standard-initialize-instance-method* init)))))) + + +;;; +;;; The NO-METHODS case allows: +;;; constant, unsupplied or non-constant initforms +;;; constant or non-constant default initargs +;;; supplied initargs that are arguments to constructor, or constants +;;; slot-filling initargs +;;; + +(define-constructor-code-type no-methods + (class name arglist supplied-initarg-names supplied-initargs) + (declare (ignore name)) + (let ((raw-allocator (raw-instance-allocator class)) + (slots-fetcher (slots-fetcher class)) + (wrapper-fetcher (wrapper-fetcher class))) + `(function + (lambda (class .wrapper. defaults init shared) + (multiple-value-bind (.constants. + .initfns-and-positions. + .supplied-initarg-positions.) + (no-methods-generator-internal class + defaults + ',supplied-initarg-names + ',supplied-initargs) + .initfns-and-positions. + .supplied-initarg-positions. + (when (and .constants. + (null (non-clos-initialize-instance-methods-p init)) + (null (non-clos-shared-initialize-methods-p shared))) + #'(lambda ,arglist + (declare (optimize (speed 3) (safety 0))) + (let ((.instance. (,raw-allocator)) + (.slots. (copy-constant-vector .constants.)) + (.positions. .supplied-initarg-positions.)) + .positions. + (setf (,slots-fetcher .instance.) .slots.) + (setf (,wrapper-fetcher .instance.) .wrapper.) + + (dolist (entry .initfns-and-positions.) + (let ((val (funcall (car entry)))) + (dolist (pos (cdr entry)) + (setf (%svref .slots. pos) val)))) + + ,@(gathering1 (collecting) + (doplist (initarg value) supplied-initargs + (unless (constantp value) + (gather1 + `(let ((.value. ,value)) + (dolist (.p. (pop .positions.)) + (setf (%svref .slots. .p.) .value.))))))) + + .instance.)))))))) + +(defun no-methods-generator-internal + (class defaults supplied-initarg-names supplied-initargs) + (flet ((bail-out () (return-from no-methods-generator-internal nil))) + (let* ((constants (compute-constant-vector class)) + (layout (wrapper-instance-slots-layout (class-wrapper class))) + (initarg-positions + (compute-initarg-positions class + (append supplied-initarg-names + (mapcar #'car defaults)))) + (initfns-and-positions ()) + (supplied-initarg-positions ()) + (used-positions ())) + ;; + ;; Go through each of the supplied initargs for three reasons. + ;; + ;; - If it fills a class slot, bail out. + ;; - If its a constant form, fill the constant vector. + ;; - Otherwise remember the positions, no two initargs + ;; will try to fill the same position, since compute + ;; initarg positions already took care of that, but + ;; we do need to know what initforms will and won't + ;; be needed. + ;; + (doplist (initarg val) supplied-initargs + (let ((positions (cdr (assq initarg initarg-positions)))) + (cond ((memq :class positions) (bail-out)) + ((constantp val) + (setq val (eval val)) + (dolist (pos positions) + (setf (svref constants pos) val))) + (t + (push positions supplied-initarg-positions))) + (setq used-positions (append positions used-positions)))) + ;; + ;; Go through each of the default initargs, for three reasons. + ;; + ;; - If it fills a class slot, bail out. + ;; - If it is a constant, and it does fill a slot, put that + ;; into the constant vector. + ;; - If it isn't a constant, record its initfn and position. + ;; + (dolist (default defaults) + (let* ((name (car default)) + (initfn (cadr default)) + (form (caddr default)) + (value ()) + (positions (cdr (assq name initarg-positions)))) + (unless (memq name supplied-initarg-names) + (cond ((memq :class positions) (bail-out)) + ((constantp form) + (setq value (eval form)) + (dolist (pos positions) + (setf (svref constants pos) value))) + (t + (push (cons initfn positions) + initfns-and-positions))) + (setq used-positions (append positions used-positions))))) + ;; + ;; Go through each of the slot initforms: + ;; + ;; - If its position has already been filled, do nothing. + ;; The initfn won't need to be called, and the slot won't + ;; need to be touched. + ;; - If it is a class slot, and has an initform, bail out. + ;; - If its a constant or unsupplied, do nothing, we know + ;; that it is already in the constant vector. + ;; - Otherwise, record its initfn and position + ;; + (dolist (slotd (class-slots class)) + (let* ((alloc (slotd-allocation slotd)) + (name (slotd-name slotd)) + (form (slotd-initform slotd)) + (initfn (slotd-initfunction slotd)) + (position (position name layout))) + (cond ((neq alloc :instance) + (unless (or (eq form *slotd-unsupplied*) + (null initfn)) + (bail-out))) + ((member position used-positions)) + ((or (constantp form) + (eq form *slotd-unsupplied*))) + (t + (push (list initfn position) initfns-and-positions))))) + + (values constants + (nreverse initfns-and-positions) + (nreverse supplied-initarg-positions))))) + + +;;; +;;; The SIMPLE-SLOTS case allows: +;;; constant or unsupplied initforms +;;; constant default initargs +;;; supplied initargs +;;; slot filling initargs +;;; + +(define-constructor-code-type simple-slots + (class name arglist supplied-initarg-names supplied-initargs) + (declare (ignore name)) + (let ((raw-allocator (raw-instance-allocator class)) + (slots-fetcher (slots-fetcher class)) + (wrapper-fetcher (wrapper-fetcher class))) + `(function + (lambda (class .wrapper. defaults init shared) + (when (and (null (non-clos-initialize-instance-methods-p init)) + (null (non-clos-shared-initialize-methods-p shared))) + (multiple-value-bind (.constants. .supplied-initarg-positions.) + (simple-slots-generator-internal class + defaults + ',supplied-initarg-names + ',supplied-initargs) + (when .constants. + (function + (lambda ,arglist + (declare (optimize (speed 3) (safety 0))) + (let ((.instance. (,raw-allocator)) + (.slots. (copy-constant-vector .constants.)) + (.positions. .supplied-initarg-positions.)) + + .positions. + (setf (,slots-fetcher .instance.) .slots.) + (setf (,wrapper-fetcher .instance.) .wrapper.) + + ,@(gathering1 (collecting) + (doplist (initarg value) supplied-initargs + (unless (constantp value) + (gather1 + `(let ((.value. ,value)) + (dolist (.p. (pop .positions.)) + (setf (%svref .slots. .p.) .value.))))))) + + .instance.)))))))))) + +(defun simple-slots-generator-internal + (class defaults supplied-initarg-names supplied-initargs) + (flet ((bail-out () (return-from simple-slots-generator-internal nil))) + (let* ((constants (compute-constant-vector class)) + (layout (wrapper-instance-slots-layout (class-wrapper class))) + (initarg-positions + (compute-initarg-positions class + (append supplied-initarg-names + (mapcar #'car defaults)))) + (supplied-initarg-positions ()) + (used-positions ())) + ;; + ;; Go through each of the supplied initargs for three reasons. + ;; + ;; - If it fills a class slot, bail out. + ;; - If its a constant form, fill the constant vector. + ;; - Otherwise remember the positions, no two initargs + ;; will try to fill the same position, since compute + ;; initarg positions already took care of that, but + ;; we do need to know what initforms will and won't + ;; be needed. + ;; + (doplist (initarg val) supplied-initargs + (let ((positions (cdr (assq initarg initarg-positions)))) + (cond ((memq :class positions) (bail-out)) + ((constantp val) + (setq val (eval val)) + (dolist (pos positions) + (setf (svref constants pos) val))) + (t + (push positions supplied-initarg-positions))) + (setq used-positions (append used-positions positions)))) + ;; + ;; Go through each of the default initargs for three reasons. + ;; + ;; - If it isn't a constant form, bail out. + ;; - If it fills a class slot, bail out. + ;; - If it is a constant, and it does fill a slot, put that + ;; into the constant vector. + ;; + (dolist (default defaults) + (let* ((name (car default)) + (form (caddr default)) + (value ()) + (positions (cdr (assq name initarg-positions)))) + (unless (memq name supplied-initarg-names) + (cond ((memq :class positions) (bail-out)) + ((not (constantp form)) + (bail-out)) + (t + (setq value (eval form)) + (dolist (pos positions) + (setf (svref constants pos) value))))))) + ;; + ;; Go through each of the slot initforms: + ;; + ;; - If its position has already been filled, do nothing. + ;; The initfn won't need to be called, and the slot won't + ;; need to be touched, we are OK. + ;; - If it has a non-constant initform, bail-out. This + ;; case doesn't handle those. + ;; - If it has a constant or unsupplied initform we don't + ;; really need to do anything, the value is in the + ;; constants vector. + ;; + (dolist (slotd (class-slots class)) + (let* ((alloc (slotd-allocation slotd)) + (name (slotd-name slotd)) + (form (slotd-initform slotd)) + (initfn (slotd-initfunction slotd)) + (position (position name layout))) + (cond ((neq alloc :instance) + (unless (or (eq form *slotd-unsupplied*) + (null initfn)) + (bail-out))) + ((member position used-positions)) + ((or (constantp form) + (eq form *slotd-unsupplied*))) + (t + (bail-out))))) + + (values constants (nreverse supplied-initarg-positions))))) diff --git a/clos/3.5/cpl.dfasl b/clos/3.5/cpl.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..e8ae73df6f571c18bff029d66cd78fb7dccbd951 GIT binary patch literal 6464 zcma)AZ)_9i8NWL_PMjuSApEJDfLok&WjG`OT1Zjq^ZCM^eZF(=97uqUn#A;ym^ibO zc3njj7?Y;XQWw&8emAO)e%LDQi^)DT5Fj6>sfx6Hq4d+Fwf(Slnl`D^q<-3zJPgAXApQIU9pEO{a z@V;+>WIQElfV&-E7qyJDks?r!pgflbMl;OkpJb`u@PP0X_F>=E6CkrTgg7?)`xy zy@!wXc6D_&_luUssHtr0&yUhQhXT>eFx%79)zh^fcJ>}R+S z-N+P&M;>?uH_^tX?Wpbd(`#(op5VAWwBN!tKl)a})4QH2T`g|X3^5vt%KZsBr5MrD zoO7M42`0T(DjJeB(Xxow1LHQyNF)bRGJ6+FnzAHEWnGd(Ao~>Y@~~#Jl@j%+XhuWq zMB){m1j@Z(u@PxUN%*tr3+G1CfzgS;17sqAOzM&20aFGtOY;JdWEw`QRNNL-;mTCV z8c50}rAxMW7hYN+j1rvG2=c!jw_as?i5Geg+73jwmEI}(@BmelkzIN-N;}F#OlA5Q z62DAe&@pYY4fI8G-P$C5K^wXQ+3f)7S}AitN(Cs*wQ`HfmSn0)R6m}<6yxdxit0ho zNz+K8lAdU1`#~b0DmVn6VoFR6C1uo@#~QLya-s=rr^S*}U_7P;tW-C7j>61#Tpf}J zlc1ipsY4*`=9(GVJOCHAK8jG{-3!P0s;7sHNDQ>Hl>~VbbhVb|-KBXK338MPL)BBV zNnZ%0gFfBP(?dFT!eY|F{`IB#U2v|Dv`BCk4*~m=l2!YIVIvNy?!g`_(_%lIzc!SN z0Uaz64r-`KXm++#Y}$Ja=m^YMfthF@ zGuB2%jxHu-dK&2@y)Z+%;c>P2q+}$AzUh25Mg&Z8RCx0q(m8u+mOM>5OVB@n{cn*2 z*zdyrGo%aq-5m7yk?z@9vLE)L?=^^$BwLnYLf;E69#thVCC|>za@WWa@QQ};Z_!kJ z9616Ho|-I5x9DMZ!0`eopTgBs)Db8aG1uAHg+rde!yLPB1^Mij0YD;vCrSuRx!($* zxfS_YB%C+_GY~2-vun zm9ZAjvI6uR=BxA|_+BmUb-NyABj`JO5pS-M7@V$z7nywK%KlNxzCv4@fy6m(x%`m=$QCQbI6tD=R{fr!136G66(AT#drF zfw;{SDnTy_lRyW)vxX88Lkm@s7T1&TQjlM41+;Ldz%h4V2StV6^G?xwCYdso0X=@m zO)djvm!AhC#7-$pbwYs3Fv|?W;|{Gu9^_$#o3ni??IPnq{P_J-lzSC;@ly$~Y4Mi5 zWZ$;$#6F0ZcgOh3F?Zr`Yl)8AR}!}W%u-CaRsI4bhihYVu}ij(KOLtOtceKM{22na z`=qGF;bMVot|TD5RJCvyQh$YvVS@COlmt;2=1I(VOu1i%v=dSy2cl)uG$1};65@a8 zA_y_AeiD3|1Y6NdsgT~pD}KzntUZmu6;@U}R8&KAst*SZD5q+kQGXmlKLiv3af49~ zsLV^QouDF2Cs31H$>BP5Ay|t;*v~F#p^v$1Bwm3EJ0TKF;6Kcs2x;Rwvxc z8f+|otO$!YR%bYptzQR)4WgzYqZZ#m(Lk3BUFz{pli)ZBo*}^`2_7TCZW7#0g1aaH zBKnOxjQ!mP#_U@nm`r>weyO~Rzdfco)UD2IihnUKES3MF{AT-DWcA$`wGp2Km&=N< zFc`aSFKKhyWxH(gr|I+^g=YtFiPnH>duQ+4`1T@cRtmUYAT z__DF-EnT=<{-XxGmKA=r%R?>?mWPKDy}PaUb9-GltxHNld7Q1Fdje9n{25+{gP=s@=o?7kufMl0f;pgz_UgNWwWm}l2t<15ZLJgQolXZEPsFZhXSWcI)IY zL6qMq6}Qj4G1DGcC*b`v7mZR8N%#=T|6v;x#?Hz-oT7F^FNM3LNgO1Xf5ffb>ti@6|Gd&fM&$NXd#fsPY181 z^CN+L=6oiP_B6sQtn+~cZ`==-#??`Ee1x+2Ay``5Lmkf-#`?9Ht`C66N^D8joOh^3e%;-yL?VR6FRc9qeKQ<^v1h140PXo>L-3|FtB?KNQ0Z zXo5St6o!P(w(NsyMN%Lbrv^;;j3VtLdjw4JHcX@pn4lLftT$sw&Qd8O zQ7XDpMv@aYvo($Eu_34F5$NmRwSyF2fPl<>wXg&76p{KAZJf-8_95t~b1KHuQ!%kZ zIAmt3aI^f^O4>n_>vd^I9kqXV8yVXHZ0ytxJ){|us8v`zA!-A%MfPkV7w`i>gYF$=v?fTIg?kbcM%EvkoxCW{11JcN9e5ni5+uz6X zwZ*|)X-I-}+LT2LLJaX9rYnARfLz2(X)AUA4NLfaz?lbdS=OUiL0+hGX+TG(F5LAr_iq^a#MlHT%j;} z4)A*_=Ri1gtNynUz|Uod)6<2_n%BWnxC7l3{U2aHH=NGa;(k7pO;3&HCJHsK3d@~? zdKqQ`U|j5U0>QmXAow{ZV>YC&%5~MJ@Mi>pe~IemtA!xLX-%kx1+Chnk+Q5MoTWXF zSgHwdW+gN@Az&L@pP+_8&)OJqZmfQn8QDEZaB7NG$P%b>X|DVONYWZ*3ClYyOD9R> zIf$Gu;O7PS(8`Jkora?d#MSlKKQDz z5kzTeUro_nkjuK-NMsj@Hj*fQKH;~114X|)O~vsK+J5!aqiD{ypDSt)#w|>8r0K+9L_KQf_+ZGQgwvZ ws%QmG@cG(+Qjx+NRB!7dDWW1j##nIc^!b@cf^D?-IecE_xSye4{Cjovzs6N6eE" (class-name (cpd-class obj)) + (cpd-count obj)))) + (:constructor make-cpd nil)) + (cpd-class nil) + (cpd-supers nil) + (cpd-after nil) + (cpd-count 0)) + +(defun compute-std-cpl (class supers) + (cond ((null supers) + ; First two branches of COND + (list class)) + ; are implementing the single + ((null (cdr supers)) + ; inheritance optimization. + (cons class (compute-std-cpl (car supers) + (class-direct-superclasses (car supers))))) + (t (multiple-value-bind (all-cpds nclasses) + (compute-std-cpl-phase-1 class supers) + (compute-std-cpl-phase-2 all-cpds) + (compute-std-cpl-phase-3 class all-cpds nclasses))))) + +(defvar *compute-std-cpl-class->entry-table-size* 60) + +(defun compute-std-cpl-phase-1 (class supers) + (let ((nclasses 0) + (all-cpds nil) + (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test + #'eq))) + (labels ((get-cpd (c) + (or (gethash c table) + (setf (gethash c table) + (make-cpd)))) + (walk (c supers) + (if (forward-referenced-class-p c) + (cpl-forward-referenced-class-error class c) + (let ((cpd (get-cpd c))) + (unless (cpd-class cpd) + ; If we have already done this class + ; before, we can quit. + (setf (cpd-class cpd) + c) + (incf nclasses) + (push cpd all-cpds) + (setf (cpd-supers cpd) + (mapcar #'get-cpd supers)) + (dolist (super supers) + (walk super (class-direct-superclasses super)))))))) + (walk class supers) + (values all-cpds nclasses)))) + +(defun compute-std-cpl-phase-2 (all-cpds) + (dolist (cpd all-cpds) + (let ((supers (cpd-supers cpd))) + (when supers + (setf (cpd-after cpd) + (nconc (cpd-after cpd) + supers)) + (incf (cpd-count (car supers)) + 1) + (do* ((t1 supers t2) + (t2 (cdr t1) + (cdr t1))) + ((null t2)) + (incf (cpd-count (car t2)) + 2) + (push (car t2) + (cpd-after (car t1)))))))) + +(defun + compute-std-cpl-phase-3 + (class all-cpds nclasses) + (let ((candidates nil) + (next-cpd nil) + (rcpl nil)) + + ;; We have to bootstrap the collection of those CPD's that have a zero count. Once we get + ;; going, we will maintain this list incrementally. + (dolist (cpd all-cpds) + (when (zerop (cpd-count cpd)) + (push cpd candidates))) + (loop (when (null candidates) + + ;; If there are no candidates, and enough classes have been put into the precedence + ;; list, then we are all done. Otherwise it means there is a consistency problem. + (if (zerop nclasses) + (return (reverse rcpl)) + (cpl-inconsistent-error class all-cpds))) + + ;; Try to find the next class to put in from among the candidates. If there is only one, + ;; its easy, otherwise we have to use the famous RPG tiebreaker rule. There is some + ;; hair here to avoid having to call DELETE on the list of candidates. I dunno if its + ;; worth it but what the hell. + (setq next-cpd + (if (null (cdr candidates)) + (prog1 (car candidates) + (setq candidates nil)) + (block tie-breaker + (dolist (c rcpl) + (let ((supers (class-direct-superclasses c))) + (if (memq (cpd-class (car candidates)) + supers) + (return-from tie-breaker (pop candidates)) + (do ((loc candidates (cdr loc))) + ((null (cdr loc))) + (let ((cpd (cadr loc))) + (when (memq (cpd-class cpd) + supers) + (setf (cdr loc) + (cddr loc)) + (return-from tie-breaker cpd)))))))))) + (decf nclasses) + (push (cpd-class next-cpd) + rcpl) + (dolist (after (cpd-after next-cpd)) + (when (zerop (decf (cpd-count after))) + (push after candidates)))))) + + +;;; Support code for signalling nice error messages. + + +(defun cpl-error (class format-string &rest format-args) + (error "While computing the class precedence list of the class ~A.~%~A" + (if (class-name class) + (format nil "named ~S" (class-name class)) + class) + (apply #'format nil format-string format-args))) + +(defun cpl-forward-referenced-class-error (class forward-class) + (flet ((class-or-name (class) + (if (class-name class) + (format nil "named ~S" (class-name class)) + class))) + (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class)))) + ) + (cpl-error class + "The class ~A is a forward referenced class.~@ + The class ~A is ~A." (class-or-name forward-class) + (class-or-name forward-class) + (if (null (cdr names)) + (format nil "a direct superclass of the class ~A" (class-or-name class)) + (format nil "reached from the class ~A by following~@ + the direct superclass chain through: ~A~ + ~% ending at the class ~A" (class-or-name class) + (format nil "~{~% the class ~A,~}" (butlast names)) + (car (last names)))))))) + +(defun find-superclass-chain (bottom top) + (labels ((walk (c chain) + (if (eq c top) + (return-from find-superclass-chain (nreverse chain)) + (dolist (super (class-direct-superclasses c)) + (walk super (cons super chain)))))) + (walk bottom (list bottom)))) + +(defun cpl-inconsistent-error (class all-cpds) + (let ((reasons (find-cycle-reasons all-cpds))) + (cpl-error class "It is not possible to compute the class precedence list because~@ + there ~A in the local precedence relations.~@ + ~A because:~{~% ~A~}." (if (cdr reasons) + "are circularities" + "is a circularity") + (if (cdr reasons) + "These arise" + "This arises") + (format-cycle-reasons (apply #'append reasons))))) + +(defun format-cycle-reasons (reasons) + (flet ((class-or-name (cpd) + (let ((class (cpd-class cpd))) + (if (class-name class) + (format nil "named ~S" (class-name class)) + class)))) + (mapcar #'(lambda (reason) + (ecase (caddr reason) + (:super (format nil + "the class ~A appears in the supers of the class ~A" + (class-or-name (cadr reason)) + (class-or-name (car reason)))) + (:in-supers (format nil + "the class ~A follows the class ~A in the supers of the class ~A" + (class-or-name (cadr reason)) + (class-or-name (car reason)) + (class-or-name (cadddr reason)))))) + reasons))) + +(defun find-cycle-reasons (all-cpds) + (let ((been-here nil) + ; List of classes we have visited. + (cycle-reasons nil)) + (labels ((chase (path) + (if (memq (car path) + (cdr path)) + (record-cycle (memq (car path) + (nreverse path))) + (unless (memq (car path) + been-here) + (push (car path) + been-here) + (dolist (after (cpd-after (car path))) + (chase (cons after path)))))) + (record-cycle + (cycle) + (let ((reasons nil)) + (do* ((t1 cycle t2) + (t2 (cdr t1) + (cdr t1))) + ((null t2)) + (let ((c1 (car t1)) + (c2 (car t2))) + (if (memq c2 (cpd-supers c1)) + (push (list c1 c2 :super) + reasons) + (dolist (cpd all-cpds) + (when (memq c2 (memq c1 (cpd-supers cpd))) + (return (push (list c1 c2 :in-supers cpd) + reasons))))))) + (push (nreverse reasons) + cycle-reasons)))) + (dolist (cpd all-cpds) + (unless (zerop (cpd-count cpd)) + (chase (list cpd)))) + cycle-reasons))) diff --git a/clos/3.5/ctypes.dfasl b/clos/3.5/ctypes.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..54d81e780c866f0e9a248c869f3d6b001dca23e8 GIT binary patch literal 801 zcmbVK&x_MQ6i&1*yOL_VuF->s!HWmCrR}z|ts00)x*OY0O43O8B6QnXx6p1%ekiMm zB6yL2yNZ&h2%fxn^5RJlPyShTUPKUC5Y6GeH{ZPXWxj9bP+071ZK8S8*?7Wy;zi*s z3dxS=lfaAoAtO5+Cl7R|_3)Y-Fh5WRezbRwO@_OQ)7sK)^Om9LmgaU0+H(|_nti2h zI$cF;TaKc+w#{*681BzlP@If|+0}B^`Hgw#vq8v4q!+PZG}vDyl^VGj?J-iW*UPJ< zyw<4J8m0AOwy8SppNIK1()7paM3v}l$fn!;_?1$n#E0sQ>Xk;RR?N=dC9ehPj=;Yq z3^^f*b7c~Gv%-YkWfK%S#f{`3UTnHl>zNi!UW$*!h2(jB(xip1s-UO%wM6_fHrGDc! zth6mvFF2c)-7DxuQ?oiZOq$w){$STfkTAUh=@Cd{kQ|V%gLDa`JV?v9^O?JQqH9|l z6jz@hi|IWFk6AXBZ{ZZCXV^wHi)y%f3a3L39PgOagWT=3RQp?y-{fV6Kf0a<%N1TP zsNJqX^#Yu^fK4jZ&%p{_sCZd~v#E|RNt|BY2au8a0Ob21k3gm%uY-IMWC>*9&H4HK E2ZDCbOaK4? literal 0 HcmV?d00001 diff --git a/clos/3.5/ctypes.lisp b/clos/3.5/ctypes.lisp new file mode 100644 index 00000000..1de6d3a4 --- /dev/null +++ b/clos/3.5/ctypes.lisp @@ -0,0 +1,25 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; + +(in-package 'clos) + +;;; +;;; The built-in method combination types as taken from page 1-31 of 88-002R. +;;; Note that the STANDARD method combination type is defined by hand in the +;;; file combin.lisp. +;;; + +(define-method-combination + :identity-with-one-argument t) +(define-method-combination and :identity-with-one-argument t) +(define-method-combination append :identity-with-one-argument nil) +(define-method-combination list :identity-with-one-argument nil) +(define-method-combination max :identity-with-one-argument t) +(define-method-combination min :identity-with-one-argument t) +(define-method-combination nconc :identity-with-one-argument t) +(define-method-combination or :identity-with-one-argument t) +(define-method-combination progn :identity-with-one-argument t) diff --git a/clos/3.5/defclass.dfasl b/clos/3.5/defclass.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..87ee9f7a7db7a6ed643cf24aa633fc85ab029f70 GIT binary patch literal 5515 zcmdTITWlN0@$N{Gl5EjuNlg%1iO;R2B#x+9aop5SqVhzZ%p;F?)E#9@iW7sTXde?= zRP}IT1Xg4tPJot0s`wGEkphhiv_XIrtctdlTca#?5{j~Gg%cxEPF$jvInh54Cu8vvWh4*@fv>bA_xsH22E6soDJ5+|X1pyKp8qJwG?JFr9yGsF0tV8Oj!l zb3@sM*;&93P32By3z@mO0bF`^u)}HMot@2P=5teulbK(boywf+SH7vl7YgT;!9#}z z`;|k74;(!F^r3-{5!ErcG_@Tgvw5O_T8ZYexicq0{-^dowZC5(JaBmMnZx@B2RiQj zuzXF}UKHTdhF`K!F3E$+d~qgJ$eqm<@TO;Qq5OkV>&TcHN$ZwbzAP?@zVbVzcHIo6 z)JQ@-q6wl{E_ow{*X4z4P`328Vxg;$*d&{M^MRoCY zWzktY|4{jI3y`&mKrM}_uZgIW&qEO_Ijoy13J8b1&jM(g zUNp^3H}?&3)s6iJETq5kRTBllAOT5`F5ZDp)hH4wx6js`G?)c1x7k(eO$*EY+EY#R=5;#JdsU6Cc0R&B&^IOJCM6RE~<1XyF%@6PMy-;gtjN zs)bh$#wC%qeN5K}h^qxAH{%hSpY&~1y7($z)1}qQhdY&);al#iyXLOPZ|Idhaq&c8 zBWwkTWL>|KF#FctG~M6}t8wX8qE^UBLqMoD#RR&mgE7<;AV~Wu(Dp=B(=zo4&wzD- zxd$>ol9hpM_g!QtWyncs5q$)9@`Sd4;%T;R**Tc`Y%OUW)h3vcfZd&jb_A*dc|7Ij zP>T7xfvhcJr6xjYThq2NOJde`yjq^gIE*73xUXhL5p)3b8oHB4z+j^|L^$PPJ`D1q z9}es=EVVfu0I~2TFz^@}?ic>Wc7>rfv_WQ8Nva;$6sYU0n#VEngw670X=$lgE`5E` zQSx)jba7tED23eVOhKu25=wDqK3|+37%i7xNV_@ZY^Jb~Q;MgQc>oTd$<1e|;i!@+ zk1aZn*I6z0E_Ntee)t)D=XB;wZh(sYPAa+0J_xnvnuwxa4Cgn;mt$}7==sxC3L-g- z* z24NYnmv>ULE#^Onuq-@UL${2mhNEHsvvV8>#us___2ORf6xIsuB*D zRPm-NLE4VpgzR|>lA;^DtG^vE)Q>t#VNX z87vvjb=R$c=Z0H}Spmtj(q{!~<)hEMZc2cZ9@@xP_F1w7Ss3n?uRPKuD6YdLtN_16 z<(EIYQ27bxO;eZh%1;`b@6j$bC^vQ|$!Sy|lSzSLRpq)?B@tK!dBfG9 zR}l+;oLZ$?2+`cmzReQtVslT{-pJxmzpx0jL++98Faw9r`0!gciBNg((B; z#6E<6#?Ikzg>(2GAKt1lf_BZp8sPoMY(1^ngf4RQ%ZRo$HCjbyIQlp{i+g); z6@>t10E@o^*vFY5=px8BBe(;=)>@|k2;mEM9*4iNMI1h5Z{UD;@M6_Q-~)!=OE0lk zd)Zlq$=D1?UzSU~_tvAi0u-mYnOru1Dxb|zNkZa3LRr$M>zysUXZoo!-AfKjSeS|@ z=Zb~gd~RUN;uI-PpUutAEBSeNy21`T0$xmetf?t@$4;M~ca@ph;tY_SQ{agWgwqPN z10w@KD1J`2c@wAKZA|yqr^4Ii(t%{AfKOp~htJd)OciO`uN0@Il<5U}UqgY-6>{{} zALxV>eqjkRcpTdPH&k()e0y`{MV@w5>9+Af|e!cDPx1)O!S| znGfyLRNI)Swqmdmx#C*`n$vQr4-hHUhOmPWQ0_}Az^?=RX+%Fvw8Faxl7gPZpCvBi z%hXT3p=yv-m#J;pMQzL0hhqaHe2sJ%R)-@|4fIGKc=&>&2xa*9Rki7BYMQMvI|4sT zG`cwWIi>NmqDB*X=^gdfHB{}c16Dew*>#1Y*zcAexSwnS$sf=n(WVBLL~aRV%R?gm z7({Gpc|1T37~0v6I~|ghcKO0mecOlk-`0WK>isG0^ux~j){pPMwVO_?zcINYh(jxK zsIyqPKZ`D8@fF1phc@C+XYuR%v*<(?cWatBv~v!17Pq%%@xT67R&zu$!(^xAYjH4EdJ zAcrEk^u0H`B&`o8El>fPosTzfX5PH{&3kV+E7bJ|bvZabHjx|6PRipm(-Sk(@~QDj zd1`!SawIFCf_nK|p=9*izm=ZKPEK_XPtN4eWJgD=?qqZzl+gOr?vNQw$5bPg>`oh6 zf48nBb86P{5%Xf|DrY4@;-;k_eJ~Ejdp3a_>Q#0AAlfy6U zl@B~3M`rR_dH)kn?B6TzfB4YBM-M&pP*+2blGOQpoGv|+IqGpx4rNEOV<%t*2Oc`` z5OjKiIvwn4_~QG;%R>EW0sh>Wc!XlXvtOPbpYV-lpU;lsTF0=Vc)n2AlQx1W%`}P^ z#dBg!@y)_I&G5yQU{vW=HeK9o^ zHbcIk84GBJLfnv^I$jn!{gO1_0*Tl^Yn{st%xbTNt7daATj#9Hem+6_Bd~RnAV^Gv z$rLY2#X^01drS!?OkaL5W;vJQo^R4$KWc|9g5!X3buW+Sh;Y$T=GpOfU`r9y2yor)*S z_De=B^fKs8bTXh7wbg8)2@S*JRDyHEf;8TE#8Ji!RuvnvNr3Q&&OE zB%3!2)g1{nnSwI#OVY|-76h@Tyc(;VrJUvU=HTB;tF$aDF9_Qy-z+rHwk(&#vi?NN zIZ?{_07LrwUlGGJEUTdg#aA(?1=IT~lj94!2QBX2#)Hcaz*Kp&Tqr34#NVi!N(gm? zYcz91gYY*@#?J@P-r%$cbtRc(?#Gzif^Gi>ZEalnR-OgU<)4AXyB3Kr&WZjWh&Cis zpvp=jWFITu@-wy*2byQ?__>HDS2MH}?lo4t0Ts1J5?V@4Q29GpPN+%<%4cz8Ed*yp zOAYvrXsNKzghLBm3Bj2A1t4~z3Z7!So?#t*Z1-X4QfJ21gpx87%&oHr0#MUfnwh=) zr`V1bq;%?;dn0IOm3mmOhiXr+YN!b<=yM!S;F6P&8Dywq1 zX_z{3Rkv&C9^+; zD)uO{En?&Odr1_jzQ+gO%Xhp28GZNKiDx%vG)fJ`0i}$u?~i8 zTX{x&Y9fJ}CWyf1@syR7$FkGb_(_@Hp~KU;@w`0!!bDbfW-AYmjASRKr{w&&JU)T# zQ(eN&;>9Y~1vh^y>{JEe&Yx-(FyKAbjFY9AYlv7rzfdK!8*6I`vh z6!){%T`aJLb=QF&H#n9I-P_V3ymx^!_QbE+r|1pE0$ls-80Zkn>gRY-^efFmpjiqw zyO!#pPPk6%Bh{iDC4O353Kx2#+-^mzdhD`bg+Fhusly(g#WgKO$g3vZ32VwyeHp;%{k@ydA#Dp3%`y6wL)4#_?vH3hU z(>`kkYIsm(?jZ7q9WLDiPqNVmS$+#v6NcI-?7_aY)2T#SMI2}D24wnEwhuqw=bx8Z z>$hRQH+;c4_G&2%EDew~TWK*M@ni3LK64@}wAQ7G3Z<7!Y-bnPhIAt|U>cQ_5D z9u0~nYk!pO+Xa<1W+0*lQ!>n91K_@|q7!qsur6r|PE?B$2;UaMw{O1o0R6I}e3kZD_fD}e>#${a5d|a|2gfsmjka=`|{xkSa9RPwJ*n8lW^tX^2v_p#cU5+mW4> z1fj-Ot(p~!D3f^9fv>aa?k?C= z4J`~8`UY9SzfF5VNreUc|7iJIC0my4&I4=PoznB{{(Vedf1K^=XB`IHtpR$JJhBjb z;1GN85m4|}a$Qza?u~3mJ?lcVstvETbV~K9Jw0$B!AC9O2G~{ABPbLxi9!SSZ4G`U z#A5EJk-lg56*wCpO0kD9e@Wp$`gyZpXRq^`8`gq#Gq7mgip|Denma8XC%R1Ie6QIk z%{Lo#az-WkgndhM`^-j>cI3__BkEn4+YV(wh&yi?y7%Ur%gI+%#H7W!D^VI_L8s4< zG;6&Qna!QE-X*@eNMm`ua{*1iWi48n#w9D`Su);>&FwS9OcOuEW|K_@O|hccXnHz; z@VlnR@@5(r4e8e0C*E87{I2M{Ol+fKl;1!GTs)SSZ~<>OkKv(q;zl`G4Kz^JPqavN zw?(@`F@W8@jj0-L0Tv5QN<6M>K_#F&yPT}WZE6Aisev}t2;l+vJya(n0aimIsba-j zbS~b12y|ehtxjc7XKpX^Z(<=d(OOq3n-48H=B~qW9%DoJ*~>pWV3=w$;IMK%bYD+b z8RtRwoG4*!P|@|0R^ojAn&$Hp%>EJ2Ch<;D5@y;6)gZUs#X_esE(4};gK&xhHGmfK z>1;kbnH!N$&E!YOJUpB1LPmcFntKj2^O$)NJU?rgtibs zHWro|p9X^$+s4Kxv+}eBBnV=qW(bK?+#Uz2Xx8&M+;{P!^OFYn6}s+(@H=PkBxg0()&Ci|Iau&FSc4zQW0SbHbix0yZP%+9O>r(_t;^!>B|O1J?J zm`$ZXLoJL#A>aF!`6qX4_ucNv3KcIc*s;^aEiCV9Cds^B&yLqnuE1^8D}n&V82}S` zDaXJ|q1F#ELj6d2reE2DMO$Olm_Ju%5zJ24MjGM@8jzGLf}tqwh6C8bt-8as(bxP+ zV6-aSh^LImZWjyQvRszGE5MQYzZ)@99YPcMytvmAjrJqh3J%#+T%hzOhi24c zyDI4-hYIm}SUM^$L?rQMAgYrNFNWqfh3FJ`W0L5-6_bp%rQnrVkQTY9%G%(R%$4ZFk;{h`; z6MB1mfL5SP0W&nf5v#?Pa!_mM@`nq+^x^9uH0}jP4$EC2qnebeeBp?0n4WgAdKtJ3iHo|l++frAZOE^bvMeZ9F2+dAl%Uti zuUYO-qMu0m_v;q)2TQl7NL^TgmuaEY@N!l7$z^PmVWSDy!j@Ju4UBCyO zQR#6gROxC8^BAJ937KesV)1@tD>h-WL?gV9*=yJvUQG{U;VRX?f!PnBzFG|`dVAVfhdpyl;m0yG3-9xqcT0l{ZxcB^ zDHecDwTj+3GJOq7lGgJge#`{=;8MVWy5GPY>buH*JO{|eu8L4>lFvcAiME4kPZxfzFl*rDG{-SK5W{Dg3pqbKbMc<+sOdGF+*e{3VH zxE(qPKP?tUVs|;)_R|lzoAly?uI^pIN5?f?`E{IGd1`nJ{K<*zNDh4dZ-UED179o+ z%%L5;?#seA{P@~)LRbph@a{((8k*H#^Yb9m*4epTe(@&J=tG+KdRXT+L*%V!tYhI7 zxcvuj%>8BLMmWOb!5ZNNSslEB5U8TO8?b~Qa?t~i-W7gYi!JqKhumec!G1QFgni-8 z8n`e@T6dlX>^nZBCW8r$9@?1uAken*Gg?v&_+3W|UWg6mcICk@sY`%=v|#~`=9f}Ob4RyOfb+U-XuJ!nhuVUS{BQ*OTR~=wOK3sHp zxxug+jQSF3c=^Uhk!m+^l&D_N?N!GLAfol@B$7*hq`)#s@q+q6c8ey?$wa zi^auFs>*+UBhss!$8He$KJcLqz)%%hT4#$s>FNNH*5D6NloVm8s5e243&ZgBkf{x% zQPwb_zX;4*!ufmSw%ap&uxLH*nw+v&E)9b48Nu69oJvc z$=H%^%>5NXzyfr?83qe4!mX0INCbm25$T56cr#|#JsQJ02t=EWw{$+nRaqyU=CNV0 zYnC)H;2P0@gFwyT^|=qV0f-?Hb}aa%Xqz43**bXDM;*gkk6ztr=iUj^{%{ZM^~wSf zP{IStlqKRdbNDt*jp41Ai1HlYWHkNID5E+%ZyO({My6^zkvc=X!fj literal 0 HcmV?d00001 diff --git a/clos/3.5/defcombin.lisp b/clos/3.5/defcombin.lisp new file mode 100644 index 00000000..5bb69ebd --- /dev/null +++ b/clos/3.5/defcombin.lisp @@ -0,0 +1,410 @@ +;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; + +(in-package 'clos) + +;;; +;;; DEFINE-METHOD-COMBINATION +;;; + +(defmacro define-method-combination (&whole form &rest args) + (declare (ignore args)) + (if (and (cddr form) + (listp (caddr form))) + (expand-long-defcombin form) + (expand-short-defcombin form))) + + +;;; +;;; STANDARD method combination +;;; +;;; The STANDARD method combination type is implemented directly by the class +;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does +;;; standard method combination directly and is defined by hand in the file +;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this +;;; file for bootstrapping reasons. +;;; +;;; A commented out copy of this definition appears in combin.lisp. +;;; If you change this definition here, be sure to change it there +;;; also. +;;; +(defmethod find-method-combination ((generic-function generic-function) + (type (eql 'standard)) + options) + (when options + (method-combination-error + "The method combination type STANDARD accepts no options.")) + *standard-method-combination*) + + + +;;; +;;; short method combinations +;;; +;;; Short method combinations all follow the same rule for computing the +;;; effective method. So, we just implement that rule once. Each short +;;; method combination object just reads the parameters out of the object +;;; and runs the same rule. +;;; +;;; +(defclass short-method-combination (standard-method-combination) + ((operator + :reader short-combination-operator + :initarg :operator) + (identity-with-one-argument + :reader short-combination-identity-with-one-argument + :initarg :identity-with-one-argument))) + +(define-gf-predicate short-method-combination-p short-method-combination) + +(defun expand-short-defcombin (whole) + (let* ((type (cadr whole)) + (documentation + (getf (cddr whole) :documentation "")) + (identity-with-one-arg + (getf (cddr whole) :identity-with-one-argument nil)) + (operator + (getf (cddr whole) :operator type))) + (make-top-level-form `(define-method-combination ,type) + '(load eval) + `(load-short-defcombin + ',type ',operator ',identity-with-one-arg ',documentation)))) + +(defun load-short-defcombin (type operator ioa doc) + (let* ((truename (load-truename)) + (specializers + (list (find-class 'generic-function) + (make-instance 'eql-specializer :object type) + *the-class-t*)) + (old-method + (get-method #'find-method-combination () specializers nil)) + (new-method nil)) + (setq new-method + (make-instance 'standard-method + :qualifiers () + :specializers specializers + :lambda-list '(generic-function type options) + :function #'(lambda (gf type options) + (declare (ignore gf)) + (do-short-method-combination + type options operator ioa new-method doc)) + :definition-source `((define-method-combination ,type) ,truename))) + (when old-method + (remove-method #'find-method-combination old-method)) + (add-method #'find-method-combination new-method))) + +(defun do-short-method-combination (type options operator ioa method doc) + (cond ((null options) (setq options '(:most-specific-first))) + ((equal options '(:most-specific-first))) + ((equal options '(:most-specific-last))) + (t + (method-combination-error + "Illegal options to a short method combination type.~%~ + The method combination type ~S accepts one option which~%~ + must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." + type))) + (make-instance 'short-method-combination + :type type + :options options + :operator operator + :identity-with-one-argument ioa + :definition-source method + :documentation doc)) + +(defmethod compute-effective-method ((generic-function generic-function) + (combin short-method-combination) + applicable-methods) + (let ((type (method-combination-type combin)) + (operator (short-combination-operator combin)) + (ioa (short-combination-identity-with-one-argument combin)) + (around ()) + (primary ())) + (dolist (m applicable-methods) + (let ((qualifiers (method-qualifiers m))) + (flet ((lose (method why) + (invalid-method-error + method + "The method ~S ~A.~%~ + The method combination type ~S was defined with the~%~ + short form of DEFINE-METHOD-COMBINATION and so requires~%~ + all methods have either the single qualifier ~S or the~%~ + single qualifier :AROUND." + method why type type))) + (cond ((null qualifiers) + (lose m "has no qualifiers")) + ((cdr qualifiers) + (lose m "has more than one qualifier")) + ((eq (car qualifiers) :around) + (push m around)) + ((eq (car qualifiers) type) + (push m primary)) + (t + (lose m "has an illegal qualifier")))))) + (setq around (nreverse around) + primary (nreverse primary)) + (let ((main-method + (if (and (null (cdr primary)) + (not (null ioa))) + `(call-method ,(car primary) ()) + `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ())) + primary))))) + (cond ((null primary) + `(error "No ~S methods for the generic function ~S." + ',type ',generic-function)) + ((null around) main-method) + (t + `(call-method ,(car around) + (,@(cdr around) (make-method ,main-method)))))))) + + +;;; +;;; long method combinations +;;; +;;; + +(defclass long-method-combination (standard-method-combination) + ((function :initarg :function + :reader long-method-combination-function))) + +(defun expand-long-defcombin (form) + (let ((type (cadr form)) + (lambda-list (caddr form)) + (method-group-specifiers (cadddr form)) + (body (cddddr form)) + (arguments-option ()) + (gf-var nil)) + (when (and (consp (car body)) (eq (caar body) :arguments)) + (setq arguments-option (cdr (pop body)))) + (when (and (consp (car body)) (eq (caar body) :generic-function)) + (setq gf-var (cadr (pop body)))) + (multiple-value-bind (documentation function) + (make-long-method-combination-function + type lambda-list method-group-specifiers arguments-option gf-var + body) + (make-top-level-form `(define-method-combination ,type) + '(load eval) + `(load-long-defcombin ',type ',documentation #',function))))) + +(defvar *long-method-combination-functions* (make-hash-table :test #'eq)) + +(defun load-long-defcombin (type doc function) + (let* ((specializers + (list (find-class 'generic-function) + (make-instance 'eql-specializer :object type) + *the-class-t*)) + (old-method + (get-method #'find-method-combination () specializers nil)) + (new-method + (make-instance 'standard-method + :qualifiers () + :specializers specializers + :lambda-list '(generic-function type options) + :function #'(lambda (generic-function type options) + (declare (ignore generic-function)) + (make-instance 'long-method-combination + :type type + :documentation doc + :options options)) + :definition-source `((define-method-combination ,type) + ,(load-truename))))) + (setf (gethash type *long-method-combination-functions*) function) + (when old-method (remove-method #'find-method-combination old-method)) + (add-method #'find-method-combination new-method))) + +(defmethod compute-effective-method ((generic-function generic-function) + (combin long-method-combination) + applicable-methods) + (funcall (gethash (method-combination-type combin) + *long-method-combination-functions*) + generic-function + combin + applicable-methods)) + +;;; +;;; +;;; +(defun make-long-method-combination-function + (type ll method-group-specifiers arguments-option gf-var body) + (declare (ignore type) (values documentation function)) + (multiple-value-bind (documentation declarations real-body) + (extract-declarations body) + + (let ((wrapped-body + (wrap-method-group-specifier-bindings method-group-specifiers + declarations + real-body))) + (when gf-var + (push `(,gf-var .generic-function.) (cadr wrapped-body))) + + (when arguments-option + (setq wrapped-body (deal-with-arguments-option wrapped-body + arguments-option))) + + (when ll + (setq wrapped-body + `(apply #'(lambda ,ll ,wrapped-body) + (method-combination-options .method-combination.)))) + + (values + documentation + `(lambda (.generic-function. .method-combination. .applicable-methods.) + (progn .generic-function. .method-combination. .applicable-methods.) + (block .long-method-combination-function. ,wrapped-body)))))) +;; +;; parse-method-group-specifiers parse the method-group-specifiers +;; + +(defun wrap-method-group-specifier-bindings + (method-group-specifiers declarations real-body) + (with-gathering ((names (collecting)) + (specializer-caches (collecting)) + (cond-clauses (collecting)) + (required-checks (collecting)) + (order-cleanups (collecting))) + (dolist (method-group-specifier method-group-specifiers) + (multiple-value-bind (name tests description order required) + (parse-method-group-specifier method-group-specifier) + (declare (ignore description)) + (let ((specializer-cache (gensym))) + (gather name names) + (gather specializer-cache specializer-caches) + (gather `((or ,@tests) + (if (equal ,specializer-cache .specializers.) + (return-from .long-method-combination-function. + '(error "More than one method of type ~S ~ + with the same specializers." + ',name)) + (setq ,specializer-cache .specializers.)) + (push .method. ,name)) + cond-clauses) + (when required + (gather `(when (null ,name) + (return-from .long-method-combination-function. + '(error "No ~S methods." ',name))) + required-checks)) + (loop (unless (and (constantp order) + (neq order (setq order (eval order)))) + (return t))) + (gather (cond ((eq order :most-specific-first) + `(setq ,name (nreverse ,name))) + ((eq order :most-specific-last) ()) + (t + `(ecase ,order + (:most-specific-first + (setq ,name (nreverse ,name))) + (:most-specific-last)))) + order-cleanups)))) + `(let (,@names ,@specializer-caches) + ,@declarations + (dolist (.method. .applicable-methods.) + (let ((.qualifiers. (method-qualifiers .method.)) + (.specializers. (method-specializers .method.))) + (progn .qualifiers. .specializers.) + (cond ,@cond-clauses))) + ,@required-checks + ,@order-cleanups + ,@real-body))) + +(defun parse-method-group-specifier (method-group-specifier) + (declare (values name tests description order required)) + (let* ((name (pop method-group-specifier)) + (patterns ()) + (tests + (gathering1 (collecting) + (block collect-tests + (loop + (if (or (null method-group-specifier) + (memq (car method-group-specifier) + '(:description :order :required))) + (return-from collect-tests t) + (let ((pattern (pop method-group-specifier))) + (push pattern patterns) + (gather1 (parse-qualifier-pattern name pattern))))))))) + (values name + tests + (getf method-group-specifier :description + (make-default-method-group-description patterns)) + (getf method-group-specifier :order :most-specific-first) + (getf method-group-specifier :required nil)))) + +(defun parse-qualifier-pattern (name pattern) + (cond ((eq pattern '()) `(null .qualifiers.)) + ((eq pattern '*) 't) + ((symbolp pattern) `(,pattern .qualifiers.)) + ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) + (t (error "In the method group specifier ~S,~%~ + ~S isn't a valid qualifier pattern." + name pattern)))) + +(defun qualifier-check-runtime (pattern qualifiers) + (loop (cond ((and (null pattern) (null qualifiers)) + (return t)) + ((eq pattern '*) (return t)) + ((and pattern qualifiers (eq (car pattern) (car qualifiers))) + (pop pattern) + (pop qualifiers)) + (t (return nil))))) + +(defun make-default-method-group-description (patterns) + (if (cdr patterns) + (format nil + "methods matching one of the patterns: ~{~S, ~} ~S" + (butlast patterns) (car (last patterns))) + (format nil + "methods matching the pattern: ~S" + (car patterns)))) + + + +;;; +;;; This baby is a complete mess. I can't believe we put it in this +;;; way. No doubt this is a large part of what drives MLY crazy. +;;; +;;; At runtime (when the effective-method is run), we bind an intercept +;;; lambda-list to the arguments to the generic function. +;;; +;;; At compute-effective-method time, the symbols in the :arguments +;;; option are bound to the symbols in the intercept lambda list. +;;; +(defun deal-with-arguments-option (wrapped-body arguments-option) + (let* ((intercept-lambda-list + (gathering1 (collecting) + (dolist (arg arguments-option) + (if (memq arg lambda-list-keywords) + (gather1 arg) + (gather1 (gensym)))))) + (intercept-rebindings + (gathering1 (collecting) + (iterate ((arg (list-elements arguments-option)) + (int (list-elements intercept-lambda-list))) + (unless (memq arg lambda-list-keywords) + (gather1 `(,arg ',int))))))) + ;; + ;; + (setf (cadr wrapped-body) + (append intercept-rebindings (cadr wrapped-body))) + ;; + ;; Be sure to fill out the intercept lambda list so that it can + ;; be too short if it wants to. + ;; + (cond ((memq '&rest intercept-lambda-list)) + ((memq '&allow-other-keys intercept-lambda-list)) + ((memq '&key intercept-lambda-list) + (setq intercept-lambda-list + (append intercept-lambda-list '(&allow-other-keys)))) + (t + (setq intercept-lambda-list + (append intercept-lambda-list '(&rest .ignore.))))) + + `(let ((inner-result. ,wrapped-body)) + `(apply #'(lambda ,',intercept-lambda-list + ,,(when (memq '.ignore. intercept-lambda-list) + ''(declare (ignore .ignore.))) + ,inner-result.) + .combined-method-args.)))) + diff --git a/clos/3.5/defs.DFASL b/clos/3.5/defs.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..44148d64f17beea596ceb297c95b91f92905f0cb GIT binary patch literal 21525 zcmeG^Yjhmdc{8&wy{)(9wK0QZJ7)1JmW_FZm>unov?Hx{*1IcP27@EZ3#%YYjwBmg zPB=Ef1jwc!8_W(RrJ+rl9GV;zP8vVJs?#JT4M~%>c@z?woTO=*v<;zYng=QU9`o9V zj14ru>SOKP=Xbx?{qA?aduQf^nvrNij!x~}H$IV@mZ$d5?%O{r-#j%f&rI!~9?Qu$ zL%DoMEHn7NYlmlY(=%H}r}t0ZmYW#MZ^;bqh^4h{>Xw)u9UfAX+02&Vq&Bi8p=DBA zq6s~-B|4l=L;03HxtnLYC&p*?y|bq=M2XYfg>t3uVK3J&f8%{>Enw~5k6Ay|0 z;sb>`Eg4QJ(LtqO6-2RE@FH0PfD~6bAQx`I{setwF5XNPV^Xu=5sOC)&7qju7fmRc zOgO6zshLo5&ID5|EQP9VN?I;&B8q}wh=_#L0!a9K_2FbJh4|E@(mDXshQtP=MhX^> zd7#jn(3KcI)on@wo`I-7l+qF^K#(w-NvTmyNfLHKb%#NX6Jz;}xA%1$-LY1U$y#y51n^iN}ASN=}^=gA5gKiRgW#KW=J~0gE`-bp&d}rWHvC% zJ;jF$0U!{e3gVJtp$;jP?^NJFQ6J3RzHfALPdKKBGg&1WQ_`_8NCaCU2ZRj~=>!Rt zXm?~xsdzpZg#T1UsbI5UTm|z{GO3e_g@)Cuhm>eq4S&MTvygjZarPatfn6XC-9aT^d_W+x>)WVE6 zmf(y+4Hniq*psl>5;??~!ef;roaHK@QNpIVk&(F|GB7i#dPujC7MawV#?jje6*Wq_ zpESM&@NKIC)Cl;2Z^odwoUM>=Z5nj8SZFGpFeI@{s`SqwcTsL+J4tX|krVlo@wxcn ze6zTNv~?jaotXcrV5B6$t$wviG^%DYdO9OE8VXSNn4vrZ?7DSQ5H22xvP55u*t`oQ5Ui;X>`sR5l$SP7ZDqjd$Mw zY||pr$^5DO>HIU=69ejB5t3@9!y^Tb(g`yAU6`&tLa{{BA6QJPj)nhw~1rJOp&oxMel1iz`SO}9~ z?}1}Wj68|;dO&X^a#k`W@^-RnPIkwf*6gaier~{>y z3I46N@XA=;YuvC2=xNKum9!dT6Rah-sp*Wm8v6K<_+$s98i);Ml^?p46bLlASCCFE zqViRo7|=I!8jCHU^|&PXL0cNx`PiODCZ=H`fqk(S%@UpDDw86+CWV%Ys@lq{zz9=C zeLqZ7EvcdBLat4iFfUEKIApCZrS)MYtb5BEa;xa2E*pNJJVDPsXL|#T&$D z2Bl{QB=IJ3SJOgL+SR;}-_;6#?F-tTO_7&(bsp0@=hthSn&-w3<#%-*)4S$ZYIFHR zJlO6G$@ zwDvfRa#~OsWoZzzpHs@~mszYgl~w4?1bCc^34q>d!og(^{s)5=YI-Z#*j-%{w-Wy31-*+XUv*Spbwm$h`k20AzDMs8^`Holu*r&|zEYRhLXUfOIUn4$68h_1 z62c5hyMhbz&k!lN$bu+@_qSf?LhC^Zt_J-Gq*a<{m=6-Ldv_W6M$EQBwI`uwafF{k z+NY+|dKz=zft)w0#3=I(>UAHMe~ywL#N-0P=82!e{HG9DRG}W9FxFtv;|LR{2{m{W z8-M}Enh!9@_tB$pJJfi=qQ|^YCknVOg46acULU<^5kPr;*Y@f97En&CqJDD-=~u-9 zc4~}{PQHCs-aokqwqmp3<;ZttR%Z-iSJf55G zzH`l;jdJNfZC2j9e`Z$Ros)Cpvw7HTjmk3z_wJsWkZ;S6kLBgD(Mfr7bZ-vIZHQCT zRUnPZu&^rK_jk!GFR@Y1`XOTjz~F)-N={|yl7aw z$}me|r({{M3v-m(!4R>dp2C7}s!6j~S(`17z{^$jNyJJ2dh*G1ARPDC;*PDaR1 zjI*Cpno-!{)QJ^@USo`0 zgtf!TYPHQc$Z)c35bh~0h2^;>sfWpG)KTFHW?!J+^1@&#*%84d!sJ481nnVsBS#{% zCOp*<5s8;CKN68dYq@-i#$e-{{* zKp*3Bl@Y2T9M4Eedd^+K4@twRff_nTzel6=c!U(8z906Xz#9xS(8BnCOwHNXp{5=t zp@ol4(dW;bBI6(kWDg1CsWw(n@(h{HZ>ek!R-wdq6S4OGI6XcZH9~Eiss%wcmF}jb z9aJ^9o*z=SOiC<7mQn}W1sR=Xxzy!4F5IA?Qaz$Xc>AGP>Zh3Mr&#KzIO_K}q*?vU zUZi(_e+)F|ve zy$Ije17h&eNGoCD*MY6U4G?*#xLNODk2#fAqiPHcuZqS6T-`dTtKm8wLJ7E2_fr-S zHVtZRC^Ova(9p}c&qeNuFvcgCs5#{xlLXk$YUnarw88fF5O|c$rR029Dq%k1-cw{6 zHu|pxa%!w`FC%t-`yzV0$a?ou1Lt`9zhvUtj=OFpt7ZB$HG?J>@g~-3*2Og3xQZ){CQl>aS8I<{W4ud*f`B<7ThcBHgCPQ8 zyRR8AfmrM6bA_o=tnq?JFqrnAf^X%vlo+P)tu!`t89i;r#ztdPjd8gE%VD9tbUZVJ zgmIOnGzW;#1t*Ccm6nZVq2n3gfaM&t7!45k6r_gYu~q~90}hs%Td%O*7tUgU@MvKv z1<_pP+dw<@^dgn)eJ)l>8+@)@Rt`3!ZXHGiUZgq=($|wpf~z~rdsFoy!zPD^dQ}tQ zj`EI4@FcijMHS8@uIei9h0(!&3uXl}eGud}dsYAipPC}CM++4|F~E^fM|j9!`H)fA zrz=qiN^<@3^7>v4wy`eJRA8l~)5;F$414Y6B=JT9!A8PF*NT|p5r7+*yWB0}l5&@H z+g+eb1?#RUm1&Esk4v2HA>5K|b~Sf|=q`2S*XC+lB0Be&E~&YpI0AD+DUlTmnHgCo zCYAzMl}pGyxFsBza4cEwVh4qJQDD)#`%yD4b~B2@A6&k|MSOWMgZ4*E1gfk!xrr|n;)KGjlep3`fMo|= zdHXD+E7UuzC9+{SEi)m|2?igBTnt0gDc2%xoD&g=Pdeb_2;5Y0jdiF&ne)aa=-^@* zSe{*s%_SAsl($+8pO71$5V_6E@SvqCS-6f$-H~)BxL9z~;$FaLHtsZOB{dx! z^Dbz(ZDP7T9$v}BcfcOWwUX5_Z*e{ItS~lo8a*w>MggK@g(jB*+^H~b%S&)8CGt&R z7qYS2e7@N69JerlRS;1`)w*meAH;0EXfA#a`5E!xn0Yu;T4o-mE)9VqX?RWs{t9q| zjUAt<`nM~IK{Z`%iFPC^crU?a*@gm}MR5MKWWNzuO3aU7fZa!oHUb_hQrJalvOAfz z;3se>Gop}4B}ruOQ;e2+MIPwM(QL5>ptswATr|)~*NPN75Mjjgop}wRUL9hsFoE%e z01hA9Z2fl19r{aW*nnH32WZT7DU!p>kGf`k>T$}@4?A0VkOw({;y^Wig9B!{M0mpI zkJ8q;327AW2hR)LXj+%E;BR`CQ)o;0`|R|=@yT1jy^<%UM)%0;;10qV-%GfZ_dMg1 z5I&M~lLyA9rzZF2CTC?R;c(UXY(;1)k72P1xL~m7AcVPclk&dN>DlqoiHU;*Kewk_ zma};XIPD!hC{Iq!%C}8T-@0BtIJF;3D!@(V;GP2Dc1vy+V`9^}nLI|m_Q~s}bGxUe zW-qluTa%1F?$WwDi-mPS7L_1v4o#3VsT!R;c-!c~neJLHq2`u8|e;9iA!o0Q{(M!HQr9+p6~69 zu22$YkCF_lTN7dPo&=nzlRsFn7p_IxEQZfcyl{XA5uMdLlDmkPA#h>aiTGArP_gJA z9@4`7eVLH6$q;deVG;~O)P}4kyj+(T@*T3H&bG(T?+&)862enUx#veSjf#qyEVj4CeS~eg5yLrM%3Gvcq(cu z=$7a}M?B1a;bAxVhdDrQUHQPcF`V!9IZ*_3b%dSf5#K4ojea!3KNuWG|h_=E;?K4;=Hk0wL#hMPw7q zUvb0;gmE5^gfMT87P0fU7;xQNl8l&%ANa=0A=XXarC8jcShK18B_BX>Y5+2mLP zNiI3!K!2i=r*zaI-ox(7!{$+k6ZSC@MLg7p9j}@p0omuTxPRohAqggA3Pxnf5Ti9m zNCOyfqM(!MSv~5xU^aV#z+RtujE(n+yx{BCg<@BW2@`L z$RTb~cGeRj76+J(kMg)5J|KJPPJy-Kff5EoG$-VL{!@^noj{)A>;(m1U> zG%&dK)ZK&m;Pr68ePaHHCn91zc#@8!PsJk=@K=-Q)LVopkO$=-pmXl#V|w%a`T_Ht zyY-mfI=^y&PJ7#r>g`7c_?&ydIp-dj@8EOp=49~9fZh}YPrI?$hePR3`0Ikd;DX*t=&m@buQ;N&V;Ya{ zd-PUOZ>Pg)Xwq5KyY%2%=y9(OTDGeT`s=L{!fcn|lpYSJ2``QAuF#}>a!HB))$>Io z^CDP#rIaQQ_|WP74Y|JeV)AEB^01L#4+mrRl@=7^d@VNm2{odl=r7Z_k7Ma`sJv-) zs1GxLMdcsDYL_+8B+yBOi(Y`@zOB&(^?cfCEaKL z2mhvGB{4$_r_n=eE*`@hczzCm0SgZEby~VU3o%2e^HKZ?5;ay>jhlIii+^dc?aU$b zOhY^aFu3yUxhg+vSE5aaV7M7T!y##;N_bzkx_lM}cDUa-J@%WR5KJM4myK?}ie*#v*rYW{+a;0uHxHGzIUipTK?EdCeW z!$F4QA3x$=nB588>YNatMY!35hTdrn`yvd>h`&ex+>JoV#s4^uhA>>M9c)D8048#Z z^n{~GT)_B$&#a~KFhhw~ZA4zByu}3(DPpJpG|er*s-}mp;^g69qaP=c>sk=mzBg0h zx|qm;7P6}ZmQwLDi|f?z(GTV62duOCFCSbCQwJCsWG720hG_ntH_Y>({`H8Y(W_zP zP+OKN!_Fb(+)%31_7?PxJ1{79ZdQVvINDfUpBz}#s5uwtH{KH#?l-11WrAVq-=KIL zSj-+vq1}E*HI_L2oYaLuI2Tjdu_4IS<#ir2z!40=`Q7$#Pd``sWEoOU_D%8FwKpJ$ zj!2wTRpGqhjx@}h!ukIpuxEcRGe***pWofIbTr0EmFo^oPiy6)W^dIjbtXiaBD1xi zvFy>EMVBs1Z>+e4AldHsI`k?ogWYW-z7^(rfda|{KR|~>!YxMNOHT4BCwYsp8Y|b( z!~ZFMOzCwZTf+~*{>JIO6ha*dOuFb`qr`6_|;{60St z{HUXcM4KdPCViSq?%>Bx8NAfNf7TW!h10pENFy+!1lBTmkTKG!93n$}BK`{4wmZ+qDC!pWOcE6Yg7ocDl zhqvn~2xMOH#}V$QPIZ_(M9F$g9-w3cCf|z$Xh{SH@mLMsM}a^WR!mTvCQR;zHoiV3 zk>M*~Ph;7Qz=a0nqjh~33+W!6M5D13Xtc|n(cXbcQNgw$2fj?nb}U^^$qr1?CWCA6nEw~l08#h<4A5${UTLLJDPivaHyg75hc-C>*C>g&`Tv@d1df?X;7;I{32z!< z6WXdvNWGu-=MrM){}Tt?0}i+&4!AogN#G6uc6CZ3p~Lkmdfx&8yqD?;>@Aceu)8UV zMEi#*NmxcHNmyP@NdkL0fVK6P=_RHzuB`L~l$lCE>m8u9^C3?9{@VuXdj)`6bAVv_ z{+%ijQQ!9|i7EwNE;kTte=Ee z2bB`7%u2$GS&4XgUj;~H5(tWyIg9vsnU6@Qm-e|50`xK;aVmTN5xRESQ@Pq4_I{Fv zr`8{b*2~UqC%g|i%^!f~o#!wQUe;FvjrzKz>iDdl)aXWN)KnV1VUjgx&=|Do0+w#a z_c`IVx(aWW!~IO_;wBQ!Y$k}f0tV5Bz*M380yZxkW9nV%KyS5^9$r^aES`U+QWT5l zpD2l9@w@=AA=a&Db-po)WnZUil#S<0ltkHhzCcNojpxrPNl^ckk_7d`lq9G{fZ7h% z%;A27Z8wo`5SzyS$EYO@a38ev!Xc&3HFr}D4KhVZ8YD+a8sr8_(jeQQtIq{>D^(HH zeo7MBy_6(~VM-E2UMmUWGAbpA?EtaCr3)syOQ;0__EC}m)13j*Rf!EQ%1T0mTbqGv zNRDWvuiE2Ee?v(eSNa?!aa?HuI)QC5UuwgWQ&fpVO7oP&AtkmBNQ-owN|6@nK}r%# zUdjmO5iAwHjSYBJBVfF$5iqv11dQ!0;g9PW+|7YEqFn^M(-~~DGZ@=c8Y~38noP!- zXWt}GX$>`}p)aN+jaTQu^V;ylUsDp{iT?%gS}Z{f_Yx{9OGA8_njuJ$moB76{2rAe zbn$sgB5Op}S!9j)j062M0KLtI4lfdxz-JGV;D4O@5d1%O;4_m6K694fGiM2V=Ilxw z)$tHSHW38uMh94ilE`|Ij4>_zVz*OzDInV!Q}LZqco#c7oT4M+A#Fs1_Y<)jTV8^I zuYSP$%lrWgT2jMKLxCBGcnd!!_=vag14<&^0+|Jo!t)g8qxDkwDm6g71-1srWZ|rh zq3{fhY90l-Mk`VS8to`0X|#JONu#|Vy7@EuFr0B4fjg2`W_Owwb?IJCgeN}vk` z?m?IvTO^t06isQp>$Zat*ucHfYSw`=DttB4yc8uZX@&A7wgt5+CF=CH?Lb>i7eqh7 zbu&F$EUCc~kVBcX8n${vo50V_n5lFH=Bx;?#A+{N8AQr?7%sa6%l@o*43F>H(T>F& zV`(~>P*cw}=4^xldLtA*W5E~P;WZ#`;C7>+Rg(pfy?8iU14od{Oh?{bWcwh{s@3Uf z`K{E{1(BTr2NyisBV`Oc2qXgQ$os-pcq9`zg4|=$`F$NJg2i`O45J);r-Yd^NPVIe zeaIue+Ui3&xSMYFDHa3-32z#rVre7vOXFX zBf-=MbKdV;xmB3^8r-b(r0g4dhvDlF6Qg@~?-|AGa+RS2x~#VwARGb{g&N`gJlvQF zPyhm>4d?C*T@14`UtW~51mmd^l#G&`E&eNUv|FsYFy`>nJ46`eHe0#Nux>?34p`uU z=@g_{9`vAp+jkEkJ`yOP3!3;E_g`Ad#4>l|?@IfeG`jk5n50&lfC)m0RaP2- z8GEEroU(KS;{s?iC+t%&h&}DDw5QxvINc6=0R``ujhpasmL6iSanp^)P5AooQtR3k zea@!zC1T-byxOxvgpY%m7fj;P847g{kZIwVFnm4)@As62K&b(hxjO`t!64iTp`a-K z;2&QLlFkM|Q!nfTJ$@DAGH^{{YXl`Je&`B%JhdK+6S|&~(N=WxmwFu1x{W|PHWcpj z!i$V(5um*%rKd<8o_i-3`0%LQEb2i!1u*d&Kc+62p7(Ry*q>Ij!|CK9RH_TS(uH^E ztk3$;P&C6W!I=s?}KxJ(RKL@0y=`~3BR#h^V zP}7$JO}@4Kp%(gH3tv=9sQvIgBiziD`qcbR=Q8KjTRKvi8|QbPO)-84?v1NPEJg8^f1pfozNeOsl66*1C zr@MJw#q#3945Hb5kFylre=UaxSKHwNfz=lfu7j^rIUi7R(Sa`4WH67 z0`P$%X$PL5UGKUA5Zp2FTliejr0_wwrWkp4=p*x+hxm=&RYT&LA?exVPGaOu<1atG zj1MmoNq%koJv563!VB|X0tQI9RsRRaWte3p{FC~O9t<3IRG|q;k{Zl@{1C5$cP^t-le44alQa0?3ckC4rvip(7i-_I zhrp1vzz2f}`FyYrMT91;u|x?$PfWK1Gz9DreoO%)q6v#MdNY~#iLVHvw^-=VX6Tat zsJw4_Y9D;>0>4_(4IhSrxh(w>25pZVhgbFUcfki-%Cz#A)3Nu%tWgcJo@FHFetr=8z zY=@iHDZ#s@SXgW0Vt#1@KeI72g), this is the only place +;;; that knows about this hack. + + +(eval-when (compile load eval) + (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq)) +(defun get-setf-function-name (name) + (or (gethash name *setf-function-names*) + (setf (gethash name *setf-function-names*) + (intern (format nil + "SETF ~A ~A" + (package-name (symbol-package name)) + (symbol-name name)) + *the-clos-package*)))) + +;;; +;;; Call this to define a setf macro for a function with the same behavior as +;;; specified by the SETF function cleanup proposal. Specifically, this will +;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b). +;;; +;;; do-standard-defsetf A macro interface for use at top level +;;; in files. Unfortunately, users may +;;; have to use this for a while. +;;; +;;; do-standard-defsetfs-for-defclass A special version called by defclass. +;;; +;;; do-standard-defsetf-1 A functional interface called by the +;;; above, defmethod and defgeneric. +;;; Since this is all a crock anyways, +;;; users are free to call this as well. +;;; +(defmacro do-standard-defsetf (&rest function-names) + `(eval-when (compile load eval) + (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name)))) + +(defun do-standard-defsetfs-for-defclass (accessors) + (dolist (name accessors) (do-standard-defsetf-1 name))) + +(defun do-standard-defsetf-1 (function-name) + (unless (setfboundp function-name) + (let* ((setf-function-name (get-setf-function-name function-name))) + + (flet ((setf-expander (body env) + (declare (ignore env)) + (let ((temps + (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) + (cdr body))) + (forms (cdr body)) + (vars (list (gensym)))) + (values temps + forms + vars + `(,setf-function-name ,@vars ,@temps) + `(,function-name ,@temps))))) + (let ((setf-method-expander (intern (concatenate 'string + (symbol-name function-name) + "-setf-expander") + (symbol-package function-name)))) + (setf (get function-name :setf-method-expander) setf-method-expander + (symbol-function setf-method-expander) #'setf-expander))) + + ))) +(defun setfboundp (symbol) +(or (get symbol :setf-inverse) + (get symbol 'il:setf-inverse) + (get symbol 'il:setfn) + (get symbol :shared-setf-inverse) + (get symbol :setf-method-expander) + (get symbol 'il:setf-method-expander))) +) + + ; eval-when + + + +;;; CLOS, like user code, must endure the fact that we don't have a properly working setf. Many +;;; things work because they get mentioned by a defclass or defmethod before they are used, but +;;; others have to be done by hand. + + +(do-standard-defsetf + class-wrapper ; *** + generic-function-name + method-function-plist + method-function-get + gdefinition + slot-value-using-class) + +(defsetf slot-value set-slot-value) + + +;;; This is like fdefinition on the Lispm. If Common Lisp had something like function specs I +;;; wouldn't need this. On the other hand, I don't like the way this really works so maybe function +;;; specs aren't really right either? I also don't understand the real implications of a Lisp-1 on +;;; this sort of thing. Certainly some of the lossage in all of this is because these SPECs name +;;; global definitions. Note that this implementation is set up so that an implementation which has +;;; a 'real' function spec mechanism can use that instead and in that way get rid of setf generic +;;; function names. + + +(defmacro parse-gspec (spec (non-setf-var . non-setf-case) + (setf-var . setf-case)) + (once-only (spec) + `(cond ((symbolp ,spec) + (let ((,non-setf-var ,spec)) + ,@non-setf-case)) + ((and (listp ,spec) + (eq (car ,spec) + 'setf) + (symbolp (cadr ,spec))) + (let ((,setf-var (cadr ,spec))) + ,@setf-case)) + (t (error "Can't understand ~S as a generic function specifier.~%~ + It must be either a symbol which can name a function or~%~ + a list like ~S, where the car is the symbol ~S and the cadr~%~ + is a symbol which can name a generic function." ,spec '(setf ) + 'setf))))) + + +;;; If symbol names a function which is traced or advised, return the unadvised, traced etc. +;;; definition. This lets me get at the generic function object even when it is traced. + + +(defun unencapsulated-fdefinition (symbol) + (il:virginfn symbol)) + + +;;; If symbol names a function which is traced or advised, redefine the `real' definition without +;;; affecting the advise. + + +(defun fdefine-carefully (symbol new-definition) + (let ((advisedp (member symbol il:advisedfns :test #'eq)) + (brokenp (member symbol il:brokenfns :test #'eq))) + + ;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking". + ;; Advising, however, is treated specially. + (xcl:unadvise-function symbol :no-error t) + (xcl:unbreak-function symbol :no-error t) + (setf (symbol-function symbol) + new-definition) + (when brokenp (xcl:rebreak-function symbol)) + (when advisedp (xcl:readvise-function symbol))) + new-definition) + +(defun gboundp (spec) + (parse-gspec spec (name (fboundp name)) + (name (fboundp (get-setf-function-name name))))) + +(defun gmakunbound (spec) + (parse-gspec spec (name (fmakunbound name)) + (name (fmakunbound (get-setf-function-name name))))) + +(defun gdefinition (spec) + (parse-gspec spec (name (or (macro-function name) + ; ?? + (unencapsulated-fdefinition name))) + (name (unencapsulated-fdefinition (get-setf-function-name name))))) + +(defun SETF\ CLOS\ GDEFINITION (new-value spec) + (parse-gspec spec (name (fdefine-carefully name new-value)) + (name (fdefine-carefully (get-setf-function-name name) + new-value)))) + + +;;; These functions are a pale imitiation of their namesake. They accept class objects or types +;;; where they should. + + +(defun *typep (object type) + (if (classp type) + (let ((class (class-of object))) + (if class + (memq type (class-precedence-list class)) + nil)) + (let ((class (find-class type nil))) + (if class + (*typep object class) + (typep object type))))) + +(defun *subtypep (type1 type2) + (let ((c1 (if (classp type1) + type1 + (find-class type1 nil))) + (c2 (if (classp type2) + type2 + (find-class type2 nil)))) + (if (and c1 c2) + (memq c2 (class-precedence-list c1)) + (if (or c1 c2) + nil + ; This isn't quite right, but... + (subtypep type1 type2))))) + +(defun do-satisfies-deftype (name predicate) + (let* ((specifier `(satisfies ,predicate)) + (expand-fn #'(lambda (&rest ignore) + (declare (ignore ignore)) + specifier))) + + ;; Specific ports can insert their own way of doing this. Many ports may find the + ;; expand-fn defined above useful. + (or + ;; This is the default for ports for which we don't know any better. Note that for + ;; most ports, providing this definition should just speed up class definition. It + ;; shouldn't have an effect on performance of most user code. + (eval `(deftype ,name nil '(satisfies ,predicate)))))) + +(defun make-type-predicate-name (name) + (intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name)) + (symbol-name name)) + *the-clos-package*)) + +(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* + *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* + *the-class-null* *the-class-list* *the-class-integer* *the-class-float* + *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* + *the-class-array* *the-class-standard-object* *the-class-class* *the-class-method* + *the-class-generic-function* *the-class-standard-class* *the-class-standard-method* + *the-class-standard-generic-function* + *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*)) + +(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* + *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* + *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* + *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* + *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* + *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) + +(defvar *built-in-class-symbols* nil) + +(defvar *built-in-wrapper-symbols* nil) + +(defun get-built-in-class-symbol (class-name) + (or (cadr (assq class-name *built-in-class-symbols*)) + (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name)) + *the-clos-package*))) + (push (list class-name symbol) + *built-in-class-symbols*) + symbol))) + +(defun get-built-in-wrapper-symbol (class-name) + (or (cadr (assq class-name *built-in-wrapper-symbols*)) + (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name)) + *the-clos-package*))) + (push (list class-name symbol) + *built-in-wrapper-symbols*) + symbol))) + +(pushnew 'class *variable-declarations*) + +(pushnew 'variable-rebinding *variable-declarations*) + +(defun variable-class (var env) + (caddr (variable-declaration 'class var env))) + +(defvar *boot-state* nil) + ; NIL EARLY BRAID COMPLETE + + +(eval-when (load eval) + (when (eq *boot-state* 'complete) + (error "Trying to load (or compile) CLOS in an environment in which it~%~ + has already been loaded. This doesn't work, you will have to~%~ + get a fresh lisp (reboot) and then load CLOS.")) + (when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~ + has already been partially loaded. This may not work, you may~%~ + need to get a fresh lisp (reboot) and then load CLOS."))) + + +;;; This is used by combined methods to communicate the next methods to the methods they call. This +;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope. + + +(defvar *next-methods* nil) + +(defvar *not-an-eql-specializer* '(not-an-eql-specializer)) + +(defvar *umi-gfs*) + +(defvar *umi-complete-classes*) + +(defvar *umi-reorder*) + +(defvar *invalidate-discriminating-function-force-p* nil) + +(defvar *invalid-dfuns-on-stack* nil) + +(defvar *standard-method-combination*) + +(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) + + ; *** + + +(defmacro define-gf-predicate (predicate &rest classes) + `(progn (defmethod ,predicate ((x t)) + nil) + ,@(mapcar #'(lambda (c) + `(defmethod ,predicate ((x ,c)) + t)) + classes))) + +(defmacro plist-value (object name) + `(with-slots (plist) + ,object + (getf plist ,name))) + +(defsetf plist-value (object name) + (new-value) + (once-only (new-value) + `(with-slots (plist) + ,object + (if ,new-value + (setf (getf plist ,name) + ,new-value) + (progn (remf plist ,name) + nil))))) + +(defvar *built-in-classes* + + ;; name supers subs cdr of cpl + '((number (t) (complex float rational) + (t)) + (complex (number) + nil + (number t)) + (float (number) + nil + (number t)) + (rational (number) + (integer ratio) + (number t)) + (integer (rational) + nil + (rational number t)) + (ratio (rational) + nil + (rational number t)) + (sequence (t) + (list vector) + (t)) + (list (sequence) + (cons null) + (sequence t)) + (cons (list) + nil + (list sequence t)) + (array (t) + (vector) + (t)) + (vector (array sequence) + (string bit-vector) + (array sequence t)) + (string (vector) + nil + (vector array sequence t)) + (bit-vector (vector) + nil + (vector array sequence t)) + (character (t) + nil + (t)) + (symbol (t) + (null) + (t)) + (null (symbol) + nil + (symbol list sequence t)))) + + +;;; The classes that define the kernel of the metabraid. + + +(defclass t nil nil (:metaclass built-in-class)) + +(defclass standard-object (t) + nil) + +(defclass metaobject (standard-object) + nil) + +(defclass specializer (metaobject) + nil) + +(defclass definition-source-mixin (standard-object) + ((source :initform (load-truename) + :reader definition-source :initarg :definition-source))) + +(defclass plist-mixin (standard-object) + ((plist :initform nil))) + +(defclass documentation-mixin (plist-mixin) + nil) + +(defclass dependent-update-mixin (plist-mixin) + nil) + + +;;; The class CLASS is a specified basic class. It is the common superclass of any kind of class. +;;; That is any class that can be a metaclass must have the class CLASS in its class precedence +;;; list. + + +(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer) + ((name :initform nil :initarg :name :accessor class-name) + (direct-superclasses :initform nil :reader class-direct-superclasses) + (direct-subclasses :initform nil :reader class-direct-subclasses) + (direct-methods :initform (cons nil nil)))) + + +;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses +;;; of the class CLASS. + + +(defclass clos-class (class) + ((class-precedence-list :initform nil) + (wrapper :initform nil))) + + +;;; The class STD-CLASS is an implementation-specific common superclass of the classes +;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. + + +(defclass std-class (clos-class) + ((direct-slots :initform nil :accessor class-direct-slots) + (slots :initform nil :accessor class-slots) + (no-of-instance-slots ; *** MOVE TO WRAPPER *** + :initform 0 :accessor class-no-of-instance-slots) + (prototype :initform nil))) + +(defclass standard-class (std-class) + nil) + +(defclass funcallable-standard-class (std-class) + nil) + +(defclass forward-referenced-class (clos-class) + nil) + +(defclass built-in-class (clos-class) + nil) + + +;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD". + + +(defclass slot-definition (metaobject) + nil) + +(defclass direct-slot-definition (slot-definition) + nil) + +(defclass effective-slot-definition (slot-definition) + nil) +; +(defclass standard-slot-definition (slot-definition) + ((name :initform nil :accessor slotd-name) + (initform :initform *slotd-unsupplied* :accessor slotd-initform) + (initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction) + (readers :initform nil :accessor slotd-readers) + (writers :initform nil :accessor slotd-writers) + (initargs :initform nil :accessor slotd-initargs) + (allocation :initform nil :accessor slotd-allocation) + (type :initform nil :accessor slotd-type) + (documentation :initform "" :initarg :documentation) + (class :initform nil :accessor slotd-class) + (instance-index :initform nil :accessor slotd-instance-index))) + +(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) + nil) + + ; Adding slots here may involve extra + ; work to the code in braid.lisp + + +(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) + nil) + + ; Adding slots here may involve extra + ; work to the code in braid.lisp + + +(defclass eql-specializer (specializer) + ((object :initarg :object :reader eql-specializer-object))) + + +;;; + + +(defmacro dolist-carefully ((var list improper-list-handler) + &body body) + `(let ((,var nil) + (.dolist-carefully. ,list)) + (loop (when (null .dolist-carefully.) + (return nil)) + (if (consp .dolist-carefully.) + (progn (setq ,var (pop .dolist-carefully.)) + ,@body) + (,improper-list-handler))))) + +(defun legal-std-documentation-p (x) + (if (or (null x) + (stringp x)) + t + "a string or NULL")) + +(defun legal-std-lambda-list-p (x) + (declare (ignore x)) + t) + +(defun legal-std-method-function-p (x) + (if (functionp x) + t + "a function")) + +(defun legal-std-qualifiers-p (x) + (flet ((improper-list nil (return-from legal-std-qualifiers-p "Is not a proper list."))) + (dolist-carefully (q x improper-list) + (let ((ok (legal-std-qualifier-p q))) + (unless (eq ok t) + (return-from legal-std-qualifiers-p (format nil "Contains ~S which ~A" q + ok))))) + t)) + +(defun legal-std-qualifier-p (x) + (if (and x (atom x)) + t + "is not a non-null atom")) + +(defun legal-std-slot-name-p (x) + (cond ((not (symbolp x)) + "is not a symbol and so cannot be bound") + ((keywordp x) + "is a keyword and so cannot be bound") + ((memq x '(t nil)) + "cannot be bound") + (t t))) + +(defun legal-std-specializers-p (x) + (flet ((improper-list nil (return-from legal-std-specializers-p "Is not a proper list."))) + (dolist-carefully (s x improper-list) + (let ((ok (legal-std-specializer-p s))) + (unless (eq ok t) + (return-from legal-std-specializers-p (format nil "Contains ~S which ~A" + s ok))))) + t)) + +(defun legal-std-specializer-p (x) + (if (or (classp x) + (eql-specializer-p x)) + t + "is neither a class object nor an eql specializer")) diff --git a/clos/3.5/defsys.DFASL b/clos/3.5/defsys.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..91e2f5e3eb6a4a639f4e2259410e2220a5d15d5f GIT binary patch literal 12629 zcmbtbYj70TmG16&3OyLX2!nV{0mg}(!946ujAJsbnHJO1yqKN=gdb#(2G7_diRfX6 z%9<69?w^;jXqYc4OR9S1A~dYzF*su$i|ClEmJV|6f^q4 zJt^JD?TM$d#-4aFp9g%;aQW!O@riA<>cp{ocD5TX%tPbl(qwr!Vw5JQ#)nJCKNGnt zk|+&xyL;zd+uHk7BP9s>gu_0!d)M9D+CO@waaJmiN%-@S z^V345gQt_TtC}$G(t6WfD&5`PJSrqL>Y*Kx$+2V6TKUm(jrces17G90da$pUi5K*2 zrg27|_8)GXsxQ+s(VQ9|Q1@#4QEltfGYK1zB0yRl&}_gi)B9=D7c#xUeL&_V7Wbmy zDH__n_y+WXmRAefHZ!=<40HqHKcJ=tw0x`C;x_}Hy^S-9={H-pV0P0lH|k!Jk3@{= z;q@~+nx$peGJ&g0u8#VdGOfwC1vLA$gSl+Ju+j8(QBBW)tPH63qt+ZT^$M!q!-VxD9 zC(Gm2kq8ZqjF)TW(nOhvG}oFNn6|2MzA~4bNuHd&Qyv`N6}$Sf&MalhelcA+x7xVC z{500j^gqR={_Y|Fd{Q|-`%hnVM1Iv2ozN6A=IjBw7@!kW@_4|RWj%eGS}5i8> zF_@-x4oypRSc=4ZK;rWXYy{csx^MVsX`*J)bdU5h=v}r~D?|m?K>t~(J@z-sWno)y z3rS`#crEj8gIxd`B1)3|7}#mET7$9E$r^&y0;O>+%8nT8ood-tGYOoEg_B4loQ--* zMmrGQucnHc9E8FIa>WAna!yvvK7lq={_?TX=x`J)aMAk&kUbSs4$5;$<&b=_Uye+@i^nhi)@s=QM<+%aD{9GXwRmYLm{mSq$(jci9Yv=t3cWkZ$j z!yWIWl}oe#DF*WBZZIp09qL+G+m;bwDFDG@W>3K6V?9Q&fy5-gABU4@3An%_%8Gde+Ui-W-o`^~Iu zJ}9qkobfc}ny~k6qwed|u_z`r!Bkb7WC>ci&Ofyv_h|PKVXlQR)LBS~W-sK6@j^tf ztho%&9y9%E5V-bM(E-K{x&!AxU$vkX26I|trcw6`ZE6EU!=$-6HE(E%s58iaH(I)= zH+ExAg=2S`?t~?4ceQBwJ20VNP-2ERV_?YX9L@Ij!+@= zdu4!Pj`G)Qef{R>E$D2Hiob!znbp9n9iHri2pH56_|)bwQ26A6JM?>QF>7tCw6MeG<5}iPH2h$tS!*|IUgG@A zX7NQtvV`cDqqNfbO7ed(Wo)i;L7&l2&ORcuuTd1Zo64osOl7+I;7sPLsRJGB&-D*H z!UilEeZUU{5?qoE0J&)k<^p<~Ko`_MuPbx2XJQvBbCrvgxBFkyXK(43<+t_c2U1%v zJ_)CF-(0_PVfG3r0~an!L?}-jmXcwGdDm2)HlhTvUclUC76YUY&~PDXtsP29KJxeP-=ms0=}W1lhKzvE*fC z{dx-PR@F))M}|w0>S)C6=^!uKLIDbhVW}+}RQHje*#XZ%-OD997D8G;ZG8L ze83nPz?S=Sg?zG@8Q2+M!ruK7rYAD~jo6b6OM~;V>Qxi$Qg~B^V)7y8($#bKIKY?! zhF1^?47`?_-7w&Y@14~1>CDzkPi89J54=5~T%7%_I860h7&4!HpiV+_NlXtb&h!Fl z%%UH#x5&LhnoOxJs}LT;uNwGm__vlWZ06|(%Jo5RPUosuLBauYx`jp z_}uDOb2%-OxQ#LVe1-TZ51^MET}!{Wvq&4@X@Dh40u46>+N6WG-!*i|X-9g`Gvapy zq4QjM_dfpoN>ut>m0uB-cQNA~m~r8upVfMBMi0eUn&{9y%sW*k$~d+a21i-U7t$!t z2J><9gI+qYFXvg`QkLm7e-V{?U6pt55*3Q3!>rPUyqYnDTcgMw zuJEjMd!^ES-mxF6P2vwkImHYhl}jLYpvMVCmJF>XT%P z-kYg}P-O#l*$cbWKhr<`7xJJgVofqezgOp6N)0olD%^NM?_VRF77!q6R+a8KRbPWF z0Mq;%tko4bTh_tij;vY|W-@$Obma3mrIRLn=;wp`)i) z(=&UcghWg5L9YvOEvG-OX<6!oM`HY)bp+Nnk?R9KBRaBsR~5}3py0C=-}~-4*dI` zU%sJwltj-Jz}F#CRcb0)NanK#fUL%iSF&bJ?A0q`i{Na7tQ_mn0lkpS77I8akO9;( zaa}W(+BBb2MOp@|S|bnI`lJ)9X7nd1`SM?2l$#Z9J^usD&<*rlQnm_Wg*CD$?XdT; z*!#}@{hB2bzeCk_dG31B)ZNmoGO@p8+bP5MBfPk85OmZsO=Rs5njASA(v0f=d<|^vv&m%GRf^%sQ4fk->2di zpxMj-GfdSexBP*MYv7xf?JH{7R%GS~B;w-tP?SD!ut~q=;%^B0ON?0_&u04cd^&2` z9fDtIc6l9L+67uyhclwXpQ6#qHPB8svT3ad=AHH zQRQD=?z19+;EAhwthUAR`(nvBFNk%$Pb1`8_;(fmcJZ%B8(iTstHD+Z2*mET%%2Fm z5fH3x1_X=D1^6IHJ8z#*WTf_7af;jlp#=w{*?bhf4&1K6H`jxyvC=Ry8eibE$iHLm zjWOXn&vh+91ji-+FESLtf=wP;vGk!F0v*d5_0@aFBBe?hv>=lj84_284qZQW(M9He z3CeE39y-PGjMrn2vW7+A&_&rW-1f9ux0Vhm&w!LQwzEOZxSk!AU>OB%AIBW!MnvEa zLvV%tLRX`{F6 zX7OvHDE6ow4)TFQ-c7jv43S~PUfx`1ND-Gi7xjUf!dy>A5j|14UcORn~wyj(dZ=*k_To!lliLt)%MJ(T5^Os-vaxInEb3(FD z1Yytm_rP-baY2E!+1)4x=)?>!LpNDLMCxiWRWLq{N-JVWTwHK4vd*jpq1|9g=ZURC zzlkjinIVB0o+|O*i#)al?Gk4q+CkHHP2PQk={mrPMA?Ti?c!F&vRd3qsq%%1H#q=v zx$2rFM(y|**He^p@r$sE(q61NOCyJ_ErFaz+$Yco&9Twk*Eq|mnoCyvaHb&7Zgk4Z z?Ba;wyfJ57Fj(lPjoG}xiBgo3{aiX1wMQHB?43?onf=tF*kiU!fOOtVRtAv~iz`qO z-8I!qWE%CRYPAQ6^M~ki)ZFgzn)irxdK7o~ZtVy!WfIA6Nk8LW87jU6#afQkKOO55 z*#jAhHwgX$;C=z8>NBW1JBk2L5(??ZV~i=Z9nAsJJIAMcIn+Vzv)r7e;u~DdQSp0R z+(*T4L99#{RZdZbvK^0^+lPUX8xC^k62~3#{Rsp`KDtfH?Phqjn?EDMmXz40%lCU8 z7b$xso9E_==u0ROFBlJ7Zd<;e;ibreI;SPt*?f_v6Gdj2qVG*k79!6wfvx}g!oT3O%+`PyCU; z(glrQ0Vnek&naeP7aZ)xZ3^<{8vL4TSIV3rk~<}A#QLsl78DsO)oOSHa|ADMO5%M> zb%K1$kuq)m8f;^EcpKja?`Y2E%IA~ct=e38rrBl4%S<>8Ch&6u=T?o=1-IDgf(310 zjde4CCnwMaxpS@Hne!}xfYZvB24`@8(OVuWO-+=U&gkU$RGB?sbs{o4HW{go9IKT_ z%6PdjOxfGX3gE}a#wSnQdZInD#2;9GBIh%a<6~2ik*SHv$Vh2)3j8@9DGygCfuJ10 zYoh9Cb+S4(N{#}M>mhrzG+r$o!L?A&P;G1?I$Rwu4^57ZAMX*QSdW`rkCV1p*WA27 zzH$_=V_XNZCU?1n)J3-w1TK2}0}ZfPscbQmtIQ(eI)vS{LNn~amFHGeeQ+c3B#!5& z>z>@eUM_g)^$wTpmpydr=#=TckZy^^#hE9Cgar+UXFae}AVO}E3*>2VeQAiEUerX% z*O%F=i7uX$O4o82p0i87xQYu80ZiCHZ*MkR01U=xKR>D<+Kp7UVBw}4eIC+c6ez!L zPwI*1QVjR?=2e|8`LNJFBhH0DT0;^gAyD|?X5kRH!JEL9ff&}OA1n$A>E77Y#~&v% zD#o^uHQ`HLF@b%bNjSk^F&XZsP~G9K2z~`b%bna3&v1gt?Y zVQimctk2t6O==PB<21i4+D~&YKKjaM?Y=KHv53B>?Urv+i&)xA0>5j#)9YpG#fd`s zo80d1E9Mn5IwM}W=@EZPBlv82qdAy@mu<4Y^+%5THjNYfTf7>Ji}oC^HdiAge8Um1 z-Smj>-1La=(g>lxrcLShtb%lzxg>&?A9DFk^j<7!OKa?=*9oWK%5_(2_x&sCD|A!z zecf*PKDAgIX0g85O@Dn8bN#@zzu$0H?a=Dp0hT86yx+Cw`r#ij=FOWLBbfFh&`B0V z)P8(TZI)}x5Qlkkh%v-DZMsqKZl*yNzJrx0tbk3#m9KS3!9zT%ze7n@=Y%DEBZ4bx z`f2R7pGe;phnB17!p&H_QWcleR@1kdEy5XJ7hb)(xUZGD{#wj4Q^h06l}%*g;2Vn3 zTgr1?E_lUy@N1>*xy5y=Qt0iYeX4TeOF2zB0qIQ^CkOw+0&(%AfF2f~0rA--J|g}K zcGBqY6G);Ip7b4VeVU3wX;)G48v^@1`|{Z|-$lw#AL8a)ilSE^f5NJ$?Z%jZ zmBrh}pe_*sKD`MocyWfDV3^?2`+UfipAHb5lcnNzq=f@pTZVEXc5a<5z0FPbF{kEF zEd=a4&yaoVXOiNrX|h{fcbQvgQl$-7SxYcg`4p2H6xpj_V7J-5-R$1XbY9uOZBMV@ z&&qaDV~wVZQ_{TUy~Vw_XQBt2I3e_9;pESH?kbOb^ud|(BOko@@FRlS^21lZ^GNCZ z$$jUO9Qft=w8uY2J0~Qt4`c*Koy`M>IN0}i6mtX4gklk$vPXI1BmA)+GcrkZ`atxe zscG*W1dyKn6i}_DXWmggox?2!9{%xlWzI?I^y)QTOEWV>dbCQT)#V#Ov3erspXB zAHdXjd7=k>3>Hi){_6lvUL0$YP?SBa9(>MGWb37KB_!h#x^l6I>lIz*whJq*0`4w_ z?C6T^pZPYx<0H2AAdIB+i*qSN??X8s!>2=Kt*?0m+Jyl&C3IbMJIl+rNqqcfuQ(UV OPviVfN*ej-qyGb!^mrWr literal 0 HcmV?d00001 diff --git a/clos/3.5/defsys.lisp b/clos/3.5/defsys.lisp new file mode 100644 index 00000000..62e5850c --- /dev/null +++ b/clos/3.5/defsys.lisp @@ -0,0 +1,761 @@ +;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; +;;; Some support stuff for compiling and loading CLOS. It would be nice if +;;; there was some portable make-system we could all agree to share for a +;;; while. At least until people really get databases and stuff. +;;; +;;; *** *** +;;; *** DIRECTIONS FOR INSTALLING CLOS AT YOUR SITE *** +;;; *** *** +;;; +;;; To get CLOS working at your site you should: +;;; +;;; - Get all the CLOS source files from Xerox. The complete list of source +;;; file names can be found in the defsystem for CLOS which appears towards +;;; the end of this file. +;;; +;;; - Edit the variable *clos-directory* below to specify the directory at +;;; your site where the clos sources and binaries will be. This variable +;;; can be found by searching from this point for the string "***" in +;;; this file. +;;; +;;; - Use the function (clos::compile-clos) to compile CLOS for your site. +;;; +;;; - Once CLOS has been compiled it can be loaded with (clos::load-clos). +;;; Note that CLOS cannot be loaded on top of itself, nor can it be +;;; loaded into the same world it was compiled in. +;;; + +(in-package "CLOS" :use (list (or (find-package :walker) + (make-package :walker :use '(:lisp))) + (or (find-package :iterate) + (make-package :iterate + :use '(:lisp :walker))) + (find-package :lisp))) + +(export (intern (symbol-name :iterate) ;Have to do this here, + (find-package :iterate)) ;because in the defsystem + (find-package :iterate)) ;(later in this file) + ;we use the symbol iterate + ;to name the file + +;;; +;;; Sure, its weird for this to be here, but in order to follow the rules +;;; about order of export and all that stuff, we can't put it in PKG before +;;; we want to use it. +;;; +(defvar *the-clos-package* (find-package :clos)) + +(defvar *clos-system-date* "5/10/91 Interim CLOS release") + + +;;; +;;; Various hacks to get people's *features* into better shape. +;;; +(eval-when (compile load eval) + #+(and Symbolics Lispm) + (multiple-value-bind (major minor) (sct:get-release-version) + (etypecase minor + (integer) + (string (setf minor (parse-integer minor :junk-allowed t)))) + (pushnew :genera *features*) + (ecase major + ((6) + (pushnew :genera-release-6 *features*)) + ((7) + (pushnew :genera-release-7 *features*) + (ecase minor + ((0 1) (pushnew :genera-release-7-1 *features*)) + ((2) (pushnew :genera-release-7-2 *features*)) + ((3) (pushnew :genera-release-7-3 *features*)) + ((4) (pushnew :genera-release-7-4 *features*)))) + ((8) + (pushnew :genera-release-8 *features*) + (ecase minor + ((0) (pushnew :genera-release-8-0 *features*)) + ((1) (pushnew :genera-release-8-1 *features*)))))) + + #+CLOE-Runtime + (let ((version (lisp-implementation-version))) + (when (string-equal version "2.0" :end1 (min 3 (length version))) + (pushnew :cloe-release-2 *features*))) + + (dolist (feature *features*) + (when (and (symbolp feature) ;3600!! + (equal (symbol-name feature) "CMU")) + (pushnew :CMU *features*))) + + #+TI + (if (eq (si:local-binary-file-type) :xld) + (pushnew ':ti-release-3 *features*) + (pushnew ':ti-release-2 *features*)) + + #+Lucid + (when (search "IBM RT PC" (machine-type)) + (pushnew :ibm-rt-pc *features*)) + + #+ExCL + (cond ((search "sun3" (lisp-implementation-version)) + (push :sun3 *features*)) + ((search "sun4" (lisp-implementation-version)) + (push :sun4 *features*))) + + #+(and HP Lucid) + (push :HP-Lucid *features*) + #+(and HP (not Lucid)) + (push :HP-HPLabs *features*) + + #+Xerox + (case il:makesysname + (:lyric (push :Xerox-Lyric *features*)) + (otherwise (pushnew :Xerox-Medley *features*))) +;;; +;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features* +;;; if you have installed turbo-closure patch. See the file kcl-mods.text +;;; for details. +;;; +;;; The xkcl version of KCL has this fixed already. +;;; + + #+xkcl(pushnew :turbo-closure *features*) + + ) + + + +;;; Yet Another Sort Of General System Facility and friends. +;;; +;;; The entry points are defsystem and operate-on-system. defsystem is used +;;; to define a new system and the files with their load/compile constraints. +;;; Operate-on-system is used to operate on a system defined that has been +;;; defined by defsystem. For example: +#|| + +(defsystem my-very-own-system + "/usr/myname/lisp/" + ((classes (precom) () ()) + (methods (precom classes) (classes) ()) + (precom () (classes methods) (classes methods)))) + +This defsystem should be read as follows: + +* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries + should be in the directory "/usr/me/lisp/". There are three files + in the system, there are named classes, methods and precom. (The + extension the filenames have depends on the lisp you are running in.) + +* For the first file, classes, the (precom) in the line means that + the file precom should be loaded before this file is loaded. The + first () means that no other files need to be loaded before this + file is compiled. The second () means that changes in other files + don't force this file to be recompiled. + +* For the second file, methods, the (precom classes) means that both + of the files precom and classes must be loaded before this file + can be loaded. The (classes) means that the file classes must be + loaded before this file can be compiled. The () means that changes + in other files don't force this file to be recompiled. + +* For the third file, precom, the first () means that no other files + need to be loaded before this file is loaded. The first use of + (classes methods) means that both classes and methods must be + loaded before this file can be compiled. The second use of (classes + methods) mean that whenever either classes or methods changes precom + must be recompiled. + +Then you can compile your system with: + + (operate-on-system 'my-very-own-system :compile) + +and load your system with: + + (operate-on-system 'my-very-own-system :load) + +||# + +;;; +(defvar *system-directory*) + +;;; +;;; *port* is a list of symbols (in the CLOS package) which represent the +;;; Common Lisp in which we are now running. Many of the facilities in +;;; defsys use the value of *port* rather than #+ and #- to conditionalize +;;; the way they work. +;;; +(defvar *port* + '(#+Genera Genera +; #+Genera-Release-6 Rel-6 +; #+Genera-Release-7-1 Rel-7 + #+Genera-Release-7-2 Rel-7 + #+Genera-Release-7-3 Rel-7 + #+Genera-Release-7-1 Rel-7-1 + #+Genera-Release-7-2 Rel-7-2 + #+Genera-Release-7-3 Rel-7-2 ;OK for now + #+Genera-Release-7-4 Rel-7-2 ;OK for now + #+Genera-Release-8 Rel-8 + #+imach Ivory + #+Cloe-Runtime Cloe + #+Lucid Lucid + #+Xerox Xerox + #+Xerox-Lyric Xerox-Lyric + #+Xerox-Medley Xerox-Medley + #+TI TI + #+(and dec vax common) Vaxlisp + #+KCL KCL + #+IBCL IBCL + #+excl excl + #+(and excl sun4) excl-sun4 + #+:CMU CMU + #+HP-HPLabs HP-HPLabs + #+:gclisp gclisp + #+pyramid pyramid + #+:coral coral)) + +;;; +;;; When you get a copy of CLOS (by tape or by FTP), the sources files will +;;; have extensions of ".lisp" in particular, this file will be defsys.lisp. +;;; The preferred way to install clos is to rename these files to have the +;;; extension which your lisp likes to use for its files. Alternately, it +;;; is possible not to rename the files. If the files are not renamed to +;;; the proper convention, the second line of the following defvar should +;;; be changed to: +;;; (let ((files-renamed-p nil) +;;; +;;; Note: Something people installing CLOS on a machine running Unix +;;; might find useful. If you want to change the extensions +;;; of the source files from ".lisp" to ".lsp", *all* you have +;;; to do is the following: +;;; +;;; % foreach i (*.lisp) +;;; ? mv $i $i:r.lsp +;;; ? end +;;; % +;;; +;;; I am sure that a lot of people already know that, and some +;;; Unix hackers may say, "jeez who doesn't know that". Those +;;; same Unix hackers are invited to fix mv so that I can type +;;; "mv *.lisp *.lsp". +;;; +(defvar *pathname-extensions* + (let ((files-renamed-p t) + (proper-extensions + (car + '(#+(and Genera (not imach)) ("lisp" . "bin") + #+(and Genera imach) ("lisp" . "ibin") + #+Cloe-Runtime ("l" . "fasl") + #+(and dec common vax (not ultrix)) ("LSP" . "FAS") + #+(and dec common vax ultrix) ("lsp" . "fas") + #+KCL ("lsp" . "o") + #+IBCL ("lsp" . "o") + #+Xerox ("lisp" . "dfasl") + #+(and Lucid MC68000) ("lisp" . "lbin") + #+(and Lucid VAX) ("lisp" . "vbin") + #+(and Lucid Prime) ("lisp" . "pbin") + #+(and Lucid SUNRise) ("lisp" . "sbin") + #+(and Lucid SPARC) ("lisp" . "sbin") + #+(and Lucid IBM-RT-PC) ("lisp" . "bbin") + #+(and Lucid MIPS) ("lisp" . "mbin") + #+(and Lucid PRISM) ("lisp" . "abin") + #+(and Lucid PA) ("lisp" . "hbin") + #+excl ("cl" . "fasl") + #+:CMU ("slisp" . "sfasl") + #+HP ("l" . "b") + #+TI ("lisp" . #.(string (si::local-binary-file-type))) + #+:gclisp ("LSP" . "F2S") + #+pyramid ("clisp" . "o") + #+:coral ("lisp" . "fasl") + )))) + (cond ((null proper-extensions) '("l" . "lbin")) + ((null files-renamed-p) (cons "lisp" (cdr proper-extensions))) + (t proper-extensions)))) + +(eval-when (compile load eval) + +(defun get-system (name) + (get name 'system-definition)) + +(defun set-system (name new-value) + (setf (get name 'system-definition) new-value)) + +(defmacro defsystem (name directory files) + `(set-system ',name (list #'(lambda () ,directory) + (make-modules ',files) + ',(mapcar #'car files)))) + +) + + +;;; +;;; The internal datastructure used when operating on a system. +;;; +(defstruct (module (:constructor make-module (name)) + (:print-function + (lambda (m s d) + (declare (ignore d)) + (format s "#" (module-name m))))) + name + load-env + comp-env + recomp-reasons) + +(defun make-modules (system-description) + (let ((modules ())) + (labels ((get-module (name) + (or (find name modules :key #'module-name) + (progn (setq modules (cons (make-module name) modules)) + (car modules)))) + (parse-spec (spec) + (if (eq spec 't) + (reverse (cdr modules)) + (case (car spec) + (+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec)))) + (- (let ((rem (mapcar #'get-module (cdr spec)))) + (remove-if #'(lambda (m) (member m rem)) (reverse (cdr modules))))) + (otherwise (mapcar #'get-module spec)))))) + (dolist (file system-description) + (let* ((name (car file)) + (port (car (cddddr file))) + (module nil)) + (when (or (null port) + (member port *port*)) + (setq module (get-module name)) + (setf (module-load-env module) (parse-spec (cadr file)) + (module-comp-env module) (parse-spec (caddr file)) + (module-recomp-reasons module) (parse-spec + (cadddr file)))))) + (let ((filenames (mapcar #'car system-description))) + (sort modules #'(lambda (name1 name2) + (member name2 (member name1 filenames))) + :key #'module-name))))) + + +(defun make-transformations (modules filter make-transform) + (let ((transforms (list nil))) + (dolist (m modules) + (when (funcall filter m transforms) (funcall make-transform m transforms))) + (reverse (cdr transforms)))) + +(defun make-compile-transformation (module transforms) + (unless (dolist (trans transforms) + (and (eq (car trans) ':compile) + (eq (cadr trans) module) + (return t))) + (dolist (c (module-comp-env module)) (make-load-transformation c transforms)) + (setf (cdr transforms) + (remove-if #'(lambda (trans) (and (eq (car trans) :load) (eq (cadr trans) module))) + (cdr transforms))) + (push `(:compile ,module) (cdr transforms)))) + +(defvar *being-loaded* ()) + +(defun make-load-transformation (module transforms) + (if (assoc module *being-loaded*) + (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*)))) + (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*))) + (catch module + (unless (dolist (trans transforms) + (when (and (eq (car trans) ':load) + (eq (cadr trans) module)) + (return t))) + (dolist (l (module-load-env module)) (make-load-transformation l transforms)) + (push `(:load ,module) (cdr transforms))))))) + +(defun make-load-without-dependencies-transformation (module transforms) + (unless (dolist (trans transforms) + (and (eq (car trans) ':load) + (eq (cadr trans) module) + (return trans))) + (push `(:load ,module) (cdr transforms)))) + +(defun compile-filter (module transforms) + (or (dolist (r (module-recomp-reasons module)) + (when (dolist (transform transforms) + (when (and (eq (car transform) ':compile) + (eq (cadr transform) r)) + (return t))) + (return t))) + (null (probe-file (make-binary-pathname (module-name module)))) + (> (file-write-date (make-source-pathname (module-name module))) + (file-write-date (make-binary-pathname (module-name module)))))) + +(defun operate-on-system (name mode &optional arg print-only) + (let ((system (get-system name))) + (unless system (error "Can't find system with name ~S." name)) + (let ((*system-directory* (funcall (car system))) + (modules (cadr system)) + (transformations ())) + (labels ((load-source (name pathname) + (format t "~&Loading source of ~A..." name) + (or print-only (load pathname))) + (load-binary (name pathname) + (format t "~&Loading binary of ~A..." name) + (or print-only (load pathname))) + (load-module (m) + (let* ((name (module-name m)) + (*load-verbose* nil) + (binary (make-binary-pathname name))) + (load-binary name binary))) + (compile-module (m) + (format t "~&Compiling ~A..." (module-name m)) + (unless print-only + (let ((name (module-name m))) + (compile-file (make-source-pathname name) + :output-file + (make-pathname :defaults + (make-binary-pathname name) + :version :newest))))) + (xcl:true (&rest ignore) (declare (ignore ignore)) 't)) + + (setq transformations + (ecase mode + (:compile + ;; Compile any files that have changed and any other files + ;; that require recompilation when another file has been + ;; recompiled. + (make-transformations + modules + #'compile-filter + #'make-compile-transformation)) + (:recompile + ;; Force recompilation of all files. + (make-transformations + modules + #'xcl:true + #'make-compile-transformation)) + (:recompile-some + ;; Force recompilation of some files. Also compile the + ;; files that require recompilation when another file has + ;; been recompiled. + (make-transformations + modules + #'(lambda (m transforms) + (or (member (module-name m) arg) + (compile-filter m transforms))) + #'make-compile-transformation)) + (:query-compile + ;; Ask the user which files to compile. Compile those + ;; and any other files which must be recompiled when + ;; another file has been recompiled. + (make-transformations + modules + #'(lambda (m transforms) + (or (compile-filter m transforms) + (y-or-n-p "Compile ~A?" + (module-name m)))) + #'make-compile-transformation)) + (:confirm-compile + ;; Offer the user a chance to prevent a file from being + ;; recompiled. + (make-transformations + modules + #'(lambda (m transforms) + (and (compile-filter m transforms) + (y-or-n-p "Go ahead and compile ~A?" + (module-name m)))) + #'make-compile-transformation)) + (:load + ;; Load the whole system. + (make-transformations + modules + #'xcl:true + #'make-load-transformation)) + (:query-load + ;; Load only those files the user says to load. + (make-transformations + modules + #'(lambda (m transforms) + (declare (ignore transforms)) + (y-or-n-p "Load ~A?" (module-name m))) + #'make-load-without-dependencies-transformation)))) + + (#+Genera + compiler:compiler-warnings-context-bind + #+TI + COMPILER:COMPILER-WARNINGS-CONTEXT-BIND + #+:LCL3.0 + lucid-common-lisp:with-deferred-warnings + #-(or Genera TI :LCL3.0) + progn + (loop (when (null transformations) (return t)) + (let ((transform (pop transformations))) + (ecase (car transform) + (:compile (compile-module (cadr transform))) + (:load (load-module (cadr transform))))))))))) + + +(defun make-source-pathname (name) (make-pathname-internal name :source)) +(defun make-binary-pathname (name) (make-pathname-internal name :binary)) + +(defun make-pathname-internal (name type) + (let* ((extension (ecase type + (:source (car *pathname-extensions*)) + (:binary (cdr *pathname-extensions*)))) + (directory (pathname + (etypecase *system-directory* + (string *system-directory*) + (pathname *system-directory*) + (cons (ecase type + (:source (car *system-directory*)) + (:binary (cdr *system-directory*))))))) + (pathname + (make-pathname + :name (string-downcase (string name)) + :type extension + :defaults directory :version :newest))) + + #+Genera + (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname)) + pathname (zl:send pathname :new-raw-type (pathname-type pathname))) + + pathname)) + + + +;;; *** SITE SPECIFIC CLOS DIRECTORY *** +;;; +;;; *clos-directory* is a variable which specifies the directory clos is stored +;;; in at your site. If the value of the variable is a single pathname, the +;;; sources and binaries should be stored in that directory. If the value of +;;; that directory is a cons, the CAR should be the source directory and the +;;; CDR should be the binary directory. +;;; +;;; By default, the value of *clos-directory* is set to the directory that +;;; this file is loaded from. This makes it simple to keep multiple copies +;;; of CLOS in different places, just load defsys from the same directory as +;;; the copy of CLOS you want to use. +;;; +;;; Note that the value of *CLOS-DIRECTORY* is set using a DEFVAR. This is +;;; done to make it possible for users to set it in their init file and then +;;; load this file. The value set in the init file will override the value +;;; here. +;;; +;;; *** *** + +(defun load-truename (&optional (errorp nil)) + (flet ((bad-time () + (when errorp + (error "LOAD-TRUENAME called but a file isn't being loaded.")))) + #+Lispm (or sys:fdefine-file-pathname (bad-time)) + #+excl excl::*source-pathname* + #+Xerox (pathname (or (il:fullname *standard-input*) (bad-time))) + #+(and dec vax common) (truename (sys::source-file #'load-truename)) + ;; + ;; The following use of `lucid::' is a kludge for 2.1 and 3.0 + ;; compatibility. In 2.1 it was in the SYSTEM package, and i + ;; 3.0 it's in the LUCID-COMMON-LISP package. + ;; + #+LUCID (or lucid::*source-pathname* (bad-time)) + #-(or Lispm excl Xerox (and dec vax common) LUCID) nil)) + +#-Symbolics +(defvar *clos-directory* + (or (load-truename t) + (error "Because load-truename is not implemented in this port~%~ + of CLOS, you must manually edit the definition of the~%~ + variable *clos-directory* in the file defsys.lisp."))) + +#+Genera +(defvar *clos-directory* + (let ((source (load-truename t))) + (flet ((subdir (name) + (scl:send source :new-pathname :raw-directory + (append (scl:send source :raw-directory) + (list name))))) + (cons source + #+genera-release-7-2 (subdir "rel-7-2") + #+genera-release-7-3 (subdir "rel-7-3") + #+genera-release-7-4 (subdir "rel-7-4") + #+genera-release-8-0 (subdir "rel-8-0") + #+genera-release-8-1 (subdir "rel-8-1") + )))) + +#+Cloe-Runtime +(defvar *clos-directory* (pathname "/usr3/hornig/clos/")) + +(defsystem clos + *clos-directory* + ;; + ;; file load compile files which port + ;; environment environment force the of + ;; recompilation + ;; of this file + ;; + ( + (patch t t () xerox) + (pkg t t ()) + (walk (pkg) (pkg) ()) + (iterate t t ()) + (macros t t ()) + (low (pkg macros) t (macros)) + (low2 (low) (low) (low) Xerox) + (fin t t (low)) + (defclass t t (low)) + (defs t t (defclass macros iterate)) + (fngen t t (low)) + (lap t t (low)) + (plap t t (low)) + (cache t t (low defs)) + (dlap t t (defs low fin cache lap)) + (boot t t (defs fin)) + (vector t t (boot defs cache fin)) + (slots t t (vector boot defs low cache fin)) + (init t t (vector boot defs low cache fin)) + (std-class t t (vector boot defs low cache fin slots)) + (cpl t t (vector boot defs low cache fin slots)) + (braid t t (boot defs low fin cache)) + (fsc t t (defclass boot defs low fin cache)) + (methods t t (defclass boot defs low fin cache)) + (combin t t (defclass boot defs low fin cache)) + (dfun t t (dlap)) + (fixup (+ precom1 precom2 precom4) t (boot defs low fin)) + (defcombin t t (defclass boot defs low fin)) + (ctypes t t (defclass defcombin)) + (construct t t (defclass boot defs low)) + (env t t (defclass boot defs low fin)) + (compat t t ()) + (precom1 (dlap) t (defs low cache fin dfun)) + (precom2 (dlap) t (defs low cache fin dfun)) + (precom4 (dlap) t (defs low cache fin dfun)) + + (clos-env t t () Xerox) + (web-editor t t () Xerox) + (new-clos-browser t t () Xerox) + )) + +(defun compile-clos (&optional m) + (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) + #+Lucid (lcl:*redefinition-action* nil) + #+excl (excl::*redefinition-warnings* nil) + #+Genera (sys:inhibit-fdefine-warnings t) + ) + (cond ((null m) (operate-on-system 'clos :compile)) + ((eq m :print) (operate-on-system 'clos :compile () t)) + ((eq m :query) (operate-on-system 'clos :query-compile)) + ((eq m :confirm) (operate-on-system 'clos :confirm-compile)) + ((eq m 't) (operate-on-system 'clos :recompile)) + ((listp m) (operate-on-system 'clos :compile-from m)) + ((symbolp m) (operate-on-system 'clos :recompile-some `(,m)))))) + +(defun load-clos (&optional m) + (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) + #+Lucid (lcl:*redefinition-action* nil) + #+excl (excl::*redefinition-warnings* nil) + #+Genera (sys:inhibit-fdefine-warnings t) + ) + (cond ((null m) (operate-on-system 'clos :load)) + ((eq m :query) (operate-on-system 'clos :query-load))) + (pushnew :clos *features*))) + +#+Genera +;;; Make sure Genera bug mail contains the CLOS bug data. A little +;;; kludgy, but what the heck. If they didn't mean for people to do +;;; this, they wouldn't have made private patch notes be flavored +;;; objects, right? Right. +(progn + (scl:defflavor clos-private-patch-info ((description)) ()) + (scl:defmethod (sct::private-patch-info-description clos-private-patch-info) () + (or description + (setf description (string-append "CLOS version: " *clos-system-date*)))) + (scl:defmethod (sct::private-patch-info-pathname clos-private-patch-info) () + *clos-directory*) + (unless (find-if #'(lambda (x) (typep x 'clos-private-patch-info)) + sct::*private-patch-info*) + (push (scl:make-instance 'clos-private-patch-info) + sct::*private-patch-info*))) + +(defun bug-report-info (&optional (stream *standard-output*)) + (format stream "~&CLOS system date: ~A~ + ~&Lisp Implementation type: ~A~ + ~&Lisp Implementation version: ~A~ + ~&*features*: ~S" + *clos-system-date* + (lisp-implementation-type) + (lisp-implementation-version) + *features*)) + + + +;;;; +;;; +;;; This stuff is not intended for external use. +;;; +(defun rename-clos () + (dolist (f (cadr (get-system 'clos))) + (let ((old nil) + (new nil)) + (let ((*system-directory* *default-pathname-defaults*)) + (setq old (make-source-pathname (car f)))) + (setq new (make-source-pathname (car f))) + (rename-file old new)))) + +#+Genera +(defun edit-clos () + (dolist (f (cadr (get-system 'clos))) + (let ((*system-directory* *clos-directory*)) + (zwei:find-file (make-source-pathname (car f)))))) + +#+Genera +(defun hardcopy-clos (&optional query-p) + (let ((files (mapcar #'(lambda (f) + (setq f (car f)) + (and (or (not query-p) + (y-or-n-p "~A? " f)) + f)) + (cadr (get-system 'clos)))) + (b zwei:*interval*)) + (unwind-protect + (dolist (f files) + (when f + (multiple-value-bind (ignore b) + (zwei:find-file (make-source-pathname f)) + (zwei:hardcopy-buffer b)))) + (zwei:make-buffer-current b)))) + + +;;; +;;; unido!ztivax!dae@seismo.css.gov +;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet +;;; Victor@carmen.uu.se +;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET +;;; +#+Genera +(defun mail-clos (to) + (let* ((original-buffer zwei:*interval*) + (*system-directory* (pathname "vaxc:/user/ftp/pub/clos/") + ;(funcall (car (get-system 'clos))) + ) + (files (list* 'defsys + 'test + (caddr (get-system 'clos)))) + (total-number (length files)) + (file nil) + (number-of-lines 0) + (i 0) + (mail-buffer nil)) + (unwind-protect + (loop + (when (null files) (return nil)) + (setq file (pop files)) + (incf i) + (multiple-value-bind (ignore b) + (zwei:find-file (make-source-pathname file)) + (setq number-of-lines (zwei:count-lines b)) + (zwei:com-mail-internal t + :initial-to to + :initial-body b + :initial-subject + (format nil + "CLOS file ~A (~A of ~A) ~D lines" + file i total-number number-of-lines)) + (setq mail-buffer zwei:*interval*) + (zwei:com-exit-com-mail) + (format t "~&Just sent ~A (~A of ~A)." b i total-number) + (zwei:kill-buffer mail-buffer))) + (zwei:make-buffer-current original-buffer)))) + + diff --git a/clos/3.5/dfun.dfasl b/clos/3.5/dfun.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..85d8576f65b059f52805874d41aa599eee2d87f6 GIT binary patch literal 14841 zcmdU03v650dFHvKNJ*v`N@8f6bsRc&R7VX{J4w~rX-{&Vh}t93M)jV6yAdaN=zF%>;>{Mcj1k3}Cj zG8H{~71UkIj+B-h&MEm) zamR389o>;ti$gn-S*^GuIb0|}{*L{R96x-|Waa2%4{YryI{F=-n%H}6Vt;gGV*lZZ zqx<)MwC6u-Lm~XefMRiQ@rM^h8y zqS3uu?%e{7wr#(^Z~K<5_jFwUorQBQ{}C7bwc$_DwJ;mp8a;O8vDoCqhbAU*u7|K- z;nTCN{locWN!9WTXW0z%E_`aXUCqaa; zTY1RETpprx;cN@AcR5FO~|!$&ywm_5#7Pks6NH6x)22I(dhe2biC)CvNag zzWyd7SFDjY^eTCjgW!~7gjiBerq%oa(XrX2<7SncQMJ*eY9omzTuf^t4Z{^tK2o7V z%qq=O@+AF|l&Zt8>dWc5^eH{a#-xk-rNOzuQ;WB=OQM0wGK@tslEnNd)9Rpfaq;id z(yNPq>2iDcMt2Ke&o_G{Qxl~Gh{@Zp6>@SZ#Cu(y`xa(>(>>G0=ydUxh1u5qm7{z2 zO-}4@gY1dJ^e8RNZkX;tb&8H3Iehfk)ba6SfH32G$MwqLN28Ua(P{Y}nqO!@DK$)w zW_KD$`^||1KY#h4P8L$tdeTV zNS25f!>`KeraT*)(}U?3? z>%#0RhiOQw`TM%KU+UoRZ#603IPu}f_8#8vpuK@~q2izf?3TDRdM3?g^yNw?6SL4S z>6b@(ujp5EbGg$OTt8uZq;jCDmxEO;a7GJ2*0)(X2ns%@&s54?XSA-THGEaCefEOu zkMfMPK?^d{4|*wgv2v)YbxGwgE3c_)VW}Kp<#kmpB9+&(a4o7da z6gjkr`*5*nfyHeg&#=Kuut-9V2WK;VV_ZX+W)19t*E6HA=b*N<0(A&iw+ ziXsDGnS#NGR>5<3Q7QGu46YgugeMFItzf=+Ij0mmVK(b-FdI;AFYjmkLG}(vH36^Lw3m8=neiTSE{cu>4QP@qa-_%%Jhgk?H z=#Z011)PsUObjfc2jUfa%Y70*23`h7sQm;|k+7)%_aNn@g6crM7Q=pEN8pAjzb$%b zpl1aMrYr;rK$HU~N+a4zI8mv^iDbxYLWOr_s1QX>pd$U6w+<~lHd^3}Ujm(U@V*IR zv>AvI+X6aZK5sRp;U4ExALOAZ0LDH1=v^?)HfwU+*A4FiC9F)tZb3(fK_IsZl<*2* zyNQ<8_aV@=2~ykw!-gAc+nTu(kODMwC83zAEbtJ>{1ppj@s}wSl=72zk!HT!Odh75 zl03o&W|#u;LgSTT!)CFQV>f{f#4U$#%$5zpA&S4$1UkTKE$G0>eF^?MjrL~nA&r10 zOCwuZ$TU|<=Ow`-6EChb!3(8s=qoU^*T4(!TgHnO2sm#OP^*}@=Fwtpt$CJW()=3{ z1Du3EB%~7?$Tw|&Lvnz~K^@@XEc`z;=^?+JYCp&>!S?eqWPc%RHuqNRd=t@49pJ!P z@6BYvl(MLa0#}q zC5l=o+&9Q`3S_N8k8K$IF{%$?umbq9xY~2yeSFJ0sL^4f81>A3o*5$}@1U;G(|1uP=;?c)285M5C9k8$Tdx5ID?tOO&i5_po49F;|Hio4TsCh7 zHyc|vRRyB%2aVXN>&a9NcK)Clc1i>N=JH-|e$6rSbrUmx)`*$9o>FRt{MpKw`PK(E zuo4FbF?HE&$*Q;~>4$9$kkTpwXt1>e!7`MIV|(e%XVtt?WEh7C!e&|?&XypsWj2S( z*mcC-sN`e$8gr!~P-A|(7JvaOrCRir9HI8*gB5@XKwZzNNvR3ydTiA7AnMW%xo!iP z$<`rk3nHw*aAUH5Fcxzs2tIX#U$+9XKEtQ>@z4x@rtcA@QQ72z$+N479!bZ7|Q8hI`)J& zA5h>F4G7E#qavI8)uIDz8nEgC7_=Ey5rYs75Sv!p*aV(YGJ_%1nnnJ{wZMdXNf2)> zHWA2>pEpLo7gb6wiR7{aXa)&|mew@`C9##y+76`y+8$ViK@f6RUq_^)L;8S~eNP}Qt$DI&mE{w&B!2YcA0gwxxe}Kc@uf^!3ko)=| z^A;V@FCU;$qdc>>260fWf*mv#n++_l=31 zZgX*kDW0*XZL1xEaz!v zRkMg1)y%{twSY9%^s0FXC9C4Bw+N7cS4)x^JpEfmI&*?Qx~k>`kj|rhVN=v3^<2Vue@uG$!ZyBqpbMpU!jRKxoKZ ztx0c0_!|&&ehUro~W3xS8? zaPcw}x8!jF5bwW_OqkN_`ddRN{=kwVZ5A!0C*&_*ezt6utkd}QK+f!!xhBV)d!`Aq}}WaDBGUraw6ZM zt5{cPE42oF_0=_J={Lax8I&Gkmow7C_|{ql&)_Ol%ZsL_;zCh7sV+SD0sUG(dx3o< z{aQODGW%UJQL?oV$hNLDsaP9?mDY=Ek;ss2re?7KcI!a?s8q5(@(=O8#M2L zUJ`hI{!?)vac$`?=uFwZ6o#Z9oQ+90@gW_nUT}T&fc^X@X8ny+|2+I2v`e|8<|oaX z+eFXr6#S*R)nT(W*5ZiO!D7~IzZKe3xbBs072A?l>>?z_k!?95=M4T>-M`%|dth6@ zF3CsAc)~JP)Wv7PVB3vgXge&@7)9`E;s(`hi-x*whDg0yVo*uKEfcRsp*6_YFe(eb zc(PFA!lNrDjgjR_LuBBRBHr#5$?YQXi-hcgorFg0@2EC=R-nR9s2qH|91{BqP2h2S z{ItmV1m#SBnD-sw{{6gfC(mU?mRQ>;WvR(&Jiu z{1iQUsTn@HUdP8_dVCol@8riY@$d?k{v3Ms7fUH{Ac1xHB;dgT>fs6W7X=%+FG|hN zcT+Ntju3lu;jD*?mHB1Lew~`F#WK8E5CmN(6#BlH^OlO%pYnr46|_0fl=~#)Uti*mMWrM9lCL`}0zm=kUfvJ2o_9(#{F6 ze*p462>3%Lb?r02hPZ4ZW|K@|&QRYrXrv7T9u5Jy8@Dpyd74c^xNFUGSD23-b%$BG z4JRM=^x}R(li58$C!^NA+@>}1i>x36)6WdlsI+5Ex_pnz3ucfXQ-zkXlmRS z0;|`|d&~8!6}hATE|!{q77LHze2Ud!A4={oMERf6pyZ&Q5o^#VDd%%o=PB-=3eFqsK^!i;zwGGzY7uS4d$5=qtJ$z-&^%HmGc zh&xH*{!AQ&E%qsITeycnxMp;ySw!3tu2(bHJB`-6PUPm_3X%Pl5b2+Zw@bug66q&} z0H2|p&pq)A3GeGdcps%?s!njzfIT~$#x-hf0NLfZoF%T15n1szh?~WQ`KXX8a4ZX{qYq^Si40a$+v=lrZE6Xk}g<09S zC!2vCu8uce15`G*xJL`Hav0w6zNr?*tF&E4QBs4;u}}n;V_{nyE{7`DUWsK7UVmN- znvVQp)P9Dlx%s>n?z#Gu7SDpc3rcfI2q{qZkT>D;Qp>q=;b4 zDBku|;46m@P#>=ohO;y+TWpX3n`NML#t#Tj_6^j&j{}Qt6U-3Nq!%j0C6N_W(J$yk zmWxfbAr1-pv4du8)O{;RCQKnRQ(~flT7rOFD-?E`+j8@S9Kw`%$kJ}UYyEW9j%a`5 zW0d@p5aYMtvxn6~@oO*Y<26@1gED??fhy5!+^1DyVzG)PwUh!%GC<$pz}BC-`xbnZ zabx|og19if4q%L%TsFs1#mZU>tTa4Kd}3|9f^qcQZb%p&^RZ2W)Ak1m%W=5HZCF>e z8$UbvSGdwlGx!nx{)Zd6Z$%j!>`Yq2`;fIDHu&lU?~j6x;N@g6BA`t$70**q{%4Kh zMY62J#}N8u^>+t@D!Y&;OnlSbSd|!a-E_oF>wzjTEgS zu%HFCt{yO(XS6OoQVvoC^6KKBUmkomlkK_mWLA$n1Wxqw;*-J#eg?2}qgndOFvVNM zl~}lVT%uhd_l-bqSlOA48DH?I4=RP2*b{P}hFqyH1Vy|L^1F=~vZEdF>mD?!e%ML2 zL6tT23>7!+FtCpN7R8RQd}5+YC}!(M z#jH`JuyqiFxVwPT7CJ8we#d`%xgS22IWxP-F(YS;Xc&(bjJtxs1K{>XP+HQk{{c$d zg+^4t1VkRH^$oO+2^D?Q(y+%txlzNuAvziXpX?EbDhUT_X{XGDd$$x#h|dnhHzzu+ zI_HR8i|^JK?-tohwk9EA#O|b+Y{{;TfIq*^QS# zZ|lVkG^{@*c(XCOKS8Rubywf3%A9BmY{ zS}BHi=S2`txN|?;169}K_hUKG^BC2kd$h5{m@U~+l%LdDfV! . ( + ; ...)) Each subentry is of the form: + ; ( ) + + +(defvar *enable-dfun-constructor-caching* t) + + ; If this is NIL, then the whole + ; mechanism for caching dfun + ; constructors is turned off. The only + ; time that makes sense is when + ; debugging LAP code. + + +(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if + *enable-dfun-constructor-caching* + "enabled" + "disabled")) + (dolist (generator-entry *dfun-constructors*) + (dolist (args-entry (cdr generator-entry)) + (format t "~&~S ~S" (cons (car generator-entry) + (caar args-entry)) + (caddr args-entry))))) + +(defun get-dfun-constructor (generator &rest args) + (let* ((generator-entry (assq generator *dfun-constructors*)) + (args-entry (assoc args (cdr generator-entry) + :test + #'equal))) + (if (null *enable-dfun-constructor-caching*) + (apply (symbol-function generator) + args) + (or (cadr args-entry) + (let ((new (apply (symbol-function generator) + args))) + (if generator-entry + (push (list (copy-list args) + new nil) + (cdr generator-entry)) + (push (list generator (list (copy-list args) + new nil)) + *dfun-constructors*)) + new))))) + +(defun load-precompiled-dfun-constructor (generator args system constructor) + (let* ((generator-entry (assq generator *dfun-constructors*)) + (args-entry (assoc args (cdr generator-entry) + :test + #'equal))) + (unless args-entry + (if generator-entry + (push (list args constructor system) + (cdr generator-entry)) + (push (list generator (list args constructor system)) + *dfun-constructors*))))) + +(defmacro + precompile-dfun-constructors + (&optional system) + (let + ((*precompiling-lap* t)) + `(progn + ,@(gathering1 (collecting) + (dolist (generator-entry *dfun-constructors*) + (dolist (args-entry (cdr generator-entry)) + (when (or (null (caddr args-entry)) + (eq (caddr args-entry) + system)) + (multiple-value-bind (closure-variables arguments iregs vregs tregs lap) + (apply (symbol-function (car generator-entry)) + (car args-entry)) + (gather1 (make-top-level-form `(precompile-dfun-constructor + ,(car generator-entry)) + '(load) + `(load-precompiled-dfun-constructor + ',(car generator-entry) + ',(car args-entry) + ',system + (precompile-lap-closure-generator ,closure-variables + ,arguments + ,iregs + ,vregs + ,tregs + ,lap)))))))))))) + +(defun make-initial-dfun (generic-function) + #'(lambda (&rest args) + (initial-dfun args generic-function))) + + +;;; When all the methods of a generic function are automatically generated reader or writer methods +;;; a number of special optimizations are possible. These are important because of the large number +;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case, +;;; the accessor generic function has only been called with one class of argument. There is no +;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure +;;; variables of the discriminating function. This case can convert to either of the next kind. +;;; TWO-CLASS-ACCESSOR Like above, but two classes. This is common enough to do specially. There is +;;; no cache vector. The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In +;;; this case, the accessor generic function has seen more than one class of argument, but the index +;;; of the slot is the same for all the classes that have been seen. A cache vector is used to +;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable +;;; of the discriminating function. This case can convert to the next kind. N-N-ACCESSOR This is +;;; the most general case. In this case, the accessor generic function has seen more than one class +;;; of argument and more than one slot index. A cache vector stores the wrappers and corresponding +;;; slot indexes. Because each cache line is more than one element long, a cache lock count is +;;; used. ONE-CLASS-ACCESSOR + + +(defun update-to-one-class-readers-dfun (generic-function wrapper index) + (let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index)))) + (notice-dfun-state generic-function `(one-class readers ,(consp index))) + ; *** + (update-dfun generic-function (funcall constructor wrapper index + #'(lambda (arg) + (declare (clos-fast-call)) + (one-class-readers-miss arg + generic-function index wrapper)))))) + +(defun update-to-one-class-writers-dfun (generic-function wrapper index) + (let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index)))) + (notice-dfun-state generic-function `(one-class writers ,(consp index))) + ; *** + (update-dfun generic-function (funcall constructor wrapper index + #'(lambda (new-value arg) + (declare (clos-fast-call)) + (one-class-writers-miss new-value arg + generic-function index wrapper)))))) + +(defun one-class-readers-miss (arg generic-function index wrapper) + (accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil)) + +(defun one-class-writers-miss (new arg generic-function index wrapper) + (accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil)) + + +;;; TWO-CLASS-ACCESSOR + + +(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index) + (let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index)))) + (notice-dfun-state generic-function `(two-class readers ,(consp index))) + ; *** + (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index + #'(lambda (arg) + (declare (clos-fast-call)) + (two-class-readers-miss arg + generic-function index wrapper-0 + wrapper-1)))))) + +(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index) + (let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index)))) + (notice-dfun-state generic-function `(two-class writers ,(consp index))) + ; *** + (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index + #'(lambda (new-value arg) + (declare (clos-fast-call)) + (two-class-writers-miss new-value arg + generic-function index wrapper-0 + wrapper-1)))))) + +(defun two-class-readers-miss (arg generic-function index w0 w1) + (accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil)) + +(defun two-class-writers-miss (new arg generic-function index w0 w1) + (accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil)) + + +;;; std accessors same index dfun + + +(defun update-to-one-index-readers-dfun (generic-function index &optional field cache) + (unless field + (setq field (wrapper-field 'number))) + (let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index)))) + (multiple-value-bind (mask size) + (compute-cache-parameters 1 nil (or cache 4)) + (unless cache + (setq cache (get-cache size))) + (notice-dfun-state generic-function `(one-index readers ,(consp index))) + ; *** + (update-dfun generic-function (funcall constructor field cache mask size index + #'(lambda (arg) + (declare (clos-fast-call)) + (one-index-readers-miss arg + generic-function index field cache + ))) + cache)))) + +(defun update-to-one-index-writers-dfun (generic-function index &optional field cache) + (unless field + (setq field (wrapper-field 'number))) + (let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index)))) + (multiple-value-bind (mask size) + (compute-cache-parameters 1 nil (or cache 4)) + (unless cache + (setq cache (get-cache size))) + (notice-dfun-state generic-function `(one-index writers ,(consp index))) + ; *** + (update-dfun generic-function (funcall constructor field cache mask size index + #'(lambda (new-value arg) + (declare (clos-fast-call)) + (one-index-writers-miss new-value arg + generic-function index field cache + ))) + cache)))) + +(defun one-index-readers-miss (arg gf index field cache) + (accessor-miss gf 'one-index 'reader nil arg index nil nil field cache)) + +(defun one-index-writers-miss (new arg gf index field cache) + (accessor-miss gf 'one-index 'writer new arg index nil nil field cache)) + +(defun one-index-limit-fn (nlines) + (default-limit-fn nlines)) + +(defun update-to-n-n-readers-dfun (generic-function &optional field cache) + (unless field + (setq field (wrapper-field 'number))) + (let ((constructor (get-dfun-constructor 'emit-n-n-readers))) + (multiple-value-bind (mask size) + (compute-cache-parameters 1 t (or cache 2)) + (unless cache + (setq cache (get-cache size))) + (notice-dfun-state generic-function `(n-n readers)) + ; *** + (update-dfun generic-function (funcall constructor field cache mask size + #'(lambda (arg) + (declare (clos-fast-call)) + (n-n-readers-miss arg generic-function + field cache))) + cache)))) + +(defun update-to-n-n-writers-dfun (generic-function &optional field cache) + (unless field + (setq field (wrapper-field 'number))) + (let ((constructor (get-dfun-constructor 'emit-n-n-writers))) + (multiple-value-bind (mask size) + (compute-cache-parameters 1 t (or cache 2)) + (unless cache + (setq cache (get-cache size))) + (notice-dfun-state generic-function `(n-n writers)) + ; *** + (update-dfun generic-function (funcall constructor field cache mask size + #'(lambda (new arg) + (declare (clos-fast-call)) + (n-n-writers-miss new arg + generic-function field cache))) + cache)))) + +(defun n-n-readers-miss (arg gf field cache) + (accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache)) + +(defun n-n-writers-miss (new arg gf field cache) + (accessor-miss gf 'n-n 'writer new arg nil nil nil field cache)) + +(defun n-n-accessors-limit-fn (nlines) + (default-limit-fn nlines)) + + +;;; + + +(defun update-to-checking-dfun (generic-function function &optional field cache) + (unless field + (setq field (wrapper-field 'number))) + (let* ((arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info)) + (nkeys (arg-info-nkeys arg-info))) + (if (every #'(lambda (mt) + (eq mt 't)) + metatypes) + (progn (notice-dfun-state generic-function `(default-method-only)) + ; *** + (update-dfun generic-function function)) + (multiple-value-bind (mask size) + (compute-cache-parameters nkeys nil (or cache 2)) + (unless cache + (setq cache (get-cache size))) + (let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp))) + (notice-dfun-state generic-function '(checking) + nkeys nil) + ; **** + (update-dfun generic-function + (funcall constructor field cache mask size function + #'(lambda (&rest args) + (declare (clos-fast-call)) + (checking-miss generic-function args function field + cache))) + cache)))))) + +(defun checking-limit-fn (nlines) + (default-limit-fn nlines)) + + +;;; + + +(defun update-to-caching-dfun (generic-function &optional field cache) + (unless field + (setq field (wrapper-field 'number))) + (let* ((arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info)) + (nkeys (arg-info-nkeys arg-info)) + (constructor (get-dfun-constructor 'emit-caching metatypes applyp))) + (multiple-value-bind (mask size) + (compute-cache-parameters nkeys t (or cache 2)) + (unless cache + (setq cache (get-cache size))) + (notice-dfun-state generic-function '(caching) + nkeys t) + ; **** + (update-dfun generic-function (funcall constructor field cache mask size + #'(lambda (&rest args) + (declare (clos-fast-call)) + (caching-miss generic-function args + field cache))) + cache)))) + +(defun caching-limit-fn (nlines) + (default-limit-fn nlines)) + + +;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of +;;; state machine. The kinds of discriminating function is the state, the various kinds of reasons +;;; for a cache miss are the state transitions. The code which implements the transitions is all in +;;; the miss handlers for each kind of dfun. Those appear here. Note that within the states that +;;; cache, there are dfun updates which simply select a new cache or cache field. Those are not +;;; considered as state transitions. + + +(defun initial-dfun (args generic-function) + (protect-cache-miss-code generic-function args + (multiple-value-bind (wrappers invalidp nfunction applicable) + (cache-miss-values generic-function args) + (multiple-value-bind (ntype nindex) + (accessor-miss-values generic-function applicable args) + (cond ((null applicable) + (apply #'no-applicable-method generic-function args)) + (invalidp (apply nfunction args)) + ((and ntype nindex) + (ecase ntype + (reader (update-to-one-class-readers-dfun generic-function wrappers + nindex)) + (writer (update-to-one-class-writers-dfun generic-function wrappers + nindex))) + (apply nfunction args)) + (ntype (apply nfunction args)) + (t (update-to-checking-dfun generic-function nfunction) + (apply nfunction args))))))) + +(defun + accessor-miss + (gf ostate otype new object oindex ow0 ow1 field cache) + (declare (ignore ow1)) + (let ((args (ecase otype ; The congruence rules assure + (reader (list object)) ; us that this is safe despite + (writer (list new object))))) + ; not knowing the new type yet. + (protect-cache-miss-code + gf args + (multiple-value-bind (wrappers invalidp nfunction applicable) + (cache-miss-values gf args) + (multiple-value-bind (ntype nindex) + (accessor-miss-values gf applicable args) + + ;; The following lexical functions change the state of the dfun to that which is their + ;; name. They accept arguments which are the parameters of the new state, and get other + ;; information from the lexical variables bound above. + (flet ((two-class (index w0 w1) + (when (zerop (random 2)) + (psetf w0 w1 w1 w0)) + (ecase ntype + (reader (update-to-two-class-readers-dfun gf w0 w1 index)) + (writer (update-to-two-class-writers-dfun gf w0 w1 index)))) + (one-index (index &optional field cache) + (ecase ntype + (reader (update-to-one-index-readers-dfun gf index field cache)) + (writer (update-to-one-index-writers-dfun gf index field cache)))) + (n-n (&optional field cache) + (ecase ntype + (reader (update-to-n-n-readers-dfun gf field cache)) + (writer (update-to-n-n-writers-dfun gf field cache)))) + (checking nil (update-to-checking-dfun gf nfunction)) + + ;; + (do-fill (valuep limit-fn update-fn) + (multiple-value-bind (nfield ncache) + (fill-cache field cache 1 valuep limit-fn wrappers nindex) + (unless (and (= nfield field) + (eq ncache cache)) + (funcall update-fn nfield ncache))))) + (cond ((null nfunction) + (apply #'no-applicable-method gf args)) + ((null ntype) + (checking) + (apply nfunction args)) + ((or invalidp (null nindex)) + (apply nfunction args)) + ((not (or (std-instance-p object) + (fsc-instance-p object))) + (checking) + (apply nfunction args)) + ((neq ntype otype) + (checking) + (apply nfunction args)) + (t (ecase ostate + (one-class (if (eql nindex oindex) + (two-class nindex ow0 wrappers) + (n-n))) + (two-class (if (eql nindex oindex) + (one-index nindex) + (n-n))) + (one-index (if (eql nindex oindex) + (do-fill nil #'one-index-limit-fn + #'(lambda (nfield ncache) + (one-index nindex nfield ncache))) + (n-n))) + (n-n (unless (consp nindex) + (do-fill t #'n-n-accessors-limit-fn #'n-n)))) + (apply nfunction args))))))))) + +(defun checking-miss (generic-function args ofunction field cache) + (protect-cache-miss-code generic-function args + (let* ((arg-info (gf-arg-info generic-function)) + (nkeys (arg-info-nkeys arg-info))) + (multiple-value-bind (wrappers invalidp nfunction) + (cache-miss-values generic-function args) + (cond (invalidp (apply nfunction args)) + ((null nfunction) + (apply #'no-applicable-method generic-function args)) + ((eq ofunction nfunction) + (multiple-value-bind (nfield ncache) + (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil) + (unless (and (= nfield field) + (eq ncache cache)) + (update-to-checking-dfun generic-function nfunction nfield + ncache))) + (apply nfunction args)) + (t (update-to-caching-dfun generic-function) + (apply nfunction args))))))) + +(defun caching-miss (generic-function args ofield ocache) + (protect-cache-miss-code generic-function args + (let* ((arg-info (gf-arg-info generic-function)) + (nkeys (arg-info-nkeys arg-info))) + (multiple-value-bind (wrappers invalidp function) + (cache-miss-values generic-function args) + (cond (invalidp (apply function args)) + ((null function) + (apply #'no-applicable-method generic-function args)) + (t (multiple-value-bind (nfield ncache) + (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers + function) + (unless (and (= nfield ofield) + (eq ncache ocache)) + (update-to-caching-dfun generic-function nfield ncache))) + (apply function args))))))) + + +;;; Some useful support functions which are shared by the implementations of the different kinds of +;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess +;;; of values. Is a single wrapper if the generic function has only one key, that is +;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized +;;; arguments to the generic function. Note that all these wrappers are valid. This function does +;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper. +;;; True if any of the specialized arguments had an invalid wrapper, false otherwise. +;;; The compiled effective method function for this set of arguments. Gotten from +;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is +;;; important since it is what keeps us in checking dfun state when possible. READER or +;;; WRITER when the only method that would be run is a standard reader or writer method. To be +;;; specific, the value is READER when the method combination is eq to +;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and +;;; the most specific primary method is a standard reader method. If is READER +;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in +;;; the object argument. Sorted list of applicable methods. + + +(defun cache-miss-values (generic-function args) + (declare (values wrappers invalidp function applicable)) + (multiple-value-bind (function appl arg-info) + (get-secondary-dispatch-function generic-function args) + (multiple-value-bind (wrappers invalidp) + (get-wrappers generic-function args arg-info) + (values wrappers invalidp (cache-miss-values-function generic-function function) + appl)))) + +(defun get-wrappers (generic-function args &optional arg-info) + (let* ((invalidp nil) + (wrappers nil) + (arg-info (or arg-info (gf-arg-info generic-function))) + (metatypes (arg-info-metatypes arg-info)) + (nkeys (arg-info-nkeys arg-info))) + (flet ((get-valid-wrapper (x) + (let ((wrapper (wrapper-of x))) + (cond ((invalid-wrapper-p wrapper) + (setq invalidp t) + (check-wrapper-validity x)) + (t wrapper))))) + (setq wrappers (block collect-wrappers + (gathering1 (collecting) + (iterate ((arg (list-elements args)) + (metatype (list-elements metatypes))) + (when (neq metatype 't) + (if (= nkeys 1) + (return-from collect-wrappers + (get-valid-wrapper arg)) + (gather1 (get-valid-wrapper arg)))))))) + (values wrappers invalidp)))) + +(defun cache-miss-values-function (generic-function function) + (if (eq *generate-random-code-segments* generic-function) + (progn (setq *generate-random-code-segments* nil) + #'(lambda (&rest args) + (declare (ignore args)) + nil)) + function)) + +(defun generate-random-code-segments (generic-function) + (dolist (arglist (generate-arglists generic-function)) + (let ((*generate-random-code-segments* generic-function)) + (apply generic-function arglist)))) + +(defun generate-arglists (generic-function) + + ;; Generate arglists using class-prototypes and eql-specializer-objects to get all the + ;; "different" values that could be returned by get-secondary-dispatch-function for this + ;; generic-function. + (let ((methods (generic-function-methods generic-function))) + (mapcar #'(lambda (class-list) + (mapcar #'(lambda (specializer) + (if (eql-specializer-p specializer) + (eql-specializer-object specializer) + (class-prototype specializer))) + (method-specializers (find class-list methods :test + #'(lambda (class-list method) + (every + #' + specializer-applicable-using-class-p + (method-specializers + method) + class-list)))))) + (generate-arglist-classes generic-function)))) + +(defun generate-arglist-classes (generic-function) + (let ((methods (generic-function-methods generic-function))) + (declare (ignore methods)) + + ;; Finish this sometime. + nil)) + +(defun accessor-miss-values (generic-function applicable args) + (declare (values type index)) + (let ((type (and (eq (generic-function-method-combination generic-function) + *standard-method-combination*) + (every #'(lambda (m) + (null (method-qualifiers m))) + applicable) + (let ((method (car applicable))) + (cond ((standard-reader-method-p method) + (and (optimize-slot-value-by-class-p (class-of (car args)) + (accessor-method-slot-name method) + nil) + 'reader)) + ((standard-writer-method-p method) + (and (optimize-slot-value-by-class-p (class-of (cadr args)) + (accessor-method-slot-name method) + t) + 'writer)) + (t nil)))))) + (values type (and type (let ((wrapper (wrapper-of (case type + (reader (car args)) + (writer (cadr args))))) + (slot-name (accessor-method-slot-name (car applicable)))) + (or (instance-slot-index wrapper slot-name) + (assq slot-name (wrapper-class-slots wrapper)))))))) diff --git a/clos/3.5/dlap.dfasl b/clos/3.5/dlap.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..cc04e654d5c7cb4aa0cdb77cd9a7604db260f1f3 GIT binary patch literal 12774 zcmb_i3vg7|dEUEv0$L%2z*sgmw&PtExB{&}LK295U9opxSM06?!kCAJ@B+eM0mcMK zF}CBlUa)0s&>w^2N1QZCo5&yDxS%&hV*%d!s*zN6`gx~`}ekO>ED0Pf!@BJY+E|k9Zu<8T3gr%btbfACf(MV)YrAe z^>jyDC~l@765`7tL#& zm)w0{@2d+{maMN;$HuW|qQe@!FK0(Na)`qdt)<6{2Ip zk@GDl7;^eGhlC1YE)49$0`yhw4q*x!F6JI4pIMY%NySWVwT% zm81fPcZ>vfesG$L7lv*L^f?O!vuVKAG@IRZ71`9zP>QoreLJ(iY|Z8sE4!(3Q`Jat zAp59|R6PjDB=az;&(&HDrN*e{ zs-vB|NqV~8I##mS_?D8aF~E{I9HRj=E=mNB_xt_*W2jaf<-qpQ)X`yQSjVm zi-WZ)qlUSen(?er!&S25L!P`688y0M(oD`aJ>l&b>Y0#xm7V*!nMSoyB?HJbz2*RC zsRD->HTkhaSOZuBU`2CPla_3nJz`X!HmaF4V$_^AYRv3x)TxBzlP0M$--<`9ayW|- zda4$z){Jdr@wgERWHiLk)q0vyk7~W(rsP&hW=k@S6XzA|Ijub& z$Yiu6v1WeG|3vB(2GN9`P7CdQq?H;SAtS5_;kV#Hw$3*OpUzFyLV>iVwg>b$kzT{5 zF7BSzGAaSH^mw^IUp{81NLlG?$%gaDrn+kN`G?=gQ-k3)9Cht*=e$DKa*CctBM^U~f zrDr8MEyM?(ZE6PYs)OOKE=kJkHoWVU5!Mua#Zb>{4)L1wEp7@Ni0BLm|W)ipWKqDnz0~aO7 zv2lr>3~TG8(N~aFai}YhqRI!UkTAM5D)hl}O4bRNsBj4gm&MRbbqk<{lG}l&U5%_q zS)PngB0U{gJ0-u`dahFb+fG{|w14I1%G=O}td)P1((B}CpsA*e4x*mtNvE`SD*S*) zSH4Z7M*>~iXkB{=$l#R$>@g*s3A5>>iIS6U2e4uqRhUzws(z`;5=W}ilj%$#84@E^ zdW2&)1gLEW`#V<~l=agX?dgy;MyoJ#(->4?8{-zKx{k)6s?lRq%NXUd`XV5KIQ|PF zlzfcbD(ziV+7rj`Axz2JRBNBK)cy>~MW}+*uEQU5%3C*yqd+=lt z<}nvFTeF`yn<0WcR8~dPLq%8=$H{R~e4uRYu;s!iS@vuqeBkgwaUsGK>jYxzMXSs? zK9=Mt_n(O|Daz;HV^Jw_fm>aQ$pI9%Sd2N;xR~`1WRFF&wXQPUH^;@Obc*Ee5ZwLX*#(O>!{QWp zaJlu7>6yw5)_yA2h4bcq7D}^U2FcNF%il z2U2zopFMc86st;1JfdtUfLM;AK?q6&(lN=U(Hij}M!`-fQ1PNIf&PsMR6JaCN&lba zdNwBfMX(6kB~mqVimnn}SM zP{H92)a8=GPKcgb`!H5RPyJCEI@xvz6V|)W*bkeQ@kU&0TXtL9Qc2qIgecgfqF{L? zTE7E4y)gd{f`)~wp`pR1M5UWySr;^};eD!uX403Ig1(I1CGj-bgF~mgfXbKr0mi?{ zj92c3a(R%8qg;K*?1UI86Qj(Je+n=kneGlPJ(w#+2Q}W^F@yH^hqAvfi{<{AZ1eMCz-PpA2PAn6)C1tX8+@C< zy$(F6oe}T`K~+&f>F7*plLQ6Na8qgSprUp1v z2aUJF5!%yHrUCUBYij4U@GcB&7rnw6&o+)MGQShgY2MY^;YJPW`(7rfVjS_;16 zTS=*s+L{^AQUR?B#3?kj1Xpn6^R9r~@hYr^26;iF78)AUgj=`>vm~xLX5mY4;l<{{ ziwAR)ExfP`^`my7;sB6dfhpygFWFdC{S@$!!M zeJJaKCY?K;5Hs>};S}wbbIfKfLU(jCFFnO;8V(JF9v0O7H{21r4I+}@9T2r* zireU*;BX+0G2V=p=$N`*b}0kyxa`tu@C3oz1YXpUFMwJNzA{itR^X};q%xhUC6?4qQZn>|0DlNWA<))^2(1EKXT zMuBg#3p_XwoIv0#(NXdaSSB!5-obJ5=79kgqlEJSfOar}WVvBsdEH#hrNJHJ-0^ns z1i;$}UN3lWD~Pm}E1$39gvD7D3a3b#OnH&kS%-4mV6Dw2$8k7j%F$9{-kz~y41Qyb z80&24W?S5~#Mj01%XNS|!nxxi@U(%q0lal~@h#^{Q+zLv65o7WmS61Cwj@8#-G*2) zd8V=@j+y#=oVxAqmXE}gx5)gKf?M|XxEDNM0PpqSoe8QFPm`PAkPBMMS(VVHU3}P^ zSk6}=N4=jP1hN++&+AnYWyAIlMuprj>Q6;u?h6mavbF2aN1Ve$Z#a0&%ZR168Cht4-Q}u}W;{!weQ3XS? zQRfAt=3<;TW?*PzoM>_9C8OrDL}>?xqDi79ov#=*$i=9_f>E{e=g18S)gwmbId?2! zRECV|Fz>OP1lTI_v~JY6&p&L`WNW*JhaQdKDM)ks5yC-PyOs$>^05{uyAScPD4B_bF)h}T;f^Id=<7F1g5#fo^{6;2 z1H9(ptfRXevnZ=HrSU85U1~0*6ocn^XM}bcL+$w@tJh#|)H-a=ihWT<3vm9^SvK`* zQjfD23}rVWRc;#fYR05ZL)si}xf&yycx0=YNFb@!o7IKoy@|`iWh%D!DzSK$iX6_I zy%4YtYR<7r+HMZq>Y`t_`Kh{KMKt0U7moYI!hC2k&KJB_t`QCs4P)bJjcqj)MY98w z9=6Vrh(xC>g2iI=%q+Uanpeq1UFL07$rY6w*oL;4xJEBAG~SUj{TIQFfk_kz$QH-t43W6($;?#7GBvUwXe1bjZ%KeF-GV1e?g1)3`#>B9f<3nlwmL&fm z$zMzIio73uS4v-#1cdky`0fYyz2NBs?`B@oduzcP!%pyAE?CS&{SWMQY@gIP_dt zMWvb8WhT8a<(aD)Lrv)N3ZYa=RJxdeG;VMx-f>l8)9>;E{+;&YcihVHFHHG>D8D3^ zvRz-dk_vyv^p7YzjPxSCej(+*FG1;VaqWjh`MU6V3N};eaeivRFlg(aKyxpw>VQ@Z zFsra}KD68ht=B=k0-6<3TPzU&GQ^T z>4^rl7>z@hJ|{2b8t{VOT{s-0S3l7h)=DQN2I?E zd<6`oXK95VPRT`)3BDr$_D|GHVgKPL0)IbXJ|7eLdqR1MDW{0?ob-BxDFkuKF@aHu zKQN4LlV0luMmxAEVV@F{&H<(nt|=>|v(FmfcB}bKoF#NrW?0!W&hpSsLB$W5LKAkp zE6DlJ7Uh>hd7UYYrLRe^zY;7xCs_Iy((DC!_4E*k&vv8@>^!>T=bW7cXW2lx!9{^wfjg#5{85tJMJ?+V0FZBlEUIPrg1i2x z&EtvMZ|Sx#mbg<);M#_;JQ=*yOvK%=eFtQXX|>d4Vlqffw}HQ&h?*Y`h2;uibz+>< z&dp*r|fxB#PpaI`aRIW+v?b$pf(QFti+i)@{u4#Vydf20ZQ1+zQQJh~EUwGcD)uJ;bJN{x*Qs zdmJE{?;mz-2u9fd5jzv0VFEKS&B<;n?>R>WvE`8*V;6bH*&f#}rvNm4k#lhqGb>*V&JRh@vT+2%|*JZnU$HZ5({BUk3hl_;n*w!=Y!a-I6`9 z_GBGbg_yuu{^26C5iC`v;Z4}~$T7h_+2GaMs4Cil7scm!RuJTINgf2xmuPGcT7!qDWQGVidWiEY1K)Kha(k~z?)N1QcEVhfS_;Cf` zLzjy_nQ}Y|+CAWrQ1i!#1S~>j!7^rd0`FXN z&IwfPQ(Nd5Kkmd^yPnYlak`V5&akC-*3Ol$sa_{!#_|C<=ly~OmfHA(npKd{CO70COCQA2k5N*(_nXf{_BTWqN$V@3U&p|UZ`b#NDrdmE z8^GHI>Kfjqcm0e?Vxr~XtvC#tg}kB^FKV)(t*BJf1E^BTuxhmDLnDpQv=B7YpRM7& TZgEKmg(Bo%rQKg~_3Hlsindex 0)) + location) + (opcode :go 'continue))) + miss))) + + +;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0). +;;; This should probably be abstracted. + + +(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value) + (with-lap-registers ((location index) + (primary index) + (cache vector) + (initial-lock-count t)) + (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache) + cache) + (with-lap-registers ((wrapper-cache-no index)) + (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper + primary wrapper-cache-no) + (opcode :move primary location) + (opcode :move (operand :cref cache 0) + initial-lock-count) + ; get lock-count + (emit-check-cache-entry cache location wrapper 'hit-internal) + (opcode :izerop wrapper-cache-no miss-label))) + ; check for obsolescence + (with-lap-registers ((size index)) + (flatten-lap (opcode :move (operand :cvar 'size) + size) + (opcode :label 'loop) + (opcode :move (operand :i1+ location) + location) + (opcode :move (operand :i1+ location) + location) + (opcode :label 'continue) + (opcode :fix= location primary miss-label) + (opcode :fix= location size 'set-location-to-min) + (emit-check-cache-entry cache location wrapper 'hit-internal) + (opcode :go 'loop) + (opcode :label 'set-location-to-min) + (opcode :izerop primary miss-label) + (opcode :move (operand :constant (index-value->index 2)) + location) + (opcode :go 'continue))) + (opcode :label 'hit-internal) + (opcode :move (operand :i1+ location) + location) + ; position for getting value + (opcode :move (emit-cache-ref cache location) + value) + (emit-lock-count-test initial-lock-count cache 'hit) + miss + (opcode :label 'hit) + hit))) + +(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value) + (let ((cache-line-size (compute-line-size (+ (length wrappers) + (if value + 1 + 0))))) + (with-lap-registers ((location index) + (primary index) + (cache vector) + (initial-lock-count t) + (next-location index) + (line-size index)) + ; Line size holds a constant that can + ; be folded in if there was a way to + ; add a constant to an index register + (flatten-lap (apply #'flatten-lap wrapper-moves) + (opcode :move (operand :constant cache-line-size) + line-size) + (opcode :move (operand :cvar 'cache) + cache) + (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label) + (opcode :move primary location) + (opcode :move location next-location) + (opcode :move (operand :cref cache 0) + initial-lock-count) + ; get the lock-count + (with-lap-registers ((size index)) + (flatten-lap (opcode :move (operand :cvar 'size) + size) + (opcode :label 'continue) + (opcode :move (operand :i+ location line-size) + next-location) + (emit-check-cache-line cache location wrappers 'hit) + (emit-adjust-location location next-location primary size + 'continue miss-label) + (opcode :label 'hit) + (and value (opcode :move (emit-cache-ref cache location) + value)) + (emit-lock-count-test initial-lock-count cache 'hit-internal) + miss + (opcode :label 'hit-internal) + hit)))))) + + +;;; Cache related lap code + + +(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code) + (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache"))) + (with-lap-registers ((cwrapper vector)) + (flatten-lap (opcode :move (emit-cache-ref cache location) + cwrapper) + (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache) + hit-code + (opcode :label exit-emit-check-1-wrapper-in-cache))))) + +(defun emit-check-cache-entry (cache location wrapper hit-label) + (with-lap-registers ((cwrapper vector)) + (flatten-lap (opcode :move (emit-cache-ref cache location) + cwrapper) + (opcode :eq cwrapper wrapper hit-label)))) + +(defun emit-check-cache-line (cache location wrappers hit-label) + (let ((checks (flatten-lap (gathering1 (flattening-lap) + (iterate ((wrapper (list-elements wrappers))) + (with-lap-registers ((cwrapper vector)) + (gather1 (flatten-lap (opcode :move + (emit-cache-ref + cache location) + cwrapper) + (opcode :neq cwrapper wrapper + + ' + exit-emit-check-cache-line + ) + (opcode :move (operand :i1+ + location) + location))))))))) + (flatten-lap checks (opcode :go hit-label) + (opcode :label 'exit-emit-check-cache-line)))) + +(defun emit-lock-count-test (initial-lock-count cache hit-label) + + ;; jumps to hit-label if cache-lock-count consistent, otherwise, continues + (with-lap-registers ((new-lock-count t)) + (flatten-lap (opcode :move (operand :cref cache 0) + new-lock-count) + ; get new cache-lock-count + (opcode :fix= new-lock-count initial-lock-count hit-label)))) + +(defun emit-adjust-location (location next-location primary size cont-label miss-label) + (flatten-lap (opcode :move next-location location) + (opcode :fix= location size 'at-end-of-cache) + (opcode :fix= location primary miss-label) + (opcode :go cont-label) + (opcode :label 'at-end-of-cache) + (opcode :fix= primary (operand :constant (index-value->index 1)) + miss-label) + (opcode :move (operand :constant (index-value->index 1)) + location) + (opcode :go cont-label))) diff --git a/clos/3.5/env.dfasl b/clos/3.5/env.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..a3ec34f955062d033e6e5b0fcf9564277bae9f2b GIT binary patch literal 9265 zcmeHNeQXrR72n-6*yilx{DCnS<7@~vA7L%qF(fvLPMQkiPY91s>QeeXj%!P1Vu_kTSb*3HLaqi4HZ>XRZ8f4 zGkYH#grt!o6$#7UnR)Zxyf-tyc{B6I(_Go0+b6n{JICUQ*tnS7H8HkpLfoDl7gNby z~UkQYa?r=aI?DnZf zu-om^jBa;W*MZ(08=Y)P#8YGI+bWHMW{1aP(TUhLF|;d|+7^9ijo7|c?AtXO6WcmF z+t!F}cXoAjcCBr1sqB>vAG0JY(mNif5*?x^HXPfz6>M*BZEppk&aRGiU9ESuR9=2A zbA+pSkb|Fc{5ZKx+Sw*fB*&ygY%-R>Uhc$-%)xY7Z#du%saha&nBT+C&peS{pa!I% z?CzI0Dm+0R zny=+5sZCdLGr|8w;`6po_2!K$u#nlwY;;*aMT~jj>oe0%eX49hD>R!`=5oOpxlBr{ zoPW(xG_5hDZBxe29?KhC2Ju?m)>;JE6b=vJ5vO*CC6FvC`&ehY-Lu~?UN0IV4J)H@W0R)@^8?5Qg&egog<`T2dU^J6?PC@ zm=)Zp1QcC$6MH-AyAP_$J-|8JcvnRcYlG#(xne}8k?J*xkqb^h;te%J~N_;=Q!@-w7D<7$2_?274B87 zk@~{3!r6w13;41n*NFpK<5`Z<&I%{`BlUBBFd_g(XfDk;8*yrm_ae1mk5)f23o5mG zt$H?6r@1ap&$vf4=jG{{un)Pbcf1{;e~{H`f!qzL^YX#R^AZQ2nEB%fty`85pvjpF zOo}ynoN8#$8bNl8w}0U;ixIZLL9??oaoq zBXmcoz!9}}d0Q26X3`Cb=+3R%qGEhhyxNCW@f?q92c2YCSHPL#Z<_bpaK>LI)tI~p zSaAdgB<7(ca9}~Ume6l43hJs~)`uiuaLaD5BKcKxpAMA#0cpbIy9lndr2q7#ai?abE`C#V)W zk>wDK1+`RIa&sBr!nq-rLG9;Q21L3F{d5C-k+dNY*O2xrAWiN>>JA3aBCwLRPjgB$-&G2H49WN+o*_R3AT-LP<5 z{Keo_j|lj3yc_?sVz@0vWzXf{_Q*}R-LP<5^2Olh`V!$bQ4F^ws4Sj?TR-IBD7VuV~+a>b9g)A{=!r&v{Ym- zi}dWsoyE$7+4~-{zl4H#IOe9m#{y{Fe`FfY>FJ@z_Z_rgO7uWK$7q8`SM_*Jdbhav zJmdD-p$Tqors0a>0ajvhIICIO>M;{8Z{|twkJOn)FQ3(MQhl`h%rXV(9g;-c5ggXhfi|Dmj3hD~PW)!$zv6*9SwOs)jR1-)t@cLiUH1SZMCJauFe0}^G7ru7m#H*YAD#vc4C zWX8m8@$uO3gqYej78@TD#iRyYS-3ci55}B zMk!ewgO+34Vxth}hVb-+7*BOU3r0~Zz&{>CmEx2~+!>oNliN~aYAiM!k0#;|L;M=U zE%#<}^96JSr1oz<7L=-!k z+zy(6ohu5|K>+C^nRsbwQaI2*A!o&J6xGK1Lfjk0&`6hlyv)^Ha zRAFHuE1;f7!KaWFh*AdPVbEK~^nT`Q0P$3ve<62?PJZYXXPxqZMF|0Bj*gNCqBaQ<9-C%tEdgzfE!BhmQrr9+xyZ=#WE@}A|G z`%{_6>p$wvl9(Ior)t3t^Ni*|!I>5OS1GM0KoiQA5NIpZE&-Tle&;)?T-lJ1a_76$ zob6JN)s>=#(CXj&j|Q%6#ebDK(lyLsmL+UOMx9^I(^r`5dOc83FwfS^<=h^Cij1Ht($eE3cP zXIVg31|XzLW2Nn666rOR9G?8|wP7nsN) zGU=wor|)EJ)#MI4nG)`YU6e&Y``A{^qCq8Sjs$LGs);(a?a4$UxjR1kpqNS|!AqFY zN$^`h8;(xIlcORyq?DQ5J=%p<{xy>ZFYxJdU34`Sh*PQOGwHVLN@XKe#exSiX%T(v zHQW*N#ZyKXJhVNPE`J~x(!Jq8e>-zfFJdRRgQEz?c3gTgmattS30O*Ob;J_FA4V?z zBw>plkDvH9?(%&{U0KBTsJQ4#-PF9j69qr6!QBH(0SCcPk!KbuA-*ON&H0L%dad-@hKC&j}uI ztT2F6^3*^`M4u0jlC%tY(V{W8N;~eNI5TH@ZFSEc`7dBx3&OWV3?2I75z~+5A?WRylcH^nfZoU3s*Fk9$I#Sern0_CdUsNuG zIzgpDAz=}V4ZX{fpR?p4nsASkjtJ?HNC&*0@{QCxP`lYPD9sMS_G1nUPR@o$SLf<0 z-i-{1Z9;!wMGwfjSX{@$CdFRHgeu%)Xv8&$kGW+*T?06)e!hZs;1nQ@o^DI6;}N5B z&w|PdsxkLa#cpiep4iBxpYC9X&^a@9yKt;v*oXKNs<4GW)i3a;nVa>q1L_&NIna-f zegh14;Gz3`48eVxgJm=aMC3QqsJ&xz?b1V9^?uE%RlA03VXuMVSio$g-`5uK7D{R0 z`mha9iamj@&TG~cBa}&(GLRZ&_|mjM_T(SW3?NkMieDRmpf!CkBz6^Pez{*Mh%~nW zZBgN1Kpnh10q%)?HA&RNS}lFRKY-6xHNaXMl)+_YpYg!&qCv!7N)7&{Z3E%&A)|MZ zDsZ&G?Fa`7nURK<2zXbhfFLY<7D#(G-AfBDAUSsZ6>&I}B|A-h#!* z`{y+ygxNGTQucF8VBF~5B~e#I>_P+O{?oHGc>_E|3pGZDH+Htz zWOmkJi%#BL(SxFqXfvqJ9SXB+6sKpzjRP=nz z(EDeh9><%`JP)~2tNRQS)v<4k!Es)KcarQ=HZ1oeTwRZFjCO&3ywDH$wd{N!*1V9N zT5zq)m-}V6u1R<)%A{+uMI|tx>RJH*Nre;2(S}W7Eu@sdh*lP;liKjyi2vHroL9&u zFkhw!r1wvBuC-_@suT;_fx*jqA`zEKFdPC86tqLWhK`P9r1eiHC3R3y2Ac-DTcZk$ zvKKT)?ChBFK10n%{4H4&{}v_#--bCh*B^r2O@(WRhg&VUrs=*tCQUFki-((;^550LB(f-Nh%l`%W`eda5 literal 0 HcmV?d00001 diff --git a/clos/3.5/env.lisp b/clos/3.5/env.lisp new file mode 100644 index 00000000..15bf87f2 --- /dev/null +++ b/clos/3.5/env.lisp @@ -0,0 +1,200 @@ +;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; +;;; Basic environmental stuff. +;;; + +(in-package 'clos) + + + +;;; +;;; +;;; + +(defgeneric describe-object (object stream)) + + +(defmethod describe-object ((object standard-object) stream) + (let* ((class (class-of object)) + (slotds (slots-to-inspect class object)) + (max-slot-name-length 0) + (instance-slotds ()) + (class-slotds ()) + (other-slotds ())) + (flet ((adjust-slot-name-length (name) + (setq max-slot-name-length + (max max-slot-name-length + (length (the string (symbol-name name)))))) + (describe-slot (name value &optional (allocation () alloc-p)) + (if alloc-p + (format stream + "~% ~A ~S ~VT ~S" + name allocation (+ max-slot-name-length 7) value) + (format stream + "~% ~A~VT ~S" + name max-slot-name-length value)))) + ;; Figure out a good width for the slot-name column. + (dolist (slotd slotds) + (adjust-slot-name-length (slotd-name slotd)) + (case (slotd-allocation slotd) + (:instance (push slotd instance-slotds)) + (:class (push slotd class-slotds)) + (otherwise (push slotd other-slotds)))) + (setq max-slot-name-length (min (+ max-slot-name-length 3) 30)) + (format stream "~%~S is an instance of class ~S:" object class) + + (when instance-slotds + (format stream "~% The following slots have :INSTANCE allocation:") + (dolist (slotd (nreverse instance-slotds)) + (describe-slot (slotd-name slotd) + (slot-value-or-default object (slotd-name slotd))))) + + (when class-slotds + (format stream "~% The following slots have :CLASS allocation:") + (dolist (slotd (nreverse class-slotds)) + (describe-slot (slotd-name slotd) + (slot-value-or-default object (slotd-name slotd))))) + + (when other-slotds + (format stream "~% The following slots have allocation as shown:") + (dolist (slotd (nreverse other-slotds)) + (describe-slot (slotd-name slotd) + (slot-value-or-default object (slotd-name slotd)) + (slotd-allocation slotd)))) + (values)))) + +(defmethod slots-to-inspect ((class std-class) (object standard-object)) + (class-slots class)) + +;;; +;;; +;;; +(defmethod describe-object ((class class) stream) + (flet ((pretty-class (c) (or (class-name c) c))) + (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) + (ft "~&~S is a class, it is an instance of ~S.~%" + class (pretty-class (class-of class))) + (let ((name (class-name class))) + (if name + (if (eq class (find-class name nil)) + (ft "Its proper name is ~S.~%" name) + (ft "Its name is ~S, but this is not a proper name.~%" name)) + (ft "It has no name (the name is NIL).~%"))) + (ft "The direct superclasses are: ~:S, and the direct~%~ + subclasses are: ~:S. The class precedence list is:~%~S~%~ + There are ~D methods specialized for this class." + (mapcar #'pretty-class (class-direct-superclasses class)) + (mapcar #'pretty-class (class-direct-subclasses class)) + (mapcar #'pretty-class (class-precedence-list class)) + (length (specializer-methods class)))))) + + + +;;; +;;; trace-method and untrace-method accept method specs as arguments. A +;;; method-spec should be a list like: +;;; ( qualifiers* (specializers*)) +;;; where should be either a symbol or a list +;;; of (SETF ). +;;; +;;; For example, to trace the method defined by: +;;; +;;; (defmethod foo ((x spaceship)) 'ss) +;;; +;;; You should say: +;;; +;;; (trace-method '(foo (spaceship))) +;;; +;;; You can also provide a method object in the place of the method +;;; spec, in which case that method object will be traced. +;;; +;;; For untrace-method, if an argument is given, that method is untraced. +;;; If no argument is given, all traced methods are untraced. +;;; +(defclass traced-method (method) + ((method :initarg :method) + (function :initarg :function + :reader method-function) + (generic-function :initform nil + :accessor method-generic-function))) + +(defmethod method-lambda-list ((m traced-method)) + (with-slots (method) m (method-lambda-list method))) + +(defmethod method-specializers ((m traced-method)) + (with-slots (method) m (method-specializers method))) + +(defmethod method-qualifiers ((m traced-method)) + (with-slots (method) m (method-qualifiers method))) + +(defmethod method-qualifiers ((m traced-method)) + (with-slots (method) m (method-qualifiers method))) + +(defmethod accessor-method-slot-name ((m traced-method)) + (with-slots (method) m (accessor-method-slot-name method))) + +(defvar *traced-methods* ()) + +(defun trace-method (spec &rest options) + (multiple-value-bind (gf omethod name) + (parse-method-or-spec spec) + (let* ((tfunction (trace-method-internal (method-function omethod) + name + options)) + (tmethod (make-instance 'traced-method + :method omethod + :function tfunction))) + (remove-method gf omethod) + (add-method gf tmethod) + (pushnew tmethod *traced-methods*) + tmethod))) + +(defun untrace-method (&optional spec) + (flet ((untrace-1 (m) + (let ((gf (method-generic-function m))) + (when gf + (remove-method gf m) + (add-method gf (slot-value m 'method)) + (setq *traced-methods* (remove m *traced-methods*)))))) + (if (not (null spec)) + (multiple-value-bind (gf method) + (parse-method-or-spec spec) + (declare (ignore gf)) + (if (memq method *traced-methods*) + (untrace-1 method) + (error "~S is not a traced method?" method))) + (dolist (m *traced-methods*) (untrace-1 m))))) + +(defun trace-method-internal (ofunction name options) + (eval `(untrace ,name)) + (setf (symbol-function name) ofunction) + (eval `(trace ,name ,@options)) + (symbol-function name)) + + + + +;(defun compile-method (spec) +; (multiple-value-bind (gf method name) +; (parse-method-or-spec spec) +; (declare (ignore gf)) +; (compile name (method-function method)) +; (setf (method-function method) (symbol-function name)))) + +(defmacro undefmethod (&rest args) + #+(or (not :lucid) :lcl3.0) + (declare (arglist name {method-qualifier}* specializers)) + `(undefmethod-1 ',args)) + +(defun undefmethod-1 (args) + (multiple-value-bind (gf method) + (parse-method-or-spec args) + (when (and gf method) + (remove-method gf method) + method))) + diff --git a/clos/3.5/fin.dfasl b/clos/3.5/fin.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..0e6be034c4883eb79f5fc4391d81657e346d2fed GIT binary patch literal 7209 zcmb_hZEREL6~6b{aS~!D4he*WCR|9MgXIPS?OGU%eB)f>>-dZ7Ye)*3Fv+DhI1Y*( zXhqjq>_bBG)~2k?FY7w3(tfR4Dbu8cwu+`{Ke9>tklIO`wCzWwsedL_>W}`a*g5CD z{)n3tn2Nyn-uLsI=bZDL^S&$zEmQum?4O^zoXJ`X^88}q@?t^0Fux$@=NA`dEcpVo z%hx6nlixa?%v%fjvDCt1?y8lYNsr|(JwLmUxnhmY&d)5)S-C=fY%!O4ZY-P0Umlyu z&gaKw78e$vee6OeH-fESAN3^amYrF!QUz;PHW#h@Z0h-8`S6o+XfbEWqeqX94$GrQ zjy-wk*x^GXo`9MNb4e;w0t*?M@q|2K%~*5iLH5Ik4j-aPqfZ?>1e5Onw0ui&&kOLU z6@R=!x#S&{3-gzitaZi8qLy>mQGU795=chsw(^#oTCn6o+L9liO%+l~K09B?KQ3QQXJ*p!g~i-VDw|E6 z2kU2Y`9dl;W98*^>WT%90h3Y%k1W&VISb~_WK;Qk{Uima%%&D*?XHec&O9AVb`;7t9n8Z9Q7&+{ zN`SCE)8*2>WbRUK{%UTW#Vc+iqc$mQ$5C z3{Rzs`_)V#4FnEExsWfsxc5a2Ec;L1DikugXXQ*`eUw(_Dj4sD%zSQyEYY3qXyiAf zGUb6(h9sFZG$o-wqtz+X&RRtW;IVr{EbAvRx7Z3E$2!?jltes0mZw{B38! zYBB#f{G04#yIdf=n;nNFK#|a#h--db4YT6})dcxxrskk^!B34@iAH#u5RbYnL9Nv+ z(F;N*Oe5)s9APUEkLgiUGioq8#@O(F^s2plBmzC5K|;VMQucY9zq- zs$*S8p=TTEsZGVzXkFJ65dNOJ9?dui`*bu&!rX(fg15S$5*rU`ese1ei7W&u349+Y zBP0NX?m#jep0YLQfgToaF5lb%)1`QVg<$dSh&riJV4$(=kzg)Z1jxPi4b)T7tyqKv z-XN2LYoCNEosAuFSnQ<|;;JUYW(@`-Ii$&ozb{bMmi|==6O`!eL@DOd<2gY!5 zBn43d_{gpHkb5-xeO(B^A`^A4fd#<;@Hf;0dLpPGvn3R?aV&1?5r{?u$n2$3S8Yf| z)&y2Nb?sHT9X%}MCff=i|4ER4kc1i#f76^^POp3?wVYWwhcfKCr~fDv{FAU60;x_q z1nK&H_*2blkgoPkYSREp#jb+X1(>OhAT`c5bAt%}Z z*}JVG9XvT(`_=|rsPG!v@Cv-t?b2+I7R2fT9YDLl#yQ2xT~Xjki){6g0xFSL_rR(O zOI?Gd>Z*XsQsq)>R6DJlQo~72Y+)zCJpdT2K|5&;`k{4@ox6}i!0uH70fA6hp8do& zFtZnV0mne`c?w)YlU(eYh?=0jZkV8k!B;RONY(=veSZ*ykAJ<}$JLgm?rsmR4NQ?6 zvmiC50rWKJfOX~f)&q~`6&$-*Xa@^z0nEMrSR}4vLbNHLD>FcPkgxx&Q7>3|ld9cL z>X@(l&Vo)Ow)9jjk5tMPbnfN=uYnw$Tu3)PZixJg>%NO9AEI^RvT>B)c%qVXmeWCk zeI=;Vb5+0eXCQYy2eCk;-!0hfHZU(sRYN$30qWgohz*lrMR4ZsX4l-H+%_W0M&z8# zCy0B&6PjDl#)#7XY-;ZOYznLB2PlIxFdA(u0NE8qk*W`IH^&CuVf%*iA+6pLw(+36 z&HZC3?ag>AKEPn{y08$Zkk!yRZg8aKSqnlTo5@)l1HdEFh>Fu}D z8b3okzD(c2{-xme`CDJL7#M;x`7wxQJsQ@d+Qvn09N?&g_AncE?WIj$-^m}{AY*%# z`W46tCLW^TL`4B;w9zo;qQ?r41Tfrd^!*AL7!m(#g?n#b3?dCIrLV&w>5aFAU#S$V z@K#od3hsWpLJ-TU%@otObQ)B=crV*=4p!rb@DJY6e;k_pgfDgX>B)C5z8499_Q}uh z$iYZf`rBV3q0c@k>-4%N6w}?pYUI-U@7?*Qk8ep)<+VS~ORK>DZ{I)D@I6V6!wHrj z%zS(vccfQ9!aA}=k}8)RK(wu>^dH%7e5~@vFVWT%fTp2F;xV)bbK`)Y5LB!9dJ_iq zV?Z|ssS=0=HFW|HsW|S3Fs}Ct#>B{Jwde^m=mSUco*g7t#q!6mg~JIv&b3zfA>I^X zp0AM*Hx&NhE^x!iza-r9_vI2C#N?>p8x+e4i1h2|sd;0QaqAJh|-A^bhiOUk{~L60{v zmA0Kdp_$`qLIYJDz+R$s9Dc-ZWGw{k29Bw_H6Sv2=mYi;kk5k-*rTvZ^<>S4+nD0q z&PMRWymQ0Efo`k-)SPqP=bZB)9+~0Zg9l;l;Jp6}mQbLox}b2YS__npP~#s!#z?QE z@1@@fzMdFS3Ic zJ9>`H{P#2T_y^BfZ}H6YrV5jq&l>SCI>$A1jyyWYWYsxn(!VyXBnPXN2 z1viGQh6VFOyM9m2_16gpOKt4!?SXaUDh~cBSNOhtCq$(%(oye5s>2yR0oRux=VLYX zIR-UK;ZTTHb3(?C-JfO`!y*J;hFN4Rj2dbv+tVJ2ys(*4-4Xt?SUTWgtt5 z4nj<9Z$xb8Mu^pJe{TuhHOzDyE*q<@kB*h?HXn*~74iSz(!Vh-w#1tv)4dLvs(u`s ztsI-j8nM~Xo9xSQ@TSd?k-rpVy1x{UA$d2&WxdDPx^Yxwj>>^XRQkX0{DW~OzCbBp zS*0K|sPbOn=h-zW+d-}8P$YVzAF5{QzW;+uA7H79mCz$j(QyjgRN@h${Q&BsB%^dV zg_}yGD{({;>xlocal>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49 + +;;;. Copyright (c) 1991 by Venue + + + + +(in-package "CLOS") + +;;; Shadow, Export, Require, Use-package, and Import forms should follow here + + + + + + +;; + + + +;;; FUNCALLABLE INSTANCES + + + +;; + + + +;;; The first part of the file contains the implementation dependent code to implement funcallable +;;; instances. Each implementation must provide the following functions and macros: +;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () should create and return a new funcallable instance. The +;;; funcallable-instance-data slots must be initialized to NIL. This is called by +;;; allocate-funcallable-instance and by the bootstrapping code. FUNCALLABLE-INSTANCE-P (x) the +;;; obvious predicate. This should be an INLINE function. it must be funcallable, but it would be +;;; nice if it compiled open. SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) change the fin so +;;; that when it is funcalled, the new-value function is called. Note that it is legal for +;;; new-value to be copied before it is installed in the fin, specifically there is no accessor for +;;; a FIN's function so this function does not have to preserve the actual new value. The new-value +;;; argument can be any funcallable thing, a closure, lambda compiled code etc. This function must +;;; coerce those values if necessary. NOTE: new-value is almost always a compiled closure. This is +;;; the important case to optimize. FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) should return the +;;; value of the data named data-name in the fin. data-name is one of the symbols in the list which +;;; is the value of funcallable-instance-data. Since data-name is almost always a quoted symbol and +;;; funcallable-instance-data is a constant, it is possible (and worthwhile) to optimize the +;;; computation of data-name's offset in the data part of the fin. This must be SETF'able. + + +(defconstant funcallable-instance-data '(wrapper slots) + "These are the 'data-slots' which funcallable instances have so that + the meta-class funcallable-standard-class can store class, and static + slots in them.") + +(defmacro funcallable-instance-data-position (data) + (if (and (consp data) + (eq (car data) + 'quote) + (boundp 'funcallable-instance-data)) + (or (position (cadr data) + funcallable-instance-data :test #'eq) + (progn (warn "Unknown funcallable-instance data: ~S." (cadr data)) + `(error "Unknown funcallable-instance data: ~S." ',(cadr data)))) + `(position ,data funcallable-instance-data :test #'eq))) + +(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~ + setting its funcallable-instance-function.")) + + +;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP. The environment +;;; is represented as a block. There is space in the top 8 bits of the pointers to the CCODE and +;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when +;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use +;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the +;;; fields of compiled-closures and which defines the closure-overlay record. That code is there +;;; because there are some clients of it in that file. + + + +;; Don't be fooled. We actually allocate one bigger than this to have a place to store the +;; backpointer to the fin. -smL + + +(defconstant funcallable-instance-closure-size 15) + +(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) + t))) + + +;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL + + +(defstruct fin-env-pointer (pointer nil :type il:fullxpointer)) + +(defun fin-env-fin (fin-env) + (fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2)))) + +(defun |set fin-env-fin| (fin-env new-value) + (il:\\rplptr fin-env (* funcallable-instance-closure-size 2) + (make-fin-env-pointer :pointer new-value)) + new-value) + +(defsetf fin-env-fin |set fin-env-fin|) + + +;; The finalization function that will clean up the backpointer from the fin-env to the fin. This +;; needs to be careful to not cons at all. This depends on there being no other finalization +;; function on compiled-closures, since there is only one finalization function per datatype. Too +;; bad. -smL + + +(defun finalize-fin (fin) + + ;; This could use the fn funcallable-instance-p, but if we get here we know that this is a + ;; closure, so we can skip that test. + (when (il:fetch (closure-overlay funcallable-instance-p) + il:of fin) + (let ((env (il:fetch (il:compiled-closure il:environment) + il:of fin))) + (when env + (setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2))) + (when (typep env 'fin-env-pointer) + (setf (fin-env-pointer-pointer env) + nil))))) + nil) + +(eval-when (load) + + ;; Install the above finalization function. + (when (fboundp 'finalize-fin) + (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin))) + +(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+ + funcallable-instance-closure-size + ) + t)) + (fin (il:make-compiled-closure nil env))) + (setf (fin-env-fin env) + fin) + (il:replace (closure-overlay funcallable-instance-p) + il:of fin il:with 't) + (set-funcallable-instance-function + fin + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (called-fin-without-function))) + fin)) + +(xcl:definline funcallable-instance-p (x) + (and (typep x 'il:compiled-closure) + (il:fetch (closure-overlay funcallable-instance-p) + il:of x))) + +(defun set-funcallable-instance-function (fin new) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + ((not (functionp new)) + (error "~S is not a function." new)) + ((typep new 'il:compiled-closure) + (let* ((fin-env (il:fetch (il:compiled-closure il:environment) + il:of fin)) + (new-env (il:fetch (il:compiled-closure il:environment) + il:of new)) + (new-env-size (if new-env + (il:\\#blockdatacells new-env) + 0)) + (fin-env-size (- funcallable-instance-closure-size (length + funcallable-instance-data + )))) + (cond ((and new-env (<= new-env-size fin-env-size)) + (dotimes (i fin-env-size) + (il:\\rplptr fin-env (* i 2) + (if (< i new-env-size) + (il:\\getbaseptr new-env (* i 2)) + nil))) + (setf (compiled-closure-fnheader fin) + (compiled-closure-fnheader new))) + (t (set-funcallable-instance-function fin (make-trampoline new)))))) + (t (set-funcallable-instance-function fin (make-trampoline new))))) + +(defun make-trampoline (function) + #'(lambda (&rest args) + (apply function args))) + +(defmacro funcallable-instance-data-1 (fin data) + `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) + il:of + ,fin) + (* (- funcallable-instance-closure-size (funcallable-instance-data-position + ,data) + 1) + ; Reserve last element to point back to + ; actual FIN! + 2))) + +(defsetf funcallable-instance-data-1 (fin data) + (new-value) + `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) + il:of + ,fin) + (* (- funcallable-instance-closure-size (funcallable-instance-data-position + ,data) + 1) + 2) + ,new-value)) + + ; end of #+Xerox + + + +;;; + + +(defmacro fsc-instance-p (fin) + `(funcallable-instance-p ,fin)) + +(defmacro fsc-instance-class (fin) + `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper))) + +(defmacro fsc-instance-wrapper (fin) + `(funcallable-instance-data-1 ,fin 'wrapper)) + +(defmacro fsc-instance-slots (fin) + `(funcallable-instance-data-1 ,fin 'slots)) + +(defun allocate-funcallable-instance (wrapper number-of-static-slots) + (let ((fin (allocate-funcallable-instance-1)) + (slots (%allocate-static-slot-storage--class number-of-static-slots))) + (setf (fsc-instance-wrapper fin) + wrapper + (fsc-instance-slots fin) + slots) + fin)) diff --git a/clos/3.5/fixup.dfasl b/clos/3.5/fixup.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..400b0fedee6e41bb08a4f28a1cc9f10fda7d438d GIT binary patch literal 547 zcmZ9H(QeZ)6ozdT)@<6K?1CF^d_6T&TgG4=ipU&ygr-guJJ4O0)P+jv5+%(5AtW9k z5{ya6Mer;WWGYdyysQT7q`o7E# zlWCEiw)faS!f`G}b1_D*#Q0Ja)?Zc9PSU-CQHO@Vsbx-@{S8f`RBGcyraBGI?b^gw>C zj9x@BcYP{v;Aglczf?OeH3J*>?Q;Skl+`VL7EqG#uA!mdZ*+~7Y7NM5)$YNW?{kxJ zo09{1{dZqh_d5R>761aUfGZ!Uzz02dXc9a0F3fX6N$6s8lZ7qnu&!1N><@ z+HR_qXcXzw;L zzw>d=Y%z(ltPAqWjnxIOwkE9H+*rN2AXH2=6SB!!)UNp4wxUMT6o4*|`Ev9Sy1gtxC;K7Zx%+aq0B z$(wD_-Q8}Nye`yF9;he zt7)(Ham^#P-XI(PU+al%(U1$8Y4~^1CTjD)sCQ^a+LGj)G^sEM`Slnvi`n+StanZ- zh4jJst#AwO@@k8}d{y&ezxYdDtb=H7)RumpTipNGOCDSOE*f&x2TMQ0;*b}s?%jXw zBXW=e{H{5C&>ZfGs&;~$5vQn5`jKRCf@9d*kKhL*0PWw6`}Hk@K;M4aw1_#9 z?$^5uic?6-rcqMtf?~shY-W_!gGGkxO^VyMIn#G z*ICofBbM+OF=L?wsO}hv<|Bc+lb~)eP`8~RPAaQz>J(zB)|2Q-t!x6cwgFMV4U30B zVjB;FlGg(zJ1>gd*21Rii-@Az-*oSaEZP*^RMG{YgGU0zL#UUyYr1F_6o!GgM?=lH zZ!}}6yrm}HSvJXV2(01HW(kn9n1`4EMoW?{gi8pZQ$9A?9s+p6EE*Y$5kQjFfO}t|%vL@+xm}W?a12LeaiFVL^4|Q39pT_MhWFg1kVSJH6hZ%>nDDHn< z=dT&Su{=tc0gNYf)65mErmial588;C~Nj6HS@2?_31Kpe|zM&?C`M%))0 zgn3+o={1aW}3gF=vO zTLMfFLn6dbTwMG&+#&FSB2G|r6jT{K zP+9aI9Y2(`+?3lDhm*`Ty3)u2)+WaM6%NjoaVp7njtZnC^-u?r*u93t@%#>jPf(#)orN zVPRQlbvOwys2Duy8H%<--)D$4l!ZST{-C8`NvTmvk`6#S!8OUyUzv0$gkZ7#npLpX zqLCZj#(dMf^u>>E3ZyiU%VJ{#7-v&3|VbB0vF&3Hp`@m%C?+V(} zSTyqusLs*wrMFK_J(~@3Rg8o%x#CYx62ZPg+zWk%Vq}td9kKLa9Z2b=qrV{f?~85R z1K`g77W*5360Gkz#`+_gox=irjyFch#`sep=q4%k0Ni=`3W&Al$XWIVGHF}tS1Z$w=f1E|N0LsCSQ(xtb(+}?$ zZfa&vXTQIHXDSuuD91w^Kv4gKN3FTqdFoVNl5I1{$a-HiRg98mn+Ex|!4t7>fuBD5 z3KmQ&tt%x3I!#Do%-_N@9-jFCPg_`g7hfO2*AqnGHa@d~&&=b`%J|F_KBIvApl(W; zBP;ny2+KIMI+I2RoEv(U15h6cZD=cqLehXSr<**|$O*bIx=4Kzvf$U>fX<5=EIj=Z zupny51X9YO9S3~Y2^jY|N+FvLSqs0�Fp^0e!Y13<$Q`W3I6`UU_1 literal 0 HcmV?d00001 diff --git a/clos/3.5/fngen.lisp b/clos/3.5/fngen.lisp new file mode 100644 index 00000000..09e6d0da --- /dev/null +++ b/clos/3.5/fngen.lisp @@ -0,0 +1,172 @@ +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + +;;;. Copyright (c) 1991 by Venue + +(in-package "CLOS") + + + +;;; GET-FUNCTION is the main user interface to this code. If it is called with a lambda expression +;;; only, it will return a corresponding function. The optional constant-converter argument, can be +;;; a function which will be called to convert each constant appearing in the lambda to whatever +;;; value should appear in the function. Whether the returned function is actually compiled depends +;;; on whether the compiler is present (see COMPILE-LAMBDA) and whether this shape of code was +;;; precompiled. + + +(defun get-function (lambda &optional (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) + (apply (get-function-generator lambda test-converter code-converter) + (compute-constants lambda constant-converter))) + +(defun default-test-converter (form) + (if (not (constantp form)) + form + '.constant.)) + +(defun default-code-converter (form) + (if (not (constantp form)) + form + (let ((gensym (gensym))) + (values gensym (list gensym))))) + +(defun default-constant-converter (form) + (and (constantp form) + (list (if (and (consp form) + (eq (car form) + 'quote)) + ; This had better + (cadr form) + ; do the same as + form)))) + + ; EVAL would have. + + + +;;; *fgens* is a list of all the function generators we have so far. Each element is a FGEN +;;; structure as implemented below. Don't ever touch this list by hand, use STORE-FGEN. + + +(defvar *fgens* nil) + +(defun store-fgen (fgen) + (setq *fgens* (nconc *fgens* (list fgen)))) + +(defun lookup-fgen (test) + (find test (the list *fgens*) + :key + #'fgen-test :test #'equal)) + +(defun make-fgen (test gensyms generator generator-lambda system) + (let ((new (make-array 6))) + (setf (svref new 0) + test + (svref new 1) + gensyms + (svref new 2) + generator + (svref new 3) + generator-lambda + (svref new 4) + system) + new)) + +(defun fgen-test (fgen) + (svref fgen 0)) + +(defun fgen-gensyms (fgen) + (svref fgen 1)) + +(defun fgen-generator (fgen) + (svref fgen 2)) + +(defun fgen-generator-lambda (fgen) + (svref fgen 3)) + +(defun fgen-system (fgen) + (svref fgen 4)) + +(defun get-function-generator (lambda test-converter code-converter) + (let* ((test (compute-test lambda test-converter)) + (fgen (lookup-fgen test))) + (if fgen + (fgen-generator fgen) + (get-new-function-generator lambda test code-converter)))) + +(defun get-new-function-generator (lambda test code-converter) + (multiple-value-bind (gensyms generator-lambda) + (get-new-function-generator-internal lambda code-converter) + (let* ((generator (compile-lambda generator-lambda)) + (fgen (make-fgen test gensyms generator generator-lambda nil))) + (store-fgen fgen) + generator))) + +(defun get-new-function-generator-internal (lambda code-converter) + (multiple-value-bind (code gensyms) + (compute-code lambda code-converter) + (values gensyms `(lambda ,gensyms #',code)))) + +(defun compute-test (lambda test-converter) + (walk-form lambda nil #'(lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((converted (funcall test-converter f))) + (values converted (neq converted f))))))) + +(defun compute-code (lambda code-converter) + (let ((gensyms nil)) + (values (walk-form lambda nil #'(lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (multiple-value-bind + (converted gens) + (funcall code-converter f) + (when gens + (setq gensyms (append gensyms gens))) + (values converted (neq converted f)))))) + gensyms))) + +(defun compute-constants (lambda constant-converter) + (macrolet ((appending nil `(let ((result nil)) + (values #'(lambda (value) + (setq result (append result value))) + #'(lambda nil result))))) + (gathering1 (appending) + (walk-form lambda nil #'(lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((consts (funcall constant-converter f)) + ) + (if consts + (progn (gather1 consts) + (values f t)) + f)))))))) + + +;;; + + +(defmacro + precompile-function-generators + (&optional system) + (make-top-level-form + `(precompile-function-generators ,system) + '(load) + `(progn ,@(gathering1 (collecting) + (dolist (fgen *fgens*) + (when (or (null (fgen-system fgen)) + (eq (fgen-system fgen) + system)) + (gather1 `(load-function-generator ',(fgen-test fgen) + ',(fgen-gensyms fgen) + #',(fgen-generator-lambda fgen) + ',(fgen-generator-lambda fgen) + ',system)))))))) + +(defun load-function-generator (test gensyms generator generator-lambda system) + (store-fgen (make-fgen test gensyms generator generator-lambda system))) diff --git a/clos/3.5/fsc.dfasl b/clos/3.5/fsc.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..e3b6de852a9674e57cbe258ad671bbbdeb9215cf GIT binary patch literal 2139 zcmcgtL2MgE6rFWQleN2v15uC?OjaPuB@=a{lr{mmOn2Am%IjTgc1@BVkX(C%Eu1*A zlU4{J5E2(;iKbD}4pNUGapVFQq)NSUH= z86S}G4b#=l_V#YG6?OFX{@(8Xp1#%Y=-u{yrxxj3@Lm7Z3W}e-SLsHbZob;t-?aww@6bqr3698asr{C-2il zOL*`7U)a8o|42!*G5Z{qPer2>Qy2f`L>D_M6f|HATf7qA?oGHpv#4bkN_KeFx8j4o z4;asgG%VzSTz(Si&qX>A>9<9C2E(sG`YgK2T$f#OZ5o8kvlzFi>9QaYDuQMJG*@Cp zo33*wv^kYL^mrO1Y6?)3gLDZ=BIGZTK@EQn%5a-mCzK%%g@)k!GUr#wnF4LT$wHet z9@aN)S@su+yaSMl0q;;Yxg|?{4e>Y4tF~FBL8UBdSpuV`Un;ZEx#GA^xG9T%CA7N8 zd1FrWoHg!&MnLOUxmXCN}U&RH4B1~Elw6WB}x z&c-+!9JRStb^Cg~syBD^r&*nXQ#XcZs={sXJU&dtz0pK`+*6UAdaPtCDWIHB9123~ zM3e$uEPi2)IAE^=W>!v#=TpBhoP@-4p=JS~NkHFg zp<*wm3y#NJ=Ne8c429DlSnT+egdYPeS{ArH-0W}h;fTn=g*tkU+d&B6amRyPz9!Eg z`4PG?DaWRz{(R8LHt~8mZR=1qHFRdA5SYgeP*P&C&wE$S0!D=@ayNlxEV&?`q52bz z#eV>p!&5s;4czm`Ffbxld;x4PgYqZ5A>?vGF#iGwrvE`Ou$qup5{l#!rtzI#7B3UW fwejXmjw{-FBsea=%jJ8)yMnI?J}3Bh;nC3}VM9Dd literal 0 HcmV?d00001 diff --git a/clos/3.5/fsc.lisp b/clos/3.5/fsc.lisp new file mode 100644 index 00000000..a2670af9 --- /dev/null +++ b/clos/3.5/fsc.lisp @@ -0,0 +1,72 @@ +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + +;;;. Copyright (c) 1991 by Venue + + +(in-package "CLOS") + + +;;; This file contains the +;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass. Much of the implementation of this +;;; metaclass is actually defined on the class STD-CLASS. What appears in this file is a modest +;;; number of simple methods related to the low-level differences in the implementation of standard +;;; and funcallable-standard instances. As it happens, none of these differences are the ones +;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all +;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class +;;; metaclass. + + +(defmethod wrapper-fetcher ((class funcallable-standard-class)) + 'fsc-instance-wrapper) + +(defmethod slots-fetcher ((class funcallable-standard-class)) + 'fsc-instance-slots) + +(defmethod raw-instance-allocator ((class funcallable-standard-class)) + 'allocate-funcallable-instance-1) + + +;;; + + +(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class) + (class standard-class)) + (null (wrapper-instance-slots-layout (class-wrapper class)))) + +(defmethod allocate-instance ((class funcallable-standard-class) + &rest initargs) + (declare (ignore initargs)) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((class-wrapper (class-wrapper class))) + (allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class)))) + +(defmethod make-reader-method-function ((class funcallable-standard-class) + slot-name) + (make-std-reader-method-function slot-name)) + +(defmethod make-writer-method-function ((class funcallable-standard-class) + slot-name) + (make-std-writer-method-function slot-name)) + + ; See the comment about + ; reader-function--std and + ; writer-function--sdt. + ; (define-function-template + ; reader-function--fsc () '(slot-name) + ; `(function (lambda (instance) + ; (slot-value-using-class + ; (wrapper-class (get-wrapper + ; instance)) instance slot-name)))) + ; (define-function-template + ; writer-function--fsc () '(slot-name) + ; `(function (lambda (nv instance) + ; (setf (slot-value-using-class + ; (wrapper-class (get-wrapper + ; instance)) instance slot-name) nv)))) + ; (eval-when (load) + ; (pre-make-templated-function-constructor + ; reader-function--fsc) + ; (pre-make-templated-function-constructor + ; writer-function--fsc)) + diff --git a/clos/3.5/init.dfasl b/clos/3.5/init.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..6676e1e1e5ea7102d7c309638378c4ed3f623488 GIT binary patch literal 4963 zcmb_gU2GHC6`q+mP8{N3NH(|*Kki24Z!sZR0)?enPwX)>@%U#wc1ZY98xq49oCM{E z6|K60ExTK_UX=h{eA=#7MJl^354A!c;v`Edbt{#JeW_gwS4^{gRX{Ekx={fh> zjuQg{sZlg{=G=Sk`TOoU=XzeK9ro#N-_*pVR605Bo|>DzG&k!$H#O~^nVOp(OS;b? z-Ti&P5&Xfi#7uH}rhjyLZt~4!dd%!Mf+PNzHl+0XBfdmP3CE58L|7Z{*EJ*B@6#hj zzb_GsA-z8}nVQ|7PR(3;t;cSZ?K?J|9Gy*$yH6y?CzCVdqgVF154pormy;7`QJJ12 zM|$?Td-{&{9LE3s_JC~YT%RIeU^>N^4!ZrxG0xO`p!WbW9XWci@94op`|XcE%zhx$ zPYL*EqlZJtW*j~4*{MsObna?&YD*J-+ zaYYctY{o)n3AE+Nd17J@lRsTdh-sRWg0P3ZHwktobM*z*l78EIH|aM+vOpxYBqMt> z)1XIWzsIixLP}hX__Ol`&Dx>P`Ylx3YK(*iB6=?_wTI-O;?crJTn_sbuz8TSl|KA( z%)}&4~LwK3z5puvwvA1iK}OhIS?|eD(1~vyN0)HIuEahLC;Nf;Hd^+_3J-9*@9|;Pt1{;dFU-Z5Yt|NAYF@jW$~9>s zC(N7gYLb-C{o7o4!>gA0&vY@?G79tPQ^+aP#n&^3vj>M34+f7zetk2IQ&u&HP$i*l z^<4vzNZfzbZyybyFzqBm1ByZsll1Sb{25& z{m1YuIEd?nClW_pJV9l|cm-K%$q%{`N81FUkwdlMeMBkjmX2qChHk}0nvOdcj#CTt zVP+ED>&dPR9mDgg!!%uE5@JC_5j(mzyT=pI<>L$%yK!nrj=7(*L=;QOXdA_FAd(3C zqm(XdF(~LmEhN^%Va%7eBqY`tQN@Rb!(o;<(Ou#<7)IHHCr?85|0R9CNUE(^%N2SN zO;Rb+{DnB4WhqPkhn}ANt>nB$s3XYzgAWh*a1H7bP}d1{jWqWk4DfoAj|>bdzBoTX zYtT&#{snd#J_DJChq$~o5%rg2*As}uJP2C_PXmJ(s|&O`&w1}~-kW^LJZ%fV76>TR z1QbgPZSfx1&w>11MS0{c;r4}zx~?Df!Kg)Xc|^~fu3xr0TCHhGuo>|*lb zSD&P%LU~fXO~R@wH%U~es?@KWEUW4xUiU{>jy$<+BGtMYoDW{h4T$WWwo#je74?yo ztIDW(-E-!X;@fIaTFxQI=Bif_J8Plp6|$&>IX`o4-HK+)JjS4^G@G};$bt7R5Pg%4UmvkbfmQx}Du-TzS5F{0Ih3#}S9#a$H z;6V{05=7^ygF*ElNedn}q}KAnrYACmP1Cb`#;xP9H;Vj%}x zJDJE<@+3p~P=M$~R6j_vEqQavT-I(}GaZ_^qDgsuNxSjmvIJP5E)S}YEM-OodGSm+ z{+s)ZDQqt(OwO(@=_~bv;l?CZ&Dsb-Y{_O`4UML$X~e$u685yS)a{Hsqu05 zEuLma&~4v1MK7MEei!`y&1!=atyHCPSE~4+IKdYu0m*A);q82MRnn5 zq2*dH^4`j30rNcX6Ikpj`UF|U2B@N8tAK8?VJkq_x&gXdWWOKN0>fQ4v(>K|KI|vg zDR!&`Q6&~1@!)MBz5(5Jr=d9xP7T`p(Ed7f^nvpg=x7C}6T&uVsfs}N0qEWh0|N8f zU$VEXaGG#XCK8($%y65eGU6t|C70eWWR1UWNEnnR(5uH}cJj+RGr8!)bx+Hs{;SNd zW}fr14VHLx*!!}%Vt#5q4BpjqEkTiy9_qJ4;kHk&hfUX+70MuAE)U`&eO|wo>lDwh zHNl@ZaPEVSm%+IM z!nM$1p`HG~3(jtioa^mCj)qYc9uqK86LAYNw!GWI0&%u#-a94>P3iM~7HUFbvYyrP(v3JPL{TU&4< z<$_m~#0IZa)ZFEAc%`$#YVLDh(riUhJ=p$=1y$)Mfw-*cC_rFhZtmp+f7YYSo!%Qi zL?I5ZD6if2N}}T(uf+EKCo4SF$CY@X3%4w{9!;hja24JMXy=!(k%m{%=t_6sRUNGp zYoL#e{DKc3L*E?qY0$R|`hE#*h0OP$3@0qVESju(s&}%Xu3}3 zRcSHzB@5u9%y`@9O~(N8V5e{`w^uyLc43cGBIYyk49@HPGQ5bjIQNCTgd&y)e`Pub z#g##6NzV`dwyZc8h|8L~^Fb4%YaB?tWaa)WK$}$%s@N|dbPFos0^!OplbFHyZx{w^ zitob+`QaYyq9Fq#CbXYGG}N394Utb{E+jtAO8=1P+C#| literal 0 HcmV?d00001 diff --git a/clos/3.5/init.lisp b/clos/3.5/init.lisp new file mode 100644 index 00000000..d44e50ef --- /dev/null +++ b/clos/3.5/init.lisp @@ -0,0 +1,183 @@ +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + +;;;. Copyright (c) 1991 by Venue + +(in-package "CLOS") + +;;; this file defines the +;;; initialization and related protocols. + + +(defmethod make-instance ((class std-class) + &rest initargs) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (setq initargs (default-initargs class initargs)) + (when initargs + (when (and (eq *boot-state* 'complete) + (let ((tail initargs)) + (loop (unless tail (return t)) + (when (eq (car tail) + ':allow-other-keys) + (return nil)) + (setq tail (cddr tail))))) + (check-initargs-1 class initargs (append (compute-applicable-methods + #'allocate-instance (list class)) + (compute-applicable-methods + #'initialize-instance + (list (class-prototype class))) + (compute-applicable-methods + #'shared-initialize + (list (class-prototype class) + t)))))) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance)) + +(defmethod make-instance ((class-name symbol) + &rest initargs) + (apply #'make-instance (find-class class-name) + initargs)) + +(defvar *default-initargs-flag* (list nil)) + +(defmethod default-initargs ((class std-class) + supplied-initargs) + + ;; This implementation of default initargs is critically dependent on all-default-initargs + ;; not having any duplicate initargs in it. + (let ((all-default (class-default-initargs class)) + (miss *default-initargs-flag*)) + (flet ((getf* (plist key) + (do nil + ((null plist) + miss) + (if (eq (car plist) + key) + (return (cadr plist)) + (setq plist (cddr plist)))))) + (labels ((default-1 (tail) + (if (null tail) + nil + (if (eq (getf* supplied-initargs (caar tail)) + miss) + (list* (caar tail) + (funcall (cadar tail)) + (default-1 (cdr tail))) + (default-1 (cdr tail)))))) + (append supplied-initargs (default-1 all-default)))))) + +(defmethod initialize-instance ((instance standard-object) + &rest initargs) + (apply #'shared-initialize instance t initargs)) + +(defmethod reinitialize-instance ((instance standard-object) + &rest initargs) + (when initargs + (when (eq *boot-state* 'complete) + (check-initargs-1 (class-of instance) + initargs + (append (compute-applicable-methods #'reinitialize-instance (list instance)) + (compute-applicable-methods #'shared-initialize (list instance t)))))) + (apply #'shared-initialize instance nil initargs) + instance) + +(defmethod update-instance-for-different-class ((previous standard-object) + (current standard-object) + &rest initargs) + (when initargs + (check-initargs-1 (class-of current) + initargs + (append (compute-applicable-methods #'update-instance-for-different-class + (list previous current)) + (compute-applicable-methods #'shared-initialize (list current t))))) + + ;; First we must compute the newly added slots. The spec defines newly added slots as "those + ;; local slots for which no slot of the same name exists in the previous class." + (let ((added-slots 'nil) + (current-slotds (class-slots (class-of current))) + (previous-slot-names (mapcar #'slotd-name (class-slots (class-of previous))))) + (dolist (slotd current-slotds) + (if (and (not (memq (slotd-name slotd) + previous-slot-names)) + (eq (slotd-allocation slotd) + ':instance)) + (push (slotd-name slotd) + added-slots))) + (apply #'shared-initialize current added-slots initargs))) + +(defmethod update-instance-for-redefined-class ((instance standard-object) + added-slots discarded-slots property-list &rest + initargs) + (declare (ignore discarded-slots property-list)) + (when initargs + (check-initargs-1 (class-of instance) + initargs + (append (compute-applicable-methods #'update-instance-for-redefined-class + (list instance)) + (compute-applicable-methods #'shared-initialize (list instance nil))))) + (apply #'shared-initialize instance added-slots initargs)) + +(defmethod shared-initialize ((instance standard-object) + slot-names &rest initargs) + + ;; initialize the instance's slots in a two step process 1) A slot for which one of the + ;; initargs in initargs can set the slot, should be set by that initarg. If more than one + ;; initarg in initargs can set the slot, the leftmost one should set it. 2) Any slot not set + ;; by step 1, may be set from its initform by step 2. Only those slots specified by the + ;; slot-names argument are set. If slot-names is: T any slot not set in step 1 is set from + ;; its initform any slot in the list, and not set in step 1 is set from + ;; its initform () no slots are set from initforms + (let* ((class (class-of instance)) + (slotds (class-slots class))) + (dolist (slotd slotds) + (let ((slot-name (slotd-name slotd)) + (slot-initargs (slotd-initargs slotd))) + (flet ((from-initargs nil + + ;; Try to initialize the slot from one of the initargs. If we + ;; succeed return T, otherwise return nil. + (doplist (initarg val) + initargs + (when (memq initarg slot-initargs) + (setf (slot-value instance slot-name) + val) + (return 't)))) + (from-initforms nil + + ;; Try to initialize the slot from its initform. This returns + ;; no meaningful value. + (if (and slot-names (or (eq slot-names 't) + (memq slot-name slot-names)) + (not (slot-boundp instance slot-name))) + (let ((initfunction (slotd-initfunction slotd))) + (when initfunction + (setf (slot-value instance slot-name) + (funcall initfunction))))))) + (or (from-initargs) + (from-initforms)))))) + instance) + + +;;; if initargs are valid return nil, otherwise signal an error + + +(defun check-initargs-1 (class initargs methods) + (let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class))))) + (unless (getf initargs :allow-other-keys) + + ;; Add to the set of slot-filling initargs the set of initargs that are accepted by + ;; the methods. If at any point we come across &allow-other-keys, we can just quit. + (dolist (method methods) + (multiple-value-bind (keys allow-other-keys) + (function-keywords method) + (when allow-other-keys (return-from check-initargs-1 nil)) + (setq legal (append keys legal)))) + + ;; Now check the supplied-initarg-names and the default initargs against the total + ;; set that we know are legal. + (doplist (key val) + initargs + (unless (memq key legal) + (error "Invalid initialization argument ~S for class ~S" key (class-name + class))))))) diff --git a/clos/3.5/iterate.dfasl b/clos/3.5/iterate.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..e90254d4922e0f37aef47414ec94460a4f15e0a7 GIT binary patch literal 24169 zcmd6P3vgT4dFH(rd`Y4xkfvn{lI3ezrYVY`M2dP*G6N6<1&{zP1%TAkra=-EAd>(C zkhZjWRFW0jN#Ho7EE(5P5?isHIt^)nrz?$7P)O-EDdwn%Cs@pN=#FxHlS^5{@1{#3MWC^ANHX0vIFU-Bye&Q+O-06|jr3+m)6!5u*Mq4j-VCXGqC<&jdMI+VLEWbM zBS+Py?c19g)UB;8n_4$+Z(Q2x4Ee-l%od%gI9G2`JEDWp(E&`qd1Ld&2DNEZYtxq2 zmaUCTKlpm~jPg)Y!oNegpCy#4tdzNU5oN5BB4on!%bh({gnkx#19r0j@4R7m5EDl=OK%8O6jUkR-K(Jp>91yreBMwGo+W#n zzHWDrO4^+v_hLDlDfvubVr1lV5;jZPlHVuZAKt84PTogbHM`JztCY=DZn|Yx(o|iy z@Mdh(%dOatQmnQosPz=r>J<;_OIM<3i7{`N<`0!1zlip#0}Bb!iI}Uhtj8jBt6sT0 zd+MI-DGOf7_4u*u*s&vx!UG%#&={OL$ayc|nK$0DK|sxTACxxW6{)T zd>rW1sH)DyQFSPu9#6#wCTLRghXaz&>wa`1J&p;Ej*T2upN@~m)Cg7*85&XDR2HSkW% z+d0&I68$EUDmEk)NsJ#=BLg5xSZg%5PYr5(JWXpQnV~Fs9%-$d6J`WvZ`ri5MXe+HOw)0u#v+O6xEKv{EEvRI zFi7KA#KGe(<#fd!Z`fm>`@YN@0AcQP`nX1!+voPX1K|+omVzXQ z?Q@D2b5Ypo^@%DKJ@f07xt%Ug*z0$5C&ha_pqL`r8wh*FK#N_P54W$^w_c(*pMTqtRI|y3c=L~v@LxuE5vEjO^KbXxd zHL3$72UAIL4vS3A7}D2c3vD5-Q<-IE-+{1Z_qoHoKUKN;+B<`qKUcooY#t6e10m|e z-mZ1*6K#N)A-BE5?eaOnU%}nQ!PL0-qP8n+5B0cRUZ>CA?hSO%?r^J0bHR3>)8F3V zwD)lFJwbQC>37q>bL(4;7r6;?^-_PIJ>(AW=FBqlojpWdhz@a*``X=nGN?pHfMZdJ zCt5=h(C{e8B1vA!R62XARPWR`>dpEly-9Du_Em=5yL;UMm)q`ix!j?U7Bu?M_hvI| z!ZGkIbxp4Q8XV|RbpUJ#Twy2`c{)M3)v0gRx9D5Vp=FG`EQbIl2v9Y0Z6Mo-A@=-zW1|%?eV_(dDJrn^aNP(3=TEp_T>D%>IeTTkN;K38w z%ocYf9fwE?q6`Ulh*%|fKRC%?65KF8tU?gl)ubMZf^UsPhsQx%lZhw@mx4)Dvc%{P z^m&6?fC&cCq{_YSptjczQOU0b2pM|vbZQCYtn5olHdEEK-QF1;uy1c7Ie7Et*5>V} zGoKOy{6sp{Hj*5SjI>R#C@;kLyttl-7eleWShspx4B}*CIeBzh(NP)V;hp-@OnrSv24KZ5B8OmD>oO78$fB zvjT!Pj#16gj2x|!Wm5>XYyfTm=EL?5&DBer%II84te{=%4RrLBAX$cE0jhibMGsTX zgbh`Hw1z}$XJB8s{-}am0EABIJ(m!C((2Q(D8U0sEhJNGT8+9J^_tVRVB4 z8@@F_Du_jJ?6@F30vTd#JU$x#caYqc2E0D?(Ka=K`$cMp+6rktNcr(t5(o)#Vq#>R z#FpVya#W>rWQf|KhN)6ykAE9wfIzVC|(`6nTuhJ6(JaS~D5ywSr zvD6@FIF+-2#0mkoCWQrsI3ra#l)dsLk8;`D<>dQ;RnloYzGRUkg(ZIKDpS68t>5Vi zYK+|3%spnd0IcP5y&Dbb;!&HwSS%(;y3Kh5?r_%JuWG<2)i&-Ks=jgwPWc|3a;M!G z+_;n#Eys&8XK)u$;83N$zC_Gf*4N7`v!{xIN;r3Hb_knLTuW%5#TAJjFJ{VX3nq>G z7;@5CeHW&Ub<0P}XbKk{mtvP=S7KMa=enjhdgW_=`SHovv3P&QlveSDfMqg%EH)W9 z5s2BYcD>Z?tG#m47qcC>>{TvJ|Jfx6w~SruI@dkDg1fuc{gTgLd-bG0W;=MLOSwG# z%gek&9{%mR;<)O)7P}tnub7SXTW7m@q^c>c>O~(XtEaT;lYUB01*WxbxxZ@GC-+y+ z`sM!Rvs#r_t;jK(OF}QU~v!3L^r~K1>7|}{2E*IyhS-F+AoFDuX<6jSEf&b~xc-SzS|8zjB zsJ;FLts-W7{F)eh`V}VwMy?*9Zddsnh|8UzIJjauoH&lJ#My&8cL%}fUm;uMbB4l{ zxr)ppm)5h7C5s-axyv00?eohF8|TWXgRLlD5_E%A1XygKvL>o3SUY7Kkj>rxseoul zDaim%pO5mZk-x{^>kE5H?twJe>t@c5chdjHyCR>a^&~jq4%f$!C~k)a0=Pkxaa{pr z&*2Ln=+_L5c$~G-f*0Mm^<^{^O zEKs&}fwFCSJ&`$H-*dVbINbd*HW`LEzL3tUSbIK0xmB*fY$`> z-RFGMy8zo2z!yMx4(pyZFy>_gW1i8hG23(f!`R=SR+(Fal!Hsa9U6nqBP5=wB=t0YUfJ6 zDSD|Eom^0UjhD*VIfX=eua)14-RxS58U}BB<+c>K=@V+!pY0b}S4Lq5bwFd6_8Lc5^LshMY z$Gq9!Jas{SUaNVMXV_nJ?tsv=fo?hmORzU z(qf>HBxc>hb8NwkHZoDvYP3e~*Lbb;Z;|`A&1zdvqjgr>_BE|e+a?CaO6q0=aT0V% ztFvjXpi3`mtxA^XitGuk6&us8ZPXg&u5PV*X((kNf^=P5d+vgC(XXw=^ke;7 z@V5oDpeiw(^_lM>9- zwr(3b)mjvEKmA>#lmTljEir>l9~Ib~cz`)n*@CUThH zd+hzqI9Td>R%_O*Gpo6#X60ppVQk@QVyefr7N+0;5>cy}AN&*RGAKJeXdnR!S`9Z1 z*sg00yjvKpWlC!~_7xce14oQy{vFtos@2atpfw0U)#?idMxR=PVmq!iaBuuW*va^E z;a~o{laNKA$V?5uly~VBBt%~~PsEPJ{%E;Y?Y#M2rzY^^s#ZOq%sz*uqwVzDyaumW zRfS*Ygda@kSj=Z|HG$SS?gXABNrIhOC5x(i^=?&`EQVlYDG)Ra`68zTwL`8@i5PV; zh59BX+w;kt;0tAept}zjA~(G&CPv}w@OE}0XL$z#PU*pbOAEM~DgPF?e2bD7a-CSx zI>2$#G@$!)op%5U^Olqf$Fk3T{8rJX`Hrs6-!b*Q|6S0$m|c3eW}&2fJ7pDDRn z58xsHHdj~vE1s9Xk8bbu>c_f9k851xZAxC$gY@_VeK$QK{DP(?m*(pzI&o6z|6t%E zlI|( zrSDMkJQ@_!eT_!7^zw_>DcQrx^OO`rzClUBPT!@Z1($|mXFK#v$SMEC)qhCIUy%Zy zM0?8o1u~1-R^TNK0~IA{o#A~wG(lx&zTGNLQs2sAPSOMwvIkh8RX|!E%T<>CMPFad zxo?%?jpg5yE}jyb=(0$vEO&s626XYKUj8ndv3rH32KN!6H&EjVb#NpCrmucJgc}W1 zvoH@qC7T!;Yota$$!5k}$%&C6eq&x^%nMIJ+kxmHcXKG3FuJC$pyH<6rdo&DAErCwlN?CoP)(t~dn~trc*X!1;!?@C~vzgAGRC0h-%Fvj@%mj@ECKyen=)#rA z2`FOvcKc`&cQV|$5^A#wMJ;PJTd^wY?Ju*Lo$a`#r;jGaBS#8ax0)-MGg*>`OwGtT zvyZQ4GmU+bRGeo7m3cIhg6=yvXp$7w`Dsxr1w+ek0zIs_)Ax|!!|w8FAt)ut__63< zPdMo54RkjPf#t`jZ7Ii{!{)gm;r?|)Qdm~;?wj;lSzsYMjCB`oxP=0kLf8QVkOSLIbKY?=W?X4J?MzsivpgnW^eY%XCuBSZ#`j~7ynkqu za-d%6R~4B05a(g(>xxIa+(lxCf_2V_WW;1sp0^uBP9*!b`aPtas|d2W1|s7~Z(+`26{u=(p0fO0$Ab z@U4n?WzDQ#t1`II%x3P0XRlRo;b|^8$-m6SoDQu*$S{I&TD2OnKdT`9Ks>17*4K@v zd{V2CkHsK+RB6itYvmH$fqY8=7J24UB5twS%o1DypyaUAeOFvrE9jWN!pHn7C7&fa z*xnm9u0!%+Ci}8R#jsmKGfR9$_8`9um!fvfXE!mE%3JjwdI*Zdbo@R+*%#@4ypX>FuyoSc|ID4dCpgRNf~CH>RTMH3LSg4(DpshAA&O^GEmnij zEr%!;mB$l9P@j-_2}Tk1^K~fu{JK$~&LYPX7*Se9$hcx8GCD96A+*0mA&nX`kN@9@ z7UTbnyjPM*0aIwy(|K;9y#pY*p5qGzC8ld($<&yAv+ zuQ=L4a(SVkK9A&4*mGmCA`AK2bEBNgV>ZTiD;g>*_swZJApeL=c!oROP2kMWjo5FXg_9t-cRRdppz_u#y-s!5WZ|ICQFY zOz%6S_wLqvKSgEoq78cAeR^*Rz4}wGMffkB<0Oe#(ib`TLqR8Q2nqIws;FwA3V)u> zxOe3w4N}1ZLD`NC?FHG2g+u}M>mgFnx2YQ`DZE%v)oza;N`Q3_HBMwRN9I!o!TjMJ zL$ZrWBl40B#)2e5E-)Ak7E~G?R%?h-uu#L4K5p37N&lKA8*^gZkSB=3K)PTdqVeHu z=J3ZEdngGTdKxxbxEDZE%yxWQv%m~q^8jR}A=EOIR2aQcQkr=Ke>6w<*m_pi43v03 z#sYzZc2V=-k-}2&+Nzl*?#pa;8iaG+F4R?@P1r$LU8j=dXG=5@_u6{zu|Fo z2_=K5LW<|V_CSE>nX9%h5;V1#E=ZxG4H&ezH-K9S(`fnLauh5Ly8Rl=bKXunW+&8! zzfiN&yI{uj+{H|F*^0vdy8jpc~e5bd|1WP2Qt>Z}gg%)4`ywmX!4qK@4w?!iaPyX8Mg-(9e{9NEII*3uqp0Vj^OH~_v8k_Y(!-d9@q z`T8<`oTp_34fuaCHb=+*S+D$2D>Z)S1hzE zBWtjEJ6$6MfrfeB=k5&S?1I9?4FHtaWHXCMH;i-d3|J2Fy1yx8q;oBLNO_z~-d)L$ z_h>^x*pP=w0N5)ehFRis1p)!|a)v;lhoEIHkWLM@QS2n?M$AcOxRDh}zL&ZMu<%7< zIr@|g-YI$`sh_zgu`FAjWf>-2QyL5@cVaKNcRX~bZV6V1+fr`tWUM*(U4f)hY~EUr7{ zt6b6dELU}sG2==XBsQptyDxQfw`atK<1z_v*KAgY@-@+|6LoFEj^dCDGa~H-K!hRa z71Az&%0-YpgR&63UuCBH8ZY?UM1EcZJ{OUf0cD;SA4GKyG)28$9 z#r{+}gu=@qu7)=;I_+h_Sz9nV1O@DKlXx^Miy;lm<+tY+2=Ik@W-{PejAjrXSHfRD_AIj(oe#`z^mXN-=q&#OaHOM7(%n1Ra4q3Q4cer*%*IfIbwQ78dyaL z7+N+5uRnriy%Nn7JHsUjD$0Yoq2+Vp4UD~eh0d$a^s?EhvP13A*C}^2zj%^yuwo932tO)oT}6}vVbgyWPKxfnh>Iu)b8 zGgBhLa1KImBnaQN?mV3=Aj)I`j|nXTH{(jTq&UkzeuEO`>6$@tA-o7`_Cg5|+2F_@ z%}+?F0p^ep30#LzlS?3!GCe5Hy8?Y$&|ImK) zfGy7f*qmd$1C%ujD0@NHn+eM3u0zdvmM0ic7(yxwA;k1E{<)miNdUrmS>N4A-!BN3_OCEAlm!rA-%qvALkzhDUsp4&9p*#lRUZ@e;y_j zcKgB=^n~L-nJ1*@f$HSwOEklYhQ*L`+W9b zh>@4Ci>fKJCss%dEI!?qY3JD{eVf5l3ik4?)^QZ zmGnMmuWvJZ`M&VP+>xi{EQJdsfn7t+N%&mK+4%EPN=v%XTLL8aqM_%T(& zdn28y)tdyrJYT6d2>`w*>rKi=ns=tm^i*Fd{BEB&G`pnboERKLgbl?`le@Ys@r#})yPKbQ3u10IXHLjdFUJRn9RgE198+);QJz&bDr zCu{@6DEbWc2a5co5(Yv*j(z}Il+Ov}(v(9!=Ge<{a&zC5ce+}5`QC)S^I0P)Zk*On zCdVTI{tiGpT3{Fyg5} z27}IhWI`_H)Li{bL6p=PY3(hD$SBA^gpw?v3UpMg9~T{^*9AJBSMD`&@f{Q7)4Zce zYYrvvP6{ZXsYd8m9)=b2d8h6RuN<3sDvDLsHy@G!QKF3#X@4Xx!vOV&1Hulcb_V97|)Bl!zOJJo3vWix7>D< z%!s?yyB$#TMCRee1j}vKnxdi?V|Jb4GfQVacQHzv8@V zhKD>h>9=~jeWpnOu&V65dl`SFKDbPeVZwJ6EmD;OiQGKzux7hh^G;c})0&I({+f(s zr-4fx6GkZavM^!H5d-E0fu50eo0}pdl0!(#g~1#CbAjmx{4zyM1hS-It%YV69_6rJ zR$Ql$i=PW*gi8kmYy25_=!GnPclT&Xaq4ywWp52eAXCvNA^qif?%Zw2@A-$xfE#i= zcY`4FmV>xlx~Ue5$MMbAHQMjWTX7IIcYcnpJRLb zkGSX!!r4Ejq})!){{&1Z>V(zwNq+tMFh9;m7C;b+@Af&bz0YAdIRv$J5W$6tXL3x6I`-zgtO}wRis}>h6PVW6y?88DHqXi+4 z^Fn0{LLS%if{qLO<_X3r=^4v|TzYbq9xd0SN-bR9eE3cT!G0d}$-j*Q8I4c4;Byd> zLH-QI&_s&vPa=$vc>uY^t;=0Np3|cre__Mf%!8oVupFwlkM;fN3mh)jhiQR_a(=lS zy#!PxoW=JBa`UIv!!tNCFn}P~IDe5QzZvZ1Q%B*s;*%JOWa8*(a>67Gv>j>4{OdS| zk~jA`eHi#26Zo#|5RNkx9LSje^*NY-%mLq07`;whkpG-ff!_+x0S1PC3N?Z+078H$ zgpXnyZXci{_pg}^P>fEjzZQRW_(Ob-i07NpG^?S}nL#9t(r*;EpjeDlH&a_sUW4+( zjJf^wh-`uhI}`s>?D^QUG2veZoA`OHdZq`_IclCf0GT?IeB_ zx!ZO{TlGz!R;#Vz_WW~odScGZgz`f8VKfMY!+b%KD9C6nMJLfn+(aybO7K5A@6sB) zhBKX)B8)Ck9FR%bj#JX4bCt9QjCY})5$U;x9M?uH0A5m=97Zvuv>6Bhj&Q-Bpd^;ag>Mj zy1u)WYrnl&_bo#|!bHi0Sz$fDL{>8+%Hd5)vN}Ve@Co@nZu%}IzehyeMOonhL#tVhBShx}6UYTvLG6Jc6|F?!c!!dFC{XHU>pi(Yl(&4b(*7dp!yj-l|9}P_Tt!0rO)ekS46MQB@ z+B0*h1_WpbEc}TwMOf#R0I%;YOCLYqttV{F5x8$tUHtMN`m&KlFt@Bm#7F@iW91@2k~gVoVH7v6-2(wh8?c$)C* zo;x8xbI$8+uE#jXx)iL)7;kABNQTFMUyYequ#S5XY_yKkNJMNy7eg@nJK*Cz9-G$lffN^3*qHGp%>*8ZA@NVSI>&g3EA~edrM}JokWG zvm*>L&g0XtU^KtwAEIF*VY;B90RMAkW`)>P2W$DjQi4MH zU=d4s@)UivsK|qlMe6m;KczQI;rFu?5iw!+{iYifLAo*<5o=Hs>cH&vIpS!&F98&c8iN7iQ>zgFQZ{tAm%3vl-=D-a5BqV*FNf z)~|}Z&CsPQZ`_?iFmF-MpE6+l!yI_F@x@trRo1tWMvx~c!>3~I99-h ze1z|O+#}0>@yFQKJDk^cab9o9`u01Wmx=LnzKAE>VV?Uq$Cjr8oMMz0w1BU?uZTO| zWSqFVpbo-I!k`T#_v9%BvS&UUl_h6IT)pdlu}MA3olocal>users>welch>lisp>clos>rev4>il-format>ITERATE.;2| 65656 + + IL:|changes| IL:|to:| (IL:VARS IL:ITERATECOMS) + + IL:|previous| IL:|date:| " 6-Feb-91 11:00:58" +IL:|{DSK}local>users>welch>lisp>clos>rev4>il-format>ITERATE.;1|) + + +; Copyright (c) 1991 by Venue. All rights reserved. + +(IL:PRETTYCOMPRINT IL:ITERATECOMS) + +(IL:RPAQQ IL:ITERATECOMS + ( + +(IL:* IL:|;;;| "************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 ") + + (IL:P (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER)) + (EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS + LIST-ELEMENTS LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL + COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING *ITERATE-WARNINGS*) + )) + (IL:VARIABLES *ITERATE-WARNINGS*) + + +(IL:* IL:|;;;| "ITERATE macro") + + (IL:FUNCTIONS ITERATE SIMPLE-EXPAND-ITERATE-FORM) + (IL:VARIABLES *ITERATE-TEMP-VARS-LIST*) + (IL:FUNCTIONS OPTIMIZE-ITERATE-FORM EXPAND-INTO-LET VARIABLES-FROM-LET + ITERATE-TRANSFORM-BODY PARSE-DECLARATIONS EXTRACT-SPECIAL-BINDINGS + FUNCTION-LAMBDA-P RENAME-LET-BINDINGS RENAME-VARIABLES MV-SETQ VARIABLE-SAME-P + MAYBE-WARN) + + (IL:* IL:|;;| "Sample iterators") + + (IL:FUNCTIONS INTERVAL LIST-ELEMENTS LIST-TAILS ELEMENTS PLIST-ELEMENTS SEQUENCE-ACCESSOR) + + (IL:* IL:|;;| "These \"iterators\" may be withdrawn") + + (IL:FUNCTIONS EACHTIME WHILE UNTIL) + (IL:* IL:\; "GATHERING macro") + (IL:FUNCTIONS GATHERING WITH-GATHERING SIMPLE-EXPAND-GATHERING-FORM) + (IL:VARIABLES *ACTIVE-GATHERERS* *ANONYMOUS-GATHERING-SITE*) + (IL:FUNCTIONS OPTIMIZE-GATHERING-FORM RENAME-AND-CAPTURE-VARIABLES WALK-GATHERING-BODY) + + (IL:* IL:|;;| "Sample gatherers") + + (IL:FUNCTIONS COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING) + (IL:* IL:\; + "Easier to read expanded code if PROG1 gets left alone ") + (XCL:FILE-ENVIRONMENTS "ITERATE"))) + + + +(IL:* IL:|;;;| +"************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 " +) + + +(IN-PACKAGE :ITERATE :USE '(:LISP :WALKER)) + +(EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS LIST-ELEMENTS + LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL COLLECTING JOINING MAXIMIZING + MINIMIZING SUMMING *ITERATE-WARNINGS*)) + +(DEFVAR *ITERATE-WARNINGS* :ANY "Controls whether warnings are issued for iterate/gather forms that aren't optimized. +NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal." +) + + + +(IL:* IL:|;;;| "ITERATE macro") + + +(DEFMACRO ITERATE (CLAUSES &BODY BODY &ENVIRONMENT ENV) + (OPTIMIZE-ITERATE-FORM CLAUSES BODY ENV)) + +(DEFUN SIMPLE-EXPAND-ITERATE-FORM (CLAUSES BODY) + + (IL:* IL:|;;| + "Expand ITERATE. This is the \"formal semantics\" expansion, which we never use. ") + + (LET* + ((BLOCK-NAME (GENSYM)) + (BOUND-VAR-LISTS (MAPCAR #'(LAMBDA (CLAUSE) + (LET ((NAMES (FIRST CLAUSE))) + (IF (LISTP NAMES) + NAMES + (LIST NAMES)))) + CLAUSES)) + (GENERATOR-VARS (MAPCAR #'(LAMBDA (CLAUSE) + (DECLARE (IGNORE CLAUSE)) + (GENSYM)) + CLAUSES))) + `(BLOCK ,BLOCK-NAME + (LET* + ,(MAPCAN #'(LAMBDA (GVAR CLAUSE VAR-LIST) (IL:* IL:\; + "For each clause, bind a generator temp to the clause, then bind the specified var(s) ") + (CONS (LIST GVAR (SECOND CLAUSE)) + (COPY-LIST VAR-LIST))) + GENERATOR-VARS CLAUSES BOUND-VAR-LISTS) + + (IL:* IL:|;;| "Note bug in formal semantics: there can be declarations in the head of BODY; they go here, rather than inside loop ") + + (LOOP ,@(MAPCAR #'(LAMBDA (VAR-LIST GEN-VAR) (IL:* IL:\; + "Set each bound variable (or set of vars) to the result of calling the corresponding generator ") + `(MULTIPLE-VALUE-SETQ ,VAR-LIST + (FUNCALL ,GEN-VAR #'(LAMBDA NIL (RETURN-FROM ,BLOCK-NAME)) + ))) + BOUND-VAR-LISTS GENERATOR-VARS) + ,@BODY))))) + +(DEFPARAMETER *ITERATE-TEMP-VARS-LIST* '(ITERATE-TEMP-1 ITERATE-TEMP-2 ITERATE-TEMP-3 + ITERATE-TEMP-4 ITERATE-TEMP-5 ITERATE-TEMP-6 + ITERATE-TEMP-7 ITERATE-TEMP-8) + "Temp var names used by ITERATE expansions.") + +(DEFUN OPTIMIZE-ITERATE-FORM (CLAUSES BODY ITERATE-ENV) + (LET* + ((TEMP-VARS *ITERATE-TEMP-VARS-LIST*) + (BLOCK-NAME (GENSYM)) + (FINISH-FORM `(RETURN-FROM ,BLOCK-NAME)) + (BOUND-VARS (MAPCAN #'(LAMBDA (CLAUSE) + (LET ((NAMES (FIRST CLAUSE))) + (IF (LISTP NAMES) + (COPY-LIST NAMES) + (LIST NAMES)))) + CLAUSES)) + ITERATE-DECLS GENERATOR-DECLS UPDATE-FORMS BINDINGS LEFTOVER-BODY) + (DO ((TAIL BOUND-VARS (CDR TAIL))) + ((NULL TAIL)) (IL:* IL:\; "Check for duplicates") + (WHEN (MEMBER (CAR TAIL) + (CDR TAIL)) + (WARN "Variable appears more than once in ITERATE: ~S" (CAR TAIL)))) + (FLET + ((GET-ITERATE-TEMP NIL + + (IL:* IL:|;;| "Make temporary var. Note that it is ok to re-use these symbols in each iterate, because they are not used within BODY. ") + + (OR (POP TEMP-VARS) + (GENSYM)))) + (DOLIST (CLAUSE CLAUSES) + (COND + ((OR (NOT (CONSP CLAUSE)) + (NOT (CONSP (CDR CLAUSE)))) + (WARN "Bad syntax in ITERATE: clause not of form (var iterator): ~S" CLAUSE)) + (T + (UNLESS (NULL (CDDR CLAUSE)) + (WARN "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" + CLAUSE)) + (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS + EXTRA-BODY) + (EXPAND-INTO-LET (SECOND CLAUSE) + 'ITERATE ITERATE-ENV) + + (IL:* IL:|;;| + "We have expanded the generator clause and parsed it into its LET pieces. ") + + (PROG* ((VARS (FIRST CLAUSE)) + GEN-ARGS RENAMED-VARS) + (SETQ VARS (IF (LISTP VARS) + (COPY-LIST VARS) + (LIST VARS))) (IL:* IL:\; + "VARS is now a (fresh) list of all iteration vars bound in this clause ") + (COND + ((EQ LET-BODY :ABORT) (IL:* IL:\; + "Already issued a warning about malformedness ") + ) + ((NULL (SETQ LET-BODY (FUNCTION-LAMBDA-P LET-BODY 1))) + (IL:* IL:\; "Not of the expected form") + (LET ((GENERATOR (SECOND CLAUSE))) + (COND + ((AND (CONSP GENERATOR) + (FBOUNDP (CAR GENERATOR))) + (IL:* IL:\; "It looks ok--a macro or function here--so the guy who wrote it just didn't do it in an optimizable way ") + (MAYBE-WARN :DEFINITION "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))" + GENERATOR)) + (T (IL:* IL:\; + "Perhaps it's just a misspelling? Probably user error ") + (MAYBE-WARN :USER + "Iterate operator in clause ~S is not fboundp." GENERATOR + ))) + (SETQ LET-BODY :ABORT))) + (T + + (IL:* IL:|;;| "We have something of the form #'(LAMBDA (finisharg) ...), possibly with some LET bindings around it. LET-BODY = ((finisharg) ...). ") + + (SETQ LET-BODY (CDR LET-BODY)) + (SETQ GEN-ARGS (POP LET-BODY)) + (WHEN LET-BINDINGS + + (IL:* IL:|;;| "The first transformation we want to perform is \"LET-eversion\": turn (let* ((generator (let (..bindings..) #'(lambda ...)))) ..body..) into (let* (..bindings.. (generator #'(lambda ...))) ..body..). This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var). Of course, none of those vars can be special, but we already checked for that above. ") + + (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS) + (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE ITERATE-ENV + LEFTOVER-BODY #'GET-ITERATE-TEMP)) + (SETQ LEFTOVER-BODY NIL) (IL:* IL:\; + "If there was any leftover from previous, it is now consumed ") + ) + + (IL:* IL:|;;| "The second transformation is substituting the body of the generator (LAMBDA (finish-arg) . gen-body) for its appearance in the update form (funcall generator #'(lambda () finish-form)), then simplifying that form. The requirement for this part is that the generator body not refer to any variables that are bound between the generator binding and the appearance in the loop body. The only variables bound in that interval are generator temporaries, which have unique names so are no problem, and the iteration variables remaining for subsequent clauses. We'll discover the story as we walk the body. ") + + (MULTIPLE-VALUE-BIND (FINISHDECL OTHER REST) + (PARSE-DECLARATIONS LET-BODY GEN-ARGS) + (DECLARE (IGNORE FINISHDECL))(IL:* IL:\; "Pull out declares, if any, separating out the one(s) referring to the finish arg, which we will throw away ") + (WHEN OTHER (IL:* IL:\; + "Combine remaining decls with decls extracted from the LET, if any ") + (SETQ OTHERDECLS (NCONC OTHERDECLS OTHER))) + (SETQ LET-BODY (COND + (OTHERDECLS (IL:* IL:\; + "There are interesting declarations, so have to keep it wrapped. ") + `(LET NIL (DECLARE ,@OTHERDECLS) + ,@REST)) + ((NULL (CDR REST)) + (IL:* IL:\; "Only one form left") + (FIRST REST)) + (T `(PROGN ,@REST))))) + (UNLESS (EQ (SETQ LET-BODY (ITERATE-TRANSFORM-BODY LET-BODY ITERATE-ENV + RENAMED-VARS (FIRST GEN-ARGS) + FINISH-FORM BOUND-VARS CLAUSE)) + :ABORT) + + (IL:* IL:|;;| "Skip the rest if transformation failed. Warning has already been issued. Note possible further optimization: if LET-BODY expanded into (prog1 oldvalue prepare-for-next-iteration), as so many do, then we could in most cases split the PROG1 into two pieces: do the (setq var oldvalue) here, and do the prepare-for-next-iteration at the bottom of the loop. This does a slight optimization of the PROG1 and also rearranges the code in a way that a reasonably clever compiler might detect how to get rid of redundant variables altogether (such as happens with INTERVAL and LIST-TAILS); that would make the whole thing closer to what you might have coded by hand. However, to do this optimization, we need to assure that (a) the prepare-for-next-iteration refers freely to no vars other than the internal vars we have extracted from the LET, and (b) that the code has no side effects. These are both true for all the iterators defined by this module, but how shall we represent side-effect info and/or tap into the compiler's knowledge of same? ") + + (WHEN LOCALDECLS (IL:* IL:\; "There were declarations for the generator locals--have to keep them for later, and rename the vars mentioned ") + (SETQ + GENERATOR-DECLS + (NCONC + GENERATOR-DECLS + (MAPCAR + #'(LAMBDA (DECL) + (LET ((HEAD (CAR DECL))) + (CONS HEAD (IF (EQ HEAD 'TYPE) + (CONS (SECOND DECL) + (SUBLIS RENAMED-VARS + (CDDR DECL))) + (SUBLIS RENAMED-VARS (CDR DECL))))) + ) + LOCALDECLS))))))) + + (IL:* IL:|;;| "Finished analyzing clause now. LET-BODY is the form which, when evaluated, returns updated values for the iteration variable(s) VARS. ") + + (WHEN (EQ LET-BODY :ABORT) + + (IL:* IL:|;;| "Some punt case: go with the formal semantics: bind a var to the generator, then call it in the update section ") + + (LET ((GVAR (GET-ITERATE-TEMP)) + (GENERATOR (SECOND CLAUSE))) + (SETQ LET-BINDINGS + (LIST (LIST GVAR + (COND + (LEFTOVER-BODY + (IL:* IL:\; "Have to use this up") + `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ + LEFTOVER-BODY + NIL)) + GENERATOR)) + (T GENERATOR))))) + (SETQ LET-BODY `(FUNCALL ,GVAR #'(LAMBDA NIL ,FINISH-FORM))))) + (PUSH (MV-SETQ (COPY-LIST VARS) + LET-BODY) + UPDATE-FORMS) + (DOLIST (V VARS) + (DECLARE (IGNORE V)) (IL:* IL:\; "Pop off the vars we have now bound from the list of vars to watch out for--we'll bind them right now ") + (POP BOUND-VARS)) + (SETQ BINDINGS (NCONC BINDINGS LET-BINDINGS + (COND + (EXTRA-BODY (IL:* IL:\; + "There was some computation to do after the bindings--here's our chance ") + (CONS (LIST (FIRST VARS) + `(PROGN ,@EXTRA-BODY NIL)) + (REST VARS))) + (T VARS)))))))))) + (DO ((TAIL BODY (CDR TAIL))) + ((NOT (AND (CONSP TAIL) + (CONSP (CAR TAIL)) + (EQ (CAAR TAIL) + 'DECLARE))) + + (IL:* IL:|;;| "TAIL now points at first non-declaration. If there were declarations, pop them off so they appear in the right place ") + + (UNLESS (EQ TAIL BODY) + (SETQ ITERATE-DECLS (LDIFF BODY TAIL)) + (SETQ BODY TAIL)))) + `(BLOCK ,BLOCK-NAME + (LET* ,BINDINGS ,@(AND GENERATOR-DECLS `((DECLARE ,@GENERATOR-DECLS))) + ,@ITERATE-DECLS + ,@LEFTOVER-BODY + (LOOP ,@(NREVERSE UPDATE-FORMS) + ,@BODY))))) + +(DEFUN EXPAND-INTO-LET (CLAUSE PARENT-NAME ENV) + + (IL:* IL:|;;| "Return values: Body, LET[*], bindings, localdecls, otherdecls, extra body, where BODY is a single form. If multiple forms in a LET, the preceding forms are returned as extra body. Returns :ABORT if it issued a punt warning. ") + + (PROG ((EXPANSION CLAUSE) + EXPANDEDP BINDING-TYPE LET-BINDINGS LET-BODY) + EXPAND + (MULTIPLE-VALUE-SETQ (EXPANSION EXPANDEDP) + (MACROEXPAND-1 EXPANSION ENV)) + (COND + ((NOT (CONSP EXPANSION)) (IL:* IL:\; "Shouldn't happen") + ) + ((SYMBOLP (SETQ BINDING-TYPE (FIRST EXPANSION))) + (CASE BINDING-TYPE + ((LET LET*) + (SETQ LET-BINDINGS (SECOND EXPANSION)) (IL:* IL:\; + "List of variable bindings") + (SETQ LET-BODY (CDDR EXPANSION)) + (GO HANDLE-LET)))) + ((AND (CONSP BINDING-TYPE) + (EQ (CAR BINDING-TYPE) + 'LAMBDA) + (NOT (FIND-IF #'(LAMBDA (X) + (MEMBER X LAMBDA-LIST-KEYWORDS)) + (SETQ LET-BINDINGS (SECOND BINDING-TYPE)))) + (EQL (LENGTH (SECOND EXPANSION)) + (LENGTH LET-BINDINGS)) + (NULL (CDDR EXPANSION))) (IL:* IL:\; + "A simple LAMBDA form can be treated as LET ") + (SETQ LET-BODY (CDDR BINDING-TYPE)) + (SETQ LET-BINDINGS (MAPCAR #'LIST LET-BINDINGS (SECOND EXPANSION))) + (SETQ BINDING-TYPE 'LET) + (GO HANDLE-LET))) + + (IL:* IL:|;;| "Fall thru if not a LET") + + (COND + (EXPANDEDP (IL:* IL:\; "try expanding again") + (GO EXPAND)) + (T (IL:* IL:\; + "Boring--return form as the body ") + (RETURN EXPANSION))) + HANDLE-LET + (RETURN (LET ((LOCALS (VARIABLES-FROM-LET LET-BINDINGS)) + EXTRA-BODY SPECIALS) + (MULTIPLE-VALUE-BIND (LOCALDECLS OTHERDECLS LET-BODY) + (PARSE-DECLARATIONS LET-BODY LOCALS) + (COND + ((SETQ SPECIALS (EXTRACT-SPECIAL-BINDINGS LOCALS LOCALDECLS)) + (MAYBE-WARN (COND + ((FIND-IF #'VARIABLE-GLOBALLY-SPECIAL-P SPECIALS) + (IL:* IL:\; + "This could be the fault of a user proclamation ") + :USER) + (T :DEFINITION)) + + "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)" + PARENT-NAME CLAUSE SPECIALS) + :ABORT) + (T (VALUES (COND + ((NOT (CONSP LET-BODY)) + (IL:* IL:\; + "Null body of LET? unlikely, but someone else will likely complain ") + NIL) + ((NULL (CDR LET-BODY)) + (IL:* IL:\; + "A single expression, which we hope is (function (lambda...)) ") + (FIRST LET-BODY)) + (T + + (IL:* IL:|;;| "More than one expression. These are forms to evaluate after the bindings but before the generator form is returned. Save them to evaluate in the next convenient place. Note that this is ok, as there is no construct that can cause a LET to return prematurely (without returning also from some surrounding construct). ") + + (SETQ EXTRA-BODY (BUTLAST LET-BODY)) + (CAR (LAST LET-BODY)))) + BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY)))))) + )) + +(DEFUN VARIABLES-FROM-LET (BINDINGS) + + (IL:* IL:|;;| "Return a list of the variables bound in the first argument to LET[*].") + + (MAPCAR #'(LAMBDA (BINDING) + (IF (CONSP BINDING) + (FIRST BINDING) + BINDING)) + BINDINGS)) + +(DEFUN ITERATE-TRANSFORM-BODY (LET-BODY ITERATE-ENV RENAMED-VARS FINISH-ARG FINISH-FORM + BOUND-VARS CLAUSE) + +(IL:* IL:|;;;| "This is the second major transformation for a single iterate clause. LET-BODY is the body of the iterator after we have extracted its local variables and declarations. We have two main tasks: (1) Substitute internal temporaries for occurrences of the LET variables; the alist RENAMED-VARS specifies this transformation. (2) Substitute evaluation of FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we check for forms that would invalidate these transformations: occurrence of FINISH-ARG outside of a funcall, and free reference to any element of BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type (ITERATE or ITERATE*), for purpose of error messages. On success, we return the transformed body; on failure, :ABORT. ") + + (WALK-FORM LET-BODY ITERATE-ENV #'(LAMBDA (FORM CONTEXT ENV) + (DECLARE (IGNORE CONTEXT)) + + (IL:* IL:|;;| + "Need to substitute RENAMED-VARS, as well as turn (FUNCALL finish-arg) into the finish form ") + + (COND + ((SYMBOLP FORM) + (LET (RENAMING) + (COND + ((AND (EQ FORM FINISH-ARG) + (VARIABLE-SAME-P FORM ENV + ITERATE-ENV)) + (IL:* IL:\; + "An occurrence of the finish arg outside of FUNCALL context--I can't handle this ") + (MAYBE-WARN :DEFINITION "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." + (SECOND CLAUSE)) + (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT)) + ((AND (SETQ RENAMING (ASSOC FORM RENAMED-VARS + )) + (VARIABLE-SAME-P FORM ENV + ITERATE-ENV)) + (IL:* IL:\; + "Reference to one of the vars we're renaming ") + (CDR RENAMING)) + ((AND (MEMBER FORM BOUND-VARS) + (VARIABLE-SAME-P FORM ENV + ITERATE-ENV)) + (IL:* IL:\; "FORM is a var that is bound in this same ITERATE, or bound later in this ITERATE*. This is a conflict. ") + (MAYBE-WARN :USER "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." + (SECOND CLAUSE) + FORM) + (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT)) + (T FORM)))) + ((AND (CONSP FORM) + (EQ (FIRST FORM) + 'FUNCALL) + (EQ (SECOND FORM) + FINISH-ARG) + (VARIABLE-SAME-P (SECOND FORM) + ENV ITERATE-ENV)) + (IL:* IL:\; + "(FUNCALL finish-arg) => finish-form ") + (UNLESS (NULL (CDDR FORM)) + (MAYBE-WARN :DEFINITION + "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." + (SECOND CLAUSE) + (CDDR FORM))) + FINISH-FORM) + (T FORM))))) + +(DEFUN PARSE-DECLARATIONS (TAIL LOCALS) + + (IL:* IL:|;;| "Extract the declarations from the head of TAIL and divide them into 2 classes: declares about variables in the list LOCALS, and all other declarations. Returns 3 values: those 2 lists plus the remainder of TAIL. ") + + (LET + (LOCALDECLS OTHERDECLS FORM) + (LOOP + (UNLESS (AND TAIL (CONSP (SETQ FORM (CAR TAIL))) + (EQ (CAR FORM) + 'DECLARE)) + (RETURN (VALUES LOCALDECLS OTHERDECLS TAIL))) + (MAPC + #'(LAMBDA (DECL) + (CASE (FIRST DECL) + ((INLINE NOTINLINE OPTIMIZE) (IL:* IL:\; + "These don't talk about vars") + (PUSH DECL OTHERDECLS)) + (T (IL:* IL:\; + "Assume all other kinds are for vars ") + (LET* ((VARS (IF (EQ (FIRST DECL) + 'TYPE) + (CDDR DECL) + (CDR DECL))) + (L (INTERSECTION LOCALS VARS)) + OTHER) + (COND + ((NULL L) (IL:* IL:\; "None talk about LOCALS") + (PUSH DECL OTHERDECLS)) + ((NULL (SETQ OTHER (SET-DIFFERENCE VARS L))) + (IL:* IL:\; "All talk about LOCALS") + (PUSH DECL LOCALDECLS)) + (T (IL:* IL:\; "Some of each") + (LET ((HEAD (CONS 'TYPE (AND (EQ (FIRST DECL) + 'TYPE) + (LIST (SECOND DECL)))))) + (PUSH (APPEND HEAD OTHER) + OTHERDECLS) + (PUSH (APPEND HEAD L) + LOCALDECLS)))))))) + (CDR FORM)) + (POP TAIL)))) + +(DEFUN EXTRACT-SPECIAL-BINDINGS (VARS DECLS) + + (IL:* IL:|;;| +"Return the subset of VARS that are special, either globally or because of a declaration in DECLS ") + + (LET ((SPECIALS (REMOVE-IF-NOT #'VARIABLE-GLOBALLY-SPECIAL-P VARS))) + (DOLIST (D DECLS) + (WHEN (EQ (CAR D) + 'SPECIAL) + (SETQ SPECIALS (UNION SPECIALS (INTERSECTION VARS (CDR D)))))) + SPECIALS)) + +(DEFUN FUNCTION-LAMBDA-P (FORM &OPTIONAL NARGS) + + (IL:* IL:|;;| "If FORM is #'(LAMBDA bindings . body) and bindings is of length NARGS, return the lambda expression ") + + (LET (ARGS BODY) + (AND (CONSP FORM) + (EQ (CAR FORM) + 'FUNCTION) + (CONSP (SETQ FORM (CDR FORM))) + (NULL (CDR FORM)) + (CONSP (SETQ FORM (CAR FORM))) + (EQ (CAR FORM) + 'LAMBDA) + (CONSP (SETQ BODY (CDR FORM))) + (LISTP (SETQ ARGS (CAR BODY))) + (OR (NULL NARGS) + (EQL (LENGTH ARGS) + NARGS)) + FORM))) + +(DEFUN RENAME-LET-BINDINGS (LET-BINDINGS BINDING-TYPE ENV LEFTOVER-BODY &OPTIONAL TEMPVARFN) + + (IL:* IL:|;;| "Perform the alpha conversion required for \"LET eversion\" of (LET[*] LET-BINDINGS . body)--rename each of the variables to an internal name. Returns 2 values: a new set of LET bindings and the alist of old var names to new (so caller can walk the body doing the rest of the renaming). BINDING-TYPE is one of LET or LET*. LEFTOVER-BODY is optional list of forms that must be eval'ed before the first binding happens. ENV is the macro expansion environment, in case we have to walk a LET*. TEMPVARFN is a function of no args to return a temporary var; if omitted, we use GENSYM. ") + + (LET (RENAMED-VARS) + (VALUES (MAPCAR #'(LAMBDA (BINDING) + (LET ((VALUEFORM (COND + ((NOT (CONSP BINDING)) + (IL:* IL:\; "No initial value") + NIL) + ((OR (EQ BINDING-TYPE 'LET) + (NULL RENAMED-VARS)) + (IL:* IL:\; + "All bindings are in parallel, so none can refer to others ") + (SECOND BINDING)) + (T (IL:* IL:\; + "In a LET*, have to substitute vars in the 2nd and subsequent initialization forms ") + (RENAME-VARIABLES (SECOND BINDING) + RENAMED-VARS ENV)))) + (NEWVAR (IF TEMPVARFN + (FUNCALL TEMPVARFN) + (GENSYM)))) + (PUSH (CONS (IF (CONSP BINDING) + (FIRST BINDING) + BINDING) + NEWVAR) + RENAMED-VARS) (IL:* IL:\; + "Add new variable to the list AFTER we have walked the initial value form ") + (WHEN LEFTOVER-BODY + + (IL:* IL:|;;| "Previous clause had some computation to do after its bindings. Here is the first opportunity to do it ") + + (SETQ VALUEFORM `(PROGN ,@LEFTOVER-BODY ,VALUEFORM)) + (SETQ LEFTOVER-BODY NIL)) + (LIST NEWVAR VALUEFORM))) + LET-BINDINGS) + RENAMED-VARS))) + +(DEFUN RENAME-VARIABLES (FORM ALIST ENV) + + (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values. ENV is FORM's environment, so we can make sure we are talking about the same variables. ") + + (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV) + (DECLARE (IGNORE CONTEXT)) + (LET (PAIR) + (COND + ((AND (SYMBOLP FORM) + (SETQ PAIR (ASSOC FORM ALIST)) + (VARIABLE-SAME-P FORM SUBENV ENV)) + (CDR PAIR)) + (T FORM)))))) + +(DEFUN MV-SETQ (VARS EXPR) + + (IL:* IL:|;;| "Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some of the simple cases for benefit of compilers that don't, and I don't care what the value is, and I know that the variables need not be set in parallel, since they can't be used free in EXPR ") + + (COND + ((NULL VARS) (IL:* IL:\; "EXPR is a side-effect") + EXPR) + ((NOT (CONSP VARS)) (IL:* IL:\; + "This is an error, but I'll let MULTIPLE-VALUE-SETQ report it ") + `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR)) + ((AND (LISTP EXPR) + (EQ (CAR EXPR) + 'VALUES)) + + (IL:* IL:|;;| "(mv-setq (a b c) (values x y z)) can be reduced to a parallel setq (psetq returns nil, but I don't care about returned value). Do this even for the single variable case so that we catch (mv-setq (a) (values x y)) ") + + (POP EXPR) (IL:* IL:\; "VALUES") + `(SETQ ,@(MAPCON #'(LAMBDA (TAIL) + (LIST (CAR TAIL) + (COND + ((OR (CDR TAIL) + (NULL (CDR EXPR))) + (IL:* IL:\; + "One result expression for this var ") + (POP EXPR)) + (T (IL:* IL:\; + "More expressions than vars, so arrange to evaluate all the rest now. ") + (CONS 'PROG1 EXPR))))) + VARS))) + ((NULL (CDR VARS)) (IL:* IL:\; "Simple one variable case") + `(SETQ ,(CAR VARS) + ,EXPR)) + (T (IL:* IL:\; + "General case--I know nothing") + `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR)))) + +(DEFUN VARIABLE-SAME-P (VAR ENV1 ENV2) + (EQ (VARIABLE-LEXICAL-P VAR ENV1) + (VARIABLE-LEXICAL-P VAR ENV2))) + +(DEFUN MAYBE-WARN (TYPE &REST WARN-ARGS) + + (IL:* IL:|;;| "Issue a warning about not being able to optimize this thing. TYPE is one of :DEFINITION, meaning the definition is at fault, and :USER, meaning the user's code is at fault. ") + + (WHEN (CASE *ITERATE-WARNINGS* + ((NIL) NIL) + ((:USER) (EQ TYPE :USER)) + (T T)) + (APPLY #'WARN WARN-ARGS))) + + + +(IL:* IL:|;;| "Sample iterators") + + +(DEFMACRO INTERVAL (&WHOLE WHOLE &KEY FROM DOWNFROM TO DOWNTO ABOVE BELOW BY TYPE) + (COND + ((AND FROM DOWNFROM) + (ERROR "Can't use both FROM and DOWNFROM in ~S" WHOLE)) + ((CDR (REMOVE NIL (LIST TO DOWNTO ABOVE BELOW))) + (ERROR "Can't use more than one limit keyword in ~S" WHOLE)) + (T + (LET* + ((DOWN (OR DOWNFROM DOWNTO ABOVE)) + (LIMIT (OR TO DOWNTO ABOVE BELOW)) + (INC (COND + ((NULL BY) + 1) + ((CONSTANTP BY) (IL:* IL:\; + "Can inline this increment") + BY)))) + `(LET ((FROM ,(OR FROM DOWNFROM 0)) + ,@(AND LIMIT `((TO ,LIMIT))) + ,@(AND (NULL INC) + `((BY ,BY)))) + ,@(AND TYPE `((DECLARE (TYPE ,TYPE FROM ,@(AND LIMIT '(TO)) + ,@(AND (NULL INC) + `(BY)))))) + #'(LAMBDA (FINISH) + ,@(COND + ((NULL LIMIT) (IL:* IL:\; + "We won't use the FINISH arg") + '((DECLARE (IGNORE FINISH))))) + (PROG1 ,(COND + (LIMIT (IL:* IL:\; + "Test the limit. If ok, return current value and increment, else quit ") + `(IF (,(COND + (ABOVE '>) + (BELOW '<) + (DOWN '>=) + (T '<=)) + FROM TO) + FROM + (FUNCALL FINISH))) + (T (IL:* IL:\; "No test") + 'FROM)) + (SETQ FROM (,(IF DOWN + '- + '+) + FROM + ,(OR INC 'BY)))))))))) + +(DEFMACRO LIST-ELEMENTS (LIST &KEY (BY '#'CDR)) + `(LET ((TAIL ,LIST)) + #'(LAMBDA (FINISH) + (PROG1 (IF (ENDP TAIL) + (FUNCALL FINISH) + (FIRST TAIL)) + (SETQ TAIL (FUNCALL ,BY TAIL)))))) + +(DEFMACRO LIST-TAILS (LIST &KEY (BY '#'CDR)) + `(LET ((TAIL ,LIST)) + #'(LAMBDA (FINISH) + (PROG1 (IF (ENDP TAIL) + (FUNCALL FINISH) + TAIL) + (SETQ TAIL (FUNCALL ,BY TAIL)))))) + +(DEFMACRO ELEMENTS (SEQUENCE) + "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type." + (LET* ((TYPE (AND (CONSP SEQUENCE) + (EQ (FIRST SEQUENCE) + 'THE) + (SECOND SEQUENCE))) + (ACCESSOR (IF TYPE + (SEQUENCE-ACCESSOR TYPE) + 'ELT)) + (LISTP (EQ TYPE 'LIST))) + + (IL:* IL:|;;| "If type is given via THE, we may be able to generate a good accessor here for the benefit of implementations that aren't smart about (ELT (THE STRING FOO)). I'm not bothering to keep the THE inside the body, however, since I assume any compiler that would understand (AREF (THE SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I bound S to (THE SIMPLE-ARRAY foo) and never modified it. If sequence is declared to be a list, it's better to cdr down it, so we have some extra cases here. Normally folks would write LIST-ELEMENTS, but maybe they wanted to get the index for free... ") + + `(LET* ((INDEX 0) + (S ,SEQUENCE) + ,@(AND (NOT LISTP) + '((SIZE (LENGTH S))))) + #'(LAMBDA (FINISH) + (VALUES (COND + ,(IF LISTP + '((NOT (ENDP S)) + (POP S)) + `((< INDEX SIZE) + (,ACCESSOR S INDEX))) + (T (FUNCALL FINISH))) + (PROG1 INDEX + (SETQ INDEX (1+ INDEX)))))))) + +(DEFMACRO PLIST-ELEMENTS (PLIST) + "Generates each time 2 items, the indicator and the value." + `(LET ((TAIL ,PLIST)) + #'(LAMBDA (FINISH) + (VALUES (IF (ENDP TAIL) + (FUNCALL FINISH) + (FIRST TAIL)) + (PROG1 (IF (ENDP (SETQ TAIL (CDR TAIL))) + (FUNCALL FINISH) + (FIRST TAIL)) + (SETQ TAIL (CDR TAIL))))))) + +(DEFUN SEQUENCE-ACCESSOR (TYPE) + + (IL:* IL:|;;| + "returns the function with which most efficiently to make accesses to a sequence of type TYPE. ") + + (CASE (IF (CONSP TYPE) (IL:* IL:\; "e.g., (VECTOR FLOAT *)") + (CAR TYPE) + TYPE) + ((ARRAY SIMPLE-ARRAY VECTOR) 'AREF) + (SIMPLE-VECTOR 'SVREF) + (STRING 'CHAR) + (SIMPLE-STRING 'SCHAR) + (BIT-VECTOR 'BIT) + (SIMPLE-BIT-VECTOR 'SBIT) + (T 'ELT))) + + + +(IL:* IL:|;;| "These \"iterators\" may be withdrawn") + + +(DEFMACRO EACHTIME (EXPR) + `#'(LAMBDA (FINISH) + (DECLARE (IGNORE FINISH)) + ,EXPR)) + +(DEFMACRO WHILE (EXPR) + `#'(LAMBDA (FINISH) + (UNLESS ,EXPR (FUNCALL FINISH)))) + +(DEFMACRO UNTIL (EXPR) + `#'(LAMBDA (FINISH) + (WHEN ,EXPR (FUNCALL FINISH)))) + + + +(IL:* IL:\; "GATHERING macro") + + +(DEFMACRO GATHERING (CLAUSES &BODY BODY &ENVIRONMENT ENV) + (OR (OPTIMIZE-GATHERING-FORM CLAUSES BODY ENV) + (SIMPLE-EXPAND-GATHERING-FORM CLAUSES BODY ENV))) + +(DEFMACRO WITH-GATHERING (CLAUSES GATHER-BODY &BODY USE-BODY) + "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour." + + (IL:* IL:|;;| "We may optimize this a little better later for those compilers that don't do a good job on (m-v-bind vars (... (values ...)) ...). ") + + `(MULTIPLE-VALUE-BIND ,(MAPCAR #'CAR CLAUSES) + (GATHERING ,CLAUSES ,GATHER-BODY) + ,@USE-BODY)) + +(DEFUN SIMPLE-EXPAND-GATHERING-FORM (CLAUSES BODY ENV) + (DECLARE (IGNORE ENV)) + + (IL:* IL:|;;| + "The \"formal semantics\" of GATHERING. We use this only in cases that can't be optimized. ") + + (LET + ((ACC-NAMES (MAPCAR #'FIRST (IF (SYMBOLP CLAUSES) (IL:* IL:\; + "Shorthand using anonymous gathering site ") + (SETQ CLAUSES `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES)))) + CLAUSES))) + (REALIZER-NAMES (MAPCAR #'(LAMBDA (BINDING) + (DECLARE (IGNORE BINDING)) + (GENSYM)) + CLAUSES))) + `(MULTIPLE-VALUE-CALL + #'(LAMBDA ,(MAPCAN #'LIST ACC-NAMES REALIZER-NAMES) + (FLET ((GATHER (VALUE &OPTIONAL (ACCUMULATOR *ANONYMOUS-GATHERING-SITE*)) + (FUNCALL ACCUMULATOR VALUE))) + ,@BODY + (VALUES ,@(MAPCAR #'(LAMBDA (RNAME) + `(FUNCALL ,RNAME)) + REALIZER-NAMES)))) + ,@(MAPCAR #'SECOND CLAUSES)))) + +(DEFVAR *ACTIVE-GATHERERS* NIL + "List of GATHERING bindings currently active during macro expansion)") + +(DEFVAR *ANONYMOUS-GATHERING-SITE* NIL + "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)." +) + +(DEFUN OPTIMIZE-GATHERING-FORM (CLAUSES BODY GATHERING-ENV) + (LET* + (ACC-INFO LEFTOVER-BODY TOP-BINDINGS FINISH-FORMS TOP-DECLS) + (DOLIST (CLAUSE (IF (SYMBOLP CLAUSES) (IL:* IL:\; "A shorthand") + `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES))) + CLAUSES)) + (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY) + (EXPAND-INTO-LET (SECOND CLAUSE) + 'GATHERING GATHERING-ENV) + (PROG* ((ACC-VAR (FIRST CLAUSE)) + RENAMED-VARS ACCUMULATOR REALIZER) + (WHEN (AND (CONSP LET-BODY) + (EQ (CAR LET-BODY) + 'VALUES) + (CONSP (SETQ LET-BODY (CDR LET-BODY))) + (SETQ ACCUMULATOR (FUNCTION-LAMBDA-P (CAR LET-BODY))) + (CONSP (SETQ LET-BODY (CDR LET-BODY))) + (SETQ REALIZER (FUNCTION-LAMBDA-P (CAR LET-BODY) + 0)) + (NULL (CDR LET-BODY))) + + (IL:* IL:|;;| "Macro returned something of the form (VALUES #'(lambda (value)") + + (IL:* IL:|;;| + "..) #'(lambda () ...)), a function to accumulate values and a function to realize the result. ") + + (WHEN BINDING-TYPE + + (IL:* IL:|;;| "Gatherer expanded into a LET") + + (COND + (OTHERDECLS (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S" + (SECOND CLAUSE) + `(DECLARE ,@OTHERDECLS)) + (GO PUNT))) + (WHEN LET-BINDINGS + + (IL:* IL:|;;| "The first transformation we want to perform is a variant of \"LET-eversion\": turn (mv-bind (acc real) (let (..bindings..) (values #'(lambda ...) #'(lambda ") + + (IL:* IL:|;;| "..))) ..body..) into (let* (..bindings.. (acc #'(lambda ...)) (real #'(lambda ...))) ..body..). This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var). Of course, none of those vars can be special, but we already checked for that above. ") + + (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS) + (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE GATHERING-ENV + LEFTOVER-BODY)) + (SETQ TOP-BINDINGS (NCONC TOP-BINDINGS LET-BINDINGS)) + (SETQ LEFTOVER-BODY NIL) (IL:* IL:\; + "If there was any leftover from previous, it is now consumed ") + )) + (SETQ LEFTOVER-BODY (NCONC LEFTOVER-BODY EXTRA-BODY)) + (IL:* IL:\; + "Computation to do after these bindings ") + (PUSH (CONS ACC-VAR (RENAME-AND-CAPTURE-VARIABLES ACCUMULATOR RENAMED-VARS + GATHERING-ENV)) + ACC-INFO) + (SETQ REALIZER (RENAME-VARIABLES REALIZER RENAMED-VARS GATHERING-ENV)) + (PUSH (COND + ((NULL (CDDDR REALIZER)) (IL:* IL:\; + "Simple (LAMBDA () expr) => expr ") + (THIRD REALIZER)) + (T (IL:* IL:\; + "There could be declarations or something, so leave as a LET ") + (CONS 'LET (CDR REALIZER)))) + FINISH-FORMS) + (UNLESS (NULL LOCALDECLS) (IL:* IL:\; + "Declarations about the LET variables also has to percolate up ") + (SETQ TOP-DECLS (NCONC TOP-DECLS (SUBLIS RENAMED-VARS LOCALDECLS)))) + (RETURN)) + (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))" + (SECOND CLAUSE)) + PUNT + (LET ((GS (GENSYM)) + (EXPANSION `(MULTIPLE-VALUE-LIST ,(SECOND CLAUSE)))) + (IL:* IL:\; + "Slow way--bind gensym to the macro expansion, and we will funcall it in the body ") + (PUSH (LIST ACC-VAR GS) + ACC-INFO) + (PUSH `(FUNCALL (CADR ,GS)) + FINISH-FORMS) + (SETQ TOP-BINDINGS + (NCONC TOP-BINDINGS + (LIST (LIST GS + (COND + (LEFTOVER-BODY + `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ LEFTOVER-BODY + NIL)) + ,EXPANSION)) + (T EXPANSION)))))))))) + (SETQ BODY (WALK-GATHERING-BODY BODY GATHERING-ENV ACC-INFO)) + (COND + ((EQ BODY :ABORT) (IL:* IL:\; + "Couldn't finish expansion") + NIL) + (T `(LET* ,TOP-BINDINGS ,@(AND TOP-DECLS `((DECLARE ,@TOP-DECLS))) + ,BODY + ,(COND + ((NULL (CDR FINISH-FORMS)) (IL:* IL:\; "just a single value") + (CAR FINISH-FORMS)) + (T `(VALUES ,@(REVERSE FINISH-FORMS))))))))) + +(DEFUN RENAME-AND-CAPTURE-VARIABLES (FORM ALIST ENV) + + (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values, and capturing any other free variables. Returns a list of the new form and the list of other closed-over vars. ENV is FORM's environment, so we can make sure we are talking about the same variables. ") + + (LET (CLOSED) + (LIST (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV) + (DECLARE (IGNORE CONTEXT)) + (LET (PAIR) + (COND + ((OR (NOT (SYMBOLP FORM)) + (NOT (VARIABLE-SAME-P FORM SUBENV ENV))) + (IL:* IL:\; + "non-variable or one that has been rebound ") + FORM) + ((SETQ PAIR (ASSOC FORM ALIST)) + (IL:* IL:\; "One to rename") + (CDR PAIR)) + (T (IL:* IL:\; "var is free") + (PUSHNEW FORM CLOSED) + FORM))))) + CLOSED))) + +(DEFUN WALK-GATHERING-BODY (BODY GATHERING-ENV ACC-INFO) + + (IL:* IL:|;;| "Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. ACC-INFO is a list of information about each of the gathering \"bindings\" in the form, in the form (var gatheringfn freevars env) ") + + (LET ((*ACTIVE-GATHERERS* (NCONC (MAPCAR #'CAR ACC-INFO) + *ACTIVE-GATHERERS*))) + + (IL:* IL:|;;| "*ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER targets. This is so that when we encounter a GATHER not belonging to us we can know whether to warn about it. ") + + (WALK-FORM + (CONS 'PROGN BODY) + GATHERING-ENV + #'(LAMBDA (FORM CONTEXT ENV) + (DECLARE (IGNORE CONTEXT)) + (LET (INFO SITE) + (COND + ((CONSP FORM) + (COND + ((NOT (EQ (CAR FORM) + 'GATHER)) (IL:* IL:\; + "We only care about GATHER") + (WHEN (AND (EQ (CAR FORM) + 'FUNCTION) + (EQ (CADR FORM) + 'GATHER)) (IL:* IL:\; + "Passed as functional--can't macroexpand ") + (MAYBE-WARN :USER + "Can't optimize GATHERING because of reference to #'GATHER." + ) + (RETURN-FROM WALK-GATHERING-BODY :ABORT)) + FORM) + ((SETQ INFO (ASSOC (SETQ SITE (IF (NULL (CDDR FORM)) + '*ANONYMOUS-GATHERING-SITE* + (THIRD FORM))) + ACC-INFO)) (IL:* IL:\; + "One of ours--expand (GATHER value var). INFO = (var gatheringfn freevars env) ") + (UNLESS (NULL (CDDDR FORM)) + (WARN "Extra arguments (> 2) in ~S discarded." FORM)) + (LET ((FN (SECOND INFO))) + (COND + ((SYMBOLP FN) (IL:* IL:\; "Unoptimized case--just call the gatherer. FN is the gensym that we bound to the list of two values returned from the gatherer. ") + `(FUNCALL (CAR ,FN) + ,(SECOND FORM))) + (T (IL:* IL:\; + "FN = (lambda (value) ...)") + (DOLIST (S (THIRD INFO)) + (UNLESS (OR (VARIABLE-SAME-P S ENV GATHERING-ENV) + (AND (VARIABLE-SPECIAL-P S ENV) + (VARIABLE-SPECIAL-P S GATHERING-ENV))) + + (IL:* IL:|;;| "Some var used free in the LAMBDA form has been rebound between here and the parent GATHERING form, so can't substitute the lambda. Ok if it's a special reference both here and in the LAMBDA, because then it's not closed over. ") + + (MAYBE-WARN :USER "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it." + S) + (RETURN-FROM WALK-GATHERING-BODY :ABORT))) + + (IL:* IL:|;;| "Return ((lambda (value) ...) actual-value). In many cases we could simplify this further by substitution, but we'd have to be careful (for example, we would need to alpha-convert any LET we found inside). Any decent compiler will do it for us. ") + + (LIST FN (SECOND FORM)))))) + ((AND (SETQ INFO (MEMBER SITE *ACTIVE-GATHERERS*)) + (OR (EQ SITE '*ANONYMOUS-GATHERING-SITE*) + (VARIABLE-SAME-P SITE ENV (FOURTH INFO)))) + (IL:* IL:\; "Some other GATHERING will take care of this form, so pass it up for now. Environment check is to make sure nobody shadowed it between here and there ") + FORM) + (T (IL:* IL:\; + "Nobody's going to handle it") + (IF (EQ SITE '*ANONYMOUS-GATHERING-SITE*) + (IL:* IL:\; + "More likely that she forgot to mention the site than forget to write an anonymous gathering. ") + (WARN "There is no gathering site specified in ~S." FORM) + (WARN + "The site ~S in ~S is not defined in an enclosing GATHERING form." + SITE FORM)) (IL:* IL:\; + "Turn it into something else so we don't warn twice in the nested case ") + `(%ORPHANED-GATHER ,@(CDR FORM))))) + ((AND (SYMBOLP FORM) + (SETQ INFO (ASSOC FORM ACC-INFO)) + (VARIABLE-SAME-P FORM ENV GATHERING-ENV)) + (IL:* IL:\; + "A variable reference to a gather binding from environment TEM ") + (MAYBE-WARN :USER + "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form." + FORM) + (RETURN-FROM WALK-GATHERING-BODY :ABORT)) + (T FORM))))))) + + + +(IL:* IL:|;;| "Sample gatherers") + + +(DEFMACRO COLLECTING (&KEY INITIAL-VALUE) + `(LET* ((HEAD ,INITIAL-VALUE) + (TAIL ,(AND INITIAL-VALUE `(LAST HEAD)))) + (VALUES #'(LAMBDA (VALUE) + (IF (NULL HEAD) + (SETQ HEAD (SETQ TAIL (LIST VALUE))) + (SETQ TAIL (CDR (RPLACD TAIL (LIST VALUE)))))) + #'(LAMBDA NIL HEAD)))) + +(DEFMACRO JOINING (&KEY INITIAL-VALUE) + `(LET ((RESULT ,INITIAL-VALUE)) + (VALUES #'(LAMBDA (VALUE) + (SETQ RESULT (NCONC RESULT VALUE))) + #'(LAMBDA NIL RESULT)))) + +(DEFMACRO MAXIMIZING (&KEY INITIAL-VALUE) + `(LET ((RESULT ,INITIAL-VALUE)) + (VALUES #'(LAMBDA (VALUE) + (WHEN ,(COND + ((AND (CONSTANTP INITIAL-VALUE) + (NOT (NULL (EVAL INITIAL-VALUE)))) + (IL:* IL:\; + "Initial value is given and we know it's not NIL, so leave out the null check ") + '(> VALUE RESULT)) + (T '(OR (NULL RESULT) + (> VALUE RESULT)))) + (SETQ RESULT VALUE))) + #'(LAMBDA NIL RESULT)))) + +(DEFMACRO MINIMIZING (&KEY INITIAL-VALUE) + `(LET ((RESULT ,INITIAL-VALUE)) + (VALUES #'(LAMBDA (VALUE) + (WHEN ,(COND + ((AND (CONSTANTP INITIAL-VALUE) + (NOT (NULL (EVAL INITIAL-VALUE)))) + (IL:* IL:\; + "Initial value is given and we know it's not NIL, so leave out the null check ") + '(< VALUE RESULT)) + (T '(OR (NULL RESULT) + (< VALUE RESULT)))) + (SETQ RESULT VALUE))) + #'(LAMBDA NIL RESULT)))) + +(DEFMACRO SUMMING (&KEY (INITIAL-VALUE 0)) + `(LET ((SUM ,INITIAL-VALUE)) + (VALUES #'(LAMBDA (VALUE) + (SETQ SUM (+ SUM VALUE))) + #'(LAMBDA NIL SUM)))) + + + +(IL:* IL:\; "Easier to read expanded code if PROG1 gets left alone ") + + +(XCL:DEFINE-FILE-ENVIRONMENT "ITERATE" :PACKAGE (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER)) + :READTABLE "XCL" + :BASE 10 + :COMPILER :COMPILE-FILE) +(IL:PUTPROPS IL:ITERATE IL:COPYRIGHT ("Venue" 1991)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL))) +IL:STOP diff --git a/clos/3.5/lap.dfasl b/clos/3.5/lap.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..e100f6db0d603af04cc05aa5bbbe0c511445f5a6 GIT binary patch literal 16273 zcmdU0Yit|WmF68jB$<{%J^WJSgo#rnc1+ij9NTglmm_i{j`$dcL+W9>v1N%imB^AK z$!XFghLfhBN2NEb*KFq$9T zKWX-ybMK{w6h%jt5@3aR9(V4{eBXK9bIvexj@qG6%paOMadLbjJMEu3HGA^ZtpC{5 zw0~ym)bwc9e+M?vCyL?tLA*_I2*wQQxbYF^)#w);m2;_w4eAv!nc;&Yhh*x5J(L zc0IJObI*?YPrhGx)vSSOd`&4!UnV!H4g}=|&_GS{Hv~DB{ z=hzwMDg0f2jh+Z3)lgLJ(;SQy@-8IhsPM=wVXb#SP5HOQ)udH<3@wgWVB3p2G=8guhnR6@iK=Z@GFJ<+WYQ{tD%$;=rvODLcUp^YKZ|o zWhBtc5Fy%N`*A#?%^Ezqv2acX@5Mnhc(e(6sQ*@E@D6UHiob9^Uz5zF!Az50IBqtz zbZJCs2nA9s)a$9^mTm49J7D zIBkb6|loTE*TOEslc}&DUuv*)*|^_Yip~|VeNrnu{@gR=yBkJ4MluA3W_g_*aOTs7^fZMG;W3tXI|L(l zOzqKPZ5S3}Mo5jthS@zLOoTOv8!4@D&Iwm*jbvJn>j&TzV~EF8d$shigP*w}qG(~~ z@~j2Dm|KfY!gj;39`st6Cf!f0oq2|Ek<4N{N+%4vIbp#+=p(){m2N*B$r%Nd1T2}bTbaH%bG ztv^D`@%3nIjkdOf4S+^7N>mD?KP4|X#L z6Im4|?&;yA#+p#4VGWE=V_U%%oPZLNJ-Xo)K++jB6-F-~`Z2i&l?*o`CTqQ7>KkvE zS0Zx4RbA=d$l!%e@xoV}B`?HBJKO2WZ#JS1wN%PTxe-80HBBSrU~3Ec2h`cw?1_`J zP>=YJO=q+IkxBol$&rbPsZpwnrnAS#XJ)h0J23LIyKI<976fl-F5=6LB6kKB(zKAf zFD!7Qk^?r1kQAXWTZRw_cgQCqB-v_P1W0Z^_Z);((aRodH>SDNE9Zl4>G+7-HEPEu@-SpjXvnYv{EXohPjLZj|bP z7J?G+3!osko(OA0koz3~N1<6)X?x{`G|$TS+qBP&!Wr=U?*R{9m+2e5x?gK()D%gw{nOY(hR=$gh(j1QY(^6?^y~ zdjGf(IzF(6jt@R{2;+SLVOjL*lD>kxQ0>hh+TZ*ky?L)KRFT+=!E-?qG(@KpcTxN) zhE*;PEv`c)m#QF-;*|wduAN|2chLGCQO!sojm?PraLgQz_ZYE&>^3zP<>tag$z?)) za5v0Tv`1UGa}e+Wkihgt?kNEscz7z)>1xXC*-E8+N8V z<}l=+(AC-k-HXJOf9mAu)L7O(IdTFTeWy)`OmJU~Fd+2(+h+hi$XvI>g2?=p)&@`* zB5fh0*=gwbltJ~03>(Z}*6n~9-T(WdhGbVs!1|z%Joj4v_1rtTpXH$c6T1+f-&~9C z3McXN38SI?XWuXya;=X+hv@qJA9z|z7Dta*Fhw1fIXZ)IOo=Wodwd{PVOBp}j=>C^ zMH|p_Ey%fPTRNgqFH-g~!J&{n^VTl6?WEj~VG=4Bu-_(lcD=A;9_cM_9m?dJB-(S& z^WD=h&07>)pu_S$3D0oDNG5TFPZ{JpT=E)Xh8hkOr(50#Os>-)76%3+u(Vi5lsFHl zE}RJ$U3hU#ftnD0gBu!!*H7IVYl7GDW=HY8s4m`SQ2Zs)wXQft1Xkvyz{>8ztQUHB zqgL>gPAlq^qwnDczHqowW3Da0h0wuAKZP4VF#fEXm zf?)_5(sIn!OOv1*H_&z?n8R9FqQD%uH!sf~pcu5<1HEoZgIKeGUs?pTHc@V0tZWf< zZC&A2=hmRvW=o!Z!L&-T<3{ju>Pj%Rc}{;ZqPLE^isAZ0C^XP&K5)8df0I8-aoQ6l zVShEfi2w$21#4Jr;bOEF8L5LoLfMJ(;cW_2)*O%KFE~XC9v# zpPZ#=ID`2l^4fYk*gp{1KP5^467rpHiR2sPA;H7-Em z04F=-s_O2?$QCk^!}yIPjjdx}D58a;kXT`BH~`D4MRs^sY=`>0@+`Bm+PGbo+eb}x#K!`mx2FKxn0v`V%(A}vaf zLix=6dKw~?e5>aPI*A14ay;jO9#XJ}GC85GK9HVM6f!d3Dde3157dTwa;6ca>3x0Ci#43IkhD645TJ?|5_$Q}k z{Zq&Mv(KE&V)oMoy{W<62vqzy0M}=8<1=4Y+TcAt@wqN6za8?d{oCaD>_AXt9Y5rK zkekD2_4$-IK5({wzE>O{JR6eQmy+FGnd!kfblf?Ide;d;rTKnF1^!oDVj( z@V`78qAcnMB+$!V6#IFw90tYlGuWsT?lW!$2jR3HKPEySk$=?d$HbUEGs6L@uM-FG zTT(k7z&E~L%$;jP(D+NMiF5-_3x!iW_q{+bexq=XN0$qTfE}mpG1_KnJ4V}4+8(9t zh!v#$5$^j3{B$+n_M1M@uPq3s0NbiNZNI@jp#l%9z=6{0TJjEH|>JxRIT~FJz4islTY^miRRT z&tDl&_17sLTwr)oM8#N7N>ihjmjN6%9ZM_xI=rNwUc%Q&5jMY$b}F99tEOf~T4OKq zzVk|e-C+l&Y4DL0ak+ZnP{Mk-GOU-Eg!Q*8hh>*nGNmV=jYRUIV+m{yfHjf4DE0*@ zNf1Jt19Y|)w7ais@1DIPqn6@33qLbC$L;?DC910>$ha{8ADBsycqs9{0eG8jcvbu2 z_yz#BwcQACH+Td9-@B95lTk|G-$UTsV~+?!cAU2vFOQ(yQ$|+ItlnlK+M}Eov_~YX zi@<7~omEdgd?LgiFk!w3hqgtZ_;d(fonqg`?kM5+Bjo3l{XILgV-*Lj;EG8$*hnTM zOD7yjnm?^h^QRSP?h^DK68qg{G~fRGY1-W#qUR&RO7TzH0HyUOVN=VwQ!*94yl2!-MT3li%9l)q!iJ^3^B$wYxwU5X-c!dfz8QLz^au+11y;Wqr zw}Py930XhD%OJ-EZX57S_WTN5jiVK=#?fL=L%?NY60TYWu37=^L#1%p*aFLLST8$Pgv_2>G2{()$e1Gzrtk|P3L3(K*ES;I zXRE-^R)F7KDsg22{whek1U}}3rSNSd68=;b_}CRFTeUmnsx73ioGeOz72vnorC&_{ zN;vq+hb56`st|dm0ui~0OCn!eO(L7^L>98W5+;p{#w8W(V=a|QVKb{-CvvTqR9;$5 zDx#9&PHeyj`BbS<)t8J(3g4+h;X4&5$mL&Bcx5#ytSi+r8|$x&w)W{=drt!w{N;Tc?Yt) zvr}}cq#k~OOn3!Hdf?hv1wJKtn%?msr{jbp$>zN(#{V8rDT|t&n z>SJ%Vhk89`^uaGcIe{8+CRzNc8jC+wU?H5hv&?yw|M?tP3>hK=B^GcdS^T9Mi@z*p z(Ip(XOZH!-9sTd>vuG;Og&EO%MG*4nbRsx7l`0&ZN(BzQ>Dt{To34U`(^W zWDmwf>&sDzz8=sokuEsv0eo55=_*SX*ii({pSkk#r6gG^`OSgEJtA?huY!Ah1>9x1 T0vlPtecJIlEV<6jpM3Iv6D>A; literal 0 HcmV?d00001 diff --git a/clos/3.5/lap.lisp b/clos/3.5/lap.lisp new file mode 100644 index 00000000..4dceda84 --- /dev/null +++ b/clos/3.5/lap.lisp @@ -0,0 +1,364 @@ +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + + +;;;. Copyright (c) 1991 by Venue + +(in-package "CLOS") + +;;; This file defines CLOS's interface to the LAP mechanism. The file is divided into two parts. The +;;; first part defines the interface used by CLOS to create abstract LAP code vectors. CLOS never +;;; creates lists that represent LAP code directly, it always calls this mechanism to do so. This +;;; provides a layer of error checking on the LAP code before it gets to the implementation-specific +;;; assembler. Note that this error checking is syntactic only, but even so is useful to have. +;;; Because of it, no specific LAP assembler should worry itself with checking the syntax of the LAP +;;; code. The second part of the file defines the LAP assemblers for each CLOS port. These are +;;; included together in the same file to make it easier to change them all should some random +;;; change be made in the LAP mechanism. + + +(defvar *make-lap-closure-generator*) + +(defvar *precompile-lap-closure-generator*) + +(defvar *lap-in-lisp*) + +(defun make-lap-closure-generator (closure-variables arguments iregs vregs tregs lap-code) + (funcall *make-lap-closure-generator* closure-variables arguments iregs vregs tregs lap-code)) + +(defmacro precompile-lap-closure-generator (cvars args i-regs v-regs t-regs lap) + (funcall *precompile-lap-closure-generator* cvars args i-regs v-regs t-regs lap)) + +(defmacro lap-in-lisp (cvars args iregs vregs tregs lap) + (declare (ignore cvars args)) + `(locally (declare (optimize (safety 0) + (speed 3))) + ,(make-lap-prog iregs vregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp))) + )) + + +;;; The following functions and macros are used by CLOS when generating LAP code: GENERATING-LAP +;;; WITH-LAP-REGISTERS ALLOCATE-REGISTER DEALLOCATE-REGISTER LAP-FLATTEN OPCODE OPERAND + + +(proclaim '(special *generating-lap*)) + + ; CAR - alist of free registers CADR + ; - alist of allocated registers CADDR + ; - max reg number allocated in each + ; alist, the entries have the form: + ; (type . (:REG )) + + + +;;; This goes around the generation of any lap code. should return a lap code sequence, this +;;; macro will take care of converting that to a lap closure generator. + + +(defmacro generating-lap (closure-variables arguments &body body) + `(let* ((*generating-lap* (list nil nil -1))) + (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body)))) + +(defmacro generating-lap-in-lisp (closure-variables arguments &body body) + `(let* ((*generating-lap* (list nil nil -1))) + (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body)))) + + +;;; Each register specification looks like: ( &key :reuse ) + + +(defmacro with-lap-registers (register-specifications &body body) + + ;; Given that, for now, there is only one keyword argument and that, for now, we do no error + ;; checking, we can be pretty sleazy about how this works. + (flet ((make-allocations + nil + (gathering1 (collecting) + (dolist (spec register-specifications) + (gather1 `(,(car spec) + (or ,(cadddr spec) + (allocate-register ',(cadr spec)))))))) + (make-deallocations nil (gathering1 + (collecting) + (dolist (spec register-specifications) + (gather1 `(unless ,(cadddr spec) + (deallocate-register ,(car spec)))))))) + `(let ,(make-allocations) + (multiple-value-prog1 (progn ,@body) + ,@(make-deallocations))))) + +(defun allocate-register (type) + (destructuring-bind (free allocated) + *generating-lap* + (let ((entry (assoc type free))) + (cond (entry (setf (car *generating-lap*) + (delete entry free) + (cadr *generating-lap*) + (cons entry allocated)) + (cdr entry)) + (t (let ((new `(,type :reg ,(incf (caddr *generating-lap*))))) + (setf (cadr *generating-lap*) + (cons new allocated)) + (cdr new))))))) + +(defun deallocate-register (reg) + (let ((entry (rassoc reg (cadr *generating-lap*)))) + (unless entry (error "Attempt to free an unallocated register.")) + (push entry (car *generating-lap*)) + (setf (cadr *generating-lap*) + (delete entry (cadr *generating-lap*))))) + +(defvar *precompiling-lap* nil) + +(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code) + (when (cadr *generating-lap*) + (error "Registers still allocated when lap being finalized.")) + (let ((iregs nil) + (vregs nil) + (tregs nil)) + (dolist (entry (car *generating-lap*)) + (ecase (car entry) + (index (push (caddr entry) + iregs)) + (vector (push (caddr entry) + vregs)) + ((t) (push (caddr entry) + tregs)))) + (cond (in-lisp-p (macroexpand `(lap-in-lisp ,closure-variables ,arguments ,iregs + ,vregs + ,tregs + ,lap-code))) + (*precompiling-lap* (values closure-variables arguments iregs vregs tregs lap-code) + ) + (t (make-lap-closure-generator closure-variables arguments iregs vregs tregs + lap-code))))) + +(defun flatten-lap (&rest opcodes-or-sequences) + (let ((result nil)) + (dolist (opcode-or-sequence opcodes-or-sequences result) + (cond ((null opcode-or-sequence)) + ((not (consp (car opcode-or-sequence))) + ; its an opcode + (setf result (append result (list opcode-or-sequence)))) + (t (setf result (append result opcode-or-sequence))))))) + +(defmacro flattening-lap nil '(let ((result nil)) + (values #'(lambda (value) + (push value result)) + #'(lambda nil (apply #'flatten-lap (reverse result)))))) + + +;;; This code deals with the syntax of the individual opcodes and operands. The first two of these +;;; variables are documented to all ports. They are lists of the symbols which name the lap opcodes +;;; and operands. They can be useful to determine whether a port has implemented all the required +;;; opcodes and operands. The third of these variables is for use of the emitter only. + + +(defvar *lap-operands* nil) + +(defvar *lap-opcodes* nil) + +(defvar *lap-emitters* (make-hash-table :test #'eq :size 30)) + +(defun opcode (name &rest args) + (let ((emitter (gethash name *lap-emitters*))) + (if emitter + (apply emitter args) + (error "No opcode named ~S." name)))) + +(defun operand (name &rest args) + (let ((emitter (gethash name *lap-emitters*))) + (if emitter + (apply emitter args) + (error "No operand named ~S." name)))) + +(defmacro defopcode (name types) + (let ((fn-name (symbol-append "LAP Opcode " name *the-clos-package*)) + (lambda-list (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + types))) + `(progn (eval-when (load eval) + (load-defopcode ',name ',fn-name)) + (defun ,fn-name ,lambda-list (defopcode-1 ',name ',types ,@lambda-list))))) + +(defmacro defoperand (name types) + (let ((fn-name (symbol-append "LAP Operand " name *the-clos-package*)) + (lambda-list (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + types))) + `(progn (eval-when (load eval) + (load-defoperand ',name ',fn-name)) + (defun ,fn-name ,lambda-list (defoperand-1 ',name ',types ,@lambda-list))))) + +(defun load-defopcode (name fn-name) + (if* (memq name *lap-operands*) + (error "LAP opcodes and operands must have disjoint names.") + (setf (gethash name *lap-emitters*) + fn-name) + (pushnew name *lap-opcodes*))) + +(defun load-defoperand (name fn-name) + (if* (memq name *lap-opcodes*) + (error "LAP opcodes and operands must have disjoint names.") + (setf (gethash name *lap-emitters*) + fn-name) + (pushnew name *lap-operands*))) + +(defun defopcode-1 (name operand-types &rest args) + (iterate ((arg (list-elements args)) + (type (list-elements operand-types))) + (check-opcode-arg name arg type)) + (cons name (copy-list args))) + +(defun defoperand-1 (name operand-types &rest args) + (iterate ((arg (list-elements args)) + (type (list-elements operand-types))) + (check-operand-arg name arg type)) + (cons name (copy-list args))) + +(defun check-opcode-arg (name arg type) + (labels ((usual (x) + (and (consp arg) + (eq (car arg) + x))) + (check (x) + (ecase x + ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x)) + (:label (symbolp arg)) + (:operand (and (consp arg) + (memq (car arg) + *lap-operands*)))))) + (unless (if (consp type) + (if (eq (car type) + 'or) + (some #'check (cdr type)) + (error "What type is this?")) + (check type)) + (error "The argument ~S to the opcode ~A is not of type ~S." arg name type)))) + +(defun check-operand-arg (name arg type) + (flet ((check (x) + (ecase x + (:symbol (symbolp arg)) + (:register-number (and (integerp arg) + (>= x 0))) + (:t t) + (:reg (and (consp arg) + (eq (car arg) + :reg))) + (:fixnum (typep arg 'fixnum))))) + (unless (if (consp type) + (if (eq (car type) + 'or) + (some #'check (cdr type)) + (error "What type is this?")) + (check type)) + (error "The argument ~S to the operand ~A is not of type ~S." arg name type)))) + + +;;; The actual opcodes. + + +(defopcode :break nil) + + ; For debugging only. Not + + +(defopcode :beep nil) + + ; all ports are required to + + +(defopcode :print (:reg)) + + ; implement this. + + +(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable))) + +(defopcode :eq ((or :reg :constant) + (or :reg :constant) + :label)) + +(defopcode :neq ((or :reg :constant) + (or :reg :constant) + :label)) + +(defopcode :fix= ((or :reg :constant) + (or :reg :constant) + :label)) + +(defopcode :izerop (:reg :label)) + +(defopcode :std-instance-p (:reg :label)) + +(defopcode :fsc-instance-p (:reg :label)) + +(defopcode :built-in-instance-p (:reg :label)) + +(defopcode :structure-instance-p (:reg :label)) + +(defopcode :jmp ((or :reg :constant))) + +(defopcode :label (:label)) + +(defopcode :go (:label)) + +(defopcode :return ((or :reg :constant))) + +(defopcode :exit-lap-in-lisp nil) + + +;;; The actual operands. + + +(defoperand :reg (:register-number)) + +(defoperand :cvar (:symbol)) + +(defoperand :arg (:symbol)) + +(defoperand :cdr (:reg)) + +(defoperand :constant (:t)) + +(defoperand :std-wrapper (:reg)) + +(defoperand :fsc-wrapper (:reg)) + +(defoperand :built-in-wrapper (:reg)) + +(defoperand :structure-wrapper (:reg)) + +(defoperand :other-wrapper (:reg)) + +(defoperand :std-slots (:reg)) + +(defoperand :fsc-slots (:reg)) + +(defoperand :cref (:reg :fixnum)) + +(defoperand :iref (:reg :reg)) + +(defoperand :iset (:reg :reg :reg)) + +(defoperand :i1+ (:reg)) + +(defoperand :i+ (:reg :reg)) + +(defoperand :i- (:reg :reg)) + +(defoperand :ilogand (:reg :reg)) + +(defoperand :ilogxor (:reg :reg)) + +(defoperand :ishift (:reg :fixnum)) + +(defoperand :lisp (:t)) + +(defoperand :lisp-variable (:symbol)) + + +;;; LAP tests (there need to be a lot more of these) + diff --git a/clos/3.5/low.dfasl b/clos/3.5/low.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..1a8764a9a340cc506b60b5d1a75b6eb9e7bbf8af GIT binary patch literal 5165 zcmb_g+ix3L8TX7GJI%#$5^vPF-FE0E>B`%Qnq(K+(6v0VkK=LdnPFy}CZ$UWiGwY2 zlkIeO1+1b%1uJ<)la!SY&=+3!C0g;&dxZEScv>Feg@+YSyp``eXM7_u#fV55&$)f) zJHPMuUC!*gx|d>UDYm`2Q`pEArS0AF&Td&+-!4j}?cL&PPFjb4>Bn(v;iosUrChNT zSt;&reVE%=%|}W<`gpBaxSNZtZLjWb=C;bE$nI9*qsT^~v=dp~*e*p@cZ)^nk8Esz zIElUAp6a)n#I6=|E9KmpWbfumYbzgLk*431QoCC@Y3lm*sVmadyR%oPW@n}+`xATfRQ=r5x9x(zGx!L&s+GW$ zRNmf^H*$A#8+gi19H>61bSJV}%vN=+dMNA(-s-O^J*p-fN^C)yCoVy#Ry?t^Zn=I} zJ*f2OKH6E?T9e1EMUy0|`_33_7LAHa!jq&ZJpCccWm~hi#zW1ALZL=8h0WT3z(u>= zE|*9J(4u-MRx5pDV;Lo8>T*IiGu6s)tx2>+)zq~N(QKDj25r3wbxF%+-iBAVog^3F zx8G7TMw-ZrBxdX8DD?-Svy18618=^x9#hikWnrLt=*D)O#L|jMc&l4CY&E0af~Lrp z8HB{$yy3N!1hJQ0PD|C&szzwQg>X+aj@E+^95>nwjb7|TLkz@8f*nobFk(MD_ns(K ze_inzS=%smqZi(XEn+8R2M5PYo)H-6R?K-#$q;K0tm5TzsLxBg1$s$1#{l&5(^o59 zsum|p%zi;WQ!eGo>oT`xu1I~L{XJ0PepGy%f0BQif0q2cdNkUNiak>wrWPii{(K=H zx&`KaeDv4HQ6U+6!Umrvqav756~8MyUl4^C?8K*;o(-g1?VqXHzD@*nOy~k4T=upQ zp;w8;h-EoE7-%`c)?M)mpy8b-nzfu6pjUha+P_Bqx9C8Y`VAUb01J8$M1>9t2{14n z!pATmM1yElI)cWeqmB^=8%ASBM0@$cUMS*(xrAPjeinvgZYE+U^|(xy32LsEF!}%>+(PBit zX)1<6Ool>$#Sn%A#tJ|pA$E?07xa5${Paya#OBR9Hm8Yei%#&g*@#ar{^3M;KUyf}%7^*^!OJ2}N&t#sFDSFLz0+awAkmaaH4>}1yr_>UJ;jbdL00$pIb zsM@@2f-~zG*-m1Exvi$8sqZ3PAExU*y6*B!f;A%{cu0N-?r+^FmDl9LR;j$QwVI1S zCKKPf!T2xLk|*RINI*7ec!3Q0$Ks)2qTvLMNUE~eP{{c~*Vycw2x0(Ec5b}g_VN_i z1z>QeiS2$9S$fbwjQU2Phn9PJex_wU9vW{ej`}(aM3?H$)>dR&j*Yfmf>hfS=qC=< zdNp0v6EdSeGs>mc83j>s^5b9XHBSCn{&{L`Ci?XU2brUAY9_E>*vo(KKs&mS+RyJ5 z?)VRM|NWF3d#fpdS?&B@en0gYOPe1ogr23+q30Q%FdHccQ(`^*Iq8wlSzu+{%QXAB z<3G;d3Bdml{0EOUw&loyK5}38onrJaoNv+H$Iar64N3-VS;`ULyzK#x$7=1<$z6N4KqRb zx78Rk1bDn|Laiy+yx=yyeUr*2eP6hSl?>#P?__nGz)QVW?TlJuucwwgbvn6d(aUiW zXpyJ3N;8L=VhXAxTw=CnR^s&^dtKU32AEw}#emC=e&r7%1?8+Zr)RZz7${bG1C(4; zOsRE5fLg#w!Gj1Wn{S|-c0;y@u%Twe5C{xRPBu%NoTR=!ruajs;2DTM%OEioVi(%$ zAtV1gC&>Sw%mQ8zYy_uTNOE}dsPk~d?;06pfyjz!D$7D2D*B)@plYfOipnHSu*`Q9 z?x@C=PqBFWv$Zij0`)03|098E@oBp-a%vuL1og8G+?xH{!S0LBu@if#j)hLYQ$N*Q z=l_$?nc}B|0(-V5bmx#9rY|^5e{f)`=Uc|ML9CQ(mrWUOFD$YSL>1;FigQ6?KtG1v zn=XTOzXyNQ$W69bJOjGm1*ugg#%ni>1bMD*9fX_&^*Gz%1<-jW`X@Z)m*FVaAm}-s z<3W2)V0QX?FaKLUwse@B8$FIX7JC6+*;H4E39U&nC<3w?-<`y{suQ4)6w@T_rL{4Z)qQK39`o!}v!JAcj!70=t0GsHBh=R4mH##`~!sFIi{ReGIMc-5$H@l>fF_s^gn||o1}aBOaaf~ zb5K*I?q{23;xiFK;Im>wr^shh{}(caYT-96a{2 zL4Zb>-%v+1?fJNlsL2dQDC?nqCm;{q&ADv46-U}XTBV8e36O>BP}Xly?|;5}^)GjT BVz>YR literal 0 HcmV?d00001 diff --git a/clos/3.5/low.lisp b/clos/3.5/low.lisp new file mode 100644 index 00000000..dcd28cef --- /dev/null +++ b/clos/3.5/low.lisp @@ -0,0 +1,194 @@ + +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + + +;;; File converted on 26-Mar-91 10:29:45 from source low +;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>low.;4 created 27-Feb-91 17:16:47 + +;;;. Copyright (c) 1991 by Venue + + + +(in-package "CLOS") + +;;; Shadow, Export, Require, Use-package, and Import forms should follow here + + + +;;; +;;;************************************************************************* +;;;Copyright (c) 1991 Venue +;;; This file contains portable versions of low-level functions and macros which are ripe for +;;; implementation specific customization. None of the code in this file *has* to be customized for +;;; a particular Common Lisp implementation. Moreover, in some implementations it may not make any +;;; sense to customize some of this code. ks. + + +(defmacro %svref (vector index) + `(locally (declare (optimize (speed 3) + (safety 0)) + (inline svref)) + (svref (the simple-vector ,vector) + (the fixnum ,index)))) + +(defsetf %svref (vector index) + (new-value) + `(locally (declare (optimize (speed 3) + (safety 0)) + (inline svref)) + (setf (svref (the simple-vector ,vector) + (the fixnum ,index)) + ,new-value))) + + +;;; without-interrupts OK, Common Lisp doesn't have this and for good reason. But For all of the +;;; Common Lisp's that CLOS runs on today, there is a meaningful way to implement this. WHAT I MEAN +;;; IS: I want the body to be evaluated in such a way that no other code that is running CLOS can be +;;; run during that evaluation. I agree that the body won't take *long* to evaluate. That is to +;;; say that I will only use without interrupts around relatively small computations. INTERRUPTS-ON +;;; should turn interrupts back on if they were on. INTERRUPTS-OFF should turn interrupts back off. +;;; These are only valid inside the body of WITHOUT-INTERRUPTS. OK? + + + +;;; AKW: IT'S CALLED, BUT NEVER REALLY USED, SO I'VE REPLACED IT WITH THE PROGN. IF WE REALLY NEED +;;; IT, CAN BE TRIVIALLY DONE WITH IL:MONITORS + + +(defmacro without-interrupts (&body body) + `(progn ,.body)) + + +;;; Very Low-Level representation of instances with meta-class standard-class. + + +(defmacro std-instance-wrapper (x) + `(%std-instance-wrapper ,x)) + +(defmacro std-instance-slots (x) + `(%std-instance-slots ,x)) + +(defun print-std-instance (instance stream depth) + ; A temporary definition used + (declare (ignore depth)) + ; for debugging the bootstrap + (printing-random-thing (instance stream) + ; code of CLOS (See high.lisp). + (format stream "#"))) + +(defmacro %allocate-instance--class (no-of-slots) + `(let ((instance (%%allocate-instance--class))) + (%allocate-instance--class-1 ,no-of-slots instance) + instance)) + +(defmacro %allocate-instance--class-1 (no-of-slots instance) + (once-only (instance) + `(progn (setf (std-instance-slots ,instance) + (%allocate-static-slot-storage--class ,no-of-slots))))) + + +;;; This is the value that we stick into a slot to tell us that it is unbound. It may seem gross, +;;; but for performance reasons, we make this an interned symbol. That means that the fast check to +;;; see if a slot is unbound is to say (EQ '..SLOT-UNBOUND..). That is considerably faster +;;; than looking at the value of a special variable. Be careful, there are places in the code which +;;; actually use ..slot-unbound.. rather than this variable. So much for modularity + + +(defvar *slot-unbound* '..slot-unbound..) + +(defmacro %allocate-static-slot-storage--class (no-of-slots) + `(make-array ,no-of-slots :initial-element *slot-unbound*)) + +(defmacro std-instance-class (instance) + `(wrapper-class (std-instance-wrapper ,instance))) + + +;; + + + +;;; FUNCTION-ARGLIST + + + +;; + + + +;;; [COMMENTED OUT AKW. NEVER CALLED] Given something which is functionp, function-arglist should +;;; return the argument list for it. CLOS does not count on having this available, but +;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of function-arglist for each +;;; specific port of clos should be put in the appropriate xxx-low file. This is what it should look +;;; like: + + + ; (defun function-arglist (function) + ; ( + ; function)) + + + +;; (FUNCTIONS CLOS::FUNCTION-PRETTY-ARGLIST) (SETFS CLOS::FUNCTION-PRETTY-ARGLIST) (FUNCTIONS +;; CLOS::SET-FUNCTION-PRETTY-ARGLIST) + + + +;;; set-function-name When given a function should give this function the name . Note that +;;; is sometimes a list. Some lisps get the upset in the tummy when they start thinking +;;; about functions which have lists as names. To deal with that there is set-function-name-intern +;;; which takes a list spec for a function name and turns it into a symbol if need be. When given a +;;; funcallable instance, set-function-name MUST side-effect that FIN to give it the name. When +;;; given any other kind of function set-function-name is allowed to return new function which is +;;; the 'same' except that it has the name. In all cases, set-function-name must return the new (or +;;; same) function. + + +(defun set-function-name #'new-name (declare (notinline set-function-name-1 intern-function-name)) + (set-function-name-1 function (intern-function-name new-name) + new-name)) + +(defun set-function-name-1 (fn new-name uninterned-name) + (cond ((typep fn 'il:compiled-closure) + (il:\\rplptr (compiled-closure-fnheader fn) + 4 new-name) + (when (and (consp uninterned-name) + (eq (car uninterned-name) + 'method)) + (let ((debug (si::compiled-function-debugging-info fn))) + (when debug + (setf (cdr debug) + uninterned-name))))) + (t nil)) + fn) + +(defun intern-function-name (name) + (cond ((symbolp name) + name) + ((listp name) + (intern (let ((*package* *the-clos-package*) + (*print-case* :upcase) + (*print-gensym* 't)) + (format nil "~S" name)) + *the-clos-package*)))) + + +;;; COMPILE-LAMBDA This is like the Common Lisp function COMPILE. In fact, that is what it ends up +;;; calling. + + +(defun compile-lambda (lambda &rest desirability) + (declare (ignore desirability)) + (compile nil lambda)) + +(defmacro precompile-random-code-segments (&optional system) + `(progn + (precompile-function-generators ,system) + (precompile-dfun-constructors ,system))) + + + +(defun record-definition (type spec &rest args) + (declare (ignore type spec args)) + ()) + +(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) \ No newline at end of file diff --git a/clos/3.5/low2.dfasl b/clos/3.5/low2.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..09194e45e4e1e6bac2bcd446a716a3ee0c36cf09 GIT binary patch literal 3300 zcmaJ@TW{mm5hkgtZP}LB-b?Is!|d8##8|qP?KWMvFho&DCf5{6kd)W%1*l^ykrLT5 zBrD0HEui%FL}2T66Y!*)0_|&G7W)(@0rb!(zx1Jf4UoT(KM-tY4yoIwtpQVqhjV7W znfYesoN>urMHiL&(Mh#dZiw~P=}GHUe6!vVoAp-Xpe()#`{J+i&h~G9QfihP&CUHr z>-fEL?Vz&ReCOd|qxx=n^RRx0I4ERPptM-QNM zj}#hJc4A%3mk-KEZvgn!mDLqEw6>9XePd;1dHne&{zqJ@&cWXZKGK};r8DAb{Y0vj z-!0eB%_IEa|H(@hN`~TUrs1FSZ9eWl@};B&NrB@8%7b?QT=2cr{CrVXY*Q+j zcG35yyRXF9(QMNw62s*H#fM%Rji3$1G#pokZ4SL!WV+d76s>gn@66vZ+(dt`=ShKC z5{J>^cLt{|h+rmRm0Zg$tsh7S`E zhkl$SkO-*v*qdEgkagWuWS8{fC`k}02lTL`Lnkd}XL`Z10V%|(uate5QcP>_h3z)S zpq|I+Yi)X~O>YC9tHXHuK7iCx`-3)J0HNt&q0qN>o8Dmxp-g2(A&z6(kctt@CV36r z_@Le9p3n@`MKb$Oqy!XP27dUk;DC_vAQ2odK=c_gZ!vlghk>=$Pd$k`qX|(Y^aMz-gIB2i`Bt)GO*vn9l1`$6r%_pz5=Dj5$nUj2>j*bMS{ z8Sgd538hxvKbBf2Y??J0RrWxCo5vOxLxY5mg6)``Gi?|j!Wsl7t(Zki)1mQ&h z`MKrVYRTAM$0?WYPDBaXK2Y9;a{q|?EnxXwmU+H=xR(9;*{i`zpJVG=cwP zw#o+6rz%Q)!e9q1gmK6gOoz&Zo~@`CmCq`lSH95xc0aB0zrZtR#Xl68%oq3nysa;O z{(HSL`?Jq9;o|9+SQKx?hnULmCf){ra7-A@4unuA1^71U>=kpSE_MC7 z144<=w>f$=Nsk129Faj1GY`kCAHh0mLqV^>BDRPtpg6?lCgTiGYR)$Cz4u;ZD`WGeO%FrXb2=IT$zF0XV$W^d=Q2q=K0? z8PZTPcZjXadw{z;uC8IeU|>Pt9hg@*l|F=PhAwa6jfx(k9?)DcR3hhLpn}!G%M@nq zr58yrb){LDMzcUEj=RL^fiypd|AAikosz*>av1R8dw7%h|Jo-4?Yr^}*O5aD{&1?l zW5M?XV<$9&x4x-<88K2}@L$D?5zHd-f0{?9f@JVxK%O*W#S=hR2)09nICIzMyIy0g z@DkXo6vhfE!=khn%$8?ML9NTs!E>zm{T$EWeci77C2SDqYVM^@Hgxvy18qD4o)rw} zlocal>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43 + +;;;. Copyright (c) 1991 by Venue + + + +(in-package "CLOS") + +;;; Shadow, Export, Require, Use-package, and Import forms should follow here + + + +;;; ************************************************************************* This is the 1100 +;;; (Xerox version) of the file portable-low. + + +(defmacro load-time-eval (form) + `(il:loadtimeconstant ,form)) + + +;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance +;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper. This +;;; is safe because there will always be some other pointer to the wrapper to keep it around. + + +(defstruct (std-instance (:predicate std-instance-p) + (:conc-name %std-instance-) + (:constructor %%allocate-instance--class nil) + (:fast-accessors t) + (:print-function %print-std-instance)) + (wrapper nil :type il:fullxpointer) + (slots nil)) + +(defun %print-std-instance (instance &optional stream depth) + + ;; See the IRM, section 25.3.3. Unfortunatly, that documentation is not correct. In + ;; particular, it makes no mention of the third argument. + (cond ((streamp stream) + + ;; Use the standard CLOS printing method, then return T to tell the printer that we + ;; have done the printing ourselves. + (print-std-instance instance stream depth) + t) + (t + ;; Internal printing (again, see the IRM section 25.3.3). Return a list containing + ;; the string of characters that would be printed, if the object were being printed + ;; for real. + (list (with-output-to-string (stream) + (print-std-instance instance stream depth)))))) + + +;; + + + +;;; FUNCTION-ARGLIST + + + +;; + + +(defun function-arglist (x) + + ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of + ;; symbols. How silly. + (let ((arglist (il:arglist x))) + (when (symbolp arglist) + + ;; This could be due to trying to extract the arglist of an interpreted function + ;; (though why that should be hard is beyond me). On the other hand, if the + ;; function is compiled, it helps to ask for the "smart" arglist. + (setq arglist (if (consp (symbol-function x)) + (second (symbol-function x)) + (il:arglist x t)))) + (if (symbolp arglist) + + ;; Probably never get here, but just in case + (list '&rest 'rest) + + ;; Make sure there are no strings where there should be symbols + (if (some #'stringp arglist) + (mapcar #'(lambda (a) + (if (symbolp a) + a + (intern a))) + arglist) + arglist)))) + +(defun printing-random-thing-internal (thing stream) + (let ((*print-base* 8)) + (princ (il:\\hiloc thing) + stream) + (princ "," stream) + (princ (il:\\loloc thing) + stream))) + +(defun record-definition (name type &optional parent-name parent-type) + (declare (ignore type parent-name)) + nil) + + +;;; FIN uses this too! + + +(eval-when (compile load eval) + (il:datatype il:compiled-closure (il:fnheader il:environment)) + (il:blockrecord closure-overlay ((funcallable-instance-p il:flag)))) + +(defun compiled-closure-fnheader (compiled-closure) + (il:fetch (il:compiled-closure il:fnheader) + il:of compiled-closure)) + +(defun set-compiled-closure-fnheader (compiled-closure nv) + (il:replace (il:compiled-closure il:fnheader) + il:of compiled-closure nv)) + +(defsetf compiled-closure-fnheader set-compiled-closure-fnheader) + + +;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure +;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of +;;; course this is completely non-robust, but it will work for now. This is not the place to go +;;; into a long tyrade about what is wrong with having record package definitions go away when you +;;; ship the sysout; there isn't enough diskspace. + + +(defun set-function-name-1 (fn new-name uninterned-name) + (cond ((typep fn 'il:compiled-closure) + (il:\\rplptr (compiled-closure-fnheader fn) + 4 new-name) + (when (and (consp uninterned-name) + (eq (car uninterned-name) + 'method)) + (let ((debug (si::compiled-function-debugging-info fn))) + (when debug + (setf (cdr debug) + uninterned-name))))) + (t nil)) + fn) diff --git a/clos/3.5/macros.dfasl b/clos/3.5/macros.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..973c7177c424242fd21e0e1ed1188fb5a4fa714b GIT binary patch literal 12420 zcmcIqeQ+Dcb-z7)kQ7M>f+(6sB;&%6T-@e`bz0bW_skT29S3=__Pvr~Q31xih^r@-S%CYeY zWpaFKVkD~^gLdU};dJcJ9_pLSPE2+WPfU${CR-TEbx)pnVss+^c(!|Vd}QimcI@TFC`Q68Dd4xi4BDw(P5~XDH6o5|Mli2YoO}lL*mgv+o8Z6C;JHKMTV7EVfzdG)4zg$3_hiJRZR^Y?jYAScSHOOf7)|hSe z=6%j)b0;lXEW>SfFmwNEOKz|rlDe%mci-Wf-AMkUE!tDY1F^d5s$JGf+-5g3_0^Vb zOGa3WfA~ooce-kzu4S~3=ctj>RTu3P>u{R}GY39w%}IV6=zio5*IWzKb<}Sk&#IBv z)mJT6;x->)W`4C*ud@JdXyTw-SE@iu59UAz!XK!?v9&K;UT-R>2^|K{NNW@2hBB&w zzf~9NAm-iX7&AX(t&{Z^XV?H~t-6F7(?IR_r%1=Q2Mf;sz4p~0sZ-LiDy|G#e@2VN z+N1LFqtbHe=aTuSFlm+6X9nm))cCBC7LE8uk;+e45o0ee8imYf@Swqv~L&!76VIs#j-o-XPKxBrSTc z+&~X`0D3r(H4r`Qf%Lo<%DEBJ0^EoX5Mfvm8@KSjSPNaHCHlQgzgKc^=|i67+>m#f zd*-<3nKz_429=6MrV{r8U~VX_TDANM7=hyC_j50GjfwW0pc9MZJBvmF%Q5OKh8X_0 zxJL%Y-nf2(`ot6TpdTIhGsux6&V9gr6Z|zVbMI_!IzQAh$6L;F50>Y-uhhxCjC&YR z$1c7iZ{p2uFyb6<&iRL$hI}wiruE~5rOQ!byUZPNP4iYt$U8M5)ck?HLMj>jGg=GL|8VP9Dfmn8_u zlwHmhepOw$i&^KU>AoS>@B`G%4iflO8W!nl!@Y$%K1fWPwEj#=4P^pVfdD%8FG|Su z*K!NFOS#1$BY@8Z<>{OmWJ^IAbaiYY`1MjQ$QGlB?T2S$XQPhU{B-VOSCkPPug>L5 zd!j;r(D;Yh<(SN_#G{~Frt^=?8q%NIXERHO1z?s9B4HvJqss{1d+ z+I=-%oT;x05(wC{up708 zg=`%i_@jx#h?y|FXe8fV>rVo70-bfxQj^Z4bfY&Zeh1?{41j9VNiC$SapL+NLO=sq6RSI(Jo5yJ(9HTL_X|iyY`iMoSquO}%IiV6X!lhW4OQ>|g*z+z1oGKAFqj z!xkbm*+S%!{=F7DWU5msB4RIH7x-&g*5ym3UkY}9BTMo#*Wq6|Kty<_Fx0b8EA8Ba zY>A1tL(v73#|Q3$(t3+QJ08SXxGuz#0|CT?GdeuRWgo2)bz4n?%VETd*1aTH#Lt=83)SbA0<*?#J>x-wYl> zGvj{p2%yX6B5&nN8;m%|74QgJVLWe^k)~fB@`FbpX0}w{`@V|myS)@iEod;7Ak2`l z4wZ}2uc>$eRowHU7y-rDV5=!iqdb5Oq$(IHfrwz6is+6@_u^*&IeU=ET*gXKUo~n4( zBh?bjF6YpnCRy>!b5BM5yz|^^i=S_f`)(G$S^d0_K2O4bMJN9kL|(`pjV{Zb51m>| z?waO!)6H@>8?$J6fmRG@c~`jf+$$uFq)UjHhaPbuY9xjzX4X3>VvPjP3JnrM+B~)+ zUU9-f*FY#yQ8e5q#I6a%&cnEm#16VN6;Y(yK+Mjed<`|Dt|6bF`(#i*Aa)pZU^tFQ z+~`@W*b#t*D~Mtz{TD%=ibX135H|Tj4ZgibO(;Uruc&wii|8;r!5pQr@&l}3q7f_T zC%Yj1*lS>|WbVhuw`t_}$z}P=D)g&W<+Y)|sf_+A^ubKG27i53Cky**qrkpm`K2!E zQk-!Rqalck|B+376-J0b4sufc6D$r%BFKmdX*WX zxAcP%ohW>X-cRSC0sd2^e6nrMwVtfJmG=31BR-hq>;gkf0kK)P8;cQ51$XCO>h#?j zP;rgA0r@C39-w5qqnE-3hv~&**^2Hu_$+ZXaWD)Ag^r?&`oWUtokZkK=!l1J^g&u3 z=WG{)5DkaQ4OHl&-#zw$6C&9C)*O9CTuY~+V(y}D_kZBn^VX;os;lrSbj1SbWe0_2 zto?w+EnFB-h{)RgR;0uNYeOHp#v=b7T8V~L5xD+_jy4M01PbGbLXt_y)!c9_gg%dj zzA&#OTTrsTfO>X-E$T8`ipWPHq>&$~igSiQad?>s3_zSJ)RH zl@=>SVd=dl(s-o!$iXTjHVIC0Rf^{}B74VE2r=P^`|+@(f7(QkAG^os?EJ&@=;Gp` zA==`cCm#SbHgwQl1Tf{(Vb&37q}QB}iJ%vHI+8p|1?WOBvH^gPgYvIST@-LanBZ5emRrQb3H7!0zHq-A>SO3JCHpGWcM+kyl82 zl%v&#wyF>nG$PapgLbx9@4@)+MQMArjlWDF(qr_93xrrE>eH^Z!a|Y>1OMJW9b%6@E%xXM6hjDhApU~uL%N9s1)Ay;`IUcz4eNn)rAE84*^6Nwyl&;aD#Gp?7qy!N}Gf)v#}XBu z1C`5fKo9sWF}9r{D~SjRK#y=|L>du2m>f9%!gCp-*oHR=FQys17$4(J4F>4U81+- z#k_zbh*^A<(tYPZk+k0O36YDXWAl_i`SX^`YWi=punHG5#axgmz zwHufe{HZW2%LFK^9DG|8ypk-zwl?gh=>rGVv_>fbb{0}aRTjZT6JjcWrgXHzAaE9S zBP8VgB}(J6mn60xHnpAP%o|dZdIr3+K`nqes&Yz@t;-(AREK=6c%mS#8HOfu0X^2uMnU=6wDA*45G|KFqTk!IqPJ?%8YEiS`<-&{++u0}2a_!Xu3l`) zFGgP1MMgu+@^o%7x)@uEUrwBO=gJ$`_lZ#8m70}#C`dqB87DkT2@*E7VKp7m(t#wU zwEqKhjrW49ro~AVF4K{}ihU`k&0g(=^Qk|`GZDB!OKXthgSrEH-w#iBTr+wzkv1sS zQo1Uw9oj|{{g(Vs=|4$8{vIZ&3q|0=ju52ekoH$-ns1#F54v+=-(vXYcVAS{D6&q% z7@f53avHN?H>CsUgAmGKZUiZ!3}#h(C3)%G1+1?pM?V7F0&WC+IwDe7 z?`@!kybCEz2Yi9xH(M!r$u3axlHUE2*uOv!^~JSbaH45qN*4r@WB{6i81lX(a0r)J zdHXVqy$-9b%3ZR4xIKh@v@#h1V zcj-(XQsu!kZO-6q)El|DO|bAX?Q4);2*Y5N;f~HBT$T&8tT!Du<^QboDyV%jf~jr_jE%RQ4q>nLT|hAWU&~f_6O-l*`p^H~n4v}#qX7Jl1JZIryzb?Ut4j*#Pbf6-SCobJY7PzrWd0U47HyhP5 zW9R#8U|So7=#>eG>0!x4eS_tx^{SbOhIc2Ogp)m%`zpeA+IF4da4OP{h$~M!)$;Dz zzkYDsjbcrqB3v(GV!WZF!UhB__)S|~xdqeYHSpmTdHZbz-?0qK6!`F7kvCuL_84?}{5r}RPFlUCuVZjoO({sH+FI=>q-D!>1z85IYn zQDDy#I(&^-l}B-=!8>v67Y9~JpV0PqKr0m>*-_4#U}l9Bf=h?*8R0mo$NP4?2rlK$ z$Fn1+$0zbn=EojWPL5Ax%OR(7IyXF~oSGOvnV-y#0(qj!AeSLj_}wDbb)^rdv>rqR z+(h-ofnl2C4>m89xB<_r=Z0oV{7{?7o5+qXV9Vl6c3>GkCnd9~rc&wvbuDxL2MPEP z>;3Pwp{$b8t2+HvVOC$&$;R35XFT(K*HdM0QhM2rX2C@y z4G<+Id~_~eecg0Lq(bObRW_wcaa6QNr9@z?RH;i=&bbT8=-t*B>N%d23fHipC2p_`=FKmy9Y`TU~rC{>5QwZmq5gO7FGPlz0 zGTTFGJn6N~MDctBy8K%IpO-1 zqBOQAVNsCp+i90}tPMYRm9^B$16~zEo|XM96vO0 wSrZC$>=Ja#V4)%RiN=o(jf!fiIlocal>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21 + +;;;. Copyright (c) 1991 Venue + + + +(in-package "CLOS") + + +;;;Macros global variable +;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not +;;; having to use eval-when a lot), this file must be loaded before it can be compiled. + + +(in-package 'clos) + +(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call)) + + +;;; Age old functions which CommonLisp cleaned-up away. They probably exist in other packages in +;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to +;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts +;;; of lossage. Common Lisp should explictly specify which symbols appear in the Lisp package. + + +(eval-when (compile load eval) + (defmacro memq (item list) + `(member ,item ,list :test #'eq)) + (defmacro assq (item list) + `(assoc ,item ,list :test #'eq)) + (defmacro rassq (item list) + `(rassoc ,item ,list :test #'eq)) + (defmacro delq (item list) + `(delete ,item ,list :test #'eq)) + (defmacro posq (item list) + `(position ,item ,list :test #'eq)) + (defmacro neq (x y) + `(not (eq ,x ,y))) + (defun make-caxr (n form) + (if (< n 4) + `(,(nth n '(car cadr caddr cadddr)) + ,form) + (make-caxr (- n 4) + `(cddddr ,form)))) + (defun make-cdxr (n form) + (cond ((zerop n) + form) + ((< n 5) + `(,(nth n '(identity cdr cddr cdddr cddddr)) + ,form)) + (t (make-cdxr (- n 4) + `(cddddr ,form)))))) + +(defun zero (&rest ignore) + (declare (ignore ignore)) + 0) + +(defun make-plist (keys vals) + (if (null vals) + nil + (list* (car keys) + (car vals) + (make-plist (cdr keys) + (cdr vals))))) + +(defun remtail (list tail) + (if (eq list tail) + nil + (cons (car list) + (remtail (cdr list) + tail)))) + + +;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just lifted it from there +;;; but I am honest. Not only that but this one is written in Common Lisp. I feel a lot like +;;; bootstrapping, or maybe more like rebuilding Rome. + + +(defmacro once-only (vars &body body) + (let ((gensym-var (gensym)) + (run-time-vars (gensym)) + (run-time-vals (gensym)) + (expand-time-val-forms nil)) + (dolist (var vars) + (push `(if (or (symbolp ,var) + (numberp ,var) + (and (listp ,var) + (member (car ,var) + ''function))) + ,var + (let ((,gensym-var (gensym))) + (push ,gensym-var ,run-time-vars) + (push ,var ,run-time-vals) + ,gensym-var)) + expand-time-val-forms)) + `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars + (reverse + expand-time-val-forms + )) + ,@body))) + `(let ,(mapcar #'list (reverse ,run-time-vars) + (reverse ,run-time-vals)) + ,wrapped-body)))) + +(eval-when + (compile load eval) + (defun extract-declarations (body &optional environment) + (declare (values documentation declarations body)) + (let (documentation declarations form) + (when (and (stringp (car body)) + (cdr body)) + (setq documentation (pop body))) + (block outer + (loop (when (null body) + (return-from outer nil)) + (setq form (car body)) + (when (block inner + (loop (cond ((not (listp form)) + (return-from outer nil)) + ((eq (car form) + 'declare) + (return-from inner 't)) + (t (multiple-value-bind + (newform macrop) + (macroexpand-1 form environment) + (if (or (not (eq newform form)) + macrop) + (setq form newform) + (return-from outer nil))))))) + (pop body) + (dolist (declaration (cdr form)) + (push declaration declarations))))) + (values documentation (and declarations `((declare ,.(nreverse declarations)))) + body)))) + +(defvar *keyword-package* (find-package 'keyword)) + +(defun make-keyword (symbol) + (intern (symbol-name symbol) + *keyword-package*)) + +(eval-when (compile load eval) + (defun string-append (&rest strings) + (setq strings (copy-list strings)) + ; The explorer can't even rplaca an + ; &rest arg? + (do ((string-loc strings (cdr string-loc))) + ((null string-loc) + (apply #'concatenate 'string strings)) + (rplaca string-loc (string (car string-loc)))))) + +(defun symbol-append (sym1 sym2 &optional (package *package*)) + (intern (string-append sym1 sym2) + package)) + +(defmacro check-member (place list &key (test #'eql) + (pretty-name place)) + (once-only (place list) + `(or (member ,place ,list :test ,test) + (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list)))) + +(defmacro alist-entry (alist key make-entry-fn) + (once-only (alist key) + `(or (assq ,key ,alist) + (progn (setf ,alist (cons (,make-entry-fn ,key) + ,alist)) + (car ,alist))))) + +(defmacro collecting-once (&key initial-value) + `(let* ((head ,initial-value) + (tail ,(and initial-value `(last head)))) + (values #'(lambda (value) + (if (null head) + (setq head (setq tail (list value))) + (unless (memq value head) + (setq tail (cdr (rplacd tail (list value))))))) + #'(lambda nil head)))) + +(defmacro doplist ((key val) + plist &body body &environment env) + (multiple-value-bind (doc decls bod) + (extract-declarations body env) + (declare (ignore doc)) + `(let ((.plist-tail. ,plist) + ,key + ,val) + ,@decls + (loop (when (null .plist-tail.) + (return nil)) + (setq ,key (pop .plist-tail.)) + (when (null .plist-tail.) + (error "Malformed plist in doplist, odd number of elements.")) + (setq ,val (pop .plist-tail.)) + (progn ,@bod))))) + +(defmacro if* (condition true &rest false) + `(if ,condition + ,true + (progn ,@false))) + + +;; + + + +;;; printing-random-thing + + + +;; + + + +;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent. + + +(defmacro printing-random-thing ((thing stream) + &body body) + (once-only (stream) + `(progn (format ,stream "#<") + ,@body + (format ,stream " ") + (printing-random-thing-internal ,thing ,stream) + (format ,stream ">")))) + +(defun printing-random-thing-internal (thing stream) + (let ((*print-base* 8)) + (princ (il:\\hiloc thing) + stream) + (princ "," stream) + (princ (il:\\loloc thing) + stream))) + + +;; + + + +;;; + + + +;; + + +(defun capitalize-words (string &optional (dashes-p t)) + (let ((string (copy-seq (string string)))) + (declare (string string)) + (do* ((flag t flag) + (length (length string) + length) + (char nil char) + (i 0 (+ i 1))) + ((= i length) + string) + (setq char (elt string i)) + (cond ((both-case-p char) + (if flag + (and (setq flag (lower-case-p char)) + (setf (elt string i) + (char-upcase char))) + (and (not flag) + (setf (elt string i) + (char-downcase char)))) + (setq flag nil)) + ((char-equal char #\-) + (setq flag t) + (unless dashes-p + (setf (elt string i) + #\Space))) + (t (setq flag nil)))))) + + +;;; FIND-CLASS This is documented in the CLOS specification. + + +(defvar *find-class* (make-hash-table :test #'eq)) + +(defun legal-class-name-p (x) + (and (symbolp x) + (not (keywordp x)))) + +(defun find-class (symbol &optional (errorp t) + environment) + (declare (ignore environment)) + (or (gethash symbol *find-class*) + (cond ((null errorp) + nil) + ((legal-class-name-p symbol) + (error "No class named: ~S." symbol)) + (t (error "~S is not a legal class name." symbol))))) + +(defsetf find-class (symbol &optional (errorp t) + environment) + (new-value) + (declare (ignore errorp environment)) + `(|SETF CLOS FIND-CLASS| ,new-value ,symbol)) + +(defun |SETF CLOS FIND-CLASS| (new-value symbol) + (if (legal-class-name-p symbol) + (setf (gethash symbol *find-class*) + new-value) + (error "~S is not a legal class name." symbol))) + +(defun find-wrapper (symbol) + (class-wrapper (find-class symbol))) + +(defmacro gathering1 (gatherer &body body) + `(gathering ((.gathering1. ,gatherer)) + (macrolet ((gather1 (x) + `(gather ,x .gathering1.))) + ,@body))) + + +;;; + + +(defmacro vectorizing (&key (size 0)) + `(let* ((limit ,size) + (result (make-array limit)) + (index 0)) + (values #'(lambda (value) + (if (= index limit) + (error "vectorizing more elements than promised.") + (progn (setf (svref result index) + value) + (incf index) + value))) + #'(lambda nil result)))) + + +;;; These are augmented definitions of list-elements and list-tails from iterate.lisp. These +;;; versions provide the extra :by keyword which can be used to specify the step function through +;;; the list. + + +(defmacro *list-elements (list &key (by #'cdr)) + `(let ((tail ,list)) + #'(lambda (finish) + (if (endp tail) + (funcall finish) + (prog1 (car tail) + (setq tail (funcall ,by tail))))))) + +(defmacro *list-tails (list &key (by #'cdr)) + `(let ((tail ,list)) + #'(lambda (finish) + (prog1 (if (endp tail) + (funcall finish) + tail) + (setq tail (funcall ,by tail)))))) diff --git a/clos/3.5/methods.dfasl b/clos/3.5/methods.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..54844882b06343f4403fc8b577be42d5e9894643 GIT binary patch literal 39714 zcmeHw3w%`NnfEzoCJ6~43^9Z-gfJo^AcKP7g?gDuW?&|nnG|r(Fp`Xxm2wd ziApavRRJ$K>t(CG*Y?*j{)&WKYP;KSX}fC0UTn9Qt=sLkyIbknU-$B@_4_~1^PV|p zCKo{W+uiT?Et)y+dEe)~KkxHCxA#5!v`K555`m_^E!%o}ySE4WcJ17@YiHn=zU_e> zeY>`A=nmY1_`sc!Ov{I^Y~RtneaF>Z+jnift-E(a_UcSaM5a~CIWU~{M|8AhOXH+uR&Ye8dw)|)0_z#!^*Ki(k zg@>Jm;dF%KCSE5FFo*ajzu5dvp=Vmk`0JI+Dyq(j;}t;_J5@S~V}-`Z@ZQ__|91)b zA$3hcTww%HK}@{>5dZVbDDsuXdgByO2N!;hA}xhW;WV)SQ>Lc9*YTtczk1n-E;G*@b_)Ys) ze$!sCDtB3xmspiG68#LSE!&HJ)n?klsYo~-39d=U+oI{93?Fx}>}~+mjSUcN6_5`C zWNIG7oq3H_MU|wjsq|P{P**w{juh2(VL@F50CrvTr6`Xz4JDTTk>5&xQjjm))D+ER z%z|!|{s18Ud>e~ERN)^y5voxH68 zoNskB6-~#R^0>hxR(cVVs*98C!WK#PGHV7EX7F3d8{lrMRi#a4vN4_t6Q2u+lJ6s_ z(oQ1Gq{#0gaz-ScjyAQ?f(W-K+Jf;^ye*tw&FMqLExRK=kBBmve+GDp-en5--9nSA zTGP?CwvHeQfq>8^E8t-OdQ;(Kl&ZZSP$jFviAx!tm%P)F z*B@QA3IhQ7Mxk_m8r16bNpYo8oX*90|ACA1{(_71{*a6Foq^Y5I+^G}?`^N+|>_WYFF>3N;o z>G_)EJt%ptcEwk;p-LJRp%Dleerq)}zen=_p~l z6o-AYZ+Cp^P5idRh1tqXAJef zv!(z{f6cmt9xq!ydOQ#4!eP=s%T?>NeaQrvuZD*8Iu#?WMd>u^hO3yJ1Y5yB>$Hs|HG310m*-#HJf(2%1mptNoIUJZq?k3c9so7t>Eb) zex<&*Ys>nLU4fphfzg}`dZZI|B~?UwItmts{vXiSB7xNs1N6Qh5j^f?y;N-WjEc41 zH@dW&5oLv_eUUS7-&h4*o-e5Gy|t*)E~xa>dumbX-{cGWv-i}Z(nI-zo_KF9dMIDe zw)fVejroFN@2y2w<_oHSZ!PlK1(p0^@IX26bK2@v!D5a8(G`f!Z`ydDjrWN*Vt`Bm zhA6)S=6lA;{poX4v@NWK(OSII(<}Xo(7iu8iPP}EXvbd zoAYv*vPHaXOa4kgXDw=rMT1P4oy|@%DL^2f0eZmf*eWxfr0uKZ%aj}O4-R-U(Y96A z?G*VbngR}e0BIJYv=1}%W`X9Ik6L#SY!|_DXn7&*!UEV266_p;rI7cZ3ShmzDuBI{ zAbvuy9Lg2Kex?BSE`oiWU^&!Bp*o7|E&%%wMXjSm4qZ*5nG}acQ~yw+diAe@+R+M0$=C)PNX`hSKvK0p#Bvpf_eQ?izel_q6&n zkH)F@osP)s5KoC3??J&D6%2ylF5sTCF5t$&10LXBZ6w+nO+}!T54N{Pz>Efy@wM?3 zqwWmw`pj&A-_Drr=_Yq#1+XscVk|sSvG`?B}+?8!cK&vV-IW&^9+PZ%faJNzJgC&xn%=6Md`p%vGuWPLG}}{=B};^Z+&uWmfDiP#HJ$*It@s}*_(on+FH$h#1WAIf%(M|Z z?qZs?`vu}Id90U5h96%KAxqVwXtEVz>UH3t%`}MY<(&47i{;^!hb&6$j$Y7SPdt-g zav)281W`UjsSyzUjn5bn%1K@%HaItYkN8I98?kyH{*r_D6I9iWNA z&KBeX!7sE!%IHL-)Sx1+<+*xoCGe(M5x2_ z*3kn>;Ny9WGya@b3^2}U@}zlakV|NzZolGL!bvA*qeIgZ(beGuxR!{_5_OFGn!P|7zGUPbk2muJ`%H@jd?N`7RF5PjP&1P1IraQGoI9TC_3*^Rf+J=X zqH8$1*{pKK`||NErq2~$osUnL)vov&o^LKFY1ZTuPCM(93unE2>?NxPnc%s$UylGt!?R8d#Ytw2}l1M74R>>({ltHPH3TU9 z%H8Mho)Q@Sk5=ODjFYizXHVbO0M_5GE!|sp25#%xu@dP^#>stKwr4|@SE|#wpHWa3 zj+=Y?zltNiQXKJ^L?EB>^x%O>Rt>#t_G+i_aqDvH3X2qXMOa3572^PHvjp}Vdb<;& zJB3GA_^;D02V@-0{ODy|qKxjk@XnpxTej_lSt+o+no;|8 z*tsLHp=;~bzMX;f-329V6e0(S$AfJFd*1wXG}DHD=JoB&3>hXm)f47k3F{DI8gob< z9Oj>4fr-Z+jq&@QtU$=GvSSvM6PEH^ai<+H1EZ`E)Ns)b!pmqlS-AoIC?(l6+(t_I z23Ar6VS{OCZ_Q+|Ek-X;Tt?HWaKb7#dHQRbBs!|4nZz6Bb#%d8a_@vQ8b z10Y{hxD_@E(z^!NnCS@iQ9q(9M0yq}oD}<$B*I)}l~>_)hN3UUa=TT|Gp^TY-kYFb zySf=af%$_2=j;w+1uPEi=vM zUNjXPS$mmvkv;4jF~iS~y6OCw$s4=wcSet+XEpPq9wX@E5e)3U6NF~>hiLdXse#9D zI*%Vm1Tc0wbPBqtdtc9oUR0vzv;QM{{J}jhU2hOHSJq=;Dba^HYVHEju$aJ0FwG=csB6sqhU>&T9!SuS=r_`&X-ibpJfs z(-5b96+Jkokn2-QD63|&UGG5>lgl3F3^b`_Stls+7sm=~K*7>~$ODvq%?S=V!Coim z=m|=NJ);slx90&o4y-5a#0rN+u*Q$`vBnpi;B8J&WJQLZosZRpgM1M_r1}NCd-JX= zf?u&^~&u<$HtQ?y0YL_BdW&x^+!GW1j*shp$yA56E+|jKp(ts~= zH<#xY_oE*4|=~lYh?6x0P1_=X3m3 z`IQqUa-?%|zAMMO)0Us@aauHnn;x;m(?)rf0U6brDcOZ0{&M- z@3ohR20{&F!o7r8(}>$|N;|=ug7#@ENU%>?OX*=*Q*XC|TPfq1E&)B()FcvJCi<(b z;BxC?cmPydwXpnStD(J9`z6@X_UxhTum}PBvU_^2-`D)0ysc%rLvfGuASszC))?l5 zENhZG9*Zf362rv8qKw3#%yMkkqlU-h$g$qRaSUbPuk(62COzzN0U}jC-)tqPrEmg* zZ*(p6&Xbrq)lN2|(^J$?3Td>;uRvVIYA6Wph)WPrJ(diyh-t`4zcr)Asw8Sywn`|Y zX2b>uwn84>-W}-K5!l)nP{K1EjvyV?t=(I@xA$xa-m+`!29}a{XC@Sjw{-1egB2uJ&l?<=2c~#qAHYaB+}gFJJJ2<%CYBL3@WaA}>_Okg8a2@) z>RXU3BPKij5vaxVn5e`yz4f`xO83kfv26EwM(phxW8_*L5AVpe^j13JT8Xh5BX&ZI zoiNmt^X^o&D1|9egPmatIuRo1dVz`_>;2uX-cU!BM$dpc-O=dLo1@XAH%FsKZ=}&<64XF%$NRgE+izuA zDEIE|!jCJ)M=`#l0SYPQJl4bc&U$b{qgFo)6nVJ8PyTyw5AdXlnz!rS^-O@z-hfnDZOzeiWk)eMNqezC#kHK3F#5-+^gY12%P=YWaO{M4=)Bm8(rLO8 zxA39}2|{kXV!FZ<$EO)0AKr;kA*DnO8Qg<@ z$P$ACQ&W9`t=+fpRO?z6)ex~g4-M3$qR~jkT~j95+D{#McJRPttCowAeNlMAm#hn| z%dybLp9D6s7ES}}`E`%A&{{x6e;kN>jT?z=JQH(}^G4e0*w8t!4$0uHYZmQ38)qh3 zc;3R{f^EiFy^06uCH{Sr`?Z(DudrX-bn+hvkg+XL;8Sri`Z_liU6XgS2(C&)l~c@+ zC?$&ax-m=ivT}e2TDb_=~2|mZ7M5J;Fo1#e7?79 zxF@f+FUuau9=*5gNKcWnUIvjYY|hg5e6@IKd%ik3i&dS4J@+HDyn7I^b0Vb%DYcYR zgOu8lH7j9Zz8MopCTB8ZuUWZS%*wEYlLfmD#_-O$^fV53&VvTqZxQ|$tE@}Z z^J4W}hN70^@6r*hi_S}xP5f%}($33AOnHS({PJ%V*u;;Sm)chF`p#v5v)}w^)+fwM zQ4+dAv3=sGt*v9z}L31(ULwGJA+ju^U*v2Vs9&F=_$TqHWFbHh+RLOGlQb62l)}f!m zNMIPPA5;>xlXn+*e| zZ_Smwx+rR>jjZ!51V7~j@3ZPQSu@vi#P4_`*FP*9`Cegq->kFd zkU`FK1<;_&W^Xt2ZCT&5RqQ@us~`~Q?kb5R-LY%iw%(rZjTATKwAqYb4-PbRA=CN| zy|#@~!C+<-a$G&yy#@%$?@!TNL5q7Zh_u?=Zcl+{d({qM%2hVr#f zjBQmLLlSsT_O)=43HJCn}k1$Sg&=oN#5oud!fbPxGX{iIUU6M3){C@17>^J@TE>wcfvdtuFAB1HwNL=Iv47Vdd zK+zOA$B)5|&O&N~LN$mIR~Iv^!2}GD!jQg>vsk(q_1_dZ=#;39U#6oLQ3w)837TS_1MsW@k)+s%oS;6(nD9jk{waJe zYA8dn=$z#TtQlJv?5EdTl`IkKI};S4oeWWn@-0_wg-(gVcP@~Jl9Sn?4?rdzCzSWwuo^*2n(tpj2hW-nE_22-#zf3L|E1@7_XE9q* zM4kp)x;A%TGyKftY4H~>V&_Gr4 zhOXY;u?Dy6)-L$!-G&ZO`Nc)$r)YEc9k=yu$2j)|M4NYqt>U8@T*3rlDwB7&LK4(q zS9h=R*26^ItzJ*BS5{tkujlnmr#{{5?K;%oque+N z$<{JnO4`X*(#}P%i>5o+`lUxARwcXz=2>@7r5xJp`ZYuyGvo@Gr;c#*1S6n#4-Q-b zjf_&V0!N_;<*|SNE}*+ok*>_h?331%76I!`S7w&5DI&-t!at`yXHN?JF)xAOqYxV0s9ozic z4TlJkUy-bbv%{O9(@{HFZeg>2tl2o69Bw(*viY?m$)oW#Rj0m^I2Jjch|J!Xx+j_P zub(uMd$n<2X0C@5m{F2#>0#3?nebWnOE80$ZA2rfVgP z5Q7KCULnde9#)G~d$JLjY_1BXqt~|M>~tgpLj^f+wL+3{ke&6|;&M5GBBED!2`PwqtC`Qi4pdV{i|>#}#T22y*8Nz6RnC{Kf<%!PCiW^Oth zqS0)jfx%IOW6hgiJDfZ!7nvlOk}z@}i#;4q&L6%nne}%Z%Doy34^8KZbJ!2~p6?OX zRA`HF4s=e28Z|gZ%~T^}4-07w<+dn$e7qS($5fMCaJuTl0`vjyCd~Qs z$x_dSOuSD{Mq8$GGe8Q#<79xlbjECICZ24?X>2(%5p30GSQqH$4-V9lBdPEwU0Vb8 zAj^hG_9`B8Is~YU72N1bY4k{F^Fh^~i$M=u?a7~n7oSpN0g{>L&X<@UXD)DxT_BXN zs>Bs%R$^Vg#G=_MD%WF|yYkG+b^7kic~OyGyU1(KtjKBkrrMZORA7l+VC2jS#5}9{ zVPhLf>W^x(?4e}Ru<0$rABj=}8!tqi{8V{ZIx?;ivbvJZH2H}eHOw}p;5usx>g0-5 zWvOv`;;CYS@t0EBio(k1)Q8|*3L`~FHXqgMT;@%w&Al8l<5Xi*1NA30;e-+{$5_Qo zys<*lOHg2Wh#m3yFn67^V;5G<#nKr+`d^*jRw^yoJ#{)woRS7{zt_TeW?ZiyX*O=q zk0p$obUM^#bovY(<_S540EbO7qDJ?W0urUT0@7D&Ps*TeLWir;;W&Jl zZSrJGlo38!rvEJupRxWt#@-Nb?S^=r8ygsj^^h95N)nfCY_iJjV=lW1kJsX0OBe=x zSm=4koSzQ;aNJm@A8j#i)Q=~L<0N|r`c|!@yJoc^CVx>RVJuXj&JOtPK>bLwS^LiO zvw7=4u-D*FHmCwP(vmRiYybqu07&gi^_xDNxcs8SNsO5FLm`@@>|3Uh%94Z0an zr~sh3gXTPQ{(R*5s5u{~Fpo@l4F*|y0tQOV9mXk8zgb^^37e-w4XrlMvHTib?(uo* z$PS>l3!VUF^i>?}p`f@_M<`gqu`4LZ?4d!|h-hz9tag%qegiIQ%K0pP1vBudPtYMK z?T7%Z=iHGFeq6&^Eo0?seoL|Ywjp&H8+;TARAVjXA6O@$eGKxi?S&G^`@3xKe*dl> zFkFz!H)L(W4N`E|h7H|xHUfEU+1OTNj8ZBp)3T4fqD{&YFz}@wJdlia>#27@-a<0I5@C{TBa%^U4l~IJ008DbIUEzS&;Cb z#i0!Z@pFf2NUG1X1NqvgF{&%vx=D7S;nf9NVp|!RoMc0B zRwsx~0dv5|l#0#{0{hj$B(4fh8D5aAj8~2hoRrO?f38)jG-*0(!}S`ydT^lKb-t!+ zBdf6N3B$N4eNXWa5h9H}Ie|vpX}dejstNb!Gug@w6Eb3AB=~~ zRG_cL2Hk-uSU^i|>AtOdJETGHmcH%Xt|ITHZW{OS@0}my$NjX;LG{C4eh$4x-JV9p z#C#kzoh`jU7ER>q^(g8l*#i$X4lQhicujr}@u!=8as5Wo;T~;%xFs?F$bE^de;qb} z;oKWr-eI`d(M`vaiMQW+I_HmXe(k1?;{Z$nFhzjL&95EHz0s^%xxTERm4zIGHwA_b zavnOUAH+8BtOLu8sv#xwJ=^7~5 z#5y{)$~0rf;K22yXCrS!Iu>|(ug1l@L$0HOAc3n>NfrWHz;*Tls`k_^$?af=JtFNR*Iz& zc^eMJ;^Lxu{bM2Vic;L*kjX0LPx{LWX_K#Q%Z?+lY)sK z%^rsaZ_fkz@o22G`bpLW-{E-7`1QZ zfGz~5=i2EG0thJt^9+-eXDIk6fjfi6DCiuF6L7j{aIVWzQgoG|?W<{(Z@2Eg6|mws&vo`v4h3w)bt}4f&Ry?a(asZS5BQMKvq*i@c5%&h7~b zdYu~TRSm?U8ykeXAhAr$!^d&Yg4%1cmV&CfIY{S!^hnXl$%G8wDb6(Ony7lsEv~JA>@H%J^DDQbsL2M0XSYZH`H zyN64vML%cd585aiin8q6R=FQuiyTF0F0d!!Dj4;`x1-rFbjFWTycSF%Tn^XI8#=nKM@|nCIz0&P(aHC7 zjEYvct1j-kP?IkxkV|On7#~ywg}+x2311s=LvmDC>b6H$8JJ6)8#gmHo>3A!1|=ho z((x&C<-o*Ew=4EQB}qm<7tgxTIb`9ea>};M` z&l-~dMFM*_P(IkcwM5t4ZK zVL4^(GtX&nHj1H}W8F$J!j?F z5_&fOYWlMN6c+#sqMtO_k2IUr^AGPetF!*=hx>C6fbV(kot<&Ne@%^lLk;;ZcvuPM z+2NTiv&`6XdxfESmC6n0%1T$SqTL40N6~OP(P1;XeAEE~z7XaNv($9;_jET@-li`+ z^b1IzS&;79#}r#Gf;gY)`v^B`>IQzyzMdX>|2(Vm97tg$ICyI|RauodjSHD98E$O~ zr^&ci0&8(NLDz_R+hG0EgJ2>9bWq0qoeNAuesXqxn+QSha>DeoHEggwJ z+}tw%@O>?WK{4Y{?g$#r=KyKq5*cQR)lfi{LoS{$#!iN?1)r6+AZ)K5VPmfqo&2>l zS>7nbeGyiTpMy0+Q>DFM=ip=<+O zqwz=MEeY~PPyixBdInF+!LuaIe)RLH0V%p;1y^oO)Q(BiXhWyX;(Yc;Vpes+ESMU` za?exBo#WZi8h?V|3)Gfu(SxVs3jXj zHIE3=!X|7HWQC!d6wO-7r%q-dvW9WtF|)>i#b)ILCT_dxBx}xnWU)E*bWeZoiO;8! zF+-=3gre)YcQz5pV9T6m2hY`0Q?MWuseo(37*e^6sCZY*6bX0g3LdhlGz=KEhVI+9 zL2C@Vwb@1&4Evp(0*!bQ?4m%S}gWQ$W|i(RB&ifmCu`f)hN*^bOQZiD)OO$w$) zACYhSi#B8+p*JT3Kqvx#P8{dpS1!!XBoJgIQaLzVL1~;R-v)qX{YeF7H&Y#-!9bX` zjArVZ(X6rwnRPr0^Y)wb_L}u#3u?$MHS2V**v_?x?g;t=rF>gB9jrS>-&q<}{^Ea#T*jQ^a$kanARt>OBYY0~8>=~2-<0##B7rP^yyr|qM`w&vuvN}G zq~|l-U(eU{SzwYC_rlbPx;DSjjC8;TK@aX2jnNFJGpD(}z_o(U?!tz51I?|X+Z4{? z3rQ1RzHoM}C*Eb+rBDRAKl!)AnLhI1)~CrG4R6RpzMP}=TNN3r;(V)ub+o_do1EoR zK;zqlb-$Kd8ontBUt{$ACMC$X9kj?*s=p_#=w_h&6SiB#5@{l@4p_r4m8s zYwKLxrdw+QXPgV^(*Y<#{{u7$l@wqvfTltZ0F4RWuv;*wG34|krxYeABS*oJz)|C7 z5NXSEP-ASM_%H!j-Dt*p74UR2m`eUm2i#5<;k~@cZ0%ran<$HYX+wM!IF~jbouk1? zI~tf5*;t^gl-j=vkND~(;Gx=Jh~&0Q*Ydo_;bu{cawm>7iz=00jyA)5$)RH{3ArBk zc4NE^(K|dBvgK>1R-pU=NG|o+b<$d(fP70!>mRffS zC%#7zDx&G<4h}3Kovcf@ZX23+KqVUJg&#ibsS(HM%%+;Ri71m6%tir4#mPP8zX4*F z+xAJICQru8tfTh4B3tQqPm6!QBK*VTy=(mADI60CkDeV8mPdIee{>~1^qIU7dVY9z zsQ9b@dQ|kB_`ijUFWac-Ou8WBmobGnJ4n|eheP5fRA0X@rKaNV3Ritb^>xb9#r zWpNU8K?2JlOETFLCmqiffTlI}v?$ROG<0e>kjy!kDF^dc??8LX!(!SwgC@90?_}5J zkgr~pp`S<9TZjk3hcH}FcAYJ#bE+~?F-o!<&1pJ6Zq22l2{c%)^jsk=n28o#Lvw&p z@RC_xL0RRqQF#d_;OshEJl-f?BaJt&~F~h;`&WDsg?b3B02vkxys*g z1oWAx@~c#c?6`*!5{vW^yWkr*AK$kl`U}2ur^UXXy|%@83ZN~rdo|C~4d}p_n_`C? zIWPoOhu`no$X!9W$`!t`-jK_Y?dVC~@1Qy*?dka9FnwZBBVAb~DGcmmFS4M%gy`vV z@&E~iex8)=5v1drDsAI`#KkJVgJ!~rZ{^2|taVo>GR!?ZI22hhl!Z=8S{u~WjKB_@Ovsm;8qQObaD>o0tvwp%BVTov|RZHt4_?C?5x}s^L zfJfk#dFX&Gz7S%!%nfdpQ?sj_siv!Vta2WD&$Go%J&dLXMm6;jM&9CPk=oN~76#tM zx^S~tKbdb%Vb!Rz)o9`cj)TQ%zG<`)&<#A$ zj(tY)pU&bFJNwUsTaG>VDb1aC4$-&edD> zbL#QX=GVgOjgj@*NbVP*a5mfPWtlt{6rvaQ6DF5OOdw05J(aA0mA|6}Mp>Pfw#r!^^ZZcx^oa7v^Od5z>@Q={!AoDJpo_k=r9z89k1Dz62XNij z0A6^o{CL6NBztyGXhE9SNst2h+n<Dy7k`_80-*olg) zpC_%Tsxnjs-zvISU)5xga9Rp?2w+V?rTwbXHB6D$@ozdsU3B3N+{{%!F^N9cmK&$L z@=Cc0)J0z;iX9;tPvPo|HZ#~5#hkim-DI>00wpWUj0>SIsysh~NmRbv;ys12AevSW zw4(n)dI(Oqqy*lk80rNRhn1v7{=#- z@#0NK_;H=QFcZGtMrx9WkZGbk^7Dzm|un?esh3 zEh-PC+4~8TLgTBEdnR& zh7;#LO+zHIGKoqU;Me=JuM z`vxk~_Q&*(WcNz)a7d&l!UxxPQAcBjfx&W)zvEg#??N=E9@mV+g;u@~Nf*V?=M*E+ z#`e{#qiJDjr!l8x-`+tRpjA#MUCV7=tJSdX)Te_Um+(iVShR;HxY#4~r_dk$uhAbd zSIHeaqFKPkPJ8=ln~pBKbPHqfkyC8dl`${}-jh8Pqm!wm z3ZPw2EgFP!CK zjRxIxYcpl6N&+}-k+>E^yc9i3&4JpBAf**oQ7c%DHQ_ROm#tV@)Cykk^aC$$)O-4Q ze|Pn2&?&P-ZudT4ul7CEJJo#&7^{>{*LRn|;9f+w0!_47`b^OR5Ne@|+KId-i>ha8 zt$hyFR|ts;uRN2vAGcYzQ= zt7&G7KS({A@M3^mgjc>pO$*!#;lRxqqQ|hu;aNYWuxJ1rbl-IqfFEo*33*3rUldpn! zvCoH=h(A0rG3aSrBfUQ;a*g!U01VX_!z-Y}S^( zuc|(kMkgfc+N$%V^E@j2vz7+VSSNQ*=r<)<0a~DAD3;R73U&l#ea3BCG-jhOG~j!q zY6|a-+MrZ)`t(hQHYr!;EWD9f#)SJ^2wsD9Ik)NCZ~EY@{A0Ku-wX<;)erTU)eLp& zPi$cNQnZSDLR}D!BA(Npv|}IcIr^OTp#AoEkKCRKnA{z9!?~;Mh@o115t?&ngGoOer&IppxjA;~^V7wr#;jrxIf5#8 zO+5F`TwDYOrv;ve6#vfC%Vc{oHb9x^qG9ecxn%8-!$O`fQjpP=gWB&P$5cd{!nlWG zRX9$5UE-Ufon#m0UjjQy)Mi3ye+5CvOScly%W))nfH7kE`7+)n+27=lDB3|MIk&e^ zo_l!KeIKAliG6DoyP#>Wq&X5_0U*GauH-k*3VP^U_{t&u@27I4m(4o=K&Mxz82M## zR>EYWM5huyJ~*&Ex^+Vzj`88bLpe0QwQp;1$4V z@CmGd%ON=I>A~GLd&Ph;bZ$sro8SN09`tZXH*{Y}+>u@Oj9U4^h+0*2MF*dVHfW|q z=)rD7p3ufJ3{@pdo(h2Q0hi1 zO#ew4)tukwj6}k735mAqB%gh4jSwGWgNBdsKB`qiC$H6m*-_t+X2yDfL%@|OVw~Gk z3;U{PaDaiDqP>E}KaWGUCXtkY9lU1vN0z|^Dxp!TvKRcpsp&?>NDu6!gARO%FXp zF0I;goXP|IX%6zTe}scfAwJAO&u#qh_R>TDdqr&6Vq9XRC{lYV!XP?30_l~!Czr@I zXZjY#*Ag!m{=x(_hddl`P>(iED)Xm`Yse1A;2Hl)Oo#)oS;sLxe`gb)m!X@RYDQuP zT(z_8puFF#?ay7Uch+$>{^|6?!&oPW<9a~jV-nS7fR{LJe>MBfntpu80eAcEh$Pu5d|weId4FHa$#CGrTL})A z-|e9aSih-nq2QM&MdubAprG~=&+NyP0uO|VIgna|`7}*fS?$F?0cc6^op=5Z>!@jm literal 0 HcmV?d00001 diff --git a/clos/3.5/methods.lisp b/clos/3.5/methods.lisp new file mode 100644 index 00000000..fa52befe --- /dev/null +++ b/clos/3.5/methods.lisp @@ -0,0 +1,1304 @@ +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + + +;;;. Copyright (c) 1991 by Venue + +(in-package "CLOS") + + + +;;; METHODS Methods themselves are simple inanimate objects. Most properties of methods are +;;; immutable, methods cannot be reinitialized. The following properties of methods can be changed: +;;; METHOD-GENERIC-FUNCTION METHOD-FUNCTION ?? + +(defclass method (metaobject) ()) + +(defclass standard-method (definition-source-mixin documentation-mixin method) + ((generic-function + :initform nil + :accessor method-generic-function) +; (qualifiers +; :initform () +; :initarg :qualifiers +; :reader method-qualifiers) + (specializers + :initform () + :initarg :specializers + :reader method-specializers) + (lambda-list + :initform () + :initarg :lambda-list + :reader method-lambda-list) + (function + :initform nil + :initarg :function + :reader method-function) ;writer defined by hand +; (documentation +; :initform "" +; :initarg :documentation) + )) + +(defclass standard-accessor-method (standard-method) + ((slot-name :initform nil + :initarg :slot-name))) + + +;;; This method has to be defined by hand! Don't try to define it using :accessor or :reader. It +;;; can't be an automatically generated reader method because that would break the way the special +;;; discriminator code which uses this feature works. -- Probably false now 8/21 + + +(defmethod accessor-method-slot-name ((m standard-accessor-method)) + (slot-value m 'slot-name)) + +(defclass standard-reader-method (standard-accessor-method) ()) +(defclass standard-writer-method (standard-accessor-method) ()) + +(defmethod print-object ((method standard-method) + stream) + (printing-random-thing (method stream) + (let ((generic-function (method-generic-function method)) + (class-name (capitalize-words (class-name (class-of method))))) + (format stream "~A ~S ~{~S ~}~:S" class-name (and generic-function ( + generic-function-name + + generic-function + )) + (method-qualifiers method) + (unparse-specializers method))))) + +(defmethod print-object ((method standard-accessor-method) + stream) + (printing-random-thing (method stream) + (let ((generic-function (method-generic-function method)) + (class-name (capitalize-words (class-name (class-of method))))) + (format stream "~A ~S, slot:~S, ~:S" class-name (and generic-function ( + generic-function-name + + generic-function + )) + (accessor-method-slot-name method) + (unparse-specializers method))))) + + +;;; INITIALIZATION Error checking is done in before methods. Because of the simplicity of standard +;;; method objects the standard primary method can fill the slots. Methods are not reinitializable. + + +(defmethod reinitialize-instance ((method standard-method) + &rest initargs) + (declare (ignore initargs)) + (error + "Attempt to reinitialize the method ~S.~%~ + Method objects cannot be reinitialized." method)) + +(defmethod shared-initialize :before ((method standard-method) + slot-names &key qualifiers lambda-list specializers function + documentation) + (declare (ignore slot-names)) + (flet ((lose (initarg value string) + (error "When initializing the method ~S:~%~ + The ~S initialization argument was: ~S.~%~ + which ~A." method initarg value string))) + (let ((check-qualifiers (legal-std-qualifiers-p qualifiers)) + (check-lambda-list (legal-std-lambda-list-p lambda-list)) + (check-specializers (legal-std-specializers-p specializers)) + (check-function (legal-std-method-function-p function)) + (check-documentation (legal-std-documentation-p documentation))) + (unless (eq check-qualifiers t) + (lose :qualifiers qualifiers check-qualifiers)) + (unless (eq check-lambda-list t) + (lose :lambda-list lambda-list check-lambda-list)) + (unless (eq check-specializers t) + (lose :specializers specializers check-specializers)) + (unless (eq check-function t) + (lose :function function check-function)) + (unless (eq check-documentation t) + (lose :documentation documentation check-documentation))))) + +(defmethod shared-initialize :before ((method standard-accessor-method) + slot-names &key slot-name) + (declare (ignore slot-names)) + (let ((legalp (legal-std-slot-name-p slot-name))) + (unless (eq legalp t) + (error "The value of the :SLOT-NAME initarg ~A." legalp)))) + +(defmethod shared-initialize :after ((method standard-method) + slot-names &key qualifiers) + (setf (plist-value method 'qualifiers) + qualifiers)) + +(defmethod method-qualifiers ((method standard-method)) + (plist-value method 'qualifiers)) + +(defclass generic-function (dependent-update-mixin + definition-source-mixin + metaobject) + () + (:metaclass funcallable-standard-class)) + +(defclass standard-generic-function (generic-function) + ((name + :initform nil + :initarg :name + :accessor generic-function-name) + (methods + :initform () + :accessor generic-function-methods) + (method-class + :initarg :method-class + :accessor generic-function-method-class) + (method-combination + :initarg :method-combination + :accessor generic-function-method-combination) + +; (permutation +; :accessor gf-permutation) + (arg-info + :initform () + :accessor gf-arg-info) + (dfun-state + :initform () + :accessor gf-dfun-state) + (effective-method-functions ;((methods . fn) ..) + :initform () + :accessor gf-effective-method-functions) + (valid-p + :initform nil + :accessor gf-valid-p) + (pretty-arglist + :initform () + :accessor gf-pretty-arglist) + ) + (:metaclass funcallable-standard-class) + (:default-initargs :method-class *the-class-standard-method* + :method-combination *standard-method-combination*)) + + +(define-gf-predicate generic-function-p generic-function) + +(define-gf-predicate method-p method) + +(define-gf-predicate standard-accessor-method-p standard-accessor-method) + +(define-gf-predicate standard-reader-method-p standard-reader-method) + +(define-gf-predicate standard-writer-method-p standard-writer-method) + +(defvar *the-class-method* (find-class 'method)) + +(defvar *the-class-standard-method* (find-class 'standard-method)) + +(defvar *the-class-generic-function* (find-class 'generic-function)) + +(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function)) + +(defmethod print-object ((generic-function generic-function) + stream) + (named-object-print-function generic-function stream (list (length (generic-function-methods + generic-function))))) + +(defmethod shared-initialize :before ((generic-function standard-generic-function) + slot-names &key (name nil namep) + (lambda-list nil lambda-list-p) + argument-precedence-order declarations documentation + (method-class nil method-class-supplied-p) + (method-combination nil method-combination-supplied-p)) + (declare (ignore slot-names declarations argument-precedence-order lambda-list lambda-list-p + name)) + (when namep (set-function-name generic-function name)) + (flet ((initarg-error (initarg value string) + (error "When initializing the generic-function ~S:~%~ + The ~S initialization argument was: ~A.~%~ + It must be ~A." generic-function initarg value string))) + (cond (method-class-supplied-p (when (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (and (classp method-class) + (*subtypep method-class *the-class-method*)) + (initarg-error :method-class method-class + "a subclass of the class METHOD")) + (setf (slot-value generic-function 'method-class) + method-class)) + ((slot-boundp generic-function 'method-class)) + (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD"))) + (cond (method-combination-supplied-p (unless (method-combination-p method-combination) + (initarg-error :method-combination + method-combination + "a method combination object"))) + ((slot-boundp generic-function 'method-combination)) + (t (initarg-error :method-combination "not supplied" "a method combination object" + ))))) + +(defmethod initialize-instance :after ((gf standard-generic-function) + &key lambda-list argument-precedence-order) + (declare (ignore slot-names)) + (when lambda-list + (setf (gf-arg-info gf) + (new-arg-info-from-generic-function lambda-list argument-precedence-order)))) + +(defmethod reinitialize-instance ((generic-function standard-generic-function) + &rest initargs &key name lambda-list argument-precedence-order + declarations documentation method-class method-combination) + (declare (ignore documentation declarations argument-precedence-order lambda-list name + method-class method-combination)) + (macrolet ((add-initarg (check name slot-name) + `(unless ,check + (push (slot-value generic-function ,slot-name) + initargs) + (push ,name initargs)))) + ; (add-initarg name :name 'name) + ; (add-initarg lambda-list :lambda-list + ; 'lambda-list) (add-initarg + ; argument-precedence-order + ; :argument-precedence-order + ; 'argument-precedence-order) + ; (add-initarg declarations + ; :declarations 'declarations) + ; (add-initarg documentation + ; :documentation 'documentation) + ; (add-initarg method-class + ; :method-class 'method-class) + ; (add-initarg method-combination + ; :method-combination + ; 'method-combination) + (apply #'call-next-method generic-function initargs))) + + +;;; These three are scheduled for demolition. + + +(defmethod remove-named-method (generic-function-name argument-specifiers &optional extra) + (let ((generic-function nil) + (method nil)) + (cond ((or (null (fboundp generic-function-name)) + (not (generic-function-p (setq generic-function (symbol-function + generic-function-name)) + ))) + (error "~S does not name a generic-function." generic-function-name)) + ((null (setq method (get-method generic-function extra (parse-specializers + argument-specifiers) + nil))) + (error "There is no method for the generic-function ~S~%~ + which matches the argument-specifiers ~S." generic-function argument-specifiers)) + (t (remove-method generic-function method))))) + +(defun real-add-named-method (generic-function-name qualifiers specializers lambda-list function + &rest other-initargs) + + ;; What about changing the class of the generic-function if there is one. Whose job is that + ;; anyways. Do we need something kind of like class-for-redefinition? + (let* ((generic-function (ensure-generic-function generic-function-name :lambda-list + (method-ll->generic-function-ll lambda-list))) + (specs (parse-specializers specializers)) + ; (existing (get-method + ; generic-function qualifiers specs + ; nil)) + (proto (method-prototype-for-gf generic-function-name)) + (new (apply #'make-instance (class-of proto) + :qualifiers qualifiers :specializers specs :lambda-list lambda-list + :function function other-initargs))) + ; (when existing (remove-method + ; generic-function existing)) + (add-method generic-function new))) + +(defun make-specializable (function-name &key (arglist nil arglistp)) + (cond ((not (null arglistp))) + ((not (fboundp function-name))) + ((fboundp 'function-arglist) + + ;; function-arglist exists, get the arglist from it. + (setq arglist (function-arglist function-name))) + (t (error "The :arglist argument to make-specializable was not supplied~%~ + and there is no version of FUNCTION-ARGLIST defined for this~%~ + port of Portable CommonLoops.~%~ + You must either define a version of FUNCTION-ARGLIST (which~%~ + should be easy), and send it off to the Portable CommonLoops~%~ + people or you should call make-specializable again with the~%~ + :arglist keyword to specify the arglist."))) + (let ((original (and (fboundp function-name) + (symbol-function function-name))) + (generic-function (make-instance 'standard-generic-function :name function-name)) + (nrequireds 0)) + (if (generic-function-p original) + original + (progn (dolist (arg arglist) + (if (memq arg lambda-list-keywords) + (return) + (incf nrequireds))) + (setf (symbol-function function-name) + generic-function) + (set-function-name generic-function function-name) + (when arglistp + (setf (gf-pretty-arglist generic-function) + arglist)) + (when original + (add-named-method function-name nil (make-list nrequireds :initial-element + 't) + arglist original)) + generic-function)))) + +(defun real-get-method (generic-function qualifiers specializers &optional (errorp t)) + (let ((hit (dolist (method (generic-function-methods generic-function)) + (when (and (equal qualifiers (method-qualifiers method)) + (every #'same-specializer-p specializers (method-specializers method + ))) + (return method))))) + (cond (hit hit) + ((null errorp) + nil) + (t (error "No method on ~S with qualifiers ~:S and specializers ~:S." + generic-function qualifiers specializers))))) + + +;;; Compute various information about a generic-function's arglist by looking at the argument lists +;;; of the methods. The hair for trying not to use &rest arguments lives here. The values returned +;;; are: number-of-required-arguments the number of required arguments to this generic-function's +;;; discriminating function &rest-argument-p whether or not this generic-function's discriminating +;;; function takes an &rest argument. specialized-argument-positions a list of the positions of the +;;; arguments this generic-function specializes (e.g. for a classical generic-function this is the +;;; list: (1)). + + +(defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function) + ) + (declare (values number-of-required-arguments &rest-argument-p specialized-argument-postions)) + (let ((number-required nil) + (restp nil) + (specialized-positions nil) + (methods (generic-function-methods generic-function))) + (dolist (method methods) + (multiple-value-setq (number-required restp specialized-positions) + (compute-discriminating-function-arglist-info-internal generic-function method + number-required restp specialized-positions))) + (values number-required restp (sort specialized-positions #'<)))) + +(defun compute-discriminating-function-arglist-info-internal (generic-function method + number-of-requireds restp + specialized-argument-positions) + (declare (ignore generic-function)) + (let ((requireds 0)) + + ;; Go through this methods arguments seeing how many are required, and whether there is + ;; an &rest argument. + (dolist (arg (method-lambda-list method)) + (cond ((eq arg '&aux) + (return)) + ((memq arg '(&optional &rest &key)) + (return (setq restp t))) + ((memq arg lambda-list-keywords)) + (t (incf requireds)))) + + ;; Now go through this method's type specifiers to see which argument positions are type + ;; specified. Treat T specially in the usual sort of way. For efficiency don't bother + ;; to keep specialized-argument-positions sorted, rather depend on our caller to do + ;; that. + (iterate ((type-spec (list-elements (method-specializers method))) + (pos (interval :from 0))) + (unless (eq type-spec *the-class-t*) + (pushnew pos specialized-argument-positions))) + + ;; Finally merge the values for this method into the values for the exisiting methods + ;; and return them. Note that if num-of-requireds is NIL it means this is the first + ;; method and we depend on that. + (values (min (or number-of-requireds requireds) + requireds) + (or restp (and number-of-requireds (/= number-of-requireds requireds))) + specialized-argument-positions))) + +(defun make-discriminating-function-arglist (number-required-arguments restp) + (nconc (gathering ((args (collecting))) + (iterate ((i (interval :from 0 :below number-required-arguments))) + (gather (intern (format nil "Discriminating Function Arg ~D" i)) + args))) + (when restp + `(&rest ,(intern "Discriminating Function &rest Arg"))))) + + +;;; + + +(defun make-arg-info (precedence metatypes number-optional key/rest-p keywords) + (let ((new (make-array 6 :adjustable nil))) + (setf (svref new 0) + 'arg-info + (svref new 1) + precedence + (svref new 2) + metatypes + (svref new 3) + number-optional + (svref new 4) + key/rest-p + (svref new 5) + keywords) + ; nil no keyword or rest + ; allowed (k1 k2 ..) each method must + ; accept these keyword arguments T + ; must have &key or &rest + new)) + +(defun check-arg-info (x) + (or (and (simple-vector-p x) + (= (array-dimension x 0) + 6) + (eq (svref x 0) + 'arg-info)) + (error "~S is not an ARG-INFO." x))) + +(defun arg-info-precedence (arg-info) + (check-arg-info arg-info) + (svref arg-info 1)) + +(defun arg-info-metatypes (arg-info) + (check-arg-info arg-info) + (svref arg-info 2)) + +(defun arg-info-number-optional (arg-info) + (check-arg-info arg-info) + (svref arg-info 3)) + +(defun arg-info-key/rest-p (arg-info) + (check-arg-info arg-info) + (svref arg-info 4)) + +(defun arg-info-keywords (arg-info) + (check-arg-info arg-info) + (svref arg-info 5)) + +(defun arg-info-applyp (arg-info) + (check-arg-info arg-info) + (or (plusp (arg-info-number-optional arg-info)) + (arg-info-key/rest-p arg-info))) + +(defun arg-info-number-required (arg-info) + (check-arg-info arg-info) + (length (arg-info-metatypes arg-info))) + +(defun arg-info-nkeys (arg-info) + (count-if #'(lambda (x) + (neq x 't)) + (arg-info-metatypes arg-info))) + +(defun new-arg-info-from-generic-function (lambda-list argument-precedence-order) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list lambda-list) + (declare (ignore allow-other-keys-p)) + (let ((metatypes (make-list nreq)) + (precedence (compute-precedence lambda-list nreq argument-precedence-order))) + (make-arg-info precedence metatypes nopt (or keysp restp) + keywords)))) + +(defun new-arg-info-from-method (method) + (multiple-value-bind (nreq nopt keysp restp) + (analyze-lambda-list (method-lambda-list method)) + (make-arg-info (compute-precedence (method-lambda-list method) + nreq nil) + (mapcar #'raise-metatype (make-list nreq) + (method-specializers method)) + nopt + (or keysp restp) + nil))) + +(defun add-arg-info (generic-function method arg-info) + (flet ((lose (string &rest args) + (error + "Attempt to add the method ~S to the generic function ~S.~%~ + But ~A" method generic-function (apply #'format nil string args))) + (compare (x y) + (if (> x y) + "more" + "fewer"))) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list (method-lambda-list method)) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info)) + (gf-keywords (arg-info-keywords arg-info))) + (unless (= nreq gf-nreq) + (lose "the method has ~A required arguments than the generic function." + (compare nreq gf-nreq))) + (unless (= nopt gf-nopt) + (lose "the method has ~S optional arguments than the generic function." + (compare nopt gf-nopt))) + (unless (eq (or keysp restp) + gf-key/rest-p) + (error "the method and generic function differ in whether they accept~%~ + rest or keyword arguments.")) + (when gf-keywords + (unless (or (and restp (not keysp)) + allow-other-keys-p + (every #'(lambda (k) + (memq k keywords)) + gf-keywords)) + (error "the generic function requires each method to accept the keyword arguments~%~ + ~S. The method does not all of accept these." gf-keywords))) + (make-arg-info (arg-info-precedence arg-info) + (mapcar #'raise-metatype (arg-info-metatypes arg-info) + (method-specializers method)) + gf-nopt gf-key/rest-p gf-keywords))))) + +(defun remove-arg-info (generic-function method arg-info) + (declare (ignore generic-function method)) + arg-info) + + +;;; + + +(defun compute-precedence (lambda-list nreq argument-precedence-order) + (let ((nreq (analyze-lambda-list lambda-list))) + (if (null argument-precedence-order) + (let ((c -1)) + (gathering1 (collecting) + (dotimes (i nreq) + (gather1 (incf c))))) + (mapcar #'(lambda (x) + (position x lambda-list)) + argument-precedence-order)))) + +(defmethod no-applicable-method (generic-function &rest args) + (cerror "Retry call to ~S" + "No matching method for the generic-function ~S,~@ + when called with arguments ~S." generic-function args) + (let ((*invalid-dfuns-on-stack* (remove generic-function *invalid-dfuns-on-stack*))) + (invalidate-discriminating-function generic-function) + (apply generic-function args))) + +(defun real-add-method (generic-function method) + (if (method-generic-function method) + (error "The method ~S is already part of the generic~@ + function ~S. It can't be added to another generic~@ + function until it is removed from the first one." method (method-generic-function + method)) + (let* ((qualifiers (method-qualifiers method)) + (lambda-list (method-lambda-list method)) + (specializers (method-specializers method)) + (existing (get-method generic-function qualifiers specializers nil))) + + ;; If there is already a method like this one then we must get rid of it before + ;; proceeding. Note that we call the generic function remove-method to remove it + ;; rather than doing it in some internal way. + (when existing (remove-method generic-function existing)) + + ;; + (let ((arg-info (gf-arg-info generic-function))) + (setf (gf-arg-info generic-function) + (if (null arg-info) + (new-arg-info-from-method method) + (add-arg-info generic-function method arg-info))) + (setf (method-generic-function method) + generic-function) + (pushnew method (generic-function-methods generic-function)) + (dolist (specializer specializers) + (add-method-on-specializer method specializer)) + (invalidate-discriminating-function generic-function) + (maybe-update-constructors generic-function method) + method)))) + +(defun real-remove-method (generic-function method) + (if (neq generic-function (method-generic-function method)) + (error "The method ~S is attached to the generic function~@ + ~S. It can't be removed from the generic function~@ + to which it is not attached." method (method-generic-function method)) + (let* ((methods (generic-function-methods generic-function)) + (new-methods (remove method methods)) + (new-arg-info (remove-arg-info generic-function method (gf-arg-info + generic-function)))) + (setf (method-generic-function method) + nil) + (setf (generic-function-methods generic-function) + new-methods) + (dolist (specializer (method-specializers method)) + (remove-method-on-specializer method specializer)) + (setf (gf-arg-info generic-function) + new-arg-info) + (invalidate-discriminating-function generic-function) + (maybe-update-constructors generic-function method) + generic-function))) + + +;;; This is it. You have reached the special place where everything comes together. This is where +;;; we ensure that the metacircularity will bottom out properly. Remember once again that the source +;;; of the problem is that the specified behavior clearly calls for the process of method lookup to +;;; itself call generic functions. This implies that for a given generic function in the method +;;; lookup protocol (compute-applicable-methods for example), we can end up in the unfortunate +;;; situation of having to call that generic function in order to call it! So, we must arrange to +;;; snap this infinite regress. The strategy taken here is to identify a particular subset of calls +;;; to method lookup protocol generic functions and snap the recursion there. This subset of generic +;;; function calls has the following properties: - Any generic function call in the world will, +;;; eventually reach one of these generic function calls. That is we are sure that if we can +;;; arrange for these calls not to recurse we know we are all set. - These calls themselves don't +;;; recurse. We arrange, by magic, for the method lookup and application involved in these calls +;;; not to call any other generic functions. + + +(defvar *magic-generic-functions* '((compute-discriminating-function ((standard-generic-function) + (standard-generic-function))) + (compute-applicable-methods ((standard-generic-function t) + (generic-function t))) + (compute-applicable-methods-using-classes (( + standard-generic-function + t) + (generic-function + t))) + ; (same-specializer-p + ; ((standard-class standard-class) (t + ; t))) (specializer-applicable-p + ; ((standard-class t) (class t))) + (specializer-applicable-using-class-p ((standard-class t) + (class t)) + ((built-in-class t) + (class t))) + (order-specializers-using-class ((standard-class standard-class t + ) + (class class t))) + (compute-effective-method ((standard-generic-function + (eql *standard-method-combination*) + t) + (generic-function + standard-method-combination t)) + ) + (method-p ((standard-method) + (method)) + ((standard-reader-method) + (method)) + ((standard-writer-method) + (method))) + (standard-accessor-method-p ((standard-method) + (t)) + ((standard-reader-method) + (standard-accessor-method)) + ((standard-writer-method) + (standard-accessor-method))) + (standard-reader-method-p ((standard-method) + (t)) + ((standard-reader-method) + (standard-reader-method)) + ((standard-writer-method) + (t))) + (standard-writer-method-p ((standard-method) + (t)) + ((standard-reader-method) + (t)) + ((standard-writer-method) + (standard-writer-method))) + (method-qualifiers ((standard-method) + (standard-method)) + ((standard-reader-method) + (standard-method))) + (method-specializers ((standard-method) + (standard-method)) + ((standard-reader-method) + (standard-method))) + (method-lambda-list ((standard-method) + (standard-method)) + ((standard-reader-method) + (standard-method))) + (method-function ((standard-method) + (standard-method)) + ((standard-reader-method) + (standard-method))) + (accessor-method-slot-name ((standard-reader-method) + (standard-accessor-method)) + ((standard-writer-method) + (standard-accessor-method))) + (classp ((standard-class) + (class)) + ((built-in-class) + (class))) + (class-precedence-list ((standard-class) + (clos-class))) + (class-finalized-p ((standard-class) + (clos-class))) + (generic-function-methods ((standard-generic-function) + (standard-generic-function))) + (generic-function-method-combination ((standard-generic-function) + (standard-generic-function) + )) + (gf-arg-info ((standard-generic-function) + (standard-generic-function))) + (gf-dfun-state ((standard-generic-function) + (standard-generic-function))) + (gf-effective-method-functions ((standard-generic-function) + (standard-generic-function))) + ((setf gf-effective-method-functions) + ((t standard-generic-function) + (t standard-generic-function))) + ; (gf-permutation + ; ((standard-generic-function) + ; (standard-generic-function))) + (slot-value-using-class ((standard-class t + standard-effective-slot-definition + ) + ; the first t is a bug + (std-class standard-object + standard-effective-slot-definition + )) + ((funcallable-standard-class t + standard-effective-slot-definition) + (std-class standard-object + standard-effective-slot-definition))) + ((setf slot-value-using-class) + ((t standard-class t standard-effective-slot-definition) + (t std-class standard-object standard-effective-slot-definition + )) + ((t funcallable-standard-class t + standard-effective-slot-definition) + (t std-class standard-object standard-effective-slot-definition + ))))) + +(defvar *magic-generic-functions-1* nil) + +(defun + fixup-magic-generic-function + (gfspec early-methods gf methods) + (flet + ((get-specls (names convert-t-p) + (mapcar #'(lambda (s) + (cond ((consp s) + `(eql ,(eval (cadr s)))) + ((eq s t) + (if convert-t-p + (find-class t) + t)) + (t (find-class s)))) + names))) + (let + ((e (assoc gfspec *magic-generic-functions* :test #'equal))) + (when e + (push (list* gf (make-arg-info + nil + (apply #'mapcar #'(lambda (&rest args) + (if (every #'(lambda (arg) + (eq arg 't)) + args) + 't + 'standard-instance)) + (mapcar #'second (cdr e))) + nil nil nil) + (gathering1 (collecting) + (dolist (pair (cdr e)) + (iterate ((em (list-elements early-methods)) + (m (list-elements methods))) + (when (equal (early-method-specializers em t) + (get-specls (cadr pair) + t)) + (gather1 (list (get-specls (car pair) + nil) + (list m) + (early-method-function em))) + (return t)))))) + *magic-generic-functions-1*))))) + +(defun get-secondary-dispatch-function (generic-function args) + (declare (values compiled-secondary-dispatch-function methods arg-info)) + (multiple-value-bind (fn methods arg-info) + (get-magic-secondary-dispatch-function generic-function args) + (if fn + (values fn methods arg-info) + (get-normal-secondary-dispatch-function generic-function args)))) + +(defun get-magic-secondary-dispatch-function (generic-function args) + (let ((e (assq generic-function *magic-generic-functions-1*))) + (when e + (dolist (entry (cddr e)) + (destructuring-bind (specls appl function) + entry + (unless (iterate ((arg (list-elements args)) + (specl (list-elements specls))) + (let ((class (class-of arg))) + (unless (if (consp specl) + (eql (cadr specl) + arg) + (or (eq specl t) + (eq specl class))) + (return t)))) + (return (values function appl (cadr e))))))))) + +(defmacro protect-cache-miss-code (gf args &body body) + (let ((wrappers (gensym)) + (invalidp (gensym)) + #'(gensym) + (appl (gensym))) + (once-only (gf args) + `(if (memq ,gf *invalid-dfuns-on-stack*) + (multiple-value-bind (,wrappers ,invalidp ,function ,appl) + (cache-miss-values ,gf ,args) + (declare (ignore ,wrappers ,invalidp)) + (if (null ,appl) + (apply #'no-applicable-method ,gf ,args) + (apply ,function ,args))) + (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*))) + ,@body))))) + +(defmethod same-specializer-p (specl1 specl2) + (eq specl1 specl2)) + +(defmethod specializer-applicable-p ((specializer class) + object) + (memq specializer (class-precedence-list (class-of object)))) + +(defmethod specializer-applicable-using-class-p ((specializer class) + class) + (*subtypep class specializer)) + +(defmethod order-specializers-using-class ((specl1 class) + (specl2 class) + class) + (cond ((eq specl1 specl2) + nil) + ((memq specl2 (memq specl1 (class-precedence-list class))) + specl1) + (t specl2))) + +(defmethod compute-applicable-methods ((generic-function generic-function) + arguments) + (labels ((filter (method) + (let ((arguments-tail arguments)) + (dolist (m-spec (method-specializers method) + t) + (unless arguments-tail + (error "The function ~S requires at least ~D arguments" + (generic-function-name generic-function) + (arg-info-number-required (gf-arg-info generic-function)))) + (unless (specializer-applicable-p m-spec (pop arguments-tail)) + (return nil))))) + (sorter (method-1 method-2) + (dolist (index (arg-info-precedence (gf-arg-info generic-function))) + (let* ((specl1 (nth index (method-specializers method-1))) + (specl2 (nth index (method-specializers method-2))) + (class (class-of (nth index arguments))) + (order (order-specializers-using-class specl1 specl2 class))) + (when order + (return-from sorter (eq order specl1))))))) + (let ((methods (generic-function-methods generic-function))) + (stable-sort (copy-list (remove-if-not #'filter methods)) + #'sorter)))) + +(defmethod compute-applicable-methods-using-classes ((generic-function generic-function) + classes) + (labels ((filter (method) + (let ((classes-tail classes)) + (dolist (m-spec (method-specializers method) + t) + (unless classes-tail + (error "The function ~S requires at least ~D arguments" + (generic-function-name generic-function) + (arg-info-number-required (gf-arg-info generic-function)))) + (unless (specializer-applicable-using-class-p m-spec (pop + classes-tail + )) + (return nil))))) + (sorter (method-1 method-2) + (dolist (index (arg-info-precedence (gf-arg-info generic-function))) + (let* ((specl1 (nth index (method-specializers method-1))) + (specl2 (nth index (method-specializers method-2))) + (class (nth index classes)) + (order (order-specializers-using-class specl1 specl2 class))) + (when order + (return-from sorter (eq order specl1))))))) + (let ((methods (generic-function-methods generic-function))) + (stable-sort (copy-list (remove-if-not #'filter methods)) + #'sorter)))) + +(defun get-normal-secondary-dispatch-function (generic-function args) + (let* ((classes (mapcar #'(lambda (arg mt) + (declare (ignore mt)) + (class-of arg)) + args + (arg-info-metatypes (gf-arg-info generic-function)))) + (methods (compute-applicable-methods-using-classes generic-function classes)) + (net (generate-discrimination-net generic-function methods)) + (arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info))) + (flet ((net-test-converter (form) + (if (and (consp form) + (eq (car form) + 'methods)) + '.methods. + (default-test-converter form))) + (net-code-converter (form) + (if (and (consp form) + (eq (car form) + 'methods)) + (let ((gensym (gensym))) + (values (make-dfun-call metatypes applyp gensym) + (list gensym))) + (default-code-converter form))) + (net-constant-converter (form) + (if (and (consp form) + (eq (car form) + 'methods)) + (list (get-effective-method-function generic-function (cdr form))) + (default-constant-converter form)))) + (if (eq (car net) + 'methods) + (and (cdr net) + (values (get-effective-method-function generic-function (cdr net)) + methods)) + (values (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) + ,net) + #'net-test-converter + #'net-code-converter + #'net-constant-converter) + methods))))) + +(defun get-effective-method-function (generic-function methods) + (let ((combin (generic-function-method-combination generic-function)) + (precomputed (gf-effective-method-functions generic-function))) + + ;; NOTE: We are assuming a restriction on user code that the method combination must not + ;; change once it is connected to the generic function. This has to be legal, because + ;; otherwise any kind of method lookup caching couldn't work. See this by saying that + ;; this cache, is just a backing cache for the fast cache. If that cache is legal, this + ;; one must be too. Should altering the set of methods flush this cache? + (let ((entry (assoc methods precomputed :test #'equal))) + (if entry + (values (cdr entry) + (car entry)) + (let* ((effective (compute-effective-method generic-function combin methods)) + (fn (make-effective-method-function generic-function effective))) + (setf (gf-effective-method-functions generic-function) + (cons (cons methods fn) + precomputed)) + (values fn methods)))))) + +(defun + generate-discrimination-net + (generic-function methods) + (let* ((arg-info (gf-arg-info generic-function)) + (nreq (arg-info-number-required arg-info)) + (metatypes (arg-info-metatypes arg-info))) + (labels ((do-column (position contenders) + (if (< position nreq) + (if (eq (nth position metatypes) + 't) + (do-column (1+ position) + contenders) + (do-methods position contenders nil nil)) + `(methods ,@contenders))) + (do-methods + (position contenders known-outcomes winners) + + ;; is a (sorted) list of methods that must be discriminated + ;; is a list of outcomes from tests already made on this argument + ;; each outcome looks like ( [t | nil]) is a (sorted) list + ;; of methods that are potentially applicable after the discrimination has been + ;; made. + (if (null contenders) + (do-column (1+ position) + winners) + (let* ((method (car contenders)) + (specl (nth position (method-specializers method)))) + (flet ((determined-to-be (truth-value) + (if (classp specl) + truth-value + (some #'(lambda (outcome) + (outcome-implies-p generic-function + (car outcome) + (cadr outcome) + specl truth-value)) + known-outcomes))) + (if-true nil (do-methods position (cdr contenders) + (if (not (classp specl)) + (cons `(,specl t) + known-outcomes) + known-outcomes) + (append winners `(,method)))) + (if-false nil (do-methods position (cdr contenders) + (if (not (classp specl)) + (cons `(,specl nil) + known-outcomes) + known-outcomes) + winners))) + (cond ((determined-to-be nil) + (if-false)) + ((determined-to-be t) + (if-true)) + (t `(if ,(compute-argument-test-form generic-function + (dfun-arg-symbol position) + specl) + ,(if-true) + ,(if-false))))))))) + (do-column 0 methods)))) + +(define-gf-predicate eql-specializer-p eql-specializer) + +(defmethod same-specializer-p ((specl1 eql-specializer) + (specl2 eql-specializer)) + (eql (eql-specializer-object specl1) + (eql-specializer-object specl2))) + +(defmethod specializer-applicable-p ((specializer eql-specializer) + object) + (eql (eql-specializer-object specializer) + object)) + +(defmethod specializer-applicable-using-class-p ((specializer eql-specializer) + class) + (eq class (class-of (eql-specializer-object specializer)))) + + ; It would be most egregious to use + ; *subtypep here. + + +(defmethod order-specializers-using-class ((specl1 eql-specializer) + (specl2 eql-specializer) + argument-class) + (declare (ignore argument-class)) + nil) + +(defmethod order-specializers-using-class ((specl1 class) + (specl2 eql-specializer) + argument-class) + (declare (ignore argument-class)) + specl2) + +(defmethod order-specializers-using-class ((specl1 eql-specializer) + (specl2 class) + argument-class) + (declare (ignore argument-class)) + specl1) + + +;;; Does a given pair of values for { } imply a given pair of values for +;;; { }. + + +(defmethod outcome-implies-p ((generic-function generic-function) + (specl1 eql-specializer) + value1 + (specl2 eql-specializer) + value2) + (flet ((same-truth-value (x y) + (or (and x y) + (and (not x) + (not y))))) + (let ((obj1 (eql-specializer-object specl1)) + (obj2 (eql-specializer-object specl2))) + (or (and (eql obj1 obj2) + (same-truth-value value1 value2)) + (and (not (eql obj1 obj2)) + value1 + (not value2)))))) + + +;;; Return a form which tests a given argument against a given specializer. + + +(defmethod compute-argument-test-form ((generic-function generic-function) + argument-form + (specializer eql-specializer)) + `(eql ,argument-form ',(eql-specializer-object specializer))) + + +;;; The value returned by compute-discriminating-function is a function object. It is called a +;;; discriminating function because it is called when the generic function is called and its role is +;;; to discriminate on the arguments to the generic function and then call appropriate method +;;; functions. A discriminating function can only be called when it is installed as the funcallable +;;; instance function of the generic function for which it was computed. More precisely, if +;;; compute-discriminating-function is called with an argument , and returns a result , +;;; that result must not be passed to apply or funcall directly. Rather, must be stored as +;;; the funcallable instance function of the same generic function (using +;;; set-funcallable-instance-function). Then the generic function can be passed to funcall or +;;; apply. An important exception is that methods on this generic function are permitted to return a +;;; function which itself ends up calling the value returned by a more specific method. This kind +;;; of `encapsulation' of discriminating function is critical to many uses of the MOP. As an +;;; example, the following canonical case is legal: (defmethod compute-discriminating-function ((gf +;;; my-generic-function)) (let ((std (call-next-method))) #'(lambda (arg) (print (list 'call-to-gf +;;; gf arg)) (funcall std arg)))) Because many discriminating functions would like to use a dynamic +;;; strategy in which the precise discriminating function changes with time it is important to +;;; specify how a discriminating function is permitted itself to change the funcallable instance +;;; function of the generic function. Discriminating functions are may set the funcallable instance +;;; function of the generic function, but the new value must be generated by making a call to +;;; COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any more specific methods which may +;;; have encapsulated the discriminating function will get a chance to encapsulate the new, inner +;;; discriminating function. This implies that if a discriminating function wants to modify itself +;;; it should first store some information in the generic function proper, and then call +;;; compute-discriminating-function. The appropriate method on compute-discriminating-function will +;;; see the information stored in the generic function and generate a discriminating function +;;; accordingly. The following is an example of a discriminating function which modifies itself in +;;; accordance with this protocol: (defmethod compute-discriminating-function ((gf +;;; my-generic-function)) #'(lambda (arg) (cond ( (set-funcallable-instance-function gf (compute-discriminating-function gf)) (funcall +;;; gf arg)) (t )))) Whereas this code would not be legal: (defmethod +;;; compute-discriminating-function ((gf my-generic-function)) #'(lambda (arg) (cond ( (set-funcallable-instance-function gf #'(lambda (a) ..)) (funcall gf arg)) (t +;;; )))) NOTE: All the examples above assume that all instances of the class +;;; my generic function accept only one argument. + + +(defmethod compute-discriminating-function ((gf standard-generic-function)) + (let* ((state (gf-dfun-state gf)) + (dfun (typecase state + (null (make-initial-dfun gf)) + (function state) + (cons (car state))))) + (doctor-dfun-for-the-debugger gf dfun))) + +(defun update-dfun (generic-function dfun &optional cache) + (let ((ostate (gf-dfun-state generic-function))) + (unless (typep ostate '(or null function)) + (free-cache (cdr ostate))) + (setf (gf-dfun-state generic-function) + (if cache + (cons dfun cache) + dfun)) + (invalidate-dfun-internal generic-function))) + +(defvar *generate-random-code-segments* nil) + +(defun invalidate-discriminating-function (generic-function) + (let ((ostate (gf-dfun-state generic-function))) + (unless (typep ostate '(or null function)) + (free-cache (cdr ostate))) + (setf (gf-dfun-state generic-function) + nil) + (setf (gf-effective-method-functions generic-function) + nil) + (invalidate-dfun-internal generic-function) + (when *generate-random-code-segments* + (let ((*generate-random-code-segments* nil)) + (generate-random-code-segments generic-function))))) + +(defun invalidate-dfun-internal (generic-function) + + ;; Set the funcallable instance function to something that just calls invalid-dfun, that is, + ;; arrange to use lazy evaluation to update the dfun later. + (set-funcallable-instance-function generic-function #'(lambda (&rest args) + (invalid-dfun generic-function + args))) + + ;; Except that during bootstrapping, we would like to update the dfun right away, and this + ;; arranges for that. + (when *invalidate-discriminating-function-force-p* + (let ((*invalid-dfuns-on-stack* (cons generic-function *invalid-dfuns-on-stack*))) + (set-funcallable-instance-function generic-function (compute-discriminating-function + generic-function))))) + +(defun invalid-dfun (gf args) + (protect-cache-miss-code gf args (let ((new-dfun (compute-discriminating-function gf))) + (set-funcallable-instance-function gf new-dfun) + (apply gf args)))) + + +;;; + + +(defmethod function-keywords ((method standard-method)) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list (method-lambda-list method)) + (declare (ignore nreq nopt keysp restp)) + (values keywords allow-other-keys-p))) + +(defun analyze-lambda-list (lambda-list) + (declare (values nrequired noptional keysp restp allow-other-keys-p keywords + keyword-parameters)) + (flet ((parse-keyword-argument (arg) + (if (listp arg) + (if (listp (car arg)) + (cadar arg) + (make-keyword (car arg))) + (make-keyword arg)))) + (let ((nrequired 0) + (noptional 0) + (keysp nil) + (restp nil) + (allow-other-keys-p nil) + (keywords nil) + (keyword-parameters nil) + (state 'required)) + (dolist (x lambda-list) + (if (memq x lambda-list-keywords) + (case x + (&optional (setq state 'optional)) + (&key (setq keysp 't state 'key)) + (&allow-other-keys (setq allow-other-keys-p 't)) + (&rest (setq restp 't state 'rest)) + (&aux (return t)) + (otherwise (error + "Encountered the non-standard lambda list keyword ~S." + x))) + (ecase state + (required (incf nrequired)) + (optional (incf noptional)) + (key + (push (parse-keyword-argument x) + keywords) + (push x keyword-parameters)) + (rest nil)))) + (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords) + (reverse keyword-parameters))))) + +(defun method-ll->generic-function-ll (ll) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) + (analyze-lambda-list ll) + (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) + (remove-if #'(lambda (s) + (or (memq s keyword-parameters) + (eq s '&allow-other-keys))) + ll))) + + +;;; This is based on the rules of method lambda list congruency defined in the spec. The lambda +;;; list it constructs is the pretty union of the lambda lists of all the methods. It doesn't take +;;; method applicability into account at all yet. + + +(defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) + (let ((methods (generic-function-methods generic-function)) + (arglist nil)) + (when methods + (multiple-value-bind (required optional rest key allow-other-keys) + (method-pretty-arglist (car methods)) + (dolist (m (cdr methods)) + (multiple-value-bind (method-key-keywords method-allow-other-keys method-key) + (function-keywords m) + + ;; we've modified function-keywords to return what we want as the third + ;; value, no other change here. + (declare (ignore method-key-keywords)) + (setq key (union key method-key)) + (setq allow-other-keys (or allow-other-keys method-allow-other-keys)))) + (when allow-other-keys + (setq arglist '(&allow-other-keys))) + (when key + (setq arglist (nconc (list '&key) + key arglist))) + (when rest + (setq arglist (nconc (list '&rest rest) + arglist))) + (when optional + (setq arglist (nconc (list '&optional) + optional arglist))) + (nconc required arglist))))) + +(defmethod method-pretty-arglist ((method standard-method)) + (let ((required nil) + (optional nil) + (rest nil) + (key nil) + (allow-other-keys nil) + (state 'required) + (arglist (method-lambda-list method))) + (dolist (arg arglist) + (cond ((eq arg '&optional) + (setq state 'optional)) + ((eq arg '&rest) + (setq state 'rest)) + ((eq arg '&key) + (setq state 'key)) + ((eq arg '&allow-other-keys) + (setq allow-other-keys 't)) + ((memq arg lambda-list-keywords)) + (t (ecase state + (required (push arg required)) + (optional (push arg optional)) + (key (push arg key)) + (rest (setq rest arg)))))) + (values (nreverse required) + (nreverse optional) + rest + (nreverse key) + allow-other-keys))) diff --git a/clos/3.5/patch.dfasl b/clos/3.5/patch.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..157f778ab78968215dbdb202a191bf4acfd3fbc8 GIT binary patch literal 2852 zcmb_e%}*Og6yIHpF`uy;NC_d$LK8x17TJWh0aA;_9^>`LuDiPiLx?Icn}BLC@<-Yz zirQ3FrARBKKojjm>7hMU>cwe#2vB16R7F*L>7}>!PspuD`eqhmllE48@Xq|+n>WAr z=Dm5d&bU&67$3;4tSx7Z9G@)~)`|uGS~kb$v&CH6;I9GB-wJBc+n1AhBbWEj=ZdQz z8kzKxKmWna#oY1@!@rnK7gvncLf&6oUH-_QSU(?i;_zVW-dENG?)5AKzv~Bo&1B^9uoP}26F0-L)_t=r zB*jobMWT*^F(tq;);-fbpy{F<6xE<0$%&*sV3}?oU&yWr8RLeLAz@nKz=ZXM=?W#~ zfG#PrwaI?Mod$#MAPPw`5{O+`9#Y(3(V--e%r(OTr;^mcq!WgXK}kh)G1qBrQUrJe zb#WqwEVB*{2$UKUVjwC`B5RWaJ57=-Q~;A4p^(&&3TloCQA16vWjb%k#Z2Zl13_SV zs{T{IX%NbE_^KTO%k&JrOiMmrT@uZNdq=14R2qP_^#5E_N zjl|a=L{K9UZ9SyJov=3R33;NnA1lq;Fi$E8U5ZPyNQfzuQb3FeN<#1nqB?1pBZM@wZvP?(s(-Boc)QE_iA0Ox!dK<`ae zfcqvp0KB=eG0Qw5@(ac5e419w^6GUyCQhK32A<)Qz|b8>x+s7fF=1aoya0v?2#reo z-!MHiC6GKNsfrv&vaaDX)=S}PhPYc_a+djuZ$tk`c??TN~PE6(d?PKIeD-bzEzB2h&zP!O!6ZQh`aGt~6r*L;W z5NoTfQAv{M*xQVIoEWjV=SaCiPW?}=7&YUwl-b!MWd_N81kCyRQI-YNOmtC1H^`r^-sZk(ff@3)m@ zrR`)n_NaE7&!XH;=~sL8?$SMxs(3d_X~%)c zaf#b{yw_uEY*+Sil_T3rTaoq1ozg{ihPAzQecw60BiWi=2PRzQyAnt1A3_k}woAX* z8c%rpyH&B-RJMV#v_PU2epnGO<-7J!gfJc-hlc7PH{pPmoX~VZ2?Ua=ih={!3r!V@ zaUd=Rkq`)r@+8s##Xc9qaQin6+;|RI2}0j%2q?0SQo4tnW)c>*s3?Y@y9v6A5cU!{ z2ynA~&k7StaK=V2*Pzg9;7TI8gLsO3x^N0U%nSST2dK8vD;rITu_UxEs?7X`r-{}U zo*|#Faq44GJVq6%SCXD2s%e~>#pnWDu zXCc5nJQv1S`|;cvJZIPLn>3T?U(I`<3ewTRrF_2jAyd<}_})Ver5Co^e=l(7aEBXr z)bpeR@Ap3X4kAwn7wLZbOah(2o#fHb9v7qVQi6!p*k*Aj3oX!z8|?=Wh6#sTY90jm zSQG6tEwwMX|9GEOS+Qg{*ZwO;V^|jY8tw$FF`y)7RB1A-lm2YhPZ_I410vV(GxM;p GxAzY<$q^0! literal 0 HcmV?d00001 diff --git a/clos/3.5/patch.lisp b/clos/3.5/patch.lisp new file mode 100644 index 00000000..eab79094 --- /dev/null +++ b/clos/3.5/patch.lisp @@ -0,0 +1,143 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE "XCL-USER") BASE 10) +(IL:FILECREATED "19-Feb-91 14:09:19"  +IL:|{DSK}local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;2| 9876 + + IL:|changes| IL:|to:| (IL:VARS IL:XEROX-PATCHESCOMS) + + IL:|previous| IL:|date:| " 6-Feb-91 10:55:16" +IL:|{DSK}local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;1|) + + +; Copyright (c) 1991 by Venue. All rights reserved. + +(IL:PRETTYCOMPRINT IL:XEROX-PATCHESCOMS) + +(IL:RPAQQ IL:XEROX-PATCHESCOMS ( + + + (IL:FUNCTIONS OPTIMIZE-LOGICAL-OP-1-ARG) + (OPTIMIZERS (LOGIOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG) + (LOGXOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG) + (LOGAND :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG) + (LOGEQV :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)) + + (IL:* IL:|;;| "A bug compiling LABELS") + + (IL:FUNCTIONS COMPILER::META-CALL-LABELS) + (FILE-ENVIRONMENTS "XEROX-PATCHES"))) + + + + + + +(IL:* IL:|;;;| +"Declare side-effects (actually, lack of side-effects) info for some internal arithmetic functions. These are needed because the compiler runs the optimizers before checking the side-effects, so side-effect declarations on the \"real\" functions are oft times ignored. Fix a nit in the compiler While no person would generate code like (logor x), macro can (and do). " +) + + +(DEFUN OPTIMIZE-LOGICAL-OP-1-ARG (FORM ENV CTXT) + (DECLARE (IGNORE ENV CTXT)) + (IF (= 2 (LENGTH FORM)) + (SECOND FORM) + 'COMPILER:PASS)) + +(DEFOPTIMIZER LOGIOR OPTIMIZE-LOGICAL-OP-1-ARG) + +(DEFOPTIMIZER LOGXOR OPTIMIZE-LOGICAL-OP-1-ARG) + +(DEFOPTIMIZER LOGAND OPTIMIZE-LOGICAL-OP-1-ARG) + +(DEFOPTIMIZER LOGEQV OPTIMIZE-LOGICAL-OP-1-ARG) + + + +(IL:* IL:|;;| "A bug compiling LABELS") + + +(DEFUN COMPILER::META-CALL-LABELS (COMPILER::NODE COMPILER:CONTEXT) + + (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them. ") + + (LET ((COMPILER::*MADE-CHANGES* NIL)) + + (IL:* IL:|;;| "First, substitute the functions wherever possible.") + + (DOLIST (COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE) + (WHEN (NULL (COMPILER::NODE-META-P (COMPILER::LABELS-BODY COMPILER::NODE))) + (SETF (COMPILER::NODE-META-P COMPILER::NODE) + NIL) + (SETQ COMPILER::*MADE-CHANGES* T))) + (WHEN (COMPILER::SUBSTITUTABLE-P (CDR COMPILER::FN-PAIR) + (CAR COMPILER::FN-PAIR)) + (LET ((COMPILER::*SUBST-OCCURRED* NIL)) + + (IL:* IL:|;;| "First try substituting into the body.") + + (SETF (COMPILER::LABELS-BODY COMPILER::NODE) + (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR) + (CAR COMPILER::FN-PAIR) + (COMPILER::LABELS-BODY COMPILER::NODE))) + (WHEN (NOT COMPILER::*SUBST-OCCURRED*) + + (IL:* IL:|;;| "Wasn't in the body - try the other functions.") + + (DOLIST (COMPILER::TARGET-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)) + (UNLESS (EQ COMPILER::TARGET-PAIR COMPILER::FN-PAIR) + (SETF (CDR COMPILER::TARGET-PAIR) + (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR) + (CAR COMPILER::FN-PAIR) + (CDR COMPILER::TARGET-PAIR))) + (WHEN COMPILER::*SUBST-OCCURRED* + (IL:* IL:\; + "Found it, we can stop now.") + (SETF (COMPILER::NODE-META-P COMPILER::NODE) + NIL) + (SETQ COMPILER::*MADE-CHANGES* T) + (RETURN))))) + + (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost. ") + + (DOLIST (COMPILER::FNS (COMPILER::LABELS-FUNS COMPILER::NODE)) + (COMPILER::MEVAL (CDR COMPILER::FNS) + :ARGUMENT)) + (COMPILER::MEVAL (COMPILER::LABELS-BODY COMPILER::NODE) + :RETURN)))) + + (IL:* IL:|;;| "Now remove any functions that aren't referenced.") + + (DOLIST (COMPILER::FN-PAIR (PROG1 (COMPILER::LABELS-FUNS COMPILER::NODE) + (SETF (COMPILER::LABELS-FUNS COMPILER::NODE) + NIL))) + (COND + ((NULL (COMPILER::VARIABLE-READ-REFS (CAR COMPILER::FN-PAIR))) + (COMPILER::RELEASE-TREE (CDR COMPILER::FN-PAIR)) + (SETQ COMPILER::*MADE-CHANGES* T)) + (T (PUSH COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE))))) + + (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.") + + (WHEN (NULL (COMPILER::LABELS-FUNS COMPILER::NODE)) + (LET ((COMPILER::BODY (COMPILER::LABELS-BODY COMPILER::NODE))) + (SETF (COMPILER::LABELS-BODY COMPILER::NODE) + NIL) + (COMPILER::RELEASE-TREE COMPILER::NODE) + (SETQ COMPILER::NODE COMPILER::BODY COMPILER::*MADE-CHANGES* T))) + + (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.") + + (IF (NULL COMPILER::*MADE-CHANGES*) + (SETF (COMPILER::NODE-META-P COMPILER::NODE) + COMPILER:CONTEXT) + (SETF (COMPILER::NODE-META-P COMPILER::NODE) + NIL))) + COMPILER::NODE) + +(DEFINE-FILE-ENVIRONMENT "XEROX-PATCHES" :PACKAGE (IN-PACKAGE "XCL-USER") + :READTABLE "XCL" + :BASE 10 + :COMPILER :COMPILE-FILE) +(IL:PUTPROPS IL:XEROX-PATCHES IL:COPYRIGHT ("Venue" 1991)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL))) +IL:STOP diff --git a/clos/3.5/pkg.dfasl b/clos/3.5/pkg.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..b67004b27af00db6c8cb93c20fac5be364396091 GIT binary patch literal 1975 zcmbtVU2o$=6t&aRrfJ+JWzn+xWWigtt~T4UVhf5ivB$}5of)skZc`qRO5$CjO`FI` z3M+)f4~VpsN+?F+xA4=-otZc>PUrdQv^gYLKW@!NO3q<(i_L z_w_-4JgRpG!*RVkO%lNCqqlDk1o}nI;5piE5?@T>o_QAcuHtd;;@uPTxk-oD@#Qy= zOYOyr+7tL5AANp&_}PKsBJQblGCw!zOQ$2#iMz__+0$oF!Rhe0_Wbzp=)k!9eg3Of z9%}I05}%4TpH*t+WH_=0@pU{9rCy4Q`OmYW8&NwXjLvWMpY)CS`&o%l%SZMJYGO^- z=d*R&V_cJzZ-mo-Q>OZoXoI(q!_I)?{mgKf9knqHk%*-UI{lMXhJUP>J2$P0yyzAx z+L}K9Wwy1CJ3b3SzCXWNqyzOh*gZvoxxCYLO;f=ORS3AzU=ekEQBctjnC&6b*2}3; zcs#$Y0ci<2j@8Cti#cf-&O42Wc%cQggDK|{+qRMC<&7#5ptuv}(X!n_w25<$CCOn? z)W(visLsrlr^hyH`%#E3%)g~3hEUSefGAT)$bUSeC7|51Sdtym+#ZFZWC zOZr#gT?E*Hreyt*@HY2YXsNZ8fFS|gAw1-ZM0X_wEs3Z!RQV{7a8775hvaQa(gxZd zEjCij!$HAf`Lk1Q86GXMY_{1l$Pl~B>)gJqz+7_x3?e%eTe#ZlU4GtfFnC zNnG>^&Y)rikd966V;gojHKbx0QkeXbkUr1X=04PNkK8WhN#7Lm zMA|~qguvde0nG<4@;DayR_)+`b;L@y8MQpZeG$dMSr=i(7QA>T^#EUo*5cF?$rZNz zSIfjwV@*$+_oY$DR8n6PX((lda)co7`70UDQQb$gtfo*-Uy6dtQactc&local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created 1-Mar-91 10:10:26 + +;;;. Copyright (c) 1991 by Venue + + +(in-package "CLOS") + + + +;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly +;;; specified in CLtL. This causes trouble. Any Lisp that has extra symbols in the Lisp package +;;; should shadow those symbols in the CLOS package. + + +(shadow 'cl:documentation) + + +;;; These come from the index pages of 88-002R. + +(eval-when (compile load eval) +(defvar *exports* + '(add-method built-in-class call-method call-next-method change-class class-name class-of + compute-applicable-methods defclass defgeneric define-method-combination defmethod + ensure-generic-function find-class find-method function-keywords generic-flet + generic-labels initialize-instance invalid-method-error make-instance + make-instances-obsolete method-combination-error method-qualifiers next-method-p + no-applicable-method no-next-method print-object reinitialize-instance remove-method + shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound + slot-value standard standard-class standard-generic-function standard-method + standard-object structure-class symbol-macrolet update-instance-for-different-class + update-instance-for-redefined-class with-accessors with-added-methods with-slots)) + +(import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*) + +(export *exports* *the-clos-package*) + +(import *exports* (find-package :lisp)) + +(export *exports* (find-package :lisp))) + + ; (defvar *chapter-3-exports* '( + ; get-setf-function + ; get-setf-function-name + ; class-prototype class object + + + +;; essential-class + + + ; class-name class-precedence-list + ; class-local-supers class-local-slots + ; class-direct-subclasses + ; class-direct-methods class-slots + ; method-arglist + ; method-argument-specifiers + ; method-function method-equal + ; slotd-name slot-missing + + + +;; define-meta-class %allocate-instance %instance-ref %instancep %instance-meta-class + + + ; allocate-instance optimize-slot-value + ; optimize-setf-of-slot-value + ; add-named-class + ; class-for-redefinition add-class + ; supers-changed slots-changed + ; check-super-metaclass-compatibility + ; make-slotd + ; compute-class-precedence-list + ; walk-method-body + ; walk-method-body-form + ; add-named-method remove-named-method + ; )) + diff --git a/clos/3.5/plap.dfasl b/clos/3.5/plap.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..543967d0f017d8c6b2133f77af8518ad457252d0 GIT binary patch literal 16188 zcmeHOYj7Lab>6!G0g5ky4^c8C*^uPWj%27J<(Fie;u2VjODwPu07|4}iKQjVkVHK~ z(TP2YZN{&08z?rZNX9CTGgf}IPNp^MHi;!sV#Yrjb)0n4sa;Qhw9}cmRv%N_owS*0 zosN1QyTAejVM34miblN8z4xB`-E+@5_uPv~sd^x!2SP^=A3HEQG8Q=c*!Z!>#smA0 zjs=b%eQa#+NMJvd2fi9kMxK1I|Mu8Sf0~MzS;1pGZJ?=dsb@W9vr`96$CzdwtT;@7}SI;qj4ufgL0Jj*J}N zH~hq1fqMh7qhB65{0I=!zG+kYU4c!TJMP`QapU^>9wn(WId-$2u>;iR?m&2CFSqH~ z(6QkzXu0|Bdp2+ESYLnjJK57x-BAhtEyBPjWi!6^!1&Q)!O@W~kBs6}4`W64{Mp)$m7R`kL(NTN<0`+l4^F+ zs)ga6ktFd@mpmZO^~yUhq-W9>wS61AKHW1Fo4!li=$kw+ksfL|X*5jVs!gUR4h;FG z4Bzvb3(K>bAX-;Uq$jl#)kxSL-9Mv6{TE}G9>pvLv9#YG8ETkK5BcD)3I1AUjfU?T zzUh?FAck5+{!>aBt+IeW+3$yjxgH>md2H*;8cjw^8+7%e(USHLH9^NlgA7AVzv1`u z$T|TCMNv-VhfWW*!q+sHWmCqo=M5jGPZ~|r?Ldy<6F3Td(v&q?jMg?7@I|8)MrncZ zcof4Y!-&%}I5EFZGOOz)Nj3#6ME0bd&D7m~dsGP}j9`zEh-Nd*c2^9=}NRatYG#z z$maOrX~Eu*Q$0Zo2#ZzStx!>|B(}zssG4j9&aAe3 zGQA$NT9~(r<=K<2Y{qNE)r1lYBdu-SMtCrrslo{)iQ=Lyf^=(iJU=`+@-QCgW;IQ*IQ*?mGyrh@T;0n9e;*1Q9HtE1kmuNKgs z7EGu`1efT~`f36FZC_A-)>jMYFSVfltgpB~u{tlon3re^4ovp?sA8||lUxF@@)K4@ zJf%goooX=tRSH0#XC1vxiNN`gtP zSQ}L$DvMf>zx@d{2pbxhIb|eZS~T(1YvT!(2QKra487G8L?GBvO%W<{^?}OLd=7^4R%x#)CBG)$ZE)@ z5O25Q6vr;ua&iq4nwvH3wXLSN3d(AG0N0cX#4B-N4M}PS>RL&o2lKdhJZ7yT#j;kib?}47{TBl5C$ypX>dOM*K|qN95VwNo_)D6ml=B^hV+0 z^`Vek=aVVaz_@V4Sg8H50ArsdyUd_0n|He0<`(l&w~#!RMx4t`pR;1F0hn@YZpDzF zf?6!4CSr8E535_ps#D&%2TwQzOKZ| z$uukPE)pB4>tJPIgBOc)I`Eah+1o;rP<7i9qHlmz@Y<2 z_63ga4~&gGdf@mt9H0&y4?LCJVv+F*h+!Z{{00^7Kv#=2+xu6N7$kB&eQT*h4MVxi zG-+JBbEo)Q4>Yde{uA89KFra z8MFCoX7e7ixy@{D#BP5MhEi2L0m=w-Z$i%9t*UX%Ok!1cLRBJ|I}SOYI-sS<4zwga zR`f%Kyw$+ueb_=*x>X|l7RY%LYN|gGgG%W$$h!KX*fpFJU(U27Q;Gf%)T$t{P!NRF zAXUynWpj7Grl(M$6xO{CbqzhqP*L%-Se#6S9mOM1XZBHDq3{BQ=P5i#;oB7cn8F`X_(KZ+g2F$i z@GT1ejKXPz>fcdew}1$;00#Pr#&{-XS zLFddQ+J7jmXmur$Jr|&VR~k*f`FfS8*9qvK8sK5tOKiNLMtBybF^O%cho>v=0gv;* zQ81r53%QIjtn6+n^J}=m9TjQ(-&Ny@^m27*9O}Z``KTg%8IQ;$-4#MJO(2|0?6BJx< zzSWnVJSF$U+z${^SAyo#t2xy`(Hri2U~LvB`eSg+RRid?Q*^Rp;m~B4lDo$Awor?I zVdM0Kd?)Y+l{~j7o4GACeB_Stz`mn_;lO5)40x792DXIDdR%JhUjgOYXfiw_nja+< z03808U4GfxB;dnx_aqGPT`?EHX&O7f?BXr|K3W;IHtAcoY=NafQ)Wl68l!cP-UTw2 z(69%tdvHni(&+Cq6#v5`{K;=^qOJBs3k9idwp;YP^xLPWP=Y(?`O=M|#RUhVay-yr zL&KWGK|&lz*iB3CFxyU3!F0Q2Ls;3>h1upgc0iXxCmL$p{drt0!>QQfV(=oO^P-)j z4tpYUA2V}^qBpAz=B^E>5bXJ&`ZK*>q?(JXpa%7z>Ge~=r6!cP>Nd7$XDzmrJHgvT z^#!`{e$rf2{*JU9P+7_wf@Ba&qRMxroHFEk>hlWkjVq+P+~{!y8x3Xt`{p=CKjz5f z=&Ky<=4cB?t2lB|B>gi-Kjr8Rj=o`zA2!Ezb9^bd7Qp6O^l&_t=b}m%vdjPD(;-@%bD-jVR7P#;C_qEc1=a#UV|3l(}$<@>425qJr&KJ8um=aa>M@a z)KGZ3D!*X!)Xv${aA^VzBVF;LWkzNYSVB3cKXS1A1^VJmOg57_F8-UN4>&r<(YHBz zlA|Gx6pq$#R7H_=g`;nn&4nOPnlG4YJbZPCB z#skJ8R5VH5NF}lM9V|gnpDXzhlr-j#13MDv45M42??a6*cNTC|yapAu*sY^%3d^u# zt85(dIS;{h$e{F(KNL18A>_f_C zgeLN$-C-yu!T;WazI25BPhqIVJe1OHotd+ldB<@m#@skn}I7_k#0|SZZcGqNpx8l4EjX*E|wU3Dmxa5*-CYVIXf zDY>W6b~FmJU4_|-?M}+lw%(O#0AOgFvTuwLA+IjeI5 z-t@98-Lx61Z?Rj?k@lvS1>@#*@Yyo^vtrS2dT*z(9zZvCv;CDr513w--w)y?Q|<$Y zQovhzr1l|sfA*x6q=I>+`S0fpUJ<4v=>#lYq4!}Sd?7;UdT5oTN1%BHVjQpAP!eyt zMt&r>b&eZNpF~D`HH&g|d@P9gnBXJ)DWHUm88;cy;v9iO zPNPu7w_3-u1Dq4y zqJldaUU{&eh8|G0S`Vmld&u_U0P4-w#ML?0)@)7a1 z(1Ks*+yb{m{5r>?@?qQA1QXA_(lM9Unk(F`=1TVEe9W8r5}#r}wqD;j7ai7^ACa{b zVPN^J$|3OXwIE zMFP9e-DliDBphUyLE>db;+KrX%Y{hXR>Tu?74N)od~%I&m z2L$Wf4$s+6OSk4F1&NEC%s|IH%MICEITS7*$c;Lu+%UbhphjGvU{RzrIjh)>P_aN+ zUJ5j8Ze_qaL14-J!bO}Y4;JoAa&iz@CB>?|q;h!ZO+-_HFtJ9dka0?2kR!Pa1{ua+ z2{TNl5QCK^7$zt4;LY58TSi`WjX)IL`&P^dfzphSr@0Ig^^C+SMxwqv5(NuZ4heXO zRk4*t&t!^6sE{2>AW_(386-T6M39m26e6*th$rmJl?6(WO_k%}@{!?vhHfu>%gLD65ql zq*ZGeoLi}bdcLAPvzT)=0F`*CLYP|T!h{nm1JVixNo9~$AV_fb5d-iyNTyjaQ1Dt8 ztb^+SDsh8=$~u6mBIo7xgN2hT1J*tUE5Tsxv%o6yc$P+u9G!rgVzJjwaiLEZGkJc> zr!?fMd^Tb;8XT%~%6zD*V$tLYGPm8y{6$PBWp8otp1gw~6?fbKAYr~`fZWYM4l$6s z5lCBckQ4z79Sdz0rI~NbaZ*yAmf%ieEw!Y8NA_82FpPC1Vi~eL-|BGD4UA8620+&BlhTPL~y$_g9ZePbQF3#{A;5T;_oqd;-;JWs5Z1)0>GsRfF zfLMVqgfA?J*@~Tlc%?*_JU5KvUb_h#=V2>@O9yaK6pe2=MY)p{}gmWaEJD#-{n9qtutrEJ9qGW?}dXidgT9p z_4@SELx*&_x#*)?jPv@T_hzO)(q;}`i0D**@KD5AA35~ih3Sv_tjYbf&<3mtDIvJ` zNW!@YeiWu_F-}(}LBhGh@$M+Z?(V^qO80y6&qx)^KVJ$Mc#=K3VI=U!8;t|-QhOi> jzx;|C{L?^uljee*O&9p`FWdy|-@yFO;IZd#uU`Fs1xDRP literal 0 HcmV?d00001 diff --git a/clos/3.5/plap.lisp b/clos/3.5/plap.lisp new file mode 100644 index 00000000..49d8b833 --- /dev/null +++ b/clos/3.5/plap.lisp @@ -0,0 +1,309 @@ +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + + +;;;. Copyright (c) 1991 by Venue + +(in-package "CLOS") + + +;;; The portable implementation of the LAP assembler. The portable implementation of the LAP +;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code. +;;; Note that this implementation is actually going to get a lot of use. Some implementations (KCL) +;;; won't implement a native LAP assembler at all. Other implementations may not implement native +;;; LAP assemblers for all of their ports. All of this implies that this portable LAP assembler +;;; needs to generate the best code it possibly can. + + +(defmacro + lap-case + (operand &body cases) + (once-only + (operand) + `(ecase (car ,operand) + ,@(mapcar #'(lambda (case) + `(,(car case) + (apply #'(lambda ,(cadr case) + ,@(cddr case)) + (cdr ,operand)))) + cases)))) + +(defvar *lap-args*) + +(defvar *lap-rest-p*) + +(defvar *lap-i-regs*) + +(defvar *lap-v-regs*) + +(defvar *lap-t-regs*) + +(defvar *lap-optimize-declaration* '((speed 3) + (safety 0) + (compilation-speed 0))) + +(eval-when (load eval) + (setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs + vector-regs t-regs lap-code) + (compile-lambda (make-lap-closure-generator-lambda + closure-var-names arg-names + index-regs vector-regs t-regs + lap-code))) + *precompile-lap-closure-generator* + #'(lambda (cvars args i-regs v-regs t-regs lap) + `#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap)) + *lap-in-lisp* + #'(lambda (cvars args iregs vregs tregs lap) + (declare (ignore cvars args)) + (make-lap-prog iregs vregs tregs (flatten-lap lap + ; (opcode :label 'exit-lap-in-lisp) + ))))) + +(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap) + (let* ((rest (memq '&rest args)) + (ldiff (and rest (ldiff args rest)))) + (when rest + (setq args (append ldiff '(&rest .lap-rest-arg.)))) + (let* ((*lap-args* (if rest + ldiff + args)) + (*lap-rest-p* (not (null rest)))) + `(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*)) + ,(make-lap-prog-internal i-regs v-regs t-regs lap)))))) + +(defun make-lap-prog (i-regs v-regs t-regs lap) + (let* ((*lap-args* 'lap-in-lisp) + (*lap-rest-p* 'lap-in-lisp)) + (make-lap-prog-internal i-regs v-regs t-regs lap))) + +(defun make-lap-prog-internal (i-regs v-regs t-regs lap) + (let* ((*lap-i-regs* i-regs) + (*lap-v-regs* v-regs) + (*lap-t-regs* t-regs) + (code (mapcar #'lap-opcode lap))) + `(prog ,(mapcar #'(lambda (reg) + `(,(lap-reg reg) + ,(lap-reg-initial-value-form reg))) + (append i-regs v-regs t-regs)) + (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*)) + (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)) + (optimize . ,*lap-optimize-declaration*)) + ,.code))) + +(defconstant *empty-vector* '#()) + +(defun lap-reg-initial-value-form (reg) + (cond ((member reg *lap-i-regs*) + 0) + ((member reg *lap-v-regs*) + '*empty-vector*) + ((member reg *lap-t-regs*) + nil) + (t (error "What kind of register is ~S?" reg)))) + +(defun lap-opcode (opcode) + (lap-case opcode (:move (from to) + `(setf ,(lap-operand to) + ,(lap-operand from))) + ((:eq :neq :fix=) + (arg1 arg2 label) + `(when ,(lap-operands (ecase (car opcode) + (:eq 'eq) + (:neq 'neq) + (:fix= 'runtime\ fix=)) + arg1 arg2) + (go ,label))) + ((:izerop) + (arg label) + `(when ,(lap-operands 'runtime\ izerop arg) + (go ,label))) + (:std-instance-p (from label) + `(when ,(lap-operands 'runtime\ std-instance-p from) + (go ,label))) + (:fsc-instance-p (from label) + `(when ,(lap-operands 'runtime\ fsc-instance-p from) + (go ,label))) + (:built-in-instance-p (from label) + (declare (ignore from)) + `(when ,t + (go ,label))) + ; *** + (:structure-instance-p (from label) + `(when ,(lap-operands 'runtime\ ??? from) + (go ,label))) + ; *** + (:jmp (fn) + (if (eq *lap-args* 'lap-in-lisp) + (error "Can't do a :JMP in LAP-IN-LISP.") + `(return ,(if *lap-rest-p* + `(runtime\ apply ,(lap-operand fn) + ,@*lap-args* .lap-rest-arg.) + `(runtime\ funcall ,(lap-operand fn) + ,@*lap-args*))))) + (:return (value) + `(return ,(lap-operand value))) + (:label (label) + label) + (:go (label) + `(go ,label)) + (:exit-lap-in-lisp nil `(go exit-lap-in-lisp)) + (:break nil `(break)) + (:beep nil) + (:print (val) + (lap-operands 'print val)))) + +(defun lap-operand (operand) + (lap-case operand (:reg (n) + (lap-reg n)) + (:cdr (reg) + (lap-operands 'cdr reg)) + ((:cvar :arg) + (name) + name) + (:constant (c) + `',c) + ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots) + (x) + (lap-operands (ecase (car operand) + (:std-wrapper 'runtime\ std-wrapper) + (:fsc-wrapper 'runtime\ fsc-wrapper) + (:built-in-wrapper 'runtime\ built-in-wrapper) + (:structure-wrapper 'runtime\ structure-wrapper) + (:std-slots 'runtime\ std-slots) + (:fsc-slots 'runtime\ fsc-slots)) + x)) + (:i1+ (index) + (lap-operands 'runtime\ i1+ index)) + (:i+ (index1 index2) + (lap-operands 'runtime\ i+ index1 index2)) + (:i- (index1 index2) + (lap-operands 'runtime\ i- index1 index2)) + (:ilogand (index1 index2) + (lap-operands 'runtime\ ilogand index1 index2)) + (:ilogxor (index1 index2) + (lap-operands 'runtime\ ilogxor index1 index2)) + (:iref (vector index) + (lap-operands 'runtime\ iref vector index)) + (:iset (vector index value) + (lap-operands 'runtime\ iset vector index value)) + (:cref (vector i) + `(runtime\ svref ,(lap-operand vector) + ,i)) + (:lisp-variable (symbol) + symbol) + (:lisp (form) + form))) + +(defun lap-operands (fn &rest regs) + (cons fn (mapcar #'lap-operand regs))) + +(defun lap-reg (n) + (intern (format nil "REG~D" n) + *the-clos-package*)) + + +;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to +;;; completely re-implement the LAP code generator, it may still be provident to consider +;;; reimplementing one or more of these to get the compiler to produce better code. That is why +;;; they are split out. + + +(proclaim '(declaration clos-fast-call)) + +(defmacro runtime\ funcall (fn &rest args) + `(funcall ,fn ,.args)) + +(defmacro runtime\ apply (fn &rest args) + `(apply ,fn ,.args)) + +(defmacro runtime\ std-wrapper (x) + `(std-instance-wrapper ,x)) + +(defmacro runtime\ fsc-wrapper (x) + `(fsc-instance-wrapper ,x)) + +(defmacro runtime\ built-in-wrapper (x) + `(built-in-wrapper-of ,x)) + +(defmacro runtime\ structure-wrapper (x) + `(??? ,x)) + +(defmacro runtime\ std-slots (x) + `(std-instance-slots (the std-instance ,x))) + +(defmacro runtime\ fsc-slots (x) + `(fsc-instance-slots ,x)) + +(defmacro runtime\ std-instance-p (x) + `(std-instance-p ,x)) + +(defmacro runtime\ fsc-instance-p (x) + `(fsc-instance-p ,x)) + +(defmacro runtime\ izerop (x) + `(zerop (the fixnum ,x))) + +(defmacro runtime\ fix= (x y) + `(= (the fixnum ,x) + (the fixnum ,y))) + + +;;; These are the implementations of the index operands. The portable assembler generates Lisp code +;;; that uses these macros. Even though the variables holding the arguments and results have type +;;; declarations on them, we put type declarations in here. Some compilers are so stupid... + + +(defmacro runtime\ iref (vector index) + `(svref (the simple-vector ,vector) + (the fixnum ,index))) + +(defmacro runtime\ iset (vector index value) + `(setf (svref (the simple-vector ,vector) + (the fixnum ,index)) + ,value)) + +(defmacro runtime\ svref (vector fixnum) + `(svref (the simple-vector ,vector) + (the fixnum ,fixnum))) + +(defmacro runtime\ i+ (index1 index2) + `(the fixnum (+ (the fixnum ,index1) + (the fixnum ,index2)))) + +(defmacro runtime\ i- (index1 index2) + `(the fixnum (- (the fixnum ,index1) + (the fixnum ,index2)))) + +(defmacro runtime\ i1+ (index) + `(the fixnum (1+ (the fixnum ,index)))) + +(defmacro runtime\ ilogand (index1 index2) + `(the fixnum (logand (the fixnum ,index1) + (the fixnum ,index2)))) + +(defmacro runtime\ ilogxor (index1 index2) + `(the fixnum (logxor (the fixnum ,index1) + (the fixnum ,index2)))) + + +;;; In the portable implementation, indexes are just fixnums. + + +(defconstant index-value-limit most-positive-fixnum) + +(defun index-value->index (index-value) + index-value) + +(defun index->index-value (index) + index) + +(defun make-index-mask (cache-size line-size) + (let ((cache-size-in-bits (floor (log cache-size 2))) + (line-size-in-bits (floor (log line-size 2))) + (mask 0)) + (dotimes (i cache-size-in-bits) + (setq mask (dpb 1 (byte 1 i) + mask))) + (dotimes (i line-size-in-bits) + (setq mask (dpb 0 (byte 1 i) + mask))) + mask)) diff --git a/clos/3.5/precom1.dfasl b/clos/3.5/precom1.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..a3c45d745c810a2946854663406a74f6837d90c4 GIT binary patch literal 686 zcmZ`%&us8+X$7u$n#^3)|P!5Yx4-7G_y?y`{m(X_o$m-FPcM5B@3isHcw%GzDsv-T=3*};0HVFq>V_?{j(WLLL|*VIkB z;pt}Jx}vTRBiau8T8{Nb!$;b(_Xl-5qOCFQAU~#~PV415Dm*~j@qi+&RMOUwRxIZ? z%32|}Ts1ssJg?u3|hDzn)Mmhg5w>c6}lkR!FMI@WoL_NEO z{dxIxB_l%3)(s1*;*a=HlHMi`@rhxp*v9e?37e3AOcb+GZxS0<)Za@#-0Z6LT A!vFvP literal 0 HcmV?d00001 diff --git a/clos/3.5/precom1.lisp b/clos/3.5/precom1.lisp new file mode 100644 index 00000000..76d6e88b --- /dev/null +++ b/clos/3.5/precom1.lisp @@ -0,0 +1,31 @@ +;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; + +(in-package 'clos) + +;;; +;;; pre-allocate generic function caches. The hope is that this will put +;;; them nicely together in memory, and that that may be a win. Of course +;;; the first gc copy will probably blow that out, this really wants to be +;;; wrapped in something that declares the area static. +;;; +;;; This preallocation only creates about 25% more caches than CLOS itself +;;; uses need. Some ports may want to preallocate some more of these. +;;; +(eval-when (load) + (flet ((allocate (n size) + (mapcar #'free-cache + (mapcar #'get-cache + (make-list n :initial-element size))))) + (allocate 128 4) + (allocate 64 8) + (allocate 64 9) + (allocate 32 16) + (allocate 16 17) + (allocate 16 32) + (allocate 1 64))) \ No newline at end of file diff --git a/clos/3.5/precom2.dfasl b/clos/3.5/precom2.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..45e202cb1da4db54f1899a8cfdfcf40a84a34507 GIT binary patch literal 19857 zcmeHPeQ*=k5x+az!r%`SMKQ*9h)7b|1?<|yB*8GoLYA?Rtn)~60^!4U91&YG*fl0; zOEbkJC28ywIgnJZ&=&tuk`B|Un4!*qY&=X-rY@a?Y2A;6b{aZ?cEU9AG-R5Y{Ne6< zd#5|uk}MlH5fm7-x4L^L>Grq#es6al{apGcv)y3s*xA|E?&&gg?CI{@({0$%(Ph}( zv8SuWW7q-j8}?SaY|pH1*zM`sUD@2VXV=r7_LkO4mu+*k)B1>|vRX7Z)L9&ES7n34 zx~bA`b=6mz?V_vF+~9P=`<0zto|cZCD@)qjc6Y8R%W|o1-O}Z0?)E%kaPRT#exmuC zD-0`F88+_O!lr zSqg(zSCl_kQTk9x*2IqjuX34Ba`0z9ebI7(K5dzyyQ8zX-Sd>Eo&M6D^hChlmtNE0 zFuSdyBXEe{$7=!y`xaOo#q}n$&9uS7^MRN9Qt6Kh^auJ<8(bDA$I+Yb=eU&1>;pRJ zeb~`1j=P6xdM=Z`Idc0vJcZlO=QciWPXC}$L-)Ysu(6xEHsNWsxQ9l8OAsNJ+C@`! zalO-G7VGM*c1v|}HAIzSv*>WSoegHU=w#u8#t}LsL^7#3f?_X_xE!#Tpd(Oz@whxP&5v;s}bpD7K(jgCd^^?sF8EP=rt%A(?wg<`$B_hb0n~a?>p{(jS~F@k)J&)?M{Ox;8L070tWj>PC96s%SRFv)_ zpSF=K6P(Toe~8slZP`?er(GmtImucYWw`t$GDsF5WjLOO;S5t_Fs~NTNpw?{o-^r% z_4-t^UQ?}4x9As)s3zB1y+B>FpuKtL<4-gj+IAVHIw{X_8kpSYQI~6QTEJTahctn{ zv>L0$UJcR=HnhNuUT1RIK)9@rfu>M_zIk<4c!o6&u<6}6-SZyrY3~_t$UEd6_MY`N zW{)({NYJR2q)w80N#=~SHs->=ypgKLyf^8k{lQW(ud!f6MD>VQEcgw_jrX_iZ`;@E z-+z+(hnT0K7mf;}1&#WV17hAN2hx=2_}A3qbENS(Bkclw+1gQ|Q8(fpt{vsh)Q+Zx zME%CW(_ZUDf3UO8IyNlk$Z9jF+iX|1`NpQe4m^}u%eXvn0>czG>|VN8B0mg zVp4PmDdIR`F){LR@A+Hn-OkzuhwVWc=gtQX34uc?F!m05$7+*PeRHy+XCJ-l)EvWI zdKfo`a_&7D@ic{`n7wiEG3%ABA%|^no0vU*td{}11Hj>=1i(9q1K?|M z0MHZM8;O9M)9ReY9^bYH(6(d+Gii5Hn)DBIWzz4=!lW-rj%;cd!mj*~+Lf0vSI(DR zdD8X4_he^&Uvg&YMl*6}L2_py?9SntVpqFdFd3oqkzuq+c% z1>&n$5nouwJtyiE>Z=91s{^{LWh*dBdQ)Nj#f3zzZE(xRE8B*|Z2RDLQ9FK&O?01S{1_a;r)=}C!6#N?vS<0Of4^kPNuzv#nNV8?? z)Y%f!<7q~x#pMq4WtZ4Z^^gH@xr<@#Rgy{r)<5ZaAjbC1RC|ZeSN8H_JWQwSDY%-| z4T>#JCuYVpuFWpDrB2gKj2npYVOV!DeC1E#(Ha?CJw0$^;d)YH>qC$Clh=F-w1l~Y z*8bT+tB-OpU6nNh%)ueDCi;#By(t#h3=dP0#Axlm75KcX9KMc+9b|1fJ36XqjJu2$ zY8aS=9)i5K{MNyelA^hdr43~z3=aQWEEy3?0426Y(kCUB-j%sv6P-`u*0f9Glr$l= zw|^D|Fz9$-m25`&oA9$<2uMKtL|wKPUiI0u|0%&f8OSC_X=Z34 zYc;UgTSJU1BD)rHCN;FIqE^1jtj=R)i62W2oAc?jp&Jwft&n!8YSf3*9(qWJh^Ru^ zBUgn3aQR+QucSR_-b^1qn-4~V+JKbQhprWtGPB6+6`G`2b5uDnSbwj489?9zAgukt zyW54K;QK7q0C#||DP~hZiTVjz^GR>ihsy(EPWUi!EM!fa-;Xh6q)-$HNHnOs{Rav!jg%6cXHU5UpOamp+by3wE)G4m{_1VqgRSEU(zJ=#YYHQHs&!4 z!eWCIES^$|G&`mb56|b(+AN+>8tkNHBn^H!ZLDzVms%zZ9y2hb<9NNa;V(sP7Fi*SCS@$?2 zL9}}u+pm~}WO3pX7?e%ov|(Y(%g?YPauCHnQaFj;gsUQvGgS=>WY8ywbrHTiNl>V} z5t?iY)8v~jmVK#&nT55?F!A9T6XwX%N|Nr$={d7e3TylwEUf8o1wbk5uG@eL9E#Fm z#V|89X*VZ;(#U|ip8|@zo+N;JW^U$5+IAdko|}0Cb7FUj(ZKwFICruZ=5u5%ggDm1 zd=jTmg5pI|I4R&opGCQ=6ry`*Zjl>H4tR1O%J6K0FBL6)JT}x$Ng&~ikIYr8+ zW|~!u$D1;|-_Ja2` zv+Ei58e*?Qt;4NnP1~ge;VK7YdmT)H^kB9sJ=hbha)gtEL*c``(DRN_ZpbkzgzR2v zm*pb5%gw%#ZEO=xS8cah-xzVg?#I+&`ta*!!eP_nbJ%&X8?A~Mi-<9w6yk2Q6jn~w zPD<^T)1QBwZe*tihrguf|5B{yUzN!7-w=N21@WK%66yI51of~L_O#79xSjp?9OM2T z$qc@k8ewW$olE}~G&pNZN?dl)UEJVUFE%);OG-#aJd?0g$Tez$1JoAXV267n{Q!1B z&%zZ{O)zR#2p^Y4b&ExkTfBNhW~ooqEQOL;{NDqsQ2$`|Nu6RJ&2ZJ6*oQvmXW0|~ zES62~l=Iftc2Ik`;epKMu5_u$HSIRtC?QMUi7v#Okec8Z((MLxQc{Xtm2ujHA^CV* z-Kvuf3vM~8<-wg^k_uiR1l-3EbKCAfFc-=cY;!}S4*jb?SS#vq2k$z$4o0h8D_PO= zKB))>4V9Az`r&i6!QaWX&p)$99;pbH_<|o=-lO;_V<_(<4k#pE!$a6*70y`RO^T-O z=B=TKC{GR#?T_W52~AwqL_O3Xd*}<2htjRtsj3+aT=R>X!4%gtQbXvI&NaDD6Ln3c z?P(g<{DI<(1;9fTZHBISjJ6eoAR@rdqc`9-=#ta*A*csT>O+9=LTMw=#~FEJJldE( ztpjSP-P!-UbCE49Qi3S_C^}KpqbNn8WkMK7aS=rjg&##Hih2~KD6~xQ<0vko2%_+# o=tNPEq7;Re32q$4MHE34eq!t-#(H8bB}OeV{t$wXux4W7zcSIgLI3~& literal 0 HcmV?d00001 diff --git a/clos/3.5/precom2.lisp b/clos/3.5/precom2.lisp new file mode 100644 index 00000000..0c763a45 --- /dev/null +++ b/clos/3.5/precom2.lisp @@ -0,0 +1,12 @@ +;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; + +(in-package 'clos) + +(precompile-dfun-constructors clos) ;this is half of a call to + ;precompile-random-code-segments diff --git a/clos/3.5/precom4.dfasl b/clos/3.5/precom4.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..203ab57dff7b918cf421270c2d3aca78964e9458 GIT binary patch literal 5599 zcmd^DO>7%g5Z+z?#C2@fPPR12Ei7$;s)}7Zb$(l{xc0_&v;NWA4v9z(X}WFFCUN8> z1q78!PaKR&8xidw0S6A{#D!DEAs}(_fg2Z2z<~=F4!v;+Gy4-ec2b&9m8dwf-`h8D z-_D!&ecw#>9^)8~OG3Q7urxQXRD|;C%F^nJaJ5_!mdmS^8AZ5?x}CfgP%k6<7L#UH!Q4_ zmjd(3O=X^TxY4@5)Goy`7ZWjcjUz9DS#i7=$cV*MuI^1C2<>R}1)Iic7;n4V zh!hKWXx;l&doU&^Lp0@X)%Kb!7K%7{IGDgK2Iwk)W^Dm-!Xk-942SN7=S+hWg)`6& zht)MJEfdS zIOtNVuh#vk_gXx&Fx;I@{J;s#DT}%lOfGEp4aO{PNLQ%}% z^EtQrN!1(AW%6lBOazQAvp9HYGGCNarR-=Ah4c^bQS&>zM9oillyshUT)s;j84*zq z#zYeyh|$7CCUE=U8P_=IFkH7FSa>+1W1Y{Gq+&WRiGi`0R1yPuIhPFUCL8rp=`3(m z2Lg0K1Yrk$I7fKfZt2r4y{(o3-O_Jj^hd<#=?08mh9-p zKuk!D zlx;7JvP&p7?HWW10ZiUS5&RLPO50>+j4scDpEw6WBG!u#+D4;3BF+ymNX-VJ#sfpt zoTr})$Q5@m9+M=4M5ur;4bwFFYi+W+=0w0npcnd}9|rytZZ*)y3Z3YJrsZMsRil!X zHeES&| zFYiru@Ev=np3|V7^MLT{fVhD)?^f4s?<+SReKpV3Q=kP?pvm)C+J&dXG!ngG$Yi-O zWRlz#Aq;KXg~7U&YK;z}eutdvxCxVG@K1vO z5=@~w^nm|m@H=!xIISy!(@d=45P|b^n4<jUJ=i59->of=ky8W_A?tAwX+Lf{=$*SYu;0MCS!nPs*hW#VU# z$;7%Z%-G(5$v*I(f~h)GI-8P5qkvaF+o`d?62KWjqC<;UTpUhM3Kjwh&R-g*vD zG5n8JM>8h$GJT`-=|JM~6}xQ+CeMNY1WeV-2ttB(_TS1{^IfJ6f$z6NK+C&Wl{-v{ zph5u@z+}0jRA@p&wZ}6~*S!d&vn}$Xm%c_i-n-T~46SiIbwN2G3!<)_QrE3>PoQf% zBvcdDO-Yqzwj@*&>if)`_I;^f+YC%%+DwDLAEvgYO`%B(2f8&P{Q7#G2)`Lw6Txie z%oj8(jT=?-E+pVc5&s1V4nGH~IIurV;k%1xk{~VH;7}JtJK=!!;M*bkXNvmxKFB;z i!h!bk>rc?iteW0@387mMdJ{rn2(?4#Q@Sg(x%oFuh+!ZA literal 0 HcmV?d00001 diff --git a/clos/3.5/precom4.lisp b/clos/3.5/precom4.lisp new file mode 100644 index 00000000..06a17cf5 --- /dev/null +++ b/clos/3.5/precom4.lisp @@ -0,0 +1,12 @@ +;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; + +(in-package 'clos) + +(precompile-function-generators clos) ;this is half of a call to + ;precompile-random-code-segments diff --git a/clos/3.5/slots.dfasl b/clos/3.5/slots.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..1f1476be0b220ed2414b252a546643e0c3722c02 GIT binary patch literal 7728 zcmcIpeQZ(HZF-@`v@KYNy}u^#|2ZG}750(g!;OdZe$@7ce57 zzW#6+`a5%}Y(CePO6JB6wL2qa3lERSWBK@qJP;qr#B(FDmv+hDkwe+%$$A|f(y?gfVfk_9S+P5G6wK?yFZO&#VKKXE#$C#dW%c2IY6fRohX#MKjby~ zL;ju2&UQJ(avQ4KvL&ea!iKxc2nUOW)z+sPI;w|_5JpbHaU521nsxxbtwg{hk3wHv z`Qps3VK_L_Z$woe4B7w%X76Mh52DrSUE83qW^3eVSnXo=&20Y$=(YvasCW({3fnJW zD14$M^a}KbGJr_9mDq_va-Co8BEIGMpd$sj$fP7gOtSa&NBhD?-%5C24ffdOHpMlA zX;m`})GFcbkP=iQjliR8{))_A!*+?xBeoVVRu>DkRwOIV`9`teAS7^&qG?Ca>LI^6 zNTJNK5X<EktOuEJQjkosdq79|yrU>dQnA8TF`N9Um@%X|)wm;9)ce z0pY7cJ)iq>sM+C_th1__JxvhKr$h)fksUz@Yl;Oabo8s?*o?X%1EjcO!q`rZw%e)XUKD4+KSbtc$3#)EnGw}iEYuj@9@Q6JT(i=S zIg=0Sk%%7ZX7)9#L)-%0D@gz3_slMk&YKa0#d#Gr`MkvICC#%=a(RJO#Yen(oYjab zXn7b8ttykVDljkz@?6|yxD;F2X|ag~xt1@$Vm~T5Rf1lVU`XUni9{kJ2#?Wwli;LN zh}#_>PR@}pM^A(gu{!#0W5>J%Cs#5g8#4R`09qd~6u%q2T#agmpV^04dIw9_o`o?7 z<`ZTZ8iDVoF7PyN5HLXx(E-Tpr(mc7lMcTU_Pech4zbK`HdefZHrr}8 zjOSegXAmNO)QArCfsDwNllRVLGGJqB@gl+x%fXp=o}t-I?gJTEkUh5vxLs>1m^VY3 zGI#VmP!|}PIj@VVz}Co)IcT#tC2HP+eb?Z&CJVM#m@~+n8<_JNi$V5)d|lu?3=Y)K z-WcHTw|Mj6+1q-`ar2|ZoxoJ!LSni}yrTqXr+VM&J@?r&w*%5g)BiYrqqV2^=1FeH zS9J`ErYJ#|M>k(Jg-+X{qUO=fi0R>`Z^cSfXxn1Otaf!lz=Vs|eE-8-BWAD2HRhsg z$uw$TWv4T+c5^9yy8AJ-&iOaXo?yq0u#PpXu^tJ1n(FJd?lu?^b-x}R;(D&-dNv@z zkX~RhKhV3{+GuGr18Qrt!gGD)8AV4(whU?CBO`su+td4j%L}M-)GSn)7hpBJ=EF)x zaG9Pz1F#l5ib`OWp91zIJB?|X3}ST2==<_g5caXG#)c6;+UFX#y!XTrJS6D0NHZxz z1b+tO-)7>loLSI%*QJVdWDzA-ZDOZa1Fvh#_NmmegJmtQ*7HRe%B2hIc zh%(HY$ehVeWJV}I1)#*AQ`n*h&n?Qnt^3Zyt3@SVWoc}(yz%j74K>1FdGkw_PP23eOFxE`lV~ZG zsSvZ{z{@bu2&D?cr$kG&3O+W$#*ie$Ilb|ePpIb)*mIj+KgHLZoP3&kev3W7=Hzdd$iL6YUuT&Y z>FqZ;HfHeQ9zLY9%t1ER%=;R7ALg+1b`^5gMp#+A2pPix9)0HJsc>Z!gdsjeb`Yj> z9ttt~kOrkI9qvOCgTh={cC$dSk_aV0p4~tRkSAd^+rjl$K!jG^N;s?xZ2;U__%R$Z z+(uWaq=W$qGR$Tq*t&Ir8r{~3?;@Gra6L(64X9L*5K!1RAcJG) zVfX4M!cfbCW#MKH$!fS8c0qz?Ar{w@oqHF}-WJFQ5S3+`R+3qE-!C1-VlAtqn(Ovx zA}(VIS$;i&1T;~+tVqsf4b}ml%67m-2+wsc{V`j&Wj$&bFKAy`%gpzY{C@+t4Re_%9 zppp3udLP@du~^uhivzK#(QP^T`B-WKHp-%Mx5L;dR;y_j8re}_ENq5f2}Tyq;VW}0 za2D@CBA$_B`FuP*mQQA$r8SjZuWz+BGtDQR%;j)+bUd40%z$=7{lvU0d_izb((~W+ z`~)GLs}pc1aDq+Qk{GC$QTig5KX=YkWz-KUAR~rf0MPNEnrDSYc;_TMLVgZm=%vcr zo|o=^AM)n-JH68#-jB}S(ctp(aRRHMQz5v%d<)B7Jx2ZPRPcwvbDy1Z-3dt_Pyg*? zfO3}O?+&cedq056agT<@lM|N%1FP0yAzA66kY?Rg9LvQqsDLgnZB34y4uW7CD--O} z4;c{IpuETIYk{Ze20?uy=f zb6^$x#N$d@;IV*Y^?XD4y#)A?e2%r$tf)jIPiS1{XiP0YBMx>u%*|znH@AG;hIm6Z z9a(TR3k7+Fr_6yjt$_$3{YH(IyoaZAoC)w}=qy`Tf!jOjH>_6O(E%kTu z;scIc{Wb{y!q;yGH(J3CPLQw6Ue&PZ*u!u80hgkguge4q0AzXBu|LO-jk1mh;2;hW r1V4r1;{wf7()c!WqH7HE=1JZ-s1g3e8^)Y5=G?}dSCDf1{rmp|E{0Ji literal 0 HcmV?d00001 diff --git a/clos/3.5/slots.lisp b/clos/3.5/slots.lisp new file mode 100644 index 00000000..c21c00d6 --- /dev/null +++ b/clos/3.5/slots.lisp @@ -0,0 +1,261 @@ +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + + +;;;. Copyright (c) 1991 by Venue + +(in-package "CLOS") + +;;; These four functions work on std-instances and fsc-instances. These are instances for which it +;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified +;;; methods from the instance structure protocol are promoted to the implementation-specific class +;;; std-class. Many of these methods call these four functions. + + +(defun get-wrapper (inst) + (cond ((std-instance-p inst) + (std-instance-wrapper inst)) + ((fsc-instance-p inst) + (fsc-instance-wrapper inst)) + (t (error "What kind of instance is this?")))) + +(defun get-slots (inst) + (cond ((std-instance-p inst) + (std-instance-slots inst)) + ((fsc-instance-p inst) + (fsc-instance-slots inst)) + (t (error "What kind of instance is this?")))) + +(defun set-wrapper (inst new) + (cond ((std-instance-p inst) + (setf (std-instance-wrapper inst) + new)) + ((fsc-instance-p inst) + (setf (fsc-instance-wrapper inst) + new)) + (t (error "What kind of instance is this?")))) + +(defun set-slots (inst new) + (cond ((std-instance-p inst) + (setf (std-instance-slots inst) + new)) + ((fsc-instance-p inst) + (setf (fsc-instance-slots inst) + new)) + (t (error "What kind of instance is this?")))) + +(defmacro get-slot-value-2 (instance wrapper slot-name slots index) + `(let ((val (%svref ,slots ,index))) + (if (eq val ',*slot-unbound*) + (slot-unbound (wrapper-class ,wrapper) + ,instance + ,slot-name) + val))) + +(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index) + (declare (ignore instance wrapper slot-name)) + `(setf (%svref ,slots ,index) + ,nv)) + +(defun get-class-slot-value-1 (object wrapper slot-name) + (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) + (if (null entry) + (slot-missing (wrapper-class wrapper) + object slot-name 'slot-value) + (if (eq (cdr entry) + *slot-unbound*) + (slot-unbound (wrapper-class wrapper) + object slot-name) + (cdr entry))))) + +(defun set-class-slot-value-1 (new-value object wrapper slot-name) + (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) + (if (null entry) + (slot-missing (wrapper-class wrapper) + object slot-name 'setf new-value) + (setf (cdr entry) + new-value)))) + +(defmethod class-slot-value ((class std-class) + slot-name) + (let ((wrapper (class-wrapper class)) + (prototype (class-prototype class))) + (get-class-slot-value-1 prototype wrapper slot-name))) + +(defmethod (setf class-slot-value) + (nv (class std-class) + slot-name) + (let ((wrapper (class-wrapper class)) + (prototype (class-prototype class))) + (set-class-slot-value-1 nv prototype wrapper slot-name))) + +(defmethod find-slot-definition ((class std-class) + slot-name) + (if (and (eq class *the-class-standard-class*) + (eq slot-name 'slots)) + *the-eslotd-standard-class-slots* + (progn (unless (class-finalized-p class) + (finalize-inheritance class)) + (dolist (eslotd (class-slots class)) + (when (eq (slotd-name eslotd) + slot-name) + (return eslotd)))))) + +(defun slot-value (object slot-name) + (let ((class (class-of object))) + (if (eq class *the-class-standard-effective-slot-definition*) + (let* ((wrapper (check-wrapper-validity object)) + (slots (get-slots object)) + (index (instance-slot-index wrapper slot-name))) + (if index + (get-slot-value-2 object wrapper slot-name slots index) + (get-class-slot-value-1 object wrapper slot-name))) + (let ((slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'slot-value) + (slot-value-using-class class object slot-definition)))))) + +(defun set-slot-value (object slot-name new-value) + (let ((class (class-of object))) + (if (eq class *the-class-standard-effective-slot-definition*) + (let* ((wrapper (check-wrapper-validity object)) + (slots (get-slots object)) + (index (instance-slot-index wrapper slot-name))) + (if index + (set-slot-value-2 new-value object wrapper slot-name slots index) + (set-class-slot-value-1 new-value object wrapper slot-name))) + (let ((slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'setf) + (setf (slot-value-using-class class object slot-definition) + new-value)))))) + +(defun slot-boundp (object slot-name) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'slot-boundp) + (slot-boundp-using-class class object slot-definition)))) + +(defun slot-makunbound (object slot-name) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'slot-makunbound) + (slot-makunbound-using-class class object slot-definition)))) + +(defun slot-exists-p (object slot-name) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (and slot-definition (slot-exists-p-using-class class object slot-definition)))) + + +;;; This isn't documented, but is used within CLOS in a number of print object methods (see +;;; named-object-print-function). + + +(defun slot-value-or-default (object slot-name &optional (default "unbound")) + (if (slot-boundp object slot-name) + (slot-value object slot-name) + default)) + + +;;; + + +(defmethod slot-value-using-class ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((wrapper (check-wrapper-validity object)) + ; trap if need be + (slots (get-slots object)) + (slot-name (slotd-name slotd)) + (index (or (slotd-instance-index slotd) + (setf (slotd-instance-index slotd) + (instance-slot-index wrapper slot-name))))) + (if index + (get-slot-value-2 object wrapper slot-name slots index) + (get-class-slot-value-1 object wrapper slot-name)))) + +(defmethod (setf slot-value-using-class) + (new-value (class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((wrapper (check-wrapper-validity object)) + ; trap if need be + (slots (get-slots object)) + (slot-name (slotd-name slotd)) + (index (or (slotd-instance-index slotd) + (setf (slotd-instance-index slotd) + (instance-slot-index wrapper slot-name))))) + (if index + (set-slot-value-2 new-value object wrapper slot-name slots index) + (set-class-slot-value-1 new-value object wrapper slot-name)))) + +(defmethod slot-boundp-using-class ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((wrapper (check-wrapper-validity object)) + ; trap if need be + (slots (get-slots object)) + (slot-name (slotd-name slotd)) + (index (or (slotd-instance-index slotd) + (setf (slotd-instance-index slotd) + (instance-slot-index wrapper slot-name))))) + (if index + (neq (svref slots index) + *slot-unbound*) + (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) + (if (null entry) + (slot-missing class object slot-name 'slot-boundp) + (neq (cdr entry) + *slot-unbound*)))))) + +(defmethod slot-makunbound-using-class ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((wrapper (check-wrapper-validity object)) + ; trap if need be + (slots (get-slots object)) + (slot-name (slotd-name slotd)) + (index (or (slotd-instance-index slotd) + (setf (slotd-instance-index slotd) + (instance-slot-index wrapper slot-name))))) + (cond (index (setf (%svref slots index) + *slot-unbound*) + object) + (t (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) + (if* (null entry) + (slot-missing class object slot-name 'slot-makunbound) + (setf (cdr entry) + *slot-unbound*) + object)))))) + +(defmethod slot-exists-p-using-class ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + t) + +(defmethod slot-missing ((class t) + instance slot-name operation &optional new-value) + (error "When attempting to ~A,~%the slot ~S is missing from the object ~S." + (ecase operation + (slot-value "read the slot's value (slot-value)") + (setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value)) + (slot-boundp "test to see if slot is bound (slot-boundp)") + (slot-makunbound "make the slot unbound (slot-makunbound)")) + slot-name instance)) + +(defmethod slot-unbound ((class t) + instance slot-name) + (error "The slot ~S is unbound in the object ~S." slot-name instance)) + +(defmethod allocate-instance ((class standard-class) + &rest initargs) + (declare (ignore initargs)) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((class-wrapper (class-wrapper class)) + (instance (%allocate-instance--class (class-no-of-instance-slots class)))) + (setf (std-instance-wrapper instance) + class-wrapper) + instance)) diff --git a/clos/3.5/std-class.dfasl b/clos/3.5/std-class.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..2cf32a27deaaf44be50b359ed590b91d026426f7 GIT binary patch literal 46612 zcmeHw33wFOm2OpaOCW)S5JHGXh&GEb!VSiFAznzgS`BLTQnFfN$BGPs7RZ2E;y8O#Dq|{Qh&!t?p{6 zg#^ZvaX$D^->SPW=bn4Ed#Y0#za|*<26tY!tF66tw|D2hy}S19^={d@+q-AyzTKNz zy;~6P{ZLIJ@{uc>_O$Nav%F>Zz8yETwr@%LH?sb&Vbx+6m z6;1JAW7v#$9n^2ubGz>D$PdST^?_g{urj3SdRK>=My64fw`f|g2KVxX|IVH8PpZwlUY3F|Yi>HH@$ps&-XqY<)fp zEsWYPY2z%kbUIM@j`ZqGMslu8LJ}1G4Bv>hdWYHyy{tQRzl10B--WG76Nnf`cN<&h=$jN z8hk55@lZoJ=(Ep3m2W%pO-eKd;x&PW8lOy()L;&8q}rNDbzg~;DbBj3n5ywItB^9y z7+$xNg?8fUrOn(4=;UON*_f^sg%Z+3N%FwsQYJ}7^$ljD*|@eo#Bkz@NYTZ^i_S(=K9PBj z*>sg7aKw1}XTA6ue7<{SveeuV#&;G*C4*xgH=oSE`9g@{-{N z=OC&qwecB_uoASIslqaPefa40f3p^2^!l$X9|bZ<{R^mZN=6@ivGAI(^hAH2d!iFg z&O}{$hqZ)ixkD)?^i4Y)xE*EV*0+2@9;kTx*$b6<&?nb2_^|r6V+IR?j~AK03;JlYOgaZ$Hvs z+wMLxP}}Z0a;&!9IC6YjbK&5&<|6zRN>lx zG%K3DgQmRRzs>Z1P18pLSw$h(2^MvrXB z$Q#YfJCHn3l6Bt6$0Gb;?_@BV)5STr`>DAHV$tqENngKo^HE1ZbR zTv`FV7U5NmG_f{TZAPsLXgcR3l;uFiWOJ)I8wCsKPo2X8?-DGa^KP3ohTUdeo^6vE z1d8?+vHV0m4~1ia(;-l6)gY&q0i{-G2uwBtCask=I9heqBm%xLBCIGqEl_99#Ip=- zfxp%>XG5(&FoAG?Z+eLD_@NVU9y3IU4W@P-G^}FY67JusEm3@KONdj<(-fw*Z;~GlJrhU5AiG=4uIk@u_TQ1`{jhV zH&PdUVeoF7Wr-Bz(7`nrU<_Y+T7WE~#jcL=w)BgDSbs^N_bF=wy*-{n=R{=aUj%tO zd5E+tBw`}{5$k%&a?jgD=kBL$ASP^n{mnqS^??kjB_M9vom^2BFeM+#b+Y*j5VT4Hij->w43MMb~TRVDa4xi?hxmEEZ)|7@kddbbTiq zJkBC`{BjB&|Mna_zI);Eyt4?8(-e>M&V%Ix*}(EV0?W=6SYEHd@*L0pZc!qV4$;q= zJtf3C6s?QBP-JuMioIc)a?TlmEi>w07gpvOV#x#1s2L12hBCEX4h000o&Sied6|Y4 z3dKHiHjaE(awsf61M+hY!ScowEMKKy`I&S4&%1>G>1-=XGNjHs14tdh{fHh6U^vcc z81uG?P1nUkA+HyZH;*81K??Hn6y)`ugS@{q7_en6>?hOa0s3v$e8PkmD2?sY)&hEcK;%N(&y+8BX-@E50MI-i)f#`W zLDP6ef#$!Q1I@oQXpT`Nzuwge1FN3P)FB_yH%8m@UKorR2=iYUj2=Th*W~DjVs-KK zu^$tuW>JJex#~hf(%w>^wsv)Jy6H*wXAtBl4smU83^-Zl%oeD zMb1)n{mFrd>*4O2h~es~is+p4WY5BASJa3Y#`MANsyf5ylN#!zhVE%>gfAC+km*=t zAlBdAk0WiA`G=vLO9}JbT^)Jx&}!eRK(r~8R*m1?kymNflWk=n3N;GMBz zJGA3Dp@s&t;R9Hw!bAv0#$?yaRakj7h|G6JT*~WoViv5M#*sv@zNxX0quv;|o5MTS zS-$tm(}fbuvwYJnU!J^>m7#WXSI2qg=FPY%wPWkvq<7cuox56h@4eBBi(GrjUJTm$ z6^qEO$+#Emhc2W?W#vIvPIZt8Wojs_VlnQ3{2Ie?V-PFYcGK9S5Y{;<_Pd26;jJQ4 z>NWNmh{_xr4BqqI_o0aW<#m0`3zh%Iw+2SgL4RZ)?|mu2jqZ+ z4N?I>Lcdq+&Cl4t$hcI&pcokW0Dy}K)D}`S9<(0=Wvc!NHhwh?kL9HMqf9>&%xQBW zPo8D?OzU$0%HZ=ap#RIlcU(9+pgM5osem(0pDCkIMwxG$Aj@De2t+R=&mT6YgrJW%Y|@J(e|QE|7Z>~yO{e~n6DQ=V zt_(#AdS50|&>vTaR?j)4@Gjy1gq#v9@rzCiH`qWyo9|TzeE!eSQ~E>M=&6ecbPpUCzM|7f2-CM=rz_R(5sbV?La&iRUKPCK^Mr@l?xQ zob!%-mT#RrMI`WBKHN~8D=&N+=od0~eLqJDo`-Qc!<}A$hJ=ylfq{*tm0v6*=Qzkh zFvOg|ipEd_wFx_P&DA!R{o}AB($}CQAJ#vk`VMsHYveN1m#DVU1sN!uwYC>XQbWBB zP}lB%dtJLbRoTun@71PMB`eRoH&>)8nQ`VlnUt!8y$;;PqTigg63pYk{Tm6MmEZ;m zu96^+1J^4OJS@R=61+!(91e_^C3sMRof2Fjfn>prJHFZWs05NlS2rYPa-=4G(FW!1 zJ}U@ebq0rO&YRvf-yd25l5_b zT7|oKrgm+!idwD0pu8-%ikDeamRg0A<$a=6oNGSBhJwLPJ* zv97bOC=9`D@>p0uo}??po$>wM^YrFIx!PJZ7(HwjMa!RznMIYyZa0gPo{a-><9PRL zQQTv~y;jmL3fjE3t7As`cI&XQ=izc|+Pu{`ARZkh zrQ5r~^Q<7jd2vH15cSy(Vbr~S;Qf^$k@)lWL|o@<^Z?olZf0z6MQ`+x^tX_~d~7 zH}nGV2@zd;8G2v99f!k?5Y=GiG3l*uA@Dt~#`LA!4gl4X@IB#!Zv%3CqsEzAg^c6V z@AH5iC*xIleDEdAriNf>7Gfvbmo^|ZOH4<^6gz^t%+-YwQxKn*8WfRG6GL&jMsB-U z&@aSN+Q>;R_I zbu>`Rdy*k|t=<n$SvkHa4Ww< zK#%%kSR(cYLobWD$4kaXF!2@PIN&kHN-v*K*1iBvZ+Nc}r$utEbX_THMh;6R25STH zl_`LlkErpoh0GOJo`+EQhS(}nfK5fxl#G>S)fp}u31+=irwuf~`*zw>3FE_|}5+~1kJxou-->~=YP z53DZfkf+=07@Rlq?_llmILL}5`5Gy7J(BFMH4DMX&NT~dR(7sgbiY|-AR0R0w(j%e zhH=f≀P3?4>mFWm3ot411C zT|~7Mqq=m}?@+H}Jjapn$pgvmt0Ew}WC%(0BL1jZ)V(0CZ|AWmecZ7wv(PNAME5>! z7AHN;GzUb0y~5Q*!|;T1bF|ije{*%B{qq4Bo+_~4vX9fp5bsnF{{m3?bg&B+2jyYk zCgkl!?lANOWz(2r|5N($L3vzj&E<6ci73~0q}sZ~M`#fg+zKy8eS3-oql%oBJetwsJ?2<=N zn^f(~^m7P^A}GMw=~uR$J@eHGN1T+umuHiI{7gKo3p08y;*}8OK&T;aMR*Myj^WsK zq24q-t0!`=;&xwO!p;6;6$dYtaPY(gEJ|@Sv=Y>gAWWhd$PN1fDBt-nMY zBoe9izexSTITPWxelcMYSk z91A5F>mdfX2XQWsc<%tc*O%lF(FKZ!ohq{NP>Qdx@>U>CIRUgud!qHNyyZwJ%kJ)w zu5P~v$^&2Kud<2yFNvDIj1y(CXP6d+&;bd@YjCg@hwC-?SBt~>8a$tEg9EN@@XNIg{zjn;5vK_9KH&-H`{pLZB z?lP<3fQ@2bGVlu8VeX(=N*>wD$VXVES$?Fs-1PjS*-P%%=EBcd6$0`yHruR(7q*&h zW;tA@tuag3r5N0>RnQ;2iG6#^+W!vsTvXdxd+X{8L6Hz)hSe#_(YwfZoLTZhca0xW zyr^ce*iCjX;Y`KwwN`>Wa7I_m>B^DY0kin7R2jxlMri(R>z%}6C$Z9I@uOx* z_l0J$PRnRk@rI`Ok}k8`0f^_L_U_M` zg|vfCG3HNVP1+5vlLyUD^9THnb*V#jyf#$_%&Ps}b$W9dx930EbEzqh+$u+!=O5Z; zo?p0s^+g`qI=pO^vTT+1vQ-(VvAYNRg4U1+)l+Q>w5SEg?8>=jme|vGNCsX)vy1Vm z$*)rLurIT`OakEpvkJPk)tE?{+^Y2Co`2Xp-#|1??lPV^K$)skEml{s;ZS=z}yD@y7{Q8PMsBY$Un}IYFblrXx#X6(1AIy&jA0PbFZT=E_jsjkAf0 z4BZ_c02v3DoDBTCWIAE*A~ao0j&X+`Qj|z?rKwrG<|;oT?ti6*Bz-F=uJ z-=N1k)3NRR_(O^nB_3xW(E;n^YFIEQenOajW}`8P3BrxG%VbH^P@+f@)m19nVJcKO zCyO)R0iV&J?d{#>{qyYT+Im2%bzCLef>{2O?JPm*qv5zy@>BAm*K`R3jG1by^Ly$ zSmtiHQ6h_YVO$Mw(}YfFq?lQ0%%Sp9%1*C!7gAh6FvK~Cpz3$o+t7bES{vNMIl9Z* zpsF(FK<1_GB8F`Z__=CuasjyX4R?n3CyVrTd_wh$@QSQ1I-~o$r|TQVW~1H3M`^8Z zFlr2R|3Y#dOAf?3W0Y&d&|ER&Sobf&MsN3{G9z>NMnXz#ZVO!O8Nsq)(2IrAcM&^K zAQ){mt~fz0VdZ(#anPF7aNKkrVy>|oX>ib-M?zX1{;FY!!;APYtiUoZz6QfyCp=KE zXirY|oCj8r*X`tCFot3Ap;$zZe8?7!H6KH&3u|crCn|+D#ZTA*nyAmPW!OJO&D6~8fzE&uL-(we zX*;UGU4lMEjP?5?BHSMEN92mpF@JW&qX1tzbvkUBZ250oC#?h?D$z`5hXy$Kw<#)xn8J) zMLqd&+y3q^i8J>Dk?vAyc2EKZt;hYup!3EHbA7_En1viwEpOpC-A=5F)7?as5|@-} zB^@yf51567n$QEkStM`^m4>*ZM{$ytFq2k#z%0Eb*M3Rkb&eOOT3#zMmM!;Ugqs;-W4AvxmtN|7HcR*_bA$%$s`t3b)u zgv1z5ui(wVckljyGE;|^QIbvC>;ELcK##}MkKO6VCxPv9qoMf9##+iGyvH}`@u0Pk zf)2DWEkkvdfO$#6jD{Ma#a~Z)42W0jS^sJ5o@y-=n&|~1O-k%7k$}f>e5eeASYd)+ zqk6x~edwh}`YZ?EBLHyH``=R0xal)jq|}_uUNO#>{X%xSH6$VnKqyw%S+^gHw4Px? zd9gnfsr4NFM3kcrM#7%nI-{@qpA=#f=wS^I^}^T#&ytSql({x;k|a;DMC|HEfz-Sn=DiGGD<;ggeDQGX`o8g`<_dw?&hlwMPk9 zeo(8X@I!zOUF~3eV8Gt9u5znfO^mEJ$vdUR4QP=7`7vAv77WH??5*t!_be0LFh}%< z$86>7EOmCRoO#AJjLX;oHo=`+!{;U&#T}rGqT{@sA5UD(!5h5wwG$Wc+Yec4uDwBu z)j~zQhU2hj2!lysZM*S_aUbQZcWmY0v8cR>M(_^iW3|VG`F^Za(%2~ZE`I)zn&b8F zx;b8-eU5X^c#3I0j6+!`^>DUHJuH)Yc;rbX)i2PhU+vrO%k(sQs?-PS^e7`I2Hu$u z)*Y)oUROJ_Gk!}f?m0@h>7Qr^f5qN7hlUK82TGRdU}I|%`W#-*H{>|eea?0}YjkbVWjI%kgf6u4ZJbZyR#@9GQek zU+nK$=m)E5T&oR+d&4+XP9DS=bGsb$sY8F6n$_<264ntoj>0wV{ z3J6>?d7`@Hq-?kVNIDC<>Trf1s?m>6;@1@uC9oRt*69rW}bO7@edyAC$aH>p(Y-vcD8>CDlTb}4~-cwgl zlVM4ylmyvqS5bm|4N&`|*s7f55?3MtS3ubK|3yjo2ToW{3H_4LB?$-6uPU274?&oN zFDT<1jdc7tu{j+}Vkk*f;FERRtQnh8bk@j4)B(_J6{?fsyiuEhywP!7ybs3(eXv0P zGLXf1u_>fwc6{+F>w;%FFYPs9(@jKqy@wvspVciEl?s|fh;cZC+|>~ zMuHF3r8`pxnDKq;VjGMuJ%Qxae(a?rt5nzAr>uneDg{~56gX6ajjZ-Nnm; zK_d)n$l!y)__;7Xzfc{6x<(NM#xH3;$sx89$I7uJC>)a7+xXDHG&j&(`$Y`IXuVn} zf!=_UbZagVlmBRxjvKmDz-^yv!#WNl!4&+uFQ*A6v9>+q7tty(KnGHBOvD;rC0NJD zF!9A$rTKJCLrnTxu=W)g7Pe_WCLKy?iiXPA8djdZ5cXXy`}Xd<4!3SMwY0b2=-t}7 zqjfib|NVyDZF}+c_Ul^rCUo15Or9Nti1oS!PIbPI6~e)uz46bPB}|$gZ98rjJ~vCf^^~fI zJ{9)1v25{4^*YeTGDR*aa_WAS0tsEL#}hM4nF8#LeUiZ)?*MksezWwLn7=&x)(1JE zmVd?gT|8`w!b-RwNMaoSM#b8|TUjtpfrGWENwC=KV<2p9CfQVuz?(7gpK@4b??go9kZX8a<^Yd1AU>+=tI$xj;u zP*fk$OId&`Wqkxei zY||-mIBL!^qp7ZD@J+K*dw#^zoLHwlDNL#VhPb#n>f-!SB{38$Jcg{WO}~%6XS4Lu zR$;moUC+F@zJ=*|Y@&K22$8 zQ%S^`{}PN*AGRSjVco;wqB{MUKW6ZtcwY>J4@IJt{Uicg&+^hYMx#g|@^WY~Z6q)J zUlt2Zmq6$@A_VDiC2kah?%xAuoN8Ftk}5326}BV-()vEpBKMQXuyi15)kO^teJynG zu1FnrBw|UV2>uTP{TB0hlY?e73Zf66&{pQY=&ys}v*%RjGr}PG9l@?^$s`Ug6^4&@ z%m4%R@0rm4g4k#rl%Q3D%OsG?(3&#b_?#8|kQH?Dh9@wn={8qBNDq9-mS`}BR^rAJ zIPx9h#`N)s=t2~q0JCI~nG)(*kX8?-2)_(Go}$9JTA?H$#l&tAv9!+eBkc{^RQa$y z=7Ii;$T7b=dT+lwN^d6y&|A4AFj99j4r6C`9oxrp1)0M%GIqVb#ucy@ zlv)eq&hZnjORS*R3g%llrW`u}(4;r<=Hz~fY=R$C&II_4VQmagLNuft4$Q8igOor0 z&EGp8_Gx1AJg@+Z%bo{D&7F2ZFm5I9;Vmps*S9Q{H!*78B2ctN4w$VXVNB*$TT7P_ zjHFs|x>sLB6=+X0p4JX~xVjfv%;?(8P6;?>JN>#gr|#MO^U$3roAPwTIj69z7$zzj zV_udfk4ap0>YRi*CSNkLL?(x(>@|_IJR`yFEN-zK7xZDe=ivL%!H8UtBKAhzuqIIg zV4^x44L7b8ji`KmUb_c{D(vJazCDdH>WY-QY$_kF*6t)B#>CCEB*r>ODVEdi9e!b# z2gSU4#xHYG-}G2uZFR_J8$e_jRRH7Bi3idi*Pn&85u^t@bh+yl@JoawDyP4g8;3Do zwpnsucAIEm|EzphEN32dReN1P^$447=|@DZd_+ufj%YeQ@p@Au{3XeyFI)q=p=FPE z&#u-@ZClz}H+%8Ya?`v$``{JUr|yMqVgE{Y{wr>pcT<7a@$cGwdpQFby%s6bx(Cje zye&I6BP+t)t#B;6Y3Fsjz$9MVjw@xi?&Wy#>^OjDi~)SMB_oc_E_;;$I^ z$R{szyUN=_Y9fTTzTfV~(Ck*;N6-;*oij?~4$4Rt1;f*>XCopaiD$|hJM4J`F_Jmg zZ$}xLk%57wb{4VBW-=rSw+4ZAYkiK-G>PUPi{~+ zAnH0e19Mg-bEeE#(o@$PwmUjV)At)DSD}9oHbMWMb+W|dE+qW>I<&&*wu`l`t}gZ) z0dRyoqL@+7H<=vO;78|1CP2xB1S5d0=+)KIt2OQ8kF0Gw*`rj{>-uY9`mzCbJ}{rb zb3Q%8h(-)6NcmY2yu|_1+o`LDwD-O4xb>|RD!lDa=n$m*vcR0 z2N?-pUPRAb&Qp2)B~~F_cyL_KOlcvn2gc4xp!Wr`Hr%Trcqdz%!?r#?@Jrxyy`bAC zFefW{`_0GhLxTS5Iroi!Y4?q?!u=9#I7aq)*TiV^M)90a&)B@Scm8|HJAe9Hy2?HO zpb~4T?F@v;+tBq?2ErT$Fz}i^3}6WB=-=WU$QRVVAU8VX!U5Tn;e!)oPnP=N#8&~r z(!3u~BGa1Jmbnl81QPMet77=;1+^8v6KYk2?k`Z2YA0sQn=bHsqCm5=!` z%_&JHSwGgn9*}O|ZR6W$xZEgG%mdGAU1o_+Hy29`G8rsK9=Z5f1}j3?7M9aZ$WmDi z#v$AeYdo6Ed#19N!-qRW*OySnn^bBl2S3>iyP8F4-G z0m^L7mKDB}9>It-&qZgSeQQ%(^;h+?vwJ6XlWqudH_Mt!`3)A1bWwAJ?%huokQFhr z99{C6Wzr?nLmjFxiyy!x$1+nqEDhdCkJNqz+V8$Il4|~dS+c)-j^12aSKgWYm{}Sx zC3hM3VSt73;h_4{{hGq`gVoB|xEjtLa66LciN6aiZWR8T!SMJL(mLIVw{bl$ev|@z3o~@a?h0y<^iQfmwh3^3MT8+w)5Q}Q z^-^um)1x?3*!Dq**~c|)lY_Lp^#i*=*7}?tYOoJ*bpmGBe5j%V?KQu_Ho)uj{yIY+ zNS}NB6y+n3Rx{gcIF-r|=^xG^Xm3UjaKBSa0ugb_#sx4=fYCuIX>#d$qw~#BY zmq4yKj6NsMof``T8%$d7SXajs`!y6_6>c!&F*p#=m>D`kGpYTIejZIf-jja36U$V* zI^0-G?tyq#8=C3~KuD=9Y=Qtx6TO>JxjTq-^71o*2>ldsbUtF-E1Re=9r*9se=%PNF#z)t}l4)Bscsm=iQitPq-Yy{O##(1Xy;&vE=u zQAIvYvu&|Uu{yrKK;Boz+qw;kG@h4=-K%Rual1~I(Q7}Gl$^w>hR_O5;@!(_QCEUB z4IKMZnt=Vt%x^!TMtErBsRPt|9xEsQjDLSE=@Tj4Mj4ccW)LfeDWnOa@%|e9>$C>QB$~%;xs8aBhy;WxW3z z@}AZVa^}-7ae6bD&dn|HLX6HakEs;xnc^i&M;5;p5C*%B<*vqM66hT0-;>~B33f`L ztmLNg8?4LtoFA0nF5BO%kLsjrW)8-iqDb9dn)2ae3sPg@HQ_i*0*z|ITKZ2Y?^SG{ z1})OCT8bHElCvL!OiYWE=~1d)scIaT*MFYMtp5m^3&><9GpGKVTa9+q$P1 zf3{Q1kt2}4vlS*U!JRu{O`RWc8%mg-U4;13#g#F$BuA~|6C7FgA!_bD~BVaJG z%O|CZ?Z-bw4U!`T{j(y|z{i&OzTT67yZqF)Qw-q41Zx`ktkCb4Z)u+S$C&U%2e$>e z8)z>+qBYwygL?@9>(!KkE~GoG2>IVo>S6(9W9vCk{)>aMzaL)&JF+21f2b~cL|ssn ztFE2V4*N^lEX5FLW@>RDaxB`jT!bzhaXbp?PW*v5=aK8z;?y4YIvxm@#8swQF0vl8 zqR3e`jgsH!_a5XTflvii z2U*Tw_fw>6VbP&`>6ve~w6{DmhclST;rnLBdwElla~wl90(qIy|6eLrmus#pYxy$A za)!@?5zCdECzStlsqI@zHN7XbQwNik0`HX_-^`<4bLUR)9Kj9 zQuXQw&Kv`f5Yk||kH(+jFe*nx26QkQpxv1}a+9JZJ(F^nzX^>1GHK8A=SdlU7@`E) z`oeWHJL_%<*LnJCd+RbUDAuJeD2f6|0FLafj)`Gp>N6~&8RBaD$9O?enN|wCW_-MK zoPh88v8%)z^C*%g=4=<3&2@R(u(Ab$qVfcT1@RBPLXe_{A+5pI3LRdzm7#3_Q90l z!$nPw;p*@iqOU+4t*<^PCxRY?zyQ8Y;AWa)Et~|UfvZoF-3n9T{=n6YY_Ms0I~hZ4 zxrd#QnPy4cWT?{8(*Ih62T*1<0ts%`grGnDu6 z;YuGr+PMR!*VpcAYv*scimHBZvIQSVYT4nvwv|-+nM!-FRG-rDqq)71Y_{y)EQSH{ z>7={t>E1}wqE2ekgbw?pOxF1xrtGlin}rihCzFZ)+pG-6`p|FFg3*n(w^BPdNNjZpieQs?Szzzp*6Vh`3}YuO zE!y_BwY0Z=5J0ipySvr#-ZBJ2#1P}jp`Mu-59>q=K~fVReb~^?EH%vSN##h8n zp2jdza#MU4fuwXIi6mi*vdws&C1pBkO>b0?=b~>756Nxitwv91!GGXCYTLZkel2D5 z_FReDt&FBc$syW4rI(T+tVcHbEn>kXV)Y1p*+w-K|ur0p0>v75h$ocLzdDwEgPnB68dInt!0Nv&E$c) zrwn?gFNW1%+9z?w_hG6vei~BlmF=&z8?S!HEQDdOJsV>z6FL1NW)ayRE006|QNgM> zV|O^fij@QmR>cG!B4d4p9tY^WaJ@*6FVG|Fko3Pv$Fkx`Vw=*j_36B9cP=%QrDC<; z)1zpizLF}YeKDPZ6}iUlu(gocXzl4Gl%_qskh2__%WtojQI~q?S#(f;&#Bue_6cl& z=}s;^CANh(=75}3d_Ws}Df?kj`LY5`>S9rZ&ULXe%Y7f^+rx~XN~9@vxNoZCYm0BmWe3pF>w*bJDDj<8Lw-W%HRVRN!ZIuOWJT;0mr;R66~Hg`fkS#*zX2>RDBDZ9(&R_yL*z) z=<{g)U9=~)H~EqFq--P6>wbq~Wk)es^Oh4LP~Wmu5|>&F*(_IkdNxI9PnT1mA7K@R z_IfVG{g$&b6#kl1X$NRlI`)vn7Fm}XR*jCYmHiKbqiuI)gCombTX<6$3uSNpK?3FG i@?Lq{B!Rj#F@fK-f0p1m3HIBcK01u?x*vP%t^W^~A?la_ literal 0 HcmV?d00001 diff --git a/clos/3.5/std-class.lisp b/clos/3.5/std-class.lisp new file mode 100644 index 00000000..a07b366c --- /dev/null +++ b/clos/3.5/std-class.lisp @@ -0,0 +1,997 @@ + +;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- + + +;;; File converted on 10-Apr-91 22:24:19 from source std-class +;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14 + +;;;. Copyright (c) 1991 by Venue + + +(in-package "CLOS") + + + +(define-gf-predicate classp class) + +(define-gf-predicate standard-class-p standard-class) + +(define-gf-predicate forward-referenced-class-p forward-referenced-class) + +(defmethod shared-initialize :after ((object documentation-mixin) + slot-names &key documentation) + (declare (ignore slot-names)) + (setf (plist-value object 'documentation) + documentation)) + +(defmethod documentation (object &optional doc-type) + (cl:documentation object doc-type)) + +(defmethod (setf documentation) + (new-value object &optional doc-type) + (declare (ignore new-value doc-type)) + (error "Can't change the documentation of ~S." object)) + +(defmethod documentation ((object documentation-mixin) + &optional doc-type) + (declare (ignore doc-type)) + (car (plist-value object 'documentation))) + +(defmethod (setf documentation) + (new-value (object documentation-mixin) + &optional doc-type) + (declare (ignore doc-type)) + (setf (plist-value object 'documentation) + new-value)) + +(defmethod documentation ((slotd standard-slot-definition) + &optional doc-type) + (declare (ignore doc-type)) + (slot-value slotd 'documentation)) + +(defmethod (setf documentation) + (new-value (slotd standard-slot-definition) + &optional doc-type) + (declare (ignore doc-type)) + (setf (slot-value slotd 'documentation) + new-value)) + +(defmethod documentation ((method standard-method) &optional doc-type) + (declare (ignore doc-type)) + (plist-value method 'documentation)) + +(defmethod (setf documentation) + (new-value (method standard-method) + &optional doc-type) + (declare (ignore doc-type)) + (setf (plist-value method 'documentation) new-value)) + +;;; Various class accessors that are a little more complicated than can be done with automatically +;;; generated reader methods. + + +(defmethod class-wrapper ((class clos-class)) + (with-slots (wrapper) + class + (let ((w? wrapper)) + (if (consp w?) + (let ((new (make-wrapper class))) + (setf (wrapper-instance-slots-layout new) + (car w?) + (wrapper-class-slots new) + (cdr w?)) + (setq wrapper new)) + w?)))) + +(defmethod class-precedence-list ((class clos-class)) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (with-slots (class-precedence-list) + class + class-precedence-list)) + +(defmethod class-finalized-p ((class clos-class)) + (with-slots (wrapper) + class + (not (null wrapper)))) + +(defmethod class-prototype ((class std-class)) + (with-slots (prototype) + class + (or prototype (setq prototype (allocate-instance class))))) + +(defmethod class-direct-default-initargs ((class std-class)) + (plist-value class 'direct-default-initargs)) + +(defmethod class-default-initargs ((class std-class)) + (plist-value class 'default-initargs)) + +(defmethod class-constructors ((class std-class)) + (plist-value class 'constructors)) + +(defmethod class-slot-cells ((class std-class)) + (plist-value class 'class-slot-cells)) + + +;;; Class accessors that are even a little bit more complicated than those above. These have a +;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses +;;; backpointers. The update methods are here, the values are read by an automatically generated +;;; reader method. + + +(defmethod add-direct-subclass ((class class) + (subclass class)) + (with-slots (direct-subclasses) + class + (pushnew subclass direct-subclasses) + subclass)) + +(defmethod remove-direct-subclass ((class class) + (subclass class)) + (with-slots (direct-subclasses) + class + (setq direct-subclasses (remove subclass direct-subclasses)) + subclass)) + + +;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic +;;; functions involved, each has one method for the class case and another method for the damned EQL +;;; specializers. All of these are specified methods and appear in their specified place in the +;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS +;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons. The car is +;;; the list methods. The cdr is a list of the generic functions. The cdr is always computed +;;; lazily. + + +(defmethod add-method-on-specializer ((method method) + (specializer class)) + (with-slots (direct-methods) + specializer + (setf (car direct-methods) + (adjoin method (car direct-methods)) + (cdr direct-methods) + nil)) + method) + +(defmethod remove-method-on-specializer ((method method) + (specializer class)) + (with-slots (direct-methods) + specializer + (setf (car direct-methods) + (remove method (car direct-methods)) + (cdr direct-methods) + nil)) + method) + +(defmethod specializer-methods ((specializer class)) + (with-slots (direct-methods) + specializer + (car direct-methods))) + +(defmethod specializer-generic-functions ((specializer class)) + (with-slots (direct-methods) + specializer + (or (cdr direct-methods) + (setf (cdr direct-methods) + (gathering1 (collecting-once) + (dolist (m (car direct-methods)) + (gather1 (method-generic-function m)))))))) + + +;;; This hash table is used to store the direct methods and direct generic functions of EQL +;;; specializers. Each value in the table is the cons. + + +(defvar *eql-specializer-methods* (make-hash-table :test #'eql)) + +(defmethod add-method-on-specializer ((method method) + (specializer eql-specializer)) + (let* ((object (eql-specializer-object specializer)) + (entry (gethash object *eql-specializer-methods*))) + (unless entry + (setq entry (setf (gethash object *eql-specializer-methods*) + (cons nil nil)))) + (setf (car entry) + (adjoin method (car entry)) + (cdr entry) + nil) + method)) + +(defmethod remove-method-on-specializer ((method method) + (specializer eql-specializer)) + (let* ((object (eql-specializer-object specializer)) + (entry (gethash object *eql-specializer-methods*))) + (when entry + (setf (car entry) + (remove method (car entry)) + (cdr entry) + nil)) + method)) + +(defmethod specializer-methods ((specializer eql-specializer)) + (car (gethash (eql-specializer-object specializer) + *eql-specializer-methods*))) + +(defmethod specializer-generic-functions ((specializer eql-specializer)) + (let* ((object (eql-specializer-object specializer)) + (entry (gethash object *eql-specializer-methods*))) + (when entry + (or (cdr entry) + (setf (cdr entry) + (gathering1 (collecting-once) + (dolist (m (car entry)) + (gather1 (method-generic-function m))))))))) + +(defun real-load-defclass (name metaclass-name supers slots other accessors) + (do-standard-defsetfs-for-defclass accessors) + ; *** + (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots + slots :definition-source `((defclass ,name () + ()) + ,(load-truename)) + other)) + +(defun ensure-class (name &rest all) + (apply #'ensure-class-using-class name (find-class name nil) + all)) + +(defmethod ensure-class-using-class (name (class null) + &rest args &key) + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (setf class (apply #'make-instance meta :name name initargs) + (find-class name) + class) + (inform-type-system-about-class class name) + ; *** + class)) + +(defmethod ensure-class-using-class (name (class clos-class) + &rest args &key) + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (unless (eq (class-of class) + meta) + (change-class class meta)) + (apply #'reinitialize-instance class initargs) + (inform-type-system-about-class class name) + ; *** + class)) + +(defun ensure-class-values (class args) + (let* ((initargs (copy-list args)) + (unsupplied (list 1)) + (supplied-meta (getf initargs :metaclass unsupplied)) + (supplied-supers (getf initargs :direct-superclasses unsupplied)) + (supplied-slots (getf initargs :direct-slots unsupplied)) + (meta (cond ((neq supplied-meta unsupplied) + (find-class supplied-meta)) + ((or (null class) + (forward-referenced-class-p class)) + *the-class-standard-class*) + (t (class-of class)))) + (proto (class-prototype meta))) + (flet ((fix-super (s) + (cond ((classp s) + s) + ((not (legal-class-name-p s)) + (error "~S is not a class or a legal class name." s)) + (t (or (find-class s nil) + (setf (find-class s) + (make-instance 'forward-referenced-class :name s))))))) + (loop (unless (remf initargs :metaclass) + (return))) + (loop (unless (remf initargs :direct-superclasses) + (return))) + (loop (unless (remf initargs :direct-slots) + (return))) + (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied) + (mapcar #'fix-super supplied-supers) + ) + :direct-slots + (and (neq supplied-slots unsupplied) + supplied-slots) + initargs))))) + + +;;; + + +(defmethod shared-initialize :before ((class std-class) + slot-names &key direct-superclasses) + (declare (ignore slot-names)) + + ;; *** error checking + ) + +(defmethod shared-initialize :after ((class std-class) + slot-names + &key (direct-superclasses + nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs + nil direct-default-initargs-p)) + (declare (ignore slot-names)) + (setq direct-superclasses (if direct-superclasses-p + (setf (slot-value class 'direct-superclasses) + (or direct-superclasses + (list *the-class-standard-object*) + )) + (slot-value class 'direct-superclasses))) + (setq direct-slots (if direct-slots-p + (setf (slot-value class 'direct-slots) + (mapcar #'(lambda (pl) + (make-direct-slotd class pl)) + direct-slots)) + (slot-value class 'direct-slots))) + (if direct-default-initargs-p + (setf (plist-value class 'direct-default-initargs) + direct-default-initargs) + (setq direct-default-initargs + (plist-value class 'direct-default-initargs))) + (setf (plist-value class 'class-slot-cells) + (gathering1 (collecting) + (dolist (dslotd direct-slots) + (when (eq (slotd-allocation dslotd) + class) + (let ((initfunction (slotd-initfunction dslotd))) + (gather1 (cons (slotd-name dslotd) + (if initfunction + (funcall initfunction) + *slot-unbound*)))))))) + (add-direct-subclasses class direct-superclasses) + (add-slot-accessors class direct-slots)) + +(defmethod reinitialize-instance :before ((class std-class) + &key direct-superclasses direct-slots + direct-default-initargs) + (declare (ignore direct-default-initargs)) + (remove-direct-subclasses class (class-direct-superclasses class)) + (remove-slot-accessors class (class-direct-slots class))) + +(defmethod reinitialize-instance :after ((class std-class) + &rest initargs &key) + (update-class class nil) + (map-dependents class #'(lambda (dependent) + (apply #'update-dependent class dependent initargs)))) + +(defun add-slot-accessors (class dslotds) + (fix-slot-accessors class dslotds 'add)) + +(defun remove-slot-accessors (class dslotds) + (fix-slot-accessors class dslotds 'remove)) + +(defun fix-slot-accessors (class dslotds add/remove) + (flet ((fix (gfspec name r/w) + (let ((gf (ensure-generic-function gfspec))) + (case r/w + (r (if (eq add/remove 'add) + (add-reader-method class gf name) + (remove-reader-method class gf))) + (w (if (eq add/remove 'add) + (add-writer-method class gf name) + (remove-writer-method class gf))))))) + (dolist (dslotd dslotds) + (let ((slot-name (slotd-name dslotd))) + (dolist (r (slotd-readers dslotd)) + (fix r slot-name 'r)) + (dolist (w (slotd-writers dslotd)) + (fix w slot-name 'w)))))) + +(defun add-direct-subclasses (class new) + (dolist (n new) + (unless (memq class (class-direct-subclasses class)) + (add-direct-subclass n class)))) + +(defun remove-direct-subclasses (class new) + (let ((old (class-direct-superclasses class))) + (dolist (o (set-difference old new)) + (remove-direct-subclass o class)))) + + +;;; + + +(defmethod finalize-inheritance ((class std-class)) + (update-class class t)) + + +;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may +;;; not be finalized. + + +(defun update-class (class finalizep) + (when (or finalizep (class-finalized-p class)) + (let* ((dsupers (class-direct-superclasses class)) + (dslotds (class-direct-slots class)) + (dinits (class-direct-default-initargs class)) + (cpl (compute-class-precedence-list class dsupers)) + (eslotds (compute-slots class cpl dslotds)) + (inits (compute-default-initargs class cpl dinits))) + (update-cpl class cpl) + (update-slots class cpl eslotds) + (update-dinits class dinits) + (update-inits class inits) + (update-constructors class))) + (unless finalizep + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil)))) + +(defun update-cpl (class cpl) + (when (class-finalized-p class) + (unless (equal (class-precedence-list class) + cpl) + (force-cache-flushes class))) + (setf (slot-value class 'class-precedence-list) + cpl)) + +(defun update-slots (class cpl eslotds) + (multiple-value-bind (nlayout nwrapper-class-slots) + (compute-storage-info cpl eslotds) + + ;; If there is a change in the shape of the instances then the old class is now obsolete. + (let* ((owrapper (class-wrapper class)) + (olayout (and owrapper (wrapper-instance-slots-layout owrapper))) + (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) + (nwrapper (cond ((null owrapper) + (make-wrapper class)) + ((and (equal nlayout olayout) + (not (iterate ((o (list-elements owrapper-class-slots)) + (n (list-elements nwrapper-class-slots))) + (unless (eq (car o) + (car n)) + (return t))))) + owrapper) + (t + + ;; This will initialize the new wrapper to have the same state as + ;; the old wrapper. We will then have to change that. This may + ;; seem like wasted work (it is), but the spec requires that we + ;; call make-instances-obsolete. + (make-instances-obsolete class) + (class-wrapper class))))) + (with-slots (wrapper no-of-instance-slots slots) + class + (setf no-of-instance-slots (length nlayout) + slots eslotds (wrapper-instance-slots-layout nwrapper) + nlayout + (wrapper-class-slots nwrapper) + nwrapper-class-slots wrapper nwrapper)) + (dolist (eslotd eslotds) + (setf (slotd-class eslotd) + class) + (setf (slotd-instance-index eslotd) + (instance-slot-index nwrapper (slotd-name eslotd))))))) + +(defun compute-storage-info (cpl eslotds) + (let ((instance nil) + (class nil)) + (dolist (eslotd eslotds) + (let ((alloc (slotd-allocation eslotd))) + (cond ((eq alloc :instance) + (push eslotd instance)) + ((classp alloc) + (push eslotd class))))) + (values (compute-layout cpl instance) + (compute-class-slots class)))) + +(defun compute-layout (cpl instance-eslotds) + (let* ((names (gathering1 (collecting) + (dolist (eslotd instance-eslotds) + (when (eq (slotd-allocation eslotd) + :instance) + (gather1 (slotd-name eslotd)))))) + (order nil)) + (labels ((rwalk (tail) + (when tail + (rwalk (cdr tail)) + (dolist (ss (class-slots (car tail))) + (let ((n (slotd-name ss))) + (when (memq n names) + (setq order (cons n order) + names + (remove n names)))))))) + (rwalk cpl) + (reverse (append names order))))) + +(defun compute-class-slots (eslotds) + (gathering1 (collecting) + (dolist (eslotd eslotds) + (gather1 (assoc (slotd-name eslotd) + (class-slot-cells (slotd-allocation eslotd))))))) +(defun update-dinits (class dinits) + (setf (plist-value class 'direct-default-initargs) + (remove-invalid dinits (class-slots class)))) + +(defun update-inits (class inits) + (setf (plist-value class 'default-initargs) + (remove-invalid inits (class-slots class)))) + +;; bug: :default-initargs aren't updated with slots are removed, so +;; update-inits removes initargs that don't have corresponding slots. + +(defun remove-invalid (inits slotds &aux (return nil)) + (dolist (element inits) + (dolist (slotd slotds) + (if (member (car element) (slot-value slotd 'initargs)) + (pushnew element return)))) + return) + + + +(defmethod compute-default-initargs ((class std-class) + cpl direct) + (labels ((walk (tail) + (if (null tail) + nil + (let ((c (pop tail))) + (append (if (eq c class) + direct + (class-direct-default-initargs c)) + (walk tail)))))) + (let ((initargs (walk cpl))) + (delete-duplicates initargs + :test #'eq :key #'car :from-end t)))) + + +;;; Protocols for constructing direct and effective slot definitions. + + +(defmethod direct-slot-definition-class ((class std-class) + initargs) + (declare (ignore initargs)) + (find-class 'standard-direct-slot-definition)) + +(defun make-direct-slotd (class initargs) + (let ((initargs (list* :class class initargs))) + (apply #'make-instance (direct-slot-definition-class class initargs) + initargs))) + + +;;; + + +(defmethod compute-slots ((class std-class) + cpl class-direct-slots) + + ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot + ;; name we find in our superclasses. Each call receives the class and a list of the dslotds + ;; with that name. The list is in most-specific-first order. + (let ((name-dslotds-alist nil)) + (labels ((collect-one-class (dslotds) + (dolist (d dslotds) + (let* ((name (slotd-name d)) + (entry (assq name name-dslotds-alist))) + (if entry + (push d (cdr entry)) + (push (list name d) + name-dslotds-alist)))))) + (collect-one-class class-direct-slots) + (dolist (c (cdr cpl)) + (collect-one-class (class-direct-slots c))) + (mapcar #'(lambda (direct) + (compute-effective-slot-definition class (nreverse (cdr direct))) + ) + name-dslotds-alist)))) + +(defmethod compute-effective-slot-definition ((class std-class) + dslotds) + (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) + (class (effective-slot-definition-class class initargs))) + (apply #'make-instance class initargs))) + +(defmethod effective-slot-definition-class ((class std-class) + initargs) + (declare (ignore initargs)) + (find-class 'standard-effective-slot-definition)) + +(defmethod compute-effective-slot-definition-initargs ((class std-class) + direct-slotds) + (let* ((name nil) + (initfunction nil) + (initform nil) + (initargs nil) + (allocation nil) + (type t) + (namep nil) + (initp nil) + (allocp nil)) + (dolist (slotd direct-slotds) + (when slotd + (unless namep + (setq name (slotd-name slotd) + namep t)) + (unless initp + (when (slotd-initfunction slotd) + (setq initform (slotd-initform slotd) + initfunction + (slotd-initfunction slotd) + initp t))) + (unless allocp + (setq allocation (slotd-allocation slotd) + allocp t)) + (setq initargs (append (slotd-initargs slotd) + initargs)) + (let ((slotd-type (slotd-type slotd))) + (setq type (cond ((null type) + slotd-type) + ((subtypep type slotd-type) + type) + (t `(and ,type ,slotd-type))))))) + (list :name name :initform initform :initfunction initfunction :initargs initargs + :allocation allocation :type type))) + + +;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object. +;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard +;;; methods. + + +(defmethod add-reader-method ((class std-class) + generic-function slot-name) + (let* ((name (class-name class)) + (method (make-a-method 'standard-reader-method nil (list (or name 'standard-object)) + (list class) + (make-reader-method-function class slot-name) + "automatically generated reader method" slot-name))) + (add-method generic-function method))) + +(defmethod add-writer-method ((class std-class) + generic-function slot-name) + (let* ((name (class-name class)) + (method (make-a-method 'standard-writer-method nil (list 'new-value (or name + + ' + standard-object + )) + (list *the-class-t* class) + (make-writer-method-function class slot-name) + "automatically generated writer method" slot-name))) + (add-method generic-function method))) + +(defmethod remove-reader-method ((class std-class) + generic-function) + (let ((method (get-method generic-function nil (list class) + nil))) + (when method (remove-method generic-function method)))) + +(defmethod remove-writer-method ((class std-class) + generic-function) + (let ((method (get-method generic-function nil (list *the-class-t* class) + nil))) + (when method (remove-method generic-function method)))) + + +;;; make-reader-method-function and make-write-method function are NOT part of the standard +;;; protocol. They are however useful, CLOS makes uses makes use of them internally and documents +;;; them for CLOS users. *** This needs work to make type testing by the writer functions which *** +;;; do type testing faster. The idea would be to have one constructor *** for each possible type +;;; test. In order to do this it would be nice *** to have help from inform-type-system-about-class +;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the +;;; simplistic use of the template has to be fixed. We *** have to give the optimize-slot-value +;;; method the user might have *** defined for this metclass a chance to run. + + +(defmethod make-reader-method-function ((class standard-class) + slot-name) + (make-std-reader-method-function slot-name)) + +(defmethod make-writer-method-function ((class standard-class) + slot-name) + (make-std-writer-method-function slot-name)) + +(defun make-std-reader-method-function (slot-name) + #'(lambda (instance) + (slot-value instance slot-name))) + +(defun make-std-writer-method-function (slot-name) + #'(lambda (nv instance) + (setf (slot-value instance slot-name) + nv))) + + ; inform-type-system-about-class + ; make-type-predicate + + + +;;; These are NOT part of the standard protocol. They are internal mechanism which CLOS uses to +;;; *try* and tell the type system about class definitions. In a more fully integrated +;;; implementation of CLOS, the type system would know about class objects and class names in a more +;;; fundamental way and the mechanism used to inform the type system about new classes would be +;;; different. + + +(defmethod inform-type-system-about-class ((class std-class) + name) + (let ((predicate-name (make-type-predicate-name name))) + (setf (symbol-function predicate-name) + (make-type-predicate name)) + (do-satisfies-deftype name predicate-name) + (setf (gethash name lisp::*typep-hash-table*) + predicate-name))) ;makes typep significantly faster... + +(defun make-type-predicate (name) + #'(lambda (x) + (not (null (memq (find-class name) + (cond ((std-instance-p x) + (class-precedence-list (std-instance-class x))) + ((fsc-instance-p x) + (class-precedence-list (fsc-instance-class x))))))))) + + +;;; These 4 definitions appear here for bootstrapping reasons. Logically, they should be in the +;;; construct file. For documentation purposes, a copy of these definitions appears in the +;;; construct file. If you change one of the definitions here, be sure to change the copy there. + + +(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs + #'allocate-instance #'initialize-instance + #'shared-initialize)) + +(defmethod maybe-update-constructors ((generic-function generic-function) + (method method)) + (when (memq generic-function *initialization-generic-functions*) + (labels ((recurse (class) + (update-constructors class) + (dolist (subclass (class-direct-subclasses class)) + (recurse subclass)))) + (when (classp (car (method-specializers method))) + (recurse (car (method-specializers method))))))) + +(defmethod update-constructors ((class std-class)) + (dolist (cons (class-constructors class)) + (install-lazy-constructor-installer cons))) + +(defmethod update-constructors ((class class)) + nil) + +(defmethod compatible-meta-class-change-p (class proto-new-class) + (eq (class-of class) + (class-of proto-new-class))) + +(defmethod check-super-metaclass-compatibility ((class t) + (new-super t)) + (unless (eq (class-of class) + (class-of new-super)) + (error "The class ~S was specified as a~%super-class of the class ~S;~%~ + but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super) + (class-of class)))) + + +;;; + + +(defun force-cache-flushes (class) + (let* ((owrapper (class-wrapper class)) + (state (wrapper-state owrapper))) + + ;; We only need to do something if the state is still T. If the state isn't T, it will + ;; be FLUSH or OBSOLETE, and both of those will already be doing what we want. In + ;; particular, we must be sure we never change an OBSOLETE into a FLUSH since OBSOLETE + ;; means do what FLUSH does and then some. + (when (eq state 't) + (let ((nwrapper (make-wrapper class))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (without-interrupts (setf (slot-value class 'wrapper) + nwrapper) + (invalidate-wrapper owrapper 'flush nwrapper)) + (update-constructors class))))) + + ; ??? *** + + +(defun flush-cache-trap (owrapper nwrapper instance) + (declare (ignore owrapper)) + (set-wrapper instance nwrapper)) + + +;;; make-instances-obsolete can be called by user code. It will cause the next access to the +;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class +;;; mechanism. + + +(defmethod make-instances-obsolete ((class std-class)) + (let ((owrapper (class-wrapper class)) + (nwrapper (make-wrapper class))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (without-interrupts (setf (slot-value class 'wrapper) + nwrapper) + (invalidate-wrapper owrapper 'obsolete nwrapper) + class))) + +(defmethod make-instances-obsolete ((class symbol)) + (make-instances-obsolete (find-class class))) + + +;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance. +;;; The times when it is called are: - when the instance is involved in method lookup - when +;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of +;;; the low-level instance access macros. Of course these times when it is called are an internal +;;; implementation detail of CLOS and are not part of the documented description of when the obsolete +;;; instance update happens. The documented description is as it appears in 88-002R. This has to +;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to +;;; return the new wrapper. It also does a little internal error checking to make sure that the +;;; traps are only happening when they should, and that the trap methods are computing apropriate +;;; new wrappers. + + +(defun obsolete-instance-trap (owrapper nwrapper instance) + + ;; local --> local transfer local --> shared discard local --> -- + ;; discard shared --> local transfer shared --> shared discard shared --> -- + ;; discard -- --> local add -- --> shared -- + (let* ((class (wrapper-class nwrapper)) + (guts (allocate-instance class)) + ; ??? allocate-instance ??? + (olayout (wrapper-instance-slots-layout owrapper)) + (nlayout (wrapper-instance-slots-layout nwrapper)) + (oslots (get-slots instance)) + (nslots (get-slots guts)) + (oclass-slots (wrapper-class-slots owrapper)) + (added nil) + (discarded nil) + (plist nil)) + + ;; Go through all the old local slots. + (iterate ((name (list-elements olayout)) + (opos (interval :from 0))) + (let ((npos (posq name nlayout))) + (if npos + (setf (svref nslots npos) + (svref oslots opos)) + (progn (push name discarded) + (unless (eq (svref oslots opos) + *slot-unbound*) + (setf (getf plist name) + (svref oslots opos))))))) + + ;; Go through all the old shared slots. + (iterate ((oclass-slot-and-val (list-elements oclass-slots))) + (let ((name (car oclass-slot-and-val)) + (val (cdr oclass-slot-and-val))) + (let ((npos (posq name nlayout))) + (if npos + (setf (svref nslots npos) + (cdr oclass-slot-and-val)) + (progn (push name discarded) + (unless (eq val *slot-unbound*) + (setf (getf plist name) + val))))))) + + ;; Go through all the new local slots to compute the added slots. + (dolist (nlocal nlayout) + (unless (or (memq nlocal olayout) + (assq nlocal oclass-slots)) + (push nlocal added))) + (without-interrupts (set-wrapper instance nwrapper) + (set-slots instance nslots)) + (update-instance-for-redefined-class instance added discarded plist) + nwrapper)) + + +;;; + + +(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc) + `(let* ((old-class (class-of instance)) + (copy (,alloc old-class)) + (guts (,alloc new-class)) + (new-wrapper (,wrapper-fetcher guts)) + (old-wrapper (class-wrapper old-class)) + (old-layout (wrapper-instance-slots-layout old-wrapper)) + (new-layout (wrapper-instance-slots-layout new-wrapper)) + (old-slots (,slots-fetcher instance)) + (new-slots (,slots-fetcher guts)) + (old-class-slots (wrapper-class-slots old-wrapper))) + + ;; "The values of local slots specified by both the class Cto and Cfrom are retained. + ;; If such a local slot was unbound, it remains unbound." + (iterate ((new-slot (list-elements new-layout)) + (new-position (interval :from 0))) + (let ((old-position (position new-slot old-layout :test #'eq))) + (when old-position + (setf (svref new-slots new-position) + (svref old-slots old-position))))) + + ;; "The values of slots specified as shared in the class Cfrom and as local in the + ;; class Cto are retained." + (iterate ((slot-and-val (list-elements old-class-slots))) + (let ((position (position (car slot-and-val) + new-layout :test #'eq))) + (when position + (setf (svref new-slots position) + (cdr slot-and-val))))) + + ;; Make the copy point to the old instance's storage, and make the old instance point + ;; to the new storage. + (without-interrupts (setf (,slots-fetcher copy) + old-slots) + (setf (,wrapper-fetcher instance) + new-wrapper) + (setf (,slots-fetcher instance) + new-slots)) + (update-instance-for-different-class copy instance) + instance)) + +(defmethod change-class ((instance standard-object) + (new-class standard-class)) + (unless (std-instance-p instance) + (error "Can't change the class of ~S to ~S~@ + because it isn't already an instance with metaclass~%~S." instance new-class + 'standard-class)) + (change-class-internal std-instance-wrapper std-instance-slots allocate-instance)) + +(defmethod change-class ((instance standard-object) + (new-class funcallable-standard-class)) + (unless (fsc-instance-p instance) + (error "Can't change the class of ~S to ~S~@ + because it isn't already an instance with metaclass~%~S." instance new-class + 'funcallable-standard-class)) + (change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance)) + +(defmethod change-class ((instance t) + (new-class-name symbol)) + (change-class instance (find-class new-class-name))) + + +;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature. By this point, +;;; all instances of it which will exist have been created, and no instance is ever created by +;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those +;;; definitions appear here. + + +(defmethod shared-initialize :before ((class built-in-class) + slot-names &rest initargs) + (declare (ignore slot-names)) + (error "Attempt to initialize or reinitialize a built in class.")) + +(defmethod class-direct-slots ((class built-in-class)) + nil) + +(defmethod class-slots ((class built-in-class)) + nil) + +(defmethod class-direct-default-initargs ((class built-in-class)) + nil) + +(defmethod class-default-initargs ((class built-in-class)) + nil) + +(defmethod check-super-metaclass-compatibility ((c class) + (s built-in-class)) + (or (eq s *the-class-t*) + (error "~S cannot have ~S as a super.~%~ + The class ~S is the only built in class that can be a~%~ + superclass of a standard class." c s *the-class-t*))) + + +;;; + + +(defmethod check-super-metaclass-compatibility ((c std-class) + (f forward-referenced-class)) + 't) + + +;;; + + +(defmethod add-dependent ((metaobject dependent-update-mixin) + dependent) + (pushnew dependent (plist-value metaobject 'dependents))) + +(defmethod remove-dependent ((metaobject dependent-update-mixin) + dependent) + (setf (plist-value metaobject 'dependents) + (delete dependent (plist-value metaobject 'dependents)))) + +(defmethod map-dependents ((metaobject dependent-update-mixin) + function) + (dolist (dependent (plist-value metaobject 'dependents)) + (funcall function dependent))) diff --git a/clos/3.5/vector.dfasl b/clos/3.5/vector.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..c33ac4f124b2cb8c5e358e466b90dc05ad5cb76c GIT binary patch literal 12305 zcmb_idvILUdB6AWLs~u7D`}DCwXp@*0*u!nV+fek*}J<}-mAU4cfGrkCG$`fBXVW0 zACYZn(sp9=2$XC?BZxTyiv?)rYl>aWgiQ($e|d z#-X%6veD3UnT;{S%x#PfWwU^9d~jmhzTH!63zK{I+|}QnYnXZ4)WrC{iTiu=`zQ9^ zKmN5fz3Xo49o)ZbqPPFfJNwu4_OIV?%N-kT{lePz0X1g`VyZ(1rY3pB`ri1&wuzlz z2Kno5S$7Kt-ML}?Z5!6#y0(4ph0@bf+gBv~^U+U0Dis6$z590W2^S_FoG1{ZJE^1e z7scj*p>!;-o9WVF`GD*#JymSc)8UL7ORAeRSuPzax{0UKbgAeb%4u0idLFRQ#2@V$ z-*tajPv`P#I;MqlhM7kzu8lAz4|!U;FQSadrxS`i!^G^SHMw@NAKeOt@PEB)knuyI z`32$dUqG^3T#}^NGDt5SR!YUTl`B(fENg}b%xtPu?5Z}k^st^a({xr+^PON((KfF~ z;og$a(l>yetG8s;Oh(Jj=O-67)KPONZ~LwTj*?5;zU3I@jhi^?{1TeLFwIO56;ISK zW62iOT!xl+ryPoap{HX5812fKIomhDa2L>8vs!*An+^|T&6FLqd%lDoyK|8kXZJ`F z9bsR6FIs5pD)lz+Nh<;AaF@lk0p`5-A_qc9yhjI=-qO)xQ)Vci$(or~)Vp$8ejx1Z znIi}8Zge!O*-dFRrR6$6d)GxKwS8W@MYgY(m-5axIU86i`dAWZEDK79BPgr%oDq(x zv4m#(z*&$5gW1uYAJl1?^sYlWb=`mC2mG_0yy`e+5js zuZT$^>@%1Yw0rHmY~Q<($)$}aSySII89CUjOKR)*74Yl1Jbtg9f2a#+yd>*EKHmk{ zq_^X;y?x;>G^f<07KRox%i#!nPX1|hVGJ1LUwtsr?xD3|xpu)3$&Mp}F<7)_NM|>Wm!qYa*k4PimOXLqY%5F*5}lu7xvMJ*8$x z!QI9#1RaT+Mu8{FJxFIAJ@VRtJ$nND*HeHkcho&yg#10|c^EtW2>u$j*)^GV%Zic75R-EebC6VpyPz#_tx zRyHFzz+vbq*9x>e+U6nE2q92(=e1nEjk%jfT!?tGbEvG6Jv9 zVp*Uxvdn}WS;@uG4lbVda`B971(&4|7q;N!1?Gey&+_jJES=p#Lq$|eu}sw%J_B94 zHFC;2ZOvG-i5KPH5XeKU_HtA@Quv4Ch!2+NxSWfGZJzHx>%O8%*HxODe8a(^3i?)gdDv&J7R6!YOQ_Nugdb zQ%@+|we^av9>Z5^0oc~)7pPe+gPK0nI6TiFuMMvrn!z|L4_ zlMFs*jrl9->GZ*JLLT!oXe>~P9ySBYK{GJcSus212v2%^soAMG_2*DkWS!v;TL-Ko zrau)rn^w-1Po$1Nlv1XxKuR{mZ2rThzdT;0i0L|)#u^qTx5k3_>#mrAzcxF|tIdEc z#sJb;GJ|G!9}u1}yRFbzkZ1`g7+5}!A0ug*0ahC(f}D)xYJ-h$TOBoVWybY6uR)|) zJ>G1SC70uJUF2$M9~-Y!rJ|Q_Y?)TtRu2@}g*MeCOxZ$#L{$#Sj+`gpfS!(v6R~{+ z{0>I7<%A316C>aOVD>o19Os!0<2r2UF>)Dnj{DHP@)F%cIX%6pe&iN&@`KG7(IsdJ zHw;8PxsjIIq`{x*v6>HZ$VN9sO0An9uXV`hlZ*cKm2;IpKyBV3vP6)^of|e|pgD>6%pP)uBQ4IvlY;{^s*{# zogSpRfL0w-fVcJy{{4ACZcGkQ^oe*CiH#iTfxMoPUZv{IIN!w_DIo`x8iGn9x^rSl zRvP(QMt+@;mvHr$f5OF^Ulm0ZGjt=l5le=v(K|#?kL&qS+jj#r&aEN5>SE;gASBO= zNf1qR3D3?pFXFHvI)T;@>o!4+wGl0+v~%wP3ctLDmfn<4$W8G30oE54Nfr~g3nV2) z?As&Q8V+AhnEn3zrJXRF*L_?#`X|KfZO+XxBhoKmr+a?JPakZE-aowjY@JLgH4kTZ zE;A+OhhB=57!wDMYDutp86A&9yND7$6zqLMmqR2JmCP{5IM{jC)~=YE4%eKX8jEQ; zaYJ4v&M(Rb2$wT*B%v;o0}=Y+m`WxW+hE&iPm!U_BD~hKS{w=2EW%7gys-B!kujK+{t-Fb|au}*wafBxs+sA?&OeE?vmRVFrrLZb;KG@D2+si?et9~{4dOGb+havfNl zq7H@b)|Jp1-B?md2CC@Mi=s1-lm-84gBZv^ah?%Z3*3b*hN!$?8ws`}Vx7oFG~U>q zGi#wuznR&ce}F!g3cB6^p4PU6*=w?6Jce6AixyLJT6jPO`J{zfHfv_vP-{jmn|*T& zZP`l@fQBVRkZ}aS*0r@c*9z!UcK6qLyKnp|O}Kf;%xe?C^w-3OskD9fGS;#v7prdv zN_!23xUqd}xhv=<3SNb-il!L0z1m*QR3JTK4h%rbK*e3PE=FA&EEQMkyY@{??HVui zPE1YV0cdhp@7}`heZ9N)?3>&<`StOAle>4Vr7&E&seT;1_pI!f%*l7GTkznrmyXIw z#ILef2JDsYr66#T(B*JmLui6vkO^z<=He!{O7d-NmE<+Z-ye2SsOHUT8BNU#RNT3^ z($&hv9c-zBj%8l3Z6d^wUU97SR(W<%xko;0DDpXGj`^yyS+CLK42iVW@IG@%WD%Nh zx6lKgXN#Z5H$WJiT7>zcOpEP{kcnCtJ}n|3ZaMsELYSR4hm5(=99#_Kgx~LLDkL(S z{0_}gn22YG#jT{8==>`^kdV(93httmhq0hJsTb4b6)BmNC|x31??cBoN#w`;=WrP< z|N8~`&>0a4e-o15aIq0ln@leoZG86<_iE5VwDLhei32hmigwPOP9XO>I6Zi<`~~@L z1sNh^+BjJ5lh5iqestgIlu}I<9rzaXT+w@=>gUS8F_bgq9}g-s<$t8d4HBOxn=eI2 zOU}%Sn6#0Kr$EK+wcIan$vv{6?2@DvY#D+QAAaZpzTXk+J%#Y>LcZyX0ynKE$&0bT zRS}U|Qbpm2Q>hp%jPLyN{o@p!)QQ6evFb@8?}`hHtl}@~qNuwqm(NmW#=spVL)WNQ zC+R~0pHTbfFachRjur#L`r{trWRFQk{AwKclHqXeQsLw$QX-JO{uFb~m-5pBMD|i> z4yDH}98H1`V>^U|(r6+vF?di-BC`plh`6ldBH_3&Igo@+I;FYv9Ma|G#-TPGP1jT%X|4UEjudM6=7 z@Q2j`5?+=L6$7g|AqMYD2c~AKG0t}|py7hk>Lk>nW_%R)Qe^0I`HNp7IX`$8W?qcM z84?jl(PG+gbrpJLBNd>?x^)0v9~lEe5YT==+q9IPr_+zuz#>QaKDnAXQXuIO`gtFc zg>W=w4r|o>uD$;&tX+}280Wp^{Cb&2RwA~}Pg2MU2_cH@7$J88=tfR%H8q5rQE8_C z0TrILNZL5@*hf5Vn!3*O)X!4&?K<==t|kcjCRbmhYQ^rR;?FQ!M=ga{wZbBxJHXhl zU&UFJ>SroWY^VT8nIpPr$Tv`g0;;Otu^?U)Pp$y+dnhii=yu+1X~be0;rPd6R1wY@ zIYQwxk5fh5c4{yrB^6r)dNtVJ6D(He>Q~hXR4nLUjjKa`)Ja%DcJK({o7`InZyVoc zO*l666?(cNl9rOe8i@oYHKGxvCjcjzjVvwj?&MoJf3l0=IZwdS`t-p zBme#mfs^CnZ!|2^&a^q{OgKV*Rh7TjMPvV)(O6G^0}W}1CCVUuAa;Nd{*#!1`AF%M zAtT7oNWHWXSQWuC1s)md_#sdi0kxVqtq=KU4DlFhR5J)~me>4OsvhGiZ^(;vN?zdV z+l26KuCf6j&A;k`PbKP$Jc>o!M9Vj*LUwFF5B`C;+5PYVZvD%s050d^Z3(Hjqeb66 znS3@eluoV}+Wamp{SV~Dp%f5mC`u&pmb;p>D%C&jpk;E%2y!6nxNkhxwh&p^A8;&F z9M{=+1YsV;VG$GY?id&U_PqTdmh2JnktNbr?@SgH5t2&wgCMFQ?pXNj?CQiqJ=JeY z*t9idBgvRRs$%#&ATMH#Ut>B74?1vU0^7hFU_Lwmp8`6X1s#qq{c`@=-n5~o!8iqb z0fhhjd|Dq)Gc!-;g{_k2Cbob0@(zpjwqi|Or!>BdBx)}s)8#+7;9+FCd}HIg$nhoB zSCI-{987=T%ws0<5qOU2G$cUaz8mY;;^-1lRJEY48^uhKf z5Gt{majueM0oi%>3-YT<5SL4OKS|Efi{}`HC?3!TK%VFaJxm^~5t z?#Aqn&__6g^pbdxtW@pMdH?)t1YQRDEd$5Wm&G?3&Z7n=<37g5whUx7t@=R`N#yhP zekz{fKHaE&he^OEXuqYSU*qD}lU)2f#l?THuae%omRs*NQ6WD{PgK$)T*u*3T8sdX z)h(^aPFmutUCXi>;^TJSvxbb>=ZZ@o!gkzx>7<+M8`uE9VXAR_ZZsf5DcdIu-fypG zj(+RApKxk%0zbgozWV^|&Z=8rsHqE|J3DsWggqZcXZ^*nI_(`i-$(1v*-q{u7e=xL z4@4Ls(mx;bi@*F4eZRV>YWiw8;)46J_aW?W6Yni?x3qorf=uUOtf*Hi<&K2)sZsq|z}r_kTmQxW@nh literal 0 HcmV?d00001 diff --git a/clos/3.5/vector.lisp b/clos/3.5/vector.lisp new file mode 100644 index 00000000..5f613f84 --- /dev/null +++ b/clos/3.5/vector.lisp @@ -0,0 +1,368 @@ +;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; +;;; Permutation vectors. +;;; + +(in-package 'clos) + +(defmacro instance-slot-index (wrapper slot-name) + `(let ((pos 0)) + (block loop + (dolist (sn (wrapper-instance-slots-layout ,wrapper)) + (when (eq ,slot-name sn) (return-from loop pos)) + (incf pos))))) + + +;;; +;;; +;;; +(defmacro %isl-cache (isl) `(%svref ,isl 1)) +(defmacro %isl-field (isl) `(%svref ,isl 2)) +(defmacro %isl-mask (isl) `(%svref ,isl 3)) +(defmacro %isl-size (isl) `(%svref ,isl 4)) +(defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5)) + +(defun make-isl (slot-name-lists) + (multiple-value-bind (mask size) + (compute-primary-pv-cache-size slot-name-lists) + (make-isl-internal (wrapper-field 'number) + (get-cache size) + mask + size + slot-name-lists))) + +(defun make-isl-internal (field cache mask size slot-name-lists) + (let ((isl (make-array 6))) + (setf (svref isl 0) 'isl + (%isl-cache isl) cache + (%isl-field isl) field + (%isl-mask isl) mask + (%isl-size isl) size + (%isl-slot-name-lists isl) slot-name-lists) + isl)) + +(defun make-isl-type-declaration (var) + `(type simple-vector ,var)) + +(defun islp (x) + (and (simple-vector-p x) + (= (array-dimension x 0) 5) + (eq (svref x 0) 'isl))) + +(defvar *slot-name-lists-inner* (make-hash-table :test #'equal)) +(defvar *slot-name-lists-outer* (make-hash-table :test #'equal)) + +(defun intern-slot-name-lists (slot-name-lists) + (flet ((inner (x) + (or (gethash x *slot-name-lists-inner*) + (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) + (outer (x) + (or (gethash x *slot-name-lists-outer*) + (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x)))))) + (outer (mapcar #'inner slot-name-lists)))) + + + +(defvar *pvs* (make-hash-table :test #'equal)) + +(defvar default-svuc-method nil) +(defvar default-setf-svuc-method nil) + +(defun optimize-slot-value-by-class-p (class slot-name setf-p) + (or (not (eq *boot-state* 'complete)) + (let* ((slot-definition (find-slot-definition class slot-name)) + (gfun-name (if setf-p + '(setf slot-value-using-class) 'slot-value-using-class)) + (gfun (gdefinition gfun-name)) + (csym (if setf-p 'default-setf-svuc-method 'default-svuc-method)) + (app-methods nil)) + (dolist (method (generic-function-methods gfun)) + (let* ((mspecs (method-specializers method)) + (specs (if setf-p (cdr mspecs) mspecs))) + (when (and (specializer-applicable-p (first specs) class) + (specializer-applicable-using-class-p (second specs) class) + (specializer-applicable-p (third specs) slot-definition)) + (push method app-methods)))) + (and app-methods (null (cdr app-methods)) + (eq (car app-methods) + (or (symbol-value csym) + (let* ((specs (if setf-p + '(t + std-class + standard-object + standard-effective-slot-definition) + '(std-class + standard-object + standard-effective-slot-definition))) + (slist (mapcar #'find-class specs))) + (set csym (get-method gfun nil slist))))))))) + +(defun lookup-pv (isl args) + (let* ((class-slot-p nil) + (elements + (gathering1 (collecting) + (iterate ((slot-names (list-elements (%isl-slot-name-lists isl))) + (arg (list-elements args))) + (when slot-names + (let* ((wrapper (check-wrapper-validity arg)) + (class (wrapper-class wrapper)) + (class-slots (wrapper-class-slots wrapper))) + (dolist (slot-name slot-names) + (if (and (optimize-slot-value-by-class-p + class slot-name nil) + (optimize-slot-value-by-class-p + class slot-name t)) + (let ((index (instance-slot-index wrapper slot-name))) + (if index + (gather1 index) + (let ((cell (assq slot-name class-slots))) + (if cell + (progn (setq class-slot-p t) (gather1 cell)) + (gather1 nil))))) + (gather1 nil))))))))) + (if class-slot-p ;Sure is a shame Common Lisp doesn't + (make-permutation-vector elements) ;give me the right kind of hash table. + (or (gethash elements *pvs*) + (setf (gethash elements *pvs*) (make-permutation-vector elements)))))) + +(defun make-permutation-vector (indexes) + (make-array (length indexes) :initial-contents indexes)) + +(defun make-pv-type-declaration (var) + `(type simple-vector ,var)) + +(defmacro pvref (pv index) + `(svref ,pv ,index)) + + + +(defun can-optimize-access (var required-parameters env) + (let ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))) + (if rebound? + (car (memq rebound? required-parameters)) + (car (memq var required-parameters))))) + +(defun optimize-slot-value (slots parameter form) + (destructuring-bind (ignore ignore slot-name) + form + (optimize-instance-access slots :read parameter (eval slot-name) nil))) + +(defun optimize-set-slot-value (slots parameter form) + (destructuring-bind (ignore ignore slot-name new-value) + form + (optimize-instance-access slots :write parameter (eval slot-name) new-value))) + +;;; +;;; The argument is an alist, the CAR of each entry is the name of +;;; a required parameter to the function. The alist is in order, so the +;;; position of an entry in the alist corresponds to the argument's position +;;; in the lambda list. +;;; +(defun optimize-instance-access (slots read/write parameter slot-name new-value) + (let* ((parameter-entry (assq parameter slots)) + (slot-entry (assq slot-name (cdr parameter-entry))) + (position (position parameter-entry slots))) + (unless parameter-entry + (error "Internal error in slot optimization.")) + (unless slot-entry + (setq slot-entry (list slot-name)) + (push slot-entry (cdr parameter-entry))) + (ecase read/write + (:read + (let ((form (list 'instance-read ''.PV-OFFSET. parameter position + `',slot-name))) + (push form (cdr slot-entry)) + form)) + (:write + (let ((form (list 'instance-write ''.PV-OFFSET. parameter position + `',slot-name '.new-value.))) + (push form (cdr slot-entry)) + `(let ((.new-value. ,new-value)) ,form)))))) + +(define-walker-template instance-read) +(define-walker-template instance-write) + + +(defmacro instance-read (pv-offset parameter position slot-name) + `(locally + (declare (optimize (speed 3) (safety 0) (compilation-speed 0))) + (let ((.INDEX. (pvref .PV. ,pv-offset))) + (if (and (typep .INDEX. 'fixnum) + (neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.)) + ',*slot-unbound*)) + .INDEX. + (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name))))) + +(defmacro instance-write (pv-offset parameter position slot-name new-value) + `(locally + (declare (optimize (speed 3) (safety 0) (compilation-speed 0))) + (let ((.INDEX. (pvref .PV. ,pv-offset))) + (if (typep .INDEX. 'fixnum) + (setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value) + (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value))))) + +(defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp)) + ;; + ;; First thing we do is a quick check to see if this is a class variable. + ;; This could be done inline by moving it to INSTANCE-READ/WRITE. I did + ;; not do that because I don't know whether its worth it. + ;; + (let ((cell (pvref pv offset))) + (if (consp cell) + (if nvp (setf (cdr cell) new-value) (cdr cell)) + ;; + ;; Well, now do a slow trap. + ;; + (if nvp + (setf (slot-value instance slot-name) new-value) + (slot-value instance slot-name))))) + +;;; +;;; This magic function has quite a job to do indeed. +;;; +;;; The careful reader will recall that contains all of the optimized +;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is +;;; a call to either INSTANCE-READ or INSTANCE-WRITE. +;;; +;;; At the time these calls were produced, the first argument was specified as +;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset +;;; arguments into the actual number that is the correct offset into the pv. +;;; +;;; But first, oh but first, we sort a bit so that for each argument +;;; we have the slots in alphabetical order. This canonicalizes the ISL's a +;;; bit and will hopefully lead to having fewer PV's floating around. Even +;;; if the gain is only modest, it costs nothing. +;;; +(defun slot-name-lists-from-slots (slots) + (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry))) + (mutate-slots slots))) + +(defun mutate-slots (slots) + (let ((sorted (sort-slots slots)) + (pv-offset -1)) + (dolist (parameter-entry sorted) + (dolist (slot-entry (cdr parameter-entry)) + (incf pv-offset) + (dolist (form (cdr slot-entry)) + (setf (cadr form) pv-offset)))) + sorted)) + +(defun sort-slots (slots) + (mapcar #'(lambda (parameter-entry) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'(lambda (a b) + (string-lessp (symbol-name (car a)) + (symbol-name (car b))))))) + slots)) + + +;;; +;;; This needs to work in terms of metatypes and also needs to work for +;;; automatically generated reader and writer functions. +;;; +(defun add-pv-binding (method-body plist required-parameters) + (let* ((isl (getf plist :isl)) + (isl-cache-symbol (make-symbol "isl-cache"))) + (nconc plist (list :isl-cache-symbol isl-cache-symbol)) + (with-gathering ((slot-variables (collecting)) + (metatypes (collecting))) + (iterate ((slots (list-elements isl)) + (i (interval :from 0))) + (cond (slots + (gather (slot-vector-symbol i) slot-variables) + (gather 'standard-instance metatypes)) + (t + (gather nil slot-variables) + (gather t metatypes)))) + `((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol)) + (.PV. *empty-vector*) + ,@(remove nil slot-variables)) + (declare ,(make-isl-type-declaration '.ISL.) + ,(make-pv-type-declaration '.PV.)) + + (let* ((cache (%isl-cache .ISL.)) + (size (%isl-size .ISL.)) + (mask (%isl-mask .ISL.)) + (field (%isl-field .ISL.))) + ,(generating-lap-in-lisp '(cache size mask field) + required-parameters + (flatten-lap + (emit-pv-dlap required-parameters metatypes slot-variables)))) + + ,@method-body))))) + +(defun emit-pv-dlap (required-parameters metatypes slot-variables) + (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv))) + slot-variables)) + (wrappers (dlap-wrappers metatypes)) + (nwrappers (remove nil wrappers))) + (flet ((wrapper-moves (miss-label) + (dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs))) + (prog1 (emit-dlap-internal + nwrappers ;wrapper-regs + (wrapper-moves 'pv-miss) ;wrapper-moves + (opcode :exit-lap-in-lisp) ;hit + (flatten-lap ;miss + (opcode :label 'pv-miss) + (opcode :move + (operand :lisp `(primary-pv-cache-miss + .ISL. ,@required-parameters)) + (operand :lisp-variable '.PV.)) + (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed. + (opcode :label 'pv-wrapper-miss) + (opcode :exit-lap-in-lisp)) + 'pv-miss ;miss-label + (operand :lisp-variable '.PV.)) ;value-reg + (mapc #'deallocate-register nwrappers))))) + +(defun compute-primary-pv-cache-size (slot-name-lists) + (compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists)) + t + 2)) + +(defun pv-cache-limit-fn (nlines) + (default-limit-fn nlines)) + +(defun primary-pv-cache-miss (isl &rest args) + (let* ((wrappers + (gathering1 (collecting) + (iterate ((slot-names (list-elements (%isl-slot-name-lists isl))) + (arg (list-elements args))) + (when slot-names (gather1 (check-wrapper-validity arg)))))) + (pv (lookup-pv isl args)) + (field (%isl-field isl)) + (cache (%isl-cache isl)) + (nkeys (length wrappers))) + (multiple-value-bind (new-field new-cache new-mask new-size) + (fill-cache field cache nkeys t #'pv-cache-limit-fn + (if (= nkeys 1) (car wrappers) wrappers) + pv) + (when (or (not (= new-field field)) + (not (eq new-cache cache))) + (without-interrupts ;NOTE: + (setf (%isl-field isl) new-field ; There is no mechanism to + (%isl-cache isl) new-cache ; synchronize the reading of + (%isl-size isl) new-size ; these values. But, this is + (%isl-mask isl) new-mask)) ; a safe order to write them + ; in. Stricly speaking, the + ; use of without-interrupts + ; is superfluous. + (when (neq new-cache cache) (free-cache cache)))) + pv)) + + + +(defmethod wrapper-fetcher ((class standard-class)) + 'std-instance-wrapper) + +(defmethod slots-fetcher ((class standard-class)) + 'std-instance-slots) + +(defmethod raw-instance-allocator ((class standard-class)) + '%%allocate-instance--class) diff --git a/clos/3.5/walk.dfasl b/clos/3.5/walk.dfasl new file mode 100644 index 0000000000000000000000000000000000000000..2973507f98d4aed67639751ab5205cc3426ceffa GIT binary patch literal 19597 zcmc(H4RBOfcILZJzknnfA@d`C+y)Fb(BjA7G1!LJf1+Dzb<1iA1jfdV)TRZk7Socz z%#0m@!LySnjs?b}=dnpVnH@WmvPL7%RK%|;PHGE6WoNUS?Cex_ma3_(WT(8lR?Spp zE0Y>~zjMxe-LHiZ@}@SS(7X5DpL5SW_ndRjJ@>pG(#qTY5x2jm`*>G6nRWN{_Z{!= zbHCV=b@%r4XFHPa7g6s1Y9QYD@>6ZS$!zbgM7BS3GMVm3?dm;tsx#YlBDt%xr=!0+ znd$4@)t~8lX;-?d_xP@kbWiWDj{a;G<-1NM(#Ptk_{lAmaR=OvY%~y#GCwn^+ zr#8B`Zg)5IXOiwMJ9cc@=-#qz=jI(dH*cw{toOzvf{NXxKHJ4Twz&hzj%4>?Ais6< z*3Ibj*v>7F?|f`qUFGNR4!@;U9MSM^4n17j@StmpyRYZCC!IWzOw%;Gsbctz!SedH zsJ}HFiw<8<1FCfR_Xg*Nqn>83ztOuVsMPTJ!P0%+NMo>NcxZUAxGf%R(KH6%LjYz5 zZ>k*7(qMaYtff^0#0%vBx+oB=4@ZL@f$eDxHZ@1Qtw9>Z9`F3%9IExy$6A`q3iNSB zgYnj2fcxZ2tM__a!d_n_=!pc|!+vkX)6A{&+28-9{ zS_Fdrh_}T{%c z7P!|H4%eFM>UAfxS(40DPk*}8odFL+VmlyY?vtrx24i<+j_@?5>)YMa+viSq9ZLdB zOSXGn1X4M$$Rymyvpq+$iEaSw>PWf!vR%nu(7F&6&>r~COfy=b!~I=Av#YPy-E%Ty zFIP{tj=AI^UZhUXzHn>E<89m16pRv62cvt#EwL!QF}w5{db`@Mu7vex)wM?bxf`iN zRTC`IO>>EN4pm)4v9JvfF0@}AxE4i+FAi2T2KVoawFDr>@zyO= z0NDkJa~{u_p`~v_!oTv!WFms5laAUB3a!sg#G0KY;8UTbSZ14CKs* z&9$tD*79`t;g}@9^UUWFu}A@~hQ?uV?t9}wZAB<`H>Oe6+}7IM5^J7^{K9y!wccZq z!%~^Wi%?PSZP^p`HU;AgFvr?^!!|2Q&E?9hQ_F@g6b%oqdn6j%N2~6RMR@hyYe6q} zZkBGD`lBF6$y#45upio&673yxHM9wogm&BbGeUSQ0aKPRPW1M^xto%2n7dy#7r$hxthu|{-2H@UEH;&n(P%#A z(;91l8V95t`YiNYWDVXmyv)l?<4Kpb%nNNgd)HYNDbUT2Q5_;HbkpmjYA!}4oIUlt zDK(oa^0+>O8O_?MnNA)3fk2D>QW|e<2}k!>a0vWsFhtR+ocSAL(iqgM z9(kmt5w9;8i9b!|>UMfOMEZs-s@@vXLj9SJK3FEbUu?(OP`KmF$g{vPxAT}A=9wFd z7nvT~QC9JeGGkxbS)Nhm32SHBaM#Xa&w3M0cazMO_w+~2&G~I5fo&z2Joc+Mlj)*g znQ1*;BpYfnt^f4stqCTQhs|X^ zEyVZZP|&12Xj*O)T)Bq_=LPz^yHB}!6eK1dKGvM(xxTG4};&r<97<5arw`p_x*)1QpeS7fSa8qfl=PC@UKvoo&lu&f!QG zZc-IIoo~{4lr%w^bq17D=9hBXJR>oGBXNeBV>Gik0AX44Z*tQ=(3GYuF2~u8wqI3b zHh|3UaQ*A(O5}SpdGuHBA4`cuF(p>&KPpSXaC&LcFCL+p9Rh(ZggP_Gxk+8P@DtyRfmT{XJRhZIMncJ%%!WQp~zXJx{6f|MbA-A zSG>32kpk})&5`K}rgKz*%$8b47$lG^Q&>Bdv^Y80B%53ca6ZRNh4ZkC_XYNG+&(eK z^@CxDORhHz9fVNZVuQQlGpfvz% zRnju%5M>y11%_?|`RKktTm-~9L54HWf|CO@eqTTjFjHBMiX3GaT7?ZQ2k!cP!MUQb z)}RwHhP24bVg_3u3tkJ8O%E@z=lZc;psMCMCS|d2A^B=}1bZz>IbmnzQI2`SpDBxyBSFzFbLj(& z#CSO;*ERLT@Sx|FxEnqUa<3%Z*<{DDo+FvAufVTzB9ZN4pH648Bb~@5$cBLv!dw8F zFK2aPc=@0>)HRSIr7RqXRagLJI_)axi_GeBvqo7|AvISGXqCpF>bEooxenc{3mLam z>`V>r#fyWkscttB)794QyeHUdZvwVc(BU1xP&H)KTeb&NGPeu=qLAfgVG0vQFhVh= zf;nkz1trh4L8zcP=3ASQjR)L(YYYOK*_L7}5`%Z%}8MjINBmlum6kokCan1~d&=^V$bm9G+QADCSY>3YWI^-g+j~q^I6+$FYm5^A+MyT5Lpt*DjNVJhq2*bS| zB*U3~+0cN^!DxW&=(|{4-wfL0JVa+K*^ejn-NS=R{fW%FKKGGipSv&FeLRiZ3wGPS z65oNPU<|7HS(IN1wty5Vn=%N?w!X%aRc8y_afR6}j|p=~)s4#X_DE%~NR zXj+5{YUxAEGOMM)d^+EdyasxJ=kQ3rbTvw=+M@el!Fn)YYtY|HkQU}!RG|gz)Rx#j zRH)B#73v>p)<nugSDZ@$?x(=@Z^<;^#H3e9S!K%>RpLf|&$+pU`h z9By(W)NDEMuN3_0E(#tjq4?r__iFPfwJbwRVKp=o{(+ktHO$1?Z_G86|0P-pli8rO z|CMj_Kg{Q;(a+Fm9uI1J8>#faOZHU_?7$Q5K&>G-}lkQs-@SrhcA@K zt2HWh%yrQSGj+~6o|x!d{w$SSC&^qF#dDL6^)@CdJPp__cCAb}2Z8%)mkRLIzCo`< zVUi@X;!v({;T*Ly?pzH|$N_a8)#O)92!OzVm9 zV{jRN7cS$=zndD*Xxf9ki`HnDL#Yt&$6+?v_;JPHk_LW(omf?Lm-D!oV?bbCJ1^me zr#PgFpTT6SnQN)JGy@8W8ssZ4arMiHmkCrdX;^D@8Ru}X?nKXtdiY( zgjrepNVeK@n%-g2;6e(HlGN4IHN)#m7Xhy-cBMS0E;s4wz|d%0*qEe~&~qOJ!+a1L zdn&BB$gtdSffAQbzjiK+tM1WnB2A%3Ou~Um~wM zAv{$RJTJ<+CdM{~Zn@~3{`;r~&xB~2D5?S!yyHnl97chBaSDITlBi_~VW$llY=NhHTZF0He<0p(~&NaOuS1;)%oh1ZmwfHkic(rm*q{pC^r?u?G!9c~Qf{WB@lS zD-3M7yn=Z9`OxS_E5HAIc+_p>;l&)SvGUIjHNIwL-x1ToFHo#P_|?vOX(mHCu=i?b z!x>x1?mBcZd={`2BjjcA6Ahp-&s~Buv^an5ZRx0-S8%GjA}LabXze&A!c*@J^Qota zfsq_2KEtv|C>esK;|jzLmND!O>%j3N8J@)8dy=EYsepHp;K~cBpBV(8e*ef{a`-f&wrZi%}m;g;U z$(t2Va+95NIVqwWS9M_c0>4_O@>2qjpFiZMSS6nh@QWNTsyY7xEL?){eMrwr!#DXh znARVVMK-*|rGZKgYO|c0-v>4&){?`5x_imz#9L#{RuE;OrHCWU`N0)4EDl8i$gD15 z6v1l(cqNRn=M4YkSgr4EWu8F_xdo2pdfBZ73PAX!*eGN zmroSP>vwE_?F0rbwWfv(;k&0cUw9}Vz&&{H$(HP5vW~FLttK|`+a+PMOD=P%rsfR~ z9^99r!21;RTbiPJv&rKKmEY-zW_D;_gy*&-GSJu1t-T0ur|4aD?(OSJr%8)T=bS2) z09+T7+rpbJ8Q3Ae${1S-f{9c!eLynaWrbKaMQ(#4j+-%yB6ROxB>X<|0MF|-A2n1) zSYKh0WbsC@c*~*d*sz5v`nsX}IDf(Gt94N%B(dHIy!no3NY##m1%jvO89)HOT$w@q zDW-Bi+b{xmlzzy8cIiWC6+Dz85FfZGvGFbUOb`UL4AF*E@C|*D?&{vEw(Cr4AT?HFgh-ycSkeTc5N#;fdCrC8#>R?w#f{BaM@YvJr*Ww9^k_gGRM%k{ z--zfsPA5(Ks#lDyXo~un&kniH$6N!^SXFJU6ij?QVr3$MT8L<)es%PU3=Iv$`?EFp z*ft*j;84UGf9#=f68VoradZE&SL%{*V(rcXerFCx= z2Z`{(O?@&)<#a(A)=q+w5$Gp}Ub_6M2*msz3BL0*)2rkA30#d)q%-xZB>nwQyvUzW z_J4AAgtGrxjK06(lCM+AzvC=-k$sKZiJi#3e}@`qAJan|G9Q20ba@1%?46&?AuChx zYF6y;QoC(|+yyq9&pK3$p9xzAcLAV-rz}Y?)Zg$q!lS#-+Y;qZH~hg&M^AsIFPViE zDVOd^H`$x?g$6Fo@L3T)SimO}iCisx+Cew>xUo&rM;W4{#KR1c%n3M6??0r*4cKwF z4AstOgvUZJpj2DF|9xwTCoJyxmQ^v7I)m#&C!5MK`YZmoLs)aJ7~NomLJDEMtolUA z5HZ4a#O03emqUuiHABkc%ij(um~+g%2>jOBJp5=GMV(MP7K!iCo7E&-aBpdA)Xy9i z6SmJXYt~aOCE~BD0CZJLn;-tbaCA>IA3<))`Qi$5!A&BQL}qbTc;n_*g&R(A@>!ab zJDr?lnx#|x!AfGGOlAVpA}e|vtF5lN=1G;KD^j6IZD5JN|hNM>lk`MkW*1)W?#|?Z zz3*&ge*R>mxx<}X8!M(OPNwD@b9FH_(Oy^Uxan<+pAZQpAD#S=yhiO_xFZWDM6)?S zLVvMgh&Rb+$Cet{w(+0;^fgL6MxzT2m6CG1i1$RxU3bW(4pmQ3@ZzDGiCDFdypck;O@<0<+s6xgbOtI*MTk%mxa# z<*fKY!c0Z$%Me7*qc#84dS&~yL_LN@xbG%FJozTmCsWpEKA++2&JN;`I&2A;uP4yf z)U?0Ota#o`^ASaRSB@z74Cr}wo1JEFHgk>M_7&%gwV7-J#rkZ)_t95gw{&EaD9ZX^Ne>N5hGCZdY=9&S4FK>uAIZJK2kK5N)c_lLW zJ1+>ka72K*wA5T(Lj_Q2to^hzDvs$ql=G27I8!nnV`hEtM3TB{ilk1t$tJ})OOe&( zlzV$VVWQJEtj8G3mkPY|+eKt)?~WT|F&smT5GmDnLYHj|FFd+d%r$>t$TuKb#WvSq zpV^icS#E`g1k2pgx9bJoigH{1!`{km9cA>r2{et<1}oT38X5T!zSq#VvwUhd#SL^v zHjWINM%qnGRVLMlNqLR2r!grnB#!3=Z{G4yScMTEtLrQjmQl*e26NC0+<^8J8ZiZj zCU;ChLN;;Az|z1%j5{YlXY^w6J&bJQb!dE)r*UTuCzmv}0=!RogrhOi>PtZS=_$%n z^u?91S9a*D@QNAPA!tRs%F@pd%T#?7t1#2Jw3@n{=tnphTKDBx%?H36jj=}vHlIW;vML&|hM6*+ z%~jO@ej^qMtBgEIbJKl`c#0WSMXC0wZF?IS{}`)F+^&(jWM{%HO;@%fV4XThay=Xg z*IrIF)L!|$h(Zo0b7mtH&^GcDXeRtu_|sLmp-^Kot(-h&%#z27l8p477x-E*5UV4z zd@nN|*k0`g?(=Cx+$iaC%LGlhY>Fmy27f>Wii?TvhX&Lf1`qz!a1{r#r~-3DZTlt$ zAZq=4dq0^-rDWH2*vC9OsAD0Wp`PUhoP>kpH8GJXbQTx4sq2xU$m!9zdXC9=ZS->(HJu*a2Db}n3#Us&2+ZKI>w?ft`t{NOnqu7}#tqYS!WWi!gsaS-O0FLv89 zy)HNDBPH}Q&P{H&n@4w;-F0SK%+L3EW4}N~QQGY0_$cjnDe&YVvJoBjc_tp0&0>ZfhCx^A--$sI2q7{Nx4 zJ2^=x48#-@vWXl$Jxea)qsgBzQP?Lomd}33S!SsBg`rGgC^@rym^BmK zX0n);Tn;q1qvp{~X7?I=_eq6_9dar8SlB3e<)zICri46JKQA zMeKRqKN3RGx{Yv_*ZsS)?q|)_;{E#YkeN7Ot@(T0?Dmu9(dB0M0<8Io+!2dj+SZ)H|;;Xf_qz5K>bqN5{u9KR~lm&zvLL(U$NAD`OjKGoCDzr-Uyg!4*Z zrT~L*AAKx_p8%pCvPtx@hmw8=3!x5figoC9_x2yBUjssQSMNsrm<^nj(_g>25zAnG zc{T&~7z)3csAKbUe%e# zrJqoGsV|$zQ_2lzyA&nU_#q#B6o=pQ>8-o>{DLR&^Fm$LuLWW3lc3lPL()1Bdhq{t e%BomDS@dGpOSDM29~Yy!)@g4OBmBkZpZ{ODq!_UP literal 0 HcmV?d00001 diff --git a/clos/3.5/walk.lisp b/clos/3.5/walk.lisp new file mode 100644 index 00000000..2172c050 --- /dev/null +++ b/clos/3.5/walk.lisp @@ -0,0 +1,2005 @@ +;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1991 Venue +;;; All rights reserved. +;;; ************************************************************************* +;;; +;;; A simple code walker, based IN PART on: (roll the credits) +;;; Larry Masinter's Masterscope +;;; Moon's Common Lisp code walker +;;; Gary Drescher's code walker +;;; Larry Masinter's simple code walker +;;; . +;;; . +;;; boy, thats fair (I hope). +;;; +;;; For now at least, this code walker really only does what CLOS needs it to +;;; do. Maybe it will grow up someday. +;;; + +;;; +;;; This code walker used to be completely portable. Now it is just "Real +;;; easy to port". This change had to happen because the hack that made it +;;; completely portable kept breaking in different releases of different +;;; Common Lisps, and in addition it never worked entirely anyways. So, +;;; its now easy to port. To port this walker, all you have to write is one +;;; simple macro and two simple functions. These macros and functions are +;;; used by the walker to manipluate the macroexpansion environments of +;;; the Common Lisp it is running in. +;;; +;;; The code which implements the macroexpansion environment manipulation +;;; mechanisms is in the first part of the file, the real walker follows it. +;;; + +(in-package 'walker) + +;;; +;;; The user entry points are walk-form and nested-walked-form. In addition, +;;; it is legal for user code to call the variable information functions: +;;; variable-lexical-p, variable-special-p and variable-class. Some users +;;; will need to call define-walker-template, they will have to figure that +;;; out for themselves. +;;; +(export '(define-walker-template + walk-form + nested-walk-form + variable-lexical-p + variable-special-p + variable-globally-special-p + *variable-declarations* + variable-declaration + )) + + + +;;; +;;; On the following pages are implementations of the implementation specific +;;; environment hacking functions for each of the implementations this walker +;;; has been ported to. If you add a new one, so this walker can run in a new +;;; implementation of Common Lisp, please send the changes back to us so that +;;; others can also use this walker in that implementation of Common Lisp. +;;; +;;; This code just hacks 'macroexpansion environments'. That is, it is only +;;; concerned with the function binding of symbols in the environment. The +;;; walker needs to be able to tell if the symbol names a lexical macro or +;;; function, and it needs to be able to build environments which contain +;;; lexical macro or function bindings. It must be able, when walking a +;;; macrolet, flet or labels form to construct an environment which reflects +;;; the bindings created by that form. Note that the environment created +;;; does NOT have to be sufficient to evaluate the body, merely to walk its +;;; body. This means that definitions do not have to be supplied for lexical +;;; functions, only the fact that that function is bound is important. For +;;; macros, the macroexpansion function must be supplied. +;;; +;;; This code is organized in a way that lets it work in implementations that +;;; stack cons their environments. That is reflected in the fact that the +;;; only operation that lets a user build a new environment is a with-body +;;; macro which executes its body with the specified symbol bound to the new +;;; environment. No code in this walker or in CLOS will hold a pointer to +;;; these environments after the body returns. Other user code is free to do +;;; so in implementations where it works, but that code is not considered +;;; portable. +;;; +;;; There are 3 environment hacking tools. One macro which is used for +;;; creating new environments, and two functions which are used to access the +;;; bindings of existing environments. +;;; +;;; WITH-AUGMENTED-ENVIRONMENT +;;; +;;; ENVIRONMENT-FUNCTION +;;; +;;; ENVIRONMENT-MACRO +;;; + +(defun unbound-lexical-function (&rest args) + (declare (ignore args)) + (error "The evaluator was called to evaluate a form in a macroexpansion~%~ + environment constructed by the CLOS portable code walker. These~%~ + environments are only useful for macroexpansion, they cannot be~%~ + used for evaluation.~%~ + This error should never occur when using CLOS.~%~ + This most likely source of this error is a program which tries to~%~ + to use the CLOS portable code walker to build its own evaluator.")) + + +;;; +;;; In Coral Common Lisp, the macroexpansion environment is just a list +;;; of environment entries. The cadr of each element specifies the type +;;; of the element. The only types that interest us are CCL::MACRO and +;;; FUNCTION. In these cases the element is interpreted as follows. +;;; +;;; ( CCL::MACRO . macroexpansion-function) +;;; +;;; ( FUNCTION . ) +;;; +;;; When in the compiler, is a gensym which will be +;;; a variable which bound at run-time to the function. +;;; When in the interpreter, is the actual function. +;;; +;;; +#+:Coral +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +(defun with-augmented-environment-internal (env functions macros) + (dolist (f functions) + (push (list* f 'function (gensym)) env)) + (dolist (m macros) + (push (list* (car m) 'ccl::macro (cadr m)) env)) + env) + +(defun environment-function (env fn) + (let ((entry (assoc fn env :test #'equal))) + (and entry + (eq (cadr entry) 'function) + (cddr entry)))) + +(defun environment-macro (env macro) + (let ((entry (assoc macro env :test #'equal))) + (and entry + (eq (cadr entry) 'ccl::macro) + (cddr entry)))) + +);#+:Coral + + +;;; +;;; Franz Common Lisp is a lot like Coral Lisp. The macroexpansion +;;; environment is just a list of entries. The cadr of each element +;;; specifies the type of the element. The types that interest us +;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE. These +;;; are interpreted as follows: +;;; +;;; ( FUNCTION . ) +;;; +;;; This happens in the interpreter with lexically +;;; bound functions. +;;; +;;; ( COMPILER::FUNCTION-VALUE . ) +;;; +;;; This happens in the compiler. The gensym represents +;;; a variable which will be bound at run time to the +;;; function object. +;;; +;;; ( EXCL::MACRO . ) +;;; +;;; In both interpreter and compiler, this is the +;;; representation used for macro definitions. +;;; +;;; +#+:ExCL +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +(defun with-augmented-environment-internal (env functions macros) + (dolist (f functions) + (push (list* f 'function #'unbound-lexical-function) env)) + (dolist (m macros) + (push (list* (car m) 'excl::macro (cadr m)) env)) + env) + +(defun environment-function (env fn) + (let ((entry (assoc fn env :test #'equal))) + (and entry + (or (eq (cadr entry) 'function) + (eq (cadr entry) 'compiler::function-value)) + (cddr entry)))) + +(defun environment-macro (env macro) + (let ((entry (assoc macro env :test #'equal))) + (and entry + (eq (cadr entry) 'excl::macro) + (cddr entry)))) + +);#+:ExCL + + +#+Lucid +(progn + +(proclaim '(inline + %alphalex-p + add-contour-to-env-shape + make-function-variable + make-sfc-contour + sfc-contour-type + sfc-contour-elements + add-sfc-contour + add-function-contour + add-macrolet-contour + find-variable-in-contour + find-alist-element-in-contour + find-macrolet-in-contour)) + +(defun %alphalex-p (object) + #-Prime + (eq (cadddr (cddddr object)) 'lucid::%alphalex) + #+Prime + (eq (caddr (cddddr object)) 'lucid::%alphalex)) + +#+Prime +(defun lucid::augment-lexenv-fvars-dummy (lexical vars) + (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '())) + +(defconstant function-contour 1) +(defconstant macrolet-contour 5) + +(defstruct lucid::contour + type + elements) + +(defun add-contour-to-env-shape (contour-type elements env-shape) + (cons (make-contour :type contour-type + :elements elements) + env-shape)) + +(defstruct (variable (:constructor make-variable (name source-type))) + name + (identifier nil) + source-type) + +(defconstant function-sfc-contour 1) +(defconstant macrolet-sfc-contour 8) +(defconstant function-variable-type 1) + +(defun make-function-variable (name) + (make-variable name function-variable-type)) + +(defun make-sfc-contour (type elements) + (cons type elements)) + +(defun sfc-contour-type (sfc-contour) + (car sfc-contour)) + +(defun sfc-contour-elements (sfc-contour) + (cdr sfc-contour)) + +(defun add-sfc-contour (element-list environment type) + (cons (make-sfc-contour type element-list) environment)) + +(defun add-function-contour (variable-list environment) + (add-sfc-contour variable-list environment function-sfc-contour)) + +(defun add-macrolet-contour (alist environment) + (add-sfc-contour alist environment macrolet-sfc-contour)) + +(defun find-variable-in-contour (name contour) + (dolist (element (sfc-contour-elements contour) nil) + (when (eq (variable-name element) name) + (return element)))) + +(defun find-alist-element-in-contour (name contour) + (cdr (assoc name (sfc-contour-elements contour)))) + +(defun find-macrolet-in-contour (name contour) + (find-alist-element-in-contour name contour)) + +(defmacro do-sfc-contours ((contour-var environment &optional result) + &body body) + `(dolist (,contour-var ,environment ,result) ,@body)) + + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let* ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +;;; +;;; with-augmented-environment-internal is where the real work of augmenting +;;; the environment happens. +;;; +(defun with-augmented-environment-internal (env functions macros) + (let ((function-names (mapcar #'first functions)) + (macro-names (mapcar #'first macros)) + (macro-functions (mapcar #'second macros))) + (cond ((or (null env) + (contour-p (first env))) + (when function-names + (setq env (add-contour-to-env-shape function-contour + function-names + env))) + (when macro-names + (setq env (add-contour-to-env-shape macrolet-contour + (pairlis macro-names + macro-functions) + env)))) + ((%alphalex-p env) + (when function-names + (setq env (lucid::augment-lexenv-fvars-dummy env function-names))) + (when macro-names + (setq env (lucid::augment-lexenv-mvars env + macro-names + macro-functions)))) + (t + (when function-names + (setq env (add-function-contour + (mapcar #'make-function-variable function-names) + env))) + (when macro-names + (setq env (add-macrolet-contour + (pairlis macro-names macro-functions) + env))))) + env)) + + +(defun environment-function (env fn) + (cond ((null env) nil) + ((contour-p (first env)) + (if (lucid::find-lexical-function fn env) + t + nil)) + ((%alphalex-p env) + (if (lucid::lexenv-fvar fn env) + t + nil)) + (t (do-sfc-contours (contour env nil) + (let ((type (sfc-contour-type contour))) + (cond ((eql type function-sfc-contour) + (when (find-variable-in-contour fn contour) + (return t))) + ((eql type macrolet-sfc-contour) + (when (find-macrolet-in-contour fn contour) + (return nil))))))))) + +(defun environment-macro (env macro) + (cond ((null env) nil) + ((contour-p (first env)) + (lucid::find-lexical-macro macro env)) + ((%alphalex-p env) + (lucid::lexenv-mvar macro env)) + (t (do-sfc-contours (contour env nil) + (let ((type (sfc-contour-type contour))) + (cond ((eql type function-sfc-contour) + (when (find-variable-in-contour macro contour) + (return nil))) + ((eql type macrolet-sfc-contour) + (let ((fn (find-macrolet-in-contour macro contour))) + (when fn + (return fn)))))))))) + + +);#+Lucid + + + +;;; +;;; On the 3600, the documentation for how the environments are represented +;;; is in sys:sys;eval.lisp. That total information is not repeated here. +;;; The important points are that: +;;; si:env-variables returns a list of which each element is: +;;; +;;; (symbol value) +;;; or (symbol . locative) +;;; +;;; The first form is for lexical variables, the second for +;;; special and instance variables. In either case CADR of +;;; the entry is the value and SETF of CADR is used to change +;;; the value. Variables are looked up with ASSQ. +;;; +;;; si:env-functions returns a list of which each element is: +;;; +;;; (symbol definition) +;;; +;;; where definition is anything that could go in a function cell. +;;; This is used for both local functions and local macros. +;;; +;;; The 3600 stack conses its environments (at least in the interpreter). +;;; This means that code written using this walker and running on the 3600 +;;; must not hold on to the environment after the walk-function returns. +;;; No code in this walker or in CLOS does that. +;;; +#+Genera +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + (let ((funs (make-symbol "FNS")) + (macs (make-symbol "MACROS")) + (new (make-symbol "NEW"))) + `(let ((,funs ,functions) + (,macs ,macros) + (,new ())) + (dolist (f ,funs) + (push `(,(car f) ,#'unbound-lexical-function) ,new)) + (dolist (m ,macs) + (push `(,(car m) (special ,(cadr m))) ,new)) + (let* ((.old-env. ,old-env) + (.old-vars. (pop .old-env.)) + (.old-funs. (pop .old-env.)) + (.old-blks. (pop .old-env.)) + (.old-tags. (pop .old-env.)) + (.old-dcls. (pop .old-env.))) + (si:with-interpreter-environment (,new-env + .old-env. + .old-vars. + (append ,new .old-funs.) + .old-blks. + .old-tags. + .old-dcls.) + ,@body))))) + + +(defun environment-function (env fn) + (if (null env) + (values nil nil) + (let ((entry (assoc fn (si:env-functions env) :test #'equal))) + (if (and entry + (or (not (listp (cadr entry))) + (not (eq (caadr entry) 'special)))) + (values (cadr entry) t) + (environment-function (si:env-parent env) fn))))) + +(defun environment-macro (env macro) + (if (null env) + (values nil nil) + (let ((entry (assoc macro (si:env-functions env) :test #'equal))) + (if (and entry + (listp (cadr entry)) + (eq (caadr entry) 'special)) + (values (cadadr entry) t) + (environment-macro (si:env-parent env) macro))))) + +);#+Genera + +#+Cloe-Runtime +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) + ,@body)) + +(defun with-augmented-environment-internal (env functions macros) + functions + (dolist (m macros) + (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env))) + env) + +(defun environment-function (env fn) + nil) + +(defun environment-macro (env macro) + (let ((entry (getf env macro))) + (if (and (consp entry) + (eq (car entry) 'compiler::macro)) + (values (cdr entry) t) + (values nil nil)))) + +);#+Cloe-Runtime + + +;;; +;;; In Xerox Lisp, the compiler and interpreter use different structures for +;;; the environment. This doesn't cause a serious problem, the parts of the +;;; environments we are concerned with are fairly similar. +;;; +#+:Xerox +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let* ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +;;; +;;; with-augmented-environment-internal is where the real work of augmenting +;;; the environment happens. Before it gets there, env had better not be NIL +;;; anymore because we have to know what kind of environment we are supposed +;;; to be building up. This is probably never a real concern in practice. +;;; It better not be because we don't do anything about it. +;;; +(defun with-augmented-environment-internal (env functions macros) + (cond + ((compiler::env-p env) + (dolist (f functions) + (setq env (compiler::copy-env-with-function + env f :function))) + (dolist (m macros) + (setq env (compiler::copy-env-with-function + env (car m) :macro (cadr m))))) + (t (setq env (if (il:environment-p env) + (il:\\copy-environment env) + (il:\\make-environment))) + ;; The functions field of the environment is a plist of function names + ;; and conses like (:function . fn) or (:macro . expansion-fn). + ;; Note that we can't smash existing entries in this plist since these + ;; are likely shared with older environments. + (dolist (f functions) + (setf (il:environment-functions env) + (list* f (cons :function #'unbound-lexical-function) + (il:environment-functions env)))) + (dolist (m macros) + (setf (il:environment-functions env) + (list* (car m) (cons :macro (cadr m)) + (il:environment-functions env)))))) + env) + +(defun environment-function (env fn) + (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function)) + ((il:environment-p env) (eq (getf (il:environment-functions env) fn) + :function)) + (t nil))) + +(defun environment-macro (env macro) + (cond ((compiler::env-p env) + (multiple-value-bind (type def) + (compiler:env-fboundp env macro) + (when (eq type :macro) def))) + ((il:environment-p env) + (xcl:destructuring-bind (type . def) + (getf (il:environment-functions env) macro) + (when (eq type :macro) def))) + (t nil))) + +);#+:Xerox + + +;;; +;;; In IBUKI Common Lisp, the macroexpansion environment is a three element +;;; list. The second element describes lexical functions and macros. The +;;; function entries in this list have the form +;;; ( . (FUNCTION . ( . nil)) +;;; The macro entries have the form +;;; ( . (MACRO . ( . nil)). +;;; +;;; +#+(or KCL IBCL) +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +(defun with-augmented-environment-internal (env functions macros) + (let ((first (first env)) + (lexicals (second env)) + (third (third env))) + (dolist (f functions) + (push `(,(car f) . (function . (,#'unbound-lexical-function . nil))) + lexicals)) + (dolist (m macros) + (push `(,(car m) . (macro . ( ,(cadr m) . nil))) + lexicals)) + (list first lexicals third))) + +(defun environment-function (env fn) + (when env + (let ((entry (assoc fn (second env)))) + (and entry + (eq (cadr entry) 'function) + (caddr entry))))) + +(defun environment-macro (env macro) + (when env + (let ((entry (assoc macro (second env)))) + (and entry + (eq (cadr entry) 'macro) + (caddr entry))))) +);#+(or KCL IBCL) + + +;;; --- TI Explorer -- + +;;; An environment is a two element list, whose car we can ignore and +;;; whose cadr is list of the local-definitions-frames. Each +;;; local-definitions-frame holds either macros or functions, but not +;;; both. Each frame is a plist of ... where +;;; is a locative to the function cell of the symbol that names +;;; the function or macro, and is the new def or NIL if this is function +;;; redefinition or (cons 'ticl:macro ) if this is a macro +;;; redefinition. +;;; +;;; Here's an example. For the form: +;;; (defun foo () +;;; (macrolet ((bar (a b) (list a b)) +;;; (bar2 (a b) (list a b))) +;;; (flet ((some-local-fn (c d) (print (list c d))) +;;; (another (c d) (print (list c d)))) +;;; (bar (some-local-fn 1 2) 3)))) + +;;; the environment arg to macroexpand-1 when called on +;;; (bar (some-local-fn 1 2) 3) +;;;is +;;;(NIL ((# NIL +;;; # NIL) +;;; (# +;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B))) +;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) +;;; (BLOCK BAR ....)) +;;; # +;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B))) +;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) +;;; (BLOCK BAR2 ....)))) +#+TI +(progn + +;;; from sys:site;macros.lisp +(eval-when (compile load eval) + +(DEFMACRO MACRO-DEF? (thing) + `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO))) + +;; the following macro generates code to check the 'local' environment +;; for a macro definition for THE SYMBOL . Such a definition would +;; be set up only by a MACROLET. If a macro definition for is +;; found, its expander function is returned. + +(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment) + `(IF ,local-function-environment + (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name)))) + (DOLIST (frame ,local-function-environment) + ;; is nil or a locative + (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame) + vcell))) + (When value (RETURN (CAR value)))))) + nil))) + + +;;;Edited by Reed Hastings 13 Jan 88 16:29 +(defun environment-macro (env macro) + "returns what macro-function would, ie. the expansion function" + ;;some code picked off macroexpand-1 + (let* ((local-definitions (cadr env)) + (local-def (find-local-definition macro local-definitions))) + (if (macro-def? local-def) + (cdr local-def)))) + +;;;Edited by Reed Hastings 13 Jan 88 16:29 +;;;Edited by Reed Hastings 7 Mar 88 19:07 +(defun environment-function (env fn) + (let* ((local-definitions (cadr env))) + (dolist (frame local-definitions) + (let ((val (getf frame + (ticl::locf (symbol-function fn)) + :not-found-marker))) + (cond ((eq val :not-found-marker)) + ((functionp val) (return t)) + ((and (listp val) + (eq (car val) 'ticl::macro)) + (return nil)) + (t + (error "we are confused"))))))) + + +;;;Edited by Reed Hastings 13 Jan 88 16:29 +;;;Edited by Reed Hastings 7 Mar 88 19:07 +(defun with-augmented-environment-internal (env functions macros) + (let ((local-definitions (cadr env)) + (new-local-fns-frame + (mapcan #'(lambda (fn) + (list (ticl:locf (symbol-function (car fn))) + #'unbound-lexical-function)) + functions)) + (new-local-macros-frame + (mapcan #'(lambda (m) + (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m)))) + macros))) + (when new-local-fns-frame + (push new-local-fns-frame local-definitions)) + (when new-local-macros-frame + (push new-local-macros-frame local-definitions)) + `(,(car env) ,local-definitions))) + + +;;;Edited by Reed Hastings 7 Mar 88 19:07 +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +);#+TI + + +#+(and dec vax common) +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +(defun with-augmented-environment-internal (env functions macros) + #'(lambda (op &optional (arg nil arg-p)) + (cond ((eq op :macro-function) + (unless arg-p (error "Invalid environment use.")) + (lookup-macro-function arg env functions macros)) + (arg-p + (error "Invalid environment operation: ~S ~S" op arg)) + (t + (lookup-macro-function op env functions macros))))) + +(defun lookup-macro-function (name env fns macros) + (let ((m (assoc name macros))) + (cond (m (cadr m)) + ((assoc name fns) :function) + (env (funcall env name)) + (t nil)))) + +(defun environment-macro (env macro) + (let ((m (and env (funcall env macro)))) + (and (not (eq m :function)) + m))) + +;;; Nobody calls environment-function. What would it return, anyway? +);#+(and dec vax common) + + +;;; +;;; In Golden Common Lisp, the macroexpansion environment is just a list +;;; of environment entries. Unless the car of the list is :compiler-menv +;;; it is an interpreted environment. The cadr of each element specifies +;;; the type of the element. The only types that interest us are GCL:MACRO +;;; and FUNCTION. In these cases the element is interpreted as follows. +;;; +;;; Compiled: +;;; ( macroexpansion-function) +;;; ( ) +;;; +;;; Interpreted: +;;; ( GCL:MACRO macroexpansion-function) +;;; ( ) +;;; +;;; When in the compiler, is a gensym which will be +;;; a variable which bound at run-time to the function. +;;; When in the interpreter, is the actual function. +;;; +;;; +#+gclisp +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) + +(defun with-augmented-environment-internal (env functions macros) + (let ((new-entries nil)) + (dolist (f functions) + (push (cons (car f) nil) new-entries)) + (dolist (m macros) + (push (cons (car m) + (if (eq :compiler-menv (car env)) + (if (eq (caadr m) 'lisp::lambda) + `(,(gensym) ,(cadr m)) + `(,(gensym) ,@(cadr m))) + `(gclisp:MACRO ,@(cadr m)))) + new-entries)) + (if (eq :compiler-menv (car env)) + `(:compiler-menv ,@new-entries ,@(cdr env)) + (append new-entries env)))) + +(defun environment-function (env fn) + (let ((entry (lisp::lexical-function fn env))) + (and entry + (eq entry 'lisp::lexical-function) + fn))) + +(defun environment-macro (env macro) + (let ((entry (assoc macro (if (eq :compiler-menv (first env)) + (rest env) + env)))) + (and entry + (consp entry) + (symbolp (car entry)) ;name + (symbolp (cadr entry)) ;gcl:macro or gensym + (nthcdr 2 entry)))) + +);#+gclisp + + + +(defmacro with-new-definition-in-environment + ((new-env old-env macrolet/flet/labels-form) &body body) + (let ((functions (make-symbol "Functions")) + (macros (make-symbol "Macros"))) + `(let ((,functions ()) + (,macros ())) + (ecase (car ,macrolet/flet/labels-form) + ((flet labels) + (dolist (fn (cadr ,macrolet/flet/labels-form)) + (push fn ,functions))) + ((macrolet) + (dolist (mac (cadr ,macrolet/flet/labels-form)) + (push (list (car mac) + (convert-macro-to-lambda (cadr mac) + (cddr mac) + (string (car mac)))) + ,macros)))) + (with-augmented-environment + (,new-env ,old-env :functions ,functions :macros ,macros) + ,@body)))) + +#-Genera +(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) + (let ((gensym (make-symbol name))) + (eval `(defmacro ,gensym ,llist ,@body)) + (macro-function gensym))) + +#+Genera +(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) + (si:defmacro-1 + 'sys:named-lambda 'sys:special (make-symbol name) llist body)) + + + + + +;;; +;;; Now comes the real walker. +;;; +;;; As the walker walks over the code, it communicates information to itself +;;; about the walk. This information includes the walk function, variable +;;; bindings, declarations in effect etc. This information is inherently +;;; lexical, so the walker passes it around in the actual environment the +;;; walker passes to macroexpansion functions. This is what makes the +;;; nested-walk-form facility work properly. +;;; +(defmacro walker-environment-bind ((var env &rest key-args) + &body body) + `(with-augmented-environment + (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) + .,body)) + +(defvar *key-to-walker-environment* (gensym)) + +(defun env-lock (env) + (environment-macro env *key-to-walker-environment*)) + +(defun walker-environment-bind-1 (env &key (walk-function nil wfnp) + (walk-form nil wfop) + (declarations nil decp) + (lexical-variables nil lexp)) + (let ((lock (environment-macro env *key-to-walker-environment*))) + (list + (list *key-to-walker-environment* + (list (if wfnp walk-function (car lock)) + (if wfop walk-form (cadr lock)) + (if decp declarations (caddr lock)) + (if lexp lexical-variables (cadddr lock))))))) + +(defun env-walk-function (env) + (car (env-lock env))) + +(defun env-walk-form (env) + (cadr (env-lock env))) + +(defun env-declarations (env) + (caddr (env-lock env))) + +(defun env-lexical-variables (env) + (cadddr (env-lock env))) + + +(defun note-declaration (declaration env) + (let ((lock (env-lock env))) + (setf (caddr lock) + (cons declaration (caddr lock))))) + +(defun note-lexical-binding (thing env) + (let ((lock (env-lock env))) + (setf (cadddr lock) + (cons thing (cadddr lock))))) + + +(defun VARIABLE-LEXICAL-P (var env) + (member var (env-lexical-variables env))) + +(defvar *VARIABLE-DECLARATIONS* '(special)) + +(defun VARIABLE-DECLARATION (declaration var env) + (if (not (member declaration *variable-declarations*)) + (error "~S is not a reckognized variable declaration." declaration) + (let ((id (or (member var (env-lexical-variables env)) var))) + (dolist (decl (env-declarations env)) + (when (and (eq (car decl) declaration) + (eq (cadr decl) id)) + (return decl)))))) + +(defun VARIABLE-SPECIAL-P (var env) + (or (not (null (variable-declaration 'special var env))) + (variable-globally-special-p var))) + +;;; +;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been +;;; declared globally special. Any particular CommonLisp implementation +;;; should customize this function accordingly and send their customization +;;; back. +;;; +;;; The default version of variable-globally-special-p is probably pretty +;;; slow, so it uses *globally-special-variables* as a cache to remember +;;; variables that it has already figured out are globally special. +;;; +;;; This would need to be reworked if an unspecial declaration got added to +;;; Common Lisp. +;;; +;;; Common Lisp nit: +;;; variable-globally-special-p should be defined in Common Lisp. +;;; +#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs + GCLisp TI pyramid) +(defvar *globally-special-variables* ()) + +(defun variable-globally-special-p (symbol) + #+Genera (si:special-variable-p symbol) + #+Cloe-Runtime (compiler::specialp symbol) + #+Lucid (lucid::proclaimed-special-p symbol) + #+TI (get symbol 'special) + #+Xerox (il:variable-globally-special-p symbol) + #+(and dec vax common) (get symbol 'system::globally-special) + #+(or KCL IBCL) (si:specialp symbol) + #+excl (get symbol 'excl::.globally-special.) + #+:CMU (or (get symbol 'lisp::globally-special) + (get symbol + 'clc::globally-special-in-compiler)) + #+HP-HPLabs (member (get symbol 'impl:vartype) + '(impl:fluid impl:global) + :test #'eq) + #+:GCLISP (gclisp::special-p symbol) + #+pyramid (or (get symbol 'lisp::globally-special) + (get symbol + 'clc::globally-special-in-compiler)) + #+:CORAL (ccl::proclaimed-special-p symbol) + #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs + GCLisp TI pyramid :CORAL) + (or (not (null (member symbol *globally-special-variables* :test #'eq))) + (when (eval `(flet ((ref () ,symbol)) + (let ((,symbol '#,(list nil))) + (and (boundp ',symbol) (eq ,symbol (ref)))))) + (push symbol *globally-special-variables*) + t))) + + + ;; +;;;;;; Handling of special forms (the infamous 24). + ;; +;;; +;;; and I quote... +;;; +;;; The set of special forms is purposely kept very small because +;;; any program analyzing program (read code walker) must have +;;; special knowledge about every type of special form. Such a +;;; program needs no special knowledge about macros... +;;; +;;; So all we have to do here is a define a way to store and retrieve +;;; templates which describe how to walk the 24 special forms and we are all +;;; set... +;;; +;;; Well, its a nice concept, and I have to admit to being naive enough that +;;; I believed it for a while, but not everyone takes having only 24 special +;;; forms as seriously as might be nice. There are (at least) 3 ways to +;;; lose: +;; +;;; 1 - Implementation x implements a Common Lisp special form as a macro +;;; which expands into a special form which: +;;; - Is a common lisp special form (not likely) +;;; - Is not a common lisp special form (on the 3600 IF --> COND). +;;; +;;; * We can safe ourselves from this case (second subcase really) by +;;; checking to see if there is a template defined for something +;;; before we check to see if we we can macroexpand it. +;;; +;;; 2 - Implementation x implements a Common Lisp macro as a special form. +;;; +;;; * This is a screw, but not so bad, we save ourselves from it by +;;; defining extra templates for the macros which are *likely* to +;;; be implemented as special forms. (DO, DO* ...) +;;; +;;; 3 - Implementation x has a special form which is not on the list of +;;; Common Lisp special forms. +;;; +;;; * This is a bad sort of a screw and happens more than I would like +;;; to think, especially in the implementations which provide more +;;; than just Common Lisp (3600, Xerox etc.). +;;; The fix is not terribly staisfactory, but will have to do for +;;; now. There is a hook in get walker-template which can get a +;;; template from the implementation's own walker. That template +;;; has to be converted, and so it may be that the right way to do +;;; this would actually be for that implementation to provide an +;;; interface to its walker which looks like the interface to this +;;; walker. +;;; + +(eval-when (compile load eval) + +(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because + `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack + ;compile time definition of macros + ;right for setf. + +(defmacro define-walker-template + (name &optional (template '(nil repeat (eval)))) + `(eval-when (load eval) + (setf (get-walker-template-internal ',name) ',template))) +) + +(defun get-walker-template (x) + (cond ((symbolp x) + (or (get-walker-template-internal x) + (get-implementation-dependent-walker-template x))) + ((and (listp x) (eq (car x) 'lambda)) + '(lambda repeat (eval))) + (t + (error "Can't get template for ~S" x)))) + +(defun get-implementation-dependent-walker-template (x) + (declare (ignore x)) + ()) + + + ;; +;;;;;; The actual templates + ;; + +(define-walker-template BLOCK (NIL NIL REPEAT (EVAL))) +(define-walker-template CATCH (NIL EVAL REPEAT (EVAL))) +(define-walker-template COMPILER-LET walk-compiler-let) +(define-walker-template DECLARE walk-unexpected-declare) +(define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL))) +(define-walker-template FLET walk-flet) +(define-walker-template FUNCTION (NIL CALL)) +(define-walker-template GO (NIL QUOTE)) +(define-walker-template IF walk-if) +(define-walker-template LABELS walk-labels) +(define-walker-template LAMBDA walk-lambda) +(define-walker-template LET walk-let) +(define-walker-template LET* walk-let*) +(define-walker-template MACROLET walk-macrolet) +(define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL))) +(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL))) +(define-walker-template MULTIPLE-VALUE-SETQ (NIL (REPEAT (SET)) EVAL)) +(define-walker-template MULTIPLE-VALUE-BIND walk-multiple-value-bind) +(define-walker-template PROGN (NIL REPEAT (EVAL))) +(define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL))) +(define-walker-template QUOTE (NIL QUOTE)) +(define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN))) +(define-walker-template SETQ (NIL REPEAT (SET EVAL))) +(define-walker-template TAGBODY walk-tagbody) +(define-walker-template THE (NIL QUOTE EVAL)) +(define-walker-template THROW (NIL EVAL EVAL)) +(define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) + +;;; The new special form. +;(define-walker-template clos::LOAD-TIME-EVAL (NIL EVAL)) + +;;; +;;; And the extra templates... +;;; +(define-walker-template DO walk-do) +(define-walker-template DO* walk-do*) +(define-walker-template PROG walk-prog) +(define-walker-template PROG* walk-prog*) +(define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL))))) + +#+Genera +(progn + (define-walker-template zl::named-lambda walk-named-lambda) + (define-walker-template SCL:LETF walk-let) + (define-walker-template SCL:LETF* walk-let*) + ) + +#+Lucid +(progn + (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda + #-LCL3.0 sys:named-lambda walk-named-lambda) + ) + +#+(or KCL IBCL) +(progn + (define-walker-template lambda-block walk-named-lambda);Not really right, + ;we don't hack block + ;names anyways. + ) + +#+TI +(progn + (define-walker-template TICL::LET-IF walk-let-if) + ) + +#+:Coral +(progn + (define-walker-template ccl:%stack-block walk-let) + ) + + + +(defun WALK-FORM (form + &optional environment + (walk-function + #'(lambda (subform context env) + (declare (ignore context env)) + subform))) + (walker-environment-bind (new-env environment :walk-function walk-function) + (walk-form-internal form :eval new-env))) + +;;; +;;; nested-walk-form provides an interface that allows nested macros, each +;;; of which must walk their body to just do one walk of the body of the +;;; inner macro. That inner walk is done with a walk function which is the +;;; composition of the two walk functions. +;;; +;;; This facility works by having the walker annotate the environment that +;;; it passes to macroexpand-1 to know which form is being macroexpanded. +;;; If then the &whole argument to the macroexpansion function is eq to +;;; the env-walk-form of the environment, nested-walk-form can be certain +;;; that there are no intervening layers and that a nested walk is alright. +;;; +;;; There are some semantic problems with this facility. In particular, if +;;; the outer walk function returns T as its walk-no-more-p value, this will +;;; prevent the inner walk function from getting a chance to walk the subforms +;;; of the form. This is almost never what you want, since it destroys the +;;; equivalence between this nested-walk-form function and two seperate +;;; walk-forms. +;;; +(defun NESTED-WALK-FORM (whole + form + &optional environment + (walk-function + #'(lambda (subform context env) + (declare (ignore context env)) + subform))) + (if (eq whole (env-walk-form environment)) + (let ((outer-walk-function (env-walk-function environment))) + (throw whole + (walk-form + form + environment + #'(lambda (f c e) + ;; First loop to make sure the inner walk function + ;; has done all it wants to do with this form. + ;; Basically, what we are doing here is providing + ;; the same contract walk-form-internal normally + ;; provides to the inner walk function. + (let ((inner-result nil) + (inner-no-more-p nil) + (outer-result nil) + (outer-no-more-p nil)) + (loop + (multiple-value-setq (inner-result inner-no-more-p) + (funcall walk-function f c e)) + (cond (inner-no-more-p (return)) + ((not (eq inner-result f))) + ((not (consp inner-result)) (return)) + ((get-walker-template (car inner-result)) (return)) + (t + (multiple-value-bind (expansion macrop) + (walker-environment-bind + (new-env e :walk-form inner-result) + (macroexpand-1 inner-result new-env)) + (if macrop + (setq inner-result expansion) + (return))))) + (setq f inner-result)) + (multiple-value-setq (outer-result outer-no-more-p) + (funcall outer-walk-function + inner-result + c + e)) + (values outer-result + (and inner-no-more-p outer-no-more-p))))))) + (walk-form form environment walk-function))) + +;;; +;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It +;;; takes a form and the current context and walks the form calling itself or +;;; the appropriate template recursively. +;;; +;;; "It is recommended that a program-analyzing-program process a form +;;; that is a list whose car is a symbol as follows: +;;; +;;; 1. If the program has particular knowledge about the symbol, +;;; process the form using special-purpose code. All of the +;;; standard special forms should fall into this category. +;;; 2. Otherwise, if macro-function is true of the symbol apply +;;; either macroexpand or macroexpand-1 and start over. +;;; 3. Otherwise, assume it is a function call. " +;;; + +(defun walk-form-internal (form context env + &aux newform newnewform + walk-no-more-p macrop + fn template) + ;; First apply the walk-function to perform whatever translation + ;; the user wants to this form. If the second value returned + ;; by walk-function is T then we don't recurse... + (catch form + (multiple-value-setq (newform walk-no-more-p) + (funcall (env-walk-function env) form context env)) + (catch newform + (cond (walk-no-more-p newform) + ((not (eq form newform)) + (walk-form-internal newform context env)) + ((not (consp newform)) newform) + ((setq template (get-walker-template (setq fn (car newform)))) + (if (symbolp template) + (funcall template newform context env) + (walk-template newform template context env))) + (t + (multiple-value-setq (newnewform macrop) + (walker-environment-bind (new-env env :walk-form newform) + (macroexpand-1 newform new-env))) + (cond (macrop (walk-form-internal newnewform context env)) + ((and (symbolp fn) + (not (fboundp fn)) + (special-form-p fn)) + (error + "~S is a special form, not defined in the CommonLisp.~%~ + manual This code walker doesn't know how to walk it.~%~ + Define a template for this special form and try again." + fn)) + (t + ;; Otherwise, walk the form as if its just a standard + ;; functioncall using a template for standard function + ;; call. + (walk-template + newnewform '(call repeat (eval)) context env)))))))) + +(defun walk-template (form template context env) + (if (atom template) + (ecase template + ((EVAL FUNCTION TEST EFFECT RETURN) + (walk-form-internal form :EVAL env)) + ((QUOTE NIL) form) + (SET + (walk-form-internal form :SET env)) + ((LAMBDA CALL) + (cond ((symbolp form) form) + #+Lispm + ((sys:validate-function-spec form) form) + (t (walk-form-internal form context env))))) + (case (car template) + (REPEAT + (walk-template-handle-repeat form + (cdr template) + ;; For the case where nothing happens + ;; after the repeat optimize out the + ;; call to length. + (if (null (cddr template)) + () + (nthcdr (- (length form) + (length + (cddr template))) + form)) + context + env)) + (IF + (walk-template form + (if (if (listp (cadr template)) + (eval (cadr template)) + (funcall (cadr template) form)) + (caddr template) + (cadddr template)) + context + env)) + (REMOTE + (walk-template form (cadr template) context env)) + (otherwise + (cond ((atom form) form) + (t (recons form + (walk-template + (car form) (car template) context env) + (walk-template + (cdr form) (cdr template) context env)))))))) + +(defun walk-template-handle-repeat (form template stop-form context env) + (if (eq form stop-form) + (walk-template form (cdr template) context env) + (walk-template-handle-repeat-1 form + template + (car template) + stop-form + context + env))) + +(defun walk-template-handle-repeat-1 (form template repeat-template + stop-form context env) + (cond ((null form) ()) + ((eq form stop-form) + (if (null repeat-template) + (walk-template stop-form (cdr template) context env) + (error "While handling repeat: + ~%~Ran into stop while still in repeat template."))) + ((null repeat-template) + (walk-template-handle-repeat-1 + form template (car template) stop-form context env)) + (t + (recons form + (walk-template (car form) (car repeat-template) context env) + (walk-template-handle-repeat-1 (cdr form) + template + (cdr repeat-template) + stop-form + context + env))))) + +(defun walk-repeat-eval (form env) + (and form + (recons form + (walk-form-internal (car form) :eval env) + (walk-repeat-eval (cdr form) env)))) + +(defun recons (x car cdr) + (if (or (not (eq (car x) car)) + (not (eq (cdr x) cdr))) + (cons car cdr) + x)) + +(defun relist (x &rest args) + (relist-internal x args nil)) + +(defun relist* (x &rest args) + (relist-internal x args 't)) + +(defun relist-internal (x args *p) + (if (null (cdr args)) + (if *p (car args) (list (car args))) + (recons x + (car args) + (relist-internal (cdr x) (cdr args) *p)))) + + + ;; +;;;;;; Special walkers + ;; + +(defun walk-declarations (body fn env + &optional doc-string-p declarations old-body + &aux (form (car body)) macrop new-form) + (cond ((and (stringp form) ;might be a doc string + (cdr body) ;isn't the returned value + (null doc-string-p) ;no doc string yet + (null declarations)) ;no declarations yet + (recons body + form + (walk-declarations (cdr body) fn env t))) + ((and (listp form) (eq (car form) 'declare)) + ;; Got ourselves a real live declaration. Record it, look for more. + (dolist (declaration (cdr form)) + (let ((type (car declaration)) + (name (cadr declaration)) + (args (cddr declaration))) + (if (member type *variable-declarations*) + (note-declaration `(,type + ,(or (variable-lexical-p name env) name) + ,.args) + env) + (note-declaration declaration env)) + (push declaration declarations))) + (recons body + form + (walk-declarations + (cdr body) fn env doc-string-p declarations))) + ((and form + (listp form) + (null (get-walker-template (car form))) + (progn + (multiple-value-setq (new-form macrop) + (macroexpand-1 form env)) + macrop)) + ;; This form was a call to a macro. Maybe it expanded + ;; into a declare? Recurse to find out. + (walk-declarations (recons body new-form (cdr body)) + fn env doc-string-p declarations + (or old-body body))) + (t + ;; Now that we have walked and recorded the declarations, + ;; call the function our caller provided to expand the body. + ;; We call that function rather than passing the real-body + ;; back, because we are RECONSING up the new body. + (funcall fn (or old-body body) env)))) + + +(defun walk-unexpected-declare (form context env) + (declare (ignore context env)) + (warn "Encountered declare ~S in a place where a declare was not expected." + form) + form) + +(defun walk-arglist (arglist context env &optional (destructuringp nil) + &aux arg) + (cond ((null arglist) ()) + ((symbolp (setq arg (car arglist))) + (or (member arg lambda-list-keywords) + (note-lexical-binding arg env)) + (recons arglist + arg + (walk-arglist (cdr arglist) + context + env + (and destructuringp + (not (member arg + lambda-list-keywords)))))) + ((consp arg) + (prog1 (if destructuringp + (walk-arglist arg context env destructuringp) + (recons arglist + (relist* arg + (car arg) + (walk-form-internal (cadr arg) :eval env) + (cddr arg)) + (walk-arglist (cdr arglist) context env nil))) + (if (symbolp (car arg)) + (note-lexical-binding (car arg) env) + (note-lexical-binding (cadar arg) env)) + (or (null (cddr arg)) + (not (symbolp (caddr arg))) + (note-lexical-binding (caddr arg) env)))) + (t + (error "Can't understand something in the arglist ~S" arglist)))) + +(defun walk-let (form context env) + (walk-let/let* form context env nil)) + +(defun walk-let* (form context env) + (walk-let/let* form context env t)) + +(defun walk-prog (form context env) + (walk-prog/prog* form context env nil)) + +(defun walk-prog* (form context env) + (walk-prog/prog* form context env t)) + +(defun walk-do (form context env) + (walk-do/do* form context env nil)) + +(defun walk-do* (form context env) + (walk-do/do* form context env t)) + +(defun walk-let/let* (form context old-env sequentialp) + (walker-environment-bind (new-env old-env) + (let* ((let/let* (car form)) + (bindings (cadr form)) + (body (cddr form)) + (walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* + form let/let* walked-bindings walked-body)))) + +(defun walk-prog/prog* (form context old-env sequentialp) + (walker-environment-bind (new-env old-env) + (let* ((possible-block-name (second form)) + (blocked-prog (and (symbolp possible-block-name) + (not (eq possible-block-name 'nil))))) + (multiple-value-bind (let/let* block-name bindings body) + (if blocked-prog + (values (car form) (cadr form) (caddr form) (cdddr form)) + (values (car form) nil (cadr form) (cddr form))) + (let* ((walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations + body + #'(lambda (real-body real-env) + (walk-tagbody-1 real-body context real-env)) + new-env))) + (if block-name + (relist* + form let/let* block-name walked-bindings walked-body) + (relist* + form let/let* walked-bindings walked-body))))))) + +(defun walk-do/do* (form context old-env sequentialp) + (walker-environment-bind (new-env old-env) + (let* ((do/do* (car form)) + (bindings (cadr form)) + (end-test (caddr form)) + (body (cdddr form)) + (walked-bindings (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* form + do/do* + (walk-bindings-2 bindings walked-bindings context new-env) + (walk-template end-test '(test repeat (eval)) context new-env) + walked-body)))) + +(defun walk-let-if (form context env) + (let ((test (cadr form)) + (bindings (caddr form)) + (body (cdddr form))) + (walk-form-internal + `(let () + (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) + bindings))) + (flet ((.let-if-dummy. () ,@body)) + (if ,test + (let ,bindings (.let-if-dummy.)) + (.let-if-dummy.)))) + context + env))) + +(defun walk-multiple-value-bind (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((mvb (car form)) + (bindings (cadr form)) + (mv-form (walk-template (caddr form) 'eval context old-env)) + (body (cdddr form)) + walked-bindings + (walked-body + (walk-declarations + body + #'(lambda (real-body real-env) + (setq walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + nil)) + (walk-repeat-eval real-body real-env)) + new-env))) + (relist* form mvb walked-bindings mv-form walked-body)))) + +(defun walk-bindings-1 (bindings old-env new-env context sequentialp) + (and bindings + (let ((binding (car bindings))) + (recons bindings + (if (symbolp binding) + (prog1 binding + (note-lexical-binding binding new-env)) + (prog1 (relist* binding + (car binding) + (walk-form-internal (cadr binding) + context + (if sequentialp + new-env + old-env)) + (cddr binding)) ;save cddr for DO/DO* + ;it is the next value + ;form. Don't walk it + ;now though. + (note-lexical-binding (car binding) new-env))) + (walk-bindings-1 (cdr bindings) + old-env + new-env + context + sequentialp))))) + +(defun walk-bindings-2 (bindings walked-bindings context env) + (and bindings + (let ((binding (car bindings)) + (walked-binding (car walked-bindings))) + (recons bindings + (if (symbolp binding) + binding + (relist* binding + (car walked-binding) + (cadr walked-binding) + (walk-template (cddr binding) + '(eval) + context + env))) + (walk-bindings-2 (cdr bindings) + (cdr walked-bindings) + context + env))))) + +(defun walk-lambda (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((arglist (cadr form)) + (body (cddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* form + (car form) + walked-arglist + walked-body)))) + +(defun walk-named-lambda (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((name (cadr form)) + (arglist (caddr form)) + (body (cdddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* form + (car form) + name + walked-arglist + walked-body)))) + +(defun walk-tagbody (form context env) + (recons form (car form) (walk-tagbody-1 (cdr form) context env))) + +(defun walk-tagbody-1 (form context env) + (and form + (recons form + (walk-form-internal (car form) + (if (symbolp (car form)) 'quote context) + env) + (walk-tagbody-1 (cdr form) context env)))) + +(defun walk-compiler-let (form context old-env) + (declare (ignore context)) + (let ((vars ()) + (vals ())) + (dolist (binding (cadr form)) + (cond ((symbolp binding) (push binding vars) (push nil vals)) + (t + (push (car binding) vars) + (push (eval (cadr binding)) vals)))) + (relist* form + (car form) + (cadr form) + (progv vars vals (walk-repeat-eval (cddr form) old-env))))) + +(defun walk-macrolet (form context old-env) + (walker-environment-bind (macro-env + nil + :walk-function (env-walk-function old-env)) + (labels ((walk-definitions (definitions) + (and definitions + (let ((definition (car definitions))) + (recons definitions + (relist* definition + (car definition) + (walk-arglist (cadr definition) + context + macro-env + t) + (walk-declarations (cddr definition) + #'walk-repeat-eval + macro-env)) + (walk-definitions (cdr definitions))))))) + (with-new-definition-in-environment (new-env old-env form) + (relist* form + (car form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) + +(defun walk-flet (form context old-env) + (labels ((walk-definitions (definitions) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context old-env) + (walk-definitions (cdr definitions)))))) + (recons form + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (with-new-definition-in-environment (new-env old-env form) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) + +(defun walk-labels (form context old-env) + (with-new-definition-in-environment (new-env old-env form) + (labels ((walk-definitions (definitions) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context new-env) + (walk-definitions (cdr definitions)))))) + (recons form + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) + +(defun walk-if (form context env) + (let ((predicate (cadr form)) + (arm1 (caddr form)) + (arm2 + (if (cddddr form) + (progn + (warn "In the form:~%~S~%~ + IF only accepts three arguments, you are using ~D.~%~ + It is true that some Common Lisps support this, but ~ + it is not~%~ + truly legal Common Lisp. For now, this code ~ + walker is interpreting ~%~ + the extra arguments as extra else clauses. ~ + Even if this is what~%~ + you intended, you should fix your source code." + form + (length (cdr form))) + (cons 'progn (cdddr form))) + (cadddr form)))) + (relist form + 'if + (walk-form-internal predicate context env) + (walk-form-internal arm1 context env) + (walk-form-internal arm2 context env)))) + + +;;; +;;; Tests tests tests +;;; + +#| +;;; +;;; Here are some examples of the kinds of things you should be able to do +;;; with your implementation of the macroexpansion environment hacking +;;; mechanism. +;;; +;;; with-lexical-macros is kind of like macrolet, but it only takes names +;;; of the macros and actual macroexpansion functions to use to macroexpand +;;; them. The win about that is that for macros which want to wrap several +;;; macrolets around their body, they can do this but have the macroexpansion +;;; functions be compiled. See the WITH-RPUSH example. +;;; +;;; If the implementation had a special way of communicating the augmented +;;; environment back to the evaluator that would be totally great. It would +;;; mean that we could just augment the environment then pass control back +;;; to the implementations own compiler or interpreter. We wouldn't have +;;; to call the actual walker. That would make this much faster. Since the +;;; principal client of this is defmethod it would make compiling defmethods +;;; faster and that would certainly be a win. +;;; +(defmacro with-lexical-macros (macros &body body &environment old-env) + (with-augmented-environment (new-env old-env :macros macros) + (walk-form (cons 'progn body) :environment new-env))) + +(defun expand-rpush (form env) + `(push ,(caddr form) ,(cadr form))) + +(defmacro with-rpush (&body body) + `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) + + +;;; +;;; Unfortunately, I don't have an automatic tester for the walker. +;;; Instead there is this set of test cases with a description of +;;; how each one should go. +;;; +(defmacro take-it-out-for-a-test-walk (form) + `(take-it-out-for-a-test-walk-1 ',form)) + +(defun take-it-out-for-a-test-walk-1 (form) + (terpri) + (terpri) + (let ((copy-of-form (copy-tree form)) + (result (walk-form form nil + #'(lambda (x y env) + (format t "~&Form: ~S ~3T Context: ~A" x y) + (when (symbolp x) + (let ((lexical (variable-lexical-p x env)) + (special (variable-special-p x env))) + (when lexical + (format t ";~3T") + (format t "lexically bound")) + (when special + (format t ";~3T") + (format t "declared special")) + (when (boundp x) + (format t ";~3T") + (format t "bound: ~S " (eval x))))) + x)))) + (cond ((not (equal result copy-of-form)) + (format t "~%Warning: Result not EQUAL to copy of start.")) + ((not (eq result form)) + (format t "~%Warning: Result not EQ to copy of start."))) + (pprint result) + result)) + +(defmacro foo (&rest ignore) ''global-foo) + +(defmacro bar (&rest ignore) ''global-bar) + +(take-it-out-for-a-test-walk (list arg1 arg2 arg3)) +(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))) + +(take-it-out-for-a-test-walk (progn (foo) (bar 1))) + +(take-it-out-for-a-test-walk (block block-name a b c)) +(take-it-out-for-a-test-walk (block block-name (list a) b c)) + +(take-it-out-for-a-test-walk (catch catch-tag (list a) b c)) +;;; +;;; This is a fairly simple macrolet case. While walking the body of the +;;; macro, x should be lexically bound. In the body of the macrolet form +;;; itself, x should not be bound. +;;; +(take-it-out-for-a-test-walk + (macrolet ((foo (x) (list x) ''inner)) + x + (foo 1))) + +;;; +;;; A slightly more complex macrolet case. In the body of the macro x +;;; should not be lexically bound. In the body of the macrolet form itself +;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it +;;; tries to macroexpand the call to foo. +;;; +(take-it-out-for-a-test-walk + (let ((x 1)) + (macrolet ((foo () (list x) ''inner)) + x + (foo)))) + +;;; +;;; A truly hairy use of compiler-let and macrolet. In the body of the +;;; macro x should not be lexically bound. In the body of the macrolet +;;; itself x should not be lexically bound. But the macro should expand +;;; into 1. +;;; +(take-it-out-for-a-test-walk + (compiler-let ((x 1)) + (let ((x 2)) + (macrolet ((foo () x)) + x + (foo))))) + + +(take-it-out-for-a-test-walk + (flet ((foo (x) (list x y)) + (bar (x) (list x y))) + (foo 1))) + +(take-it-out-for-a-test-walk + (let ((y 2)) + (flet ((foo (x) (list x y)) + (bar (x) (list x y))) + (foo 1)))) + +(take-it-out-for-a-test-walk + (labels ((foo (x) (bar x)) + (bar (x) (foo x))) + (foo 1))) + +(take-it-out-for-a-test-walk + (flet ((foo (x) (foo x))) + (foo 1))) + +(take-it-out-for-a-test-walk + (flet ((foo (x) (foo x))) + (flet ((bar (x) (foo x))) + (bar 1)))) + +(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b)) +(take-it-out-for-a-test-walk (prog () (declare (special a b)))) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a b)) + (foo a) b c)) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a) (special b)) + (foo a) b c)) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a)) + (declare (special b)) + (foo a) b c)) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a)) + (declare (special b)) + (let ((a 1)) + (foo a) b c))) +(take-it-out-for-a-test-walk (eval-when () + a + (foo a))) +(take-it-out-for-a-test-walk (eval-when (eval when load) + a + (foo a))) + +(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b))) +(take-it-out-for-a-test-walk (multiple-value-bind (a b) + (foo a b) + (declare (special a)) + (list a b))) +(take-it-out-for-a-test-walk (progn (function foo))) +(take-it-out-for-a-test-walk (progn a b (go a))) +(take-it-out-for-a-test-walk (if a b c)) +(take-it-out-for-a-test-walk (if a b)) +(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)) +(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b)) + 1 2)) +(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c))) +(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))) +(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) + (declare (special a b)) + (list a b c))) +(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) + (declare (special a b)) + (list a b c))) +(take-it-out-for-a-test-walk (let ((a 1) (b 2)) + (foo bar) + (declare (special a)) + (foo a b))) +(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)) +(take-it-out-for-a-test-walk (multiple-value-prog1 a b c)) +(take-it-out-for-a-test-walk (progn a b c)) +(take-it-out-for-a-test-walk (progv vars vals a b c)) +(take-it-out-for-a-test-walk (quote a)) +(take-it-out-for-a-test-walk (return-from block-name a b c)) +(take-it-out-for-a-test-walk (setq a 1)) +(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)) +(take-it-out-for-a-test-walk (tagbody a b c (go a))) +(take-it-out-for-a-test-walk (the foo (foo-form a b c))) +(take-it-out-for-a-test-walk (throw tag-form a)) +(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)) + +(defmacro flet-1 (a b) ''outer) +(defmacro labels-1 (a b) ''outer) + +(take-it-out-for-a-test-walk + (flet ((flet-1 (a b) () (flet-1 a b) (list a b))) + (flet-1 1 2) + (foo 1 2))) +(take-it-out-for-a-test-walk + (labels ((label-1 (a b) () (label-1 a b)(list a b))) + (label-1 1 2) + (foo 1 2))) +(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) + (macrolet-1 a b) + (foo 1 2))) + +(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) + (foo 1))) + +(take-it-out-for-a-test-walk (progn (bar 1) + (macrolet ((bar (a) + `(inner-bar-expanded ,a))) + (bar 2)))) + +(take-it-out-for-a-test-walk (progn (bar 1) + (macrolet ((bar (s) + (bar s) + `(inner-bar-expanded ,s))) + (bar 2)))) + +(take-it-out-for-a-test-walk (cond (a b) + ((foo bar) a (foo a)))) + + +(let ((the-lexical-variables ())) + (walk-form '(let ((a 1) (b 2)) + #'(lambda (x) (list a b x y))) + () + #'(lambda (form context env) + (when (and (symbolp form) + (variable-lexical-p form env)) + (push form the-lexical-variables)) + form)) + (or (and (= (length the-lexical-variables) 3) + (member 'a the-lexical-variables) + (member 'b the-lexical-variables) + (member 'x the-lexical-variables)) + (error "Walker didn't do lexical variables of a closure properly."))) + +|# + +()