From trittweiler at common-lisp.net Thu Aug 2 15:42:23 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 2 Aug 2007 11:42:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070802154223.E092061061@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18634 Modified Files: slime.el Log Message: * slime.el (slime-kill-all-buffers): Now also kills all buffers beginning with a `*SLIME' prefix (like, for instance, `*SLIME Apropos*', or `*SLIME macroexpansion*'.) --- /project/slime/cvsroot/slime/slime.el 2007/06/28 12:27:51 1.794 +++ /project/slime/cvsroot/slime/slime.el 2007/08/02 15:42:23 1.795 @@ -4578,7 +4578,8 @@ (when (or (string= (buffer-name buf) slime-event-buffer-name) (string-match "^\\*inferior-lisp*" (buffer-name buf)) (string-match "^\\*slime-repl .*\\*$" (buffer-name buf)) - (string-match "^\\*sldb .*\\*$" (buffer-name buf))) + (string-match "^\\*sldb .*\\*$" (buffer-name buf)) + (string-match "^\\*SLIME.*\\*$" (buffer-name buf))) (kill-buffer buf)))) From trittweiler at common-lisp.net Thu Aug 2 15:44:32 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 2 Aug 2007 11:44:32 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070802154432.35A6266001@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18837 Modified Files: ChangeLog Log Message: * slime.el (slime-kill-all-buffers): Now also kills all buffers beginning with a `*SLIME' prefix (like, for instance, `*SLIME Apropos*', or `*SLIME macroexpansion*'.) --- /project/slime/cvsroot/slime/ChangeLog 2007/06/28 12:27:51 1.1139 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/02 15:44:31 1.1140 @@ -1,3 +1,9 @@ +2007-08-02 Tobias C. Rittweiler + + * slime.el (slime-kill-all-buffers): Now also kills all buffers + beginning with a `*SLIME' prefix (like, for instance, `*SLIME + Apropos*', or `*SLIME macroexpansion*'.) + 2007-06-28 Helmut Eller * slime.el (def-slime-selector-method): Revert Marco's change from From mkoeppe at common-lisp.net Mon Aug 6 03:20:01 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 5 Aug 2007 23:20:01 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070806032001.59E2E1E07C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9464 Modified Files: swank.lisp Log Message: (backtrace): Handle printer errors while printing a frame. This makes debugging print-object methods with SLIME easier. Reported by Utz-Uwe Haus. --- /project/slime/cvsroot/slime/swank.lisp 2007/06/04 16:17:17 1.490 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/06 03:20:00 1.491 @@ -2923,7 +2923,10 @@ (loop for frame in (compute-backtrace start end) for i from start collect (list i (with-output-to-string (stream) - (print-frame frame stream))))) + (handler-case + (print-frame frame stream) + (t () + (format stream "[error printing frame]"))))))) (defslimefun debugger-info-for-emacs (start end) "Return debugger state, with stack frames from START to END. From mkoeppe at common-lisp.net Mon Aug 6 03:20:28 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 5 Aug 2007 23:20:28 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070806032028.C932F2B127@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10305 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/02 15:44:31 1.1140 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/06 03:20:28 1.1141 @@ -1,3 +1,9 @@ +2007-08-05 Matthias Koeppe + + * swank.lisp (backtrace): Handle printer errors while printing a + frame. This makes debugging print-object methods with SLIME + easier. Reported by Utz-Uwe Haus. + 2007-08-02 Tobias C. Rittweiler * slime.el (slime-kill-all-buffers): Now also kills all buffers From jcunningham at common-lisp.net Thu Aug 9 09:18:50 2007 From: jcunningham at common-lisp.net (jcunningham) Date: Thu, 9 Aug 2007 05:18:50 -0400 (EDT) Subject: [slime-cvs] CVS slime/doc Message-ID: <20070809091850.7D53E3F019@common-lisp.net> Update of /project/slime/cvsroot/slime/doc In directory clnet:/tmp/cvs-serv9143 Added Files: slime-refcard.pdf slime-refcard.tex Log Message: Added doc/slime-refcard.tex and doc/slime-refcard.pdf --- /project/slime/cvsroot/slime/doc/slime-refcard.pdf 2007/08/09 09:18:50 NONE +++ /project/slime/cvsroot/slime/doc/slime-refcard.pdf 2007/08/09 09:18:50 1.1 %PDF-1.4 3 0 obj << /Length 2570 /Filter /FlateDecode >> stream x??ZMs??????)%??X? 2?JU2?n9?Jmf}????hIeJ???=?C~{?4DJM??T.6E????x???????L???L???????P*?w:?"?Uz????????r2??qO????b??g?M>??@N????h??????Op?h????????"O??2???@I?&??????:????@?N'????U2?????????b?:??].?4JQz?qQf?~ ???????N?a|????H??{?yG???Ua??????'??J?2w?/??????u?? ????x?t??-?e?zg??CzRvK??????# ?J??? ??L????#'H?4?g X&?d*tK0??T? ?B????4O? ????j?n?f?X[n???'~y?/???y??IZg??!???X?Mc???x?]@ ???e?J??2?>J??**6b=P?.?b??d????R??G??D???????a]4???<~(?l?????????j/\???b??^;z??>??k?"???*?$?|?w??6??v???aFa??????%5???UU?)?^??6?bny ?????h???K???P???~??8q???)?aU?X???8c?mK?i??:?2U?8v??y=?e-@?r\k1?????pt??CGGCp}??"???;???PQD[?+?95??=??w?H?E??????????????,?S???$??i?P?E????m?v=?n???-JI/??/?4?w?o?A???3&??C????o? ?u??| J.?????dUVQ?S?kJ???1VH??|???H????*^t??????{??,(?t??A??g????ao??Hr???.?????????T?T????6???p3Y?$?????:??]???6 ??F?????z??8???Wc????????'?????? ?v?h"P????????9C???BB???s3?G? ????\.j?`/??l?Y?{???+9?HT??a?Y??J ?/?Q? ??W???????.`kSZ.j^8???????a?S?????Nc????f????????? T???;?)????[*???yL-M?]??'?1?$4m(?4??vc????f?Y???I???;5?4?\?g???s;O??1I?? 8b??????? ?k??1?3 ?????p???G2w?L)?T?>?c???6????P>???`??H??;?wU?O?|?/`??r???????? S?>?endstream endobj 2 0 obj << /Type /Page /Contents 3 0 R /Resources 1 0 R /MediaBox [0 0 595.2756 841.8898] /Parent 21 0 R >> endobj 1 0 obj << /Font << /F15 6 0 R /F17 9 0 R /F16 12 0 R /F18 13 0 R /F8 16 0 R /F19 17 0 R /F20 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 19 0 obj << /Length1 772 /Length2 1135 /Length3 532 /Length 1698 /Filter /FlateDecode >> stream x??RkTSW??A???C?R$?!/H?g(/?%X?i0D??XBDH?%Ja?? F????!???V?+HS??n?H??J??)?=? &??7l?Z???J?ek?7?zM ?!??I0?\I?8? G_?F???0?k}? ???) \Xnt???(x??"B? ?B?^?az??? ?????? ??O??!DP"2]?/?u???!???2?L&????_?+?Q!??9?@???t 9D$??L@PVXMZf?Q? ?2?l ?p????3C +k?? ??????q????Sg??8???![?Y??????7?H??0J????K,F?PaX ?(#?0?W~??/?h? ???%?bkE}???M?}?;??w??"a?G)?e????&$???|?????g [??m????-???z?????d? y?{?W? ?_|??n?y? ????|?~??{??sRk?FL?B??????????Q?Kn??-????T.Z???|0??? ????:?y2??b?'??c????J????? 2?Qz? ??????;i?Nl?????X?1??:E???F9?K????RU%???S67??$?{?????-lq??*??aN??l-5-w?4xy?????????+?eGND?|??g??????i??g?i2~gXb}>?????? ?b???t$? ???????F ??:???r3?D ??aewOU????0wh9-?W?OH~P?`?? 5???????!V?P7???(0??????pukJ?' ???????.???SrA???7???F????q?9z?rj?*>???=q?????c {g? 5??y??Z6v????m?z;[x?5???p???6???})N??u??%4??oUm?}?=????i/?.?[BV??c2???ZU??x?kT?jG?????*g?O?wr?.?????e?$X??:??[?? ?Xwi?L???c????}??1ug ??c?g}?&?k????? ?q??~?-????kW??S{h?Ib??1?M???????D?~??????L.??sT?,????T??Y?}??&??u?-??7??D?}T ?C?WZjN_?t????7?4~z?z~?w??w??X?x?U????????wv??'?.?????i{??wu??;???????5????avv?*2?.?D?W????P??1o|?q?V???}l???yv4??u?by??\?J????g5?Na?????' ???'0?O???'??endstream endobj 20 0 obj << /Type /Font /Subtype /Type1 /Encoding 22 0 R /FirstChar 60 /LastChar 62 /Widths 23 0 R /BaseFont /YELWLG+CMMIB10 /FontDescriptor 18 0 R >> endobj 18 0 obj << /Ascent 694 /CapHeight 686 /Descent -194 /FontName /YELWLG+CMMIB10 /ItalicAngle -14.04 /StemV 113 /XHeight 444 /FontBBox [-15 -250 1216 750] /Flags 4 /CharSet (/less/greater) /FontFile 19 0 R >> endobj 23 0 obj [894 0 894 ] endobj 22 0 obj << /Type /Encoding /Differences [ 0 /.notdef 60/less 61/.notdef 62/greater 63/.notdef] >> endobj 24 0 obj << /Length 180 /Filter /FlateDecode >> stream x?m?1 ?@E??? t.??]A1?[ZY??ZZ( ),> stream x?36?32W0P0Q?52P02Q03RH1?*?2??(XA??s??> /FirstChar 60 /LastChar 62 /Widths 26 0 R /Encoding 27 0 R /CharProcs 28 0 R >> endobj 26 0 obj [32.27 0 32.27 ] endobj 27 0 obj << /Type /Encoding /Differences [60/a60 61/.notdef 62/a62] >> endobj 28 0 obj << /a60 24 0 R /a62 25 0 R >> endobj 15 0 obj << /Length1 1375 /Length2 8853 /Length3 532 /Length 9685 /Filter /FlateDecode >> stream x???eT\???qMp?CAp-????>?CL,l??<??? ?{?? ?dX????`7?0?-? z ?o?)?????9????!-????l ;?j????Q. ??????:?e???????a.?1???O??f?ng??'?`?????.m?y??p/???D?2]?}???.???i???Vqfm?4I?` ?|?8W?^\my??G???'#??WS"?Z=4????R+??4?+??+VR???@?P??? H?3?}>JN???~,?q??#????IIA(f?K??j? ???`qEeD:0 7?:??????9???0y?3??M?'???N&???B?yB>?"??7??? ?_^?l?/????f?Sn?']mD????o ??3???~|?????f'j?8??Q?lq?V???j?????b?c(7??X?mu?????a?M?z!B??a9s?(?(??FSi??n??HN?D\??? ????w????;e@????7&??Jk??]P r?W???U?[i?C??[n !{?,_??WY?_?W??l???1???'??p%???r??? 5P?L??3,??M?1??B?*??r0?Y6?,? ?|?????S?;???5 ?1a????I?G?-??Q??T???i5%??"??a?]????J#){6?/?B????}=:EJ??? |?7d?l?G0???Br?b?cSOz????????s??R(?;??g??_ _?X???cEhY?R?F3??]????K"??8???b"?#?M?{???y?.&?,??.&?????G?w+?&Z?d?x????B?G?+E???z?v??{?!??~/???'??6????-? 5?{?G??]??;?.?`Q???,?1z??u?vK27w~?\?@????i?p:?? ??N?????8?????xf0??? ?wpG??b?$?:?y7?p????????Ud?-?d???????????]a?&:G??)?"L ?]B\U?6????S ?y?>?tpK ??!?G????????M? 6??zK?u:???~-?^??L%Wpk??< D?2?{?Yt? ^Y?o`?????? ???? ?#? ?}-?.?9*G/S?1? ?Q ,????}6G\ ????To4?f3???/??DM????&???EX{=???1?$Ur?Ei?M???/?a{M??(???A?z??V/??SAy???\?J?v??E?^? Wr]?/???X?????(? ?V?Q2]?HLv?i?????W?bS?=xp6?q???}??y?5?Vy???\v ?}???????^j??\??? ??HUc???\?}?Q{?#2?0?5?p??,??X?k??:#?6???l???_?Wom??N? ?Yi??????1?;_???????g?2?8'????????#?}{H5.???5"6??????1nv?q?i?j????!7$? x?r???+??J?????*"?z?P4?$Jx?:? l??dsC?~???c????Gsp??Bv?Sz ?@??N?IR??z???f???A??????o?3So???s?}n{X>?qo????????s3c]?n?#"?BA^l+????6S??/(eh:?0J??:G?+[?9?_%o?"Q ???????.?r????F????y?]}?NZP??h???n?s?s&?9??????????"+UjA??1???b???Gw??/?H1???h'?V???;U\?=-I?????J????B?????o^?]_1?t\????9?) "S?? x???????v5??Q??*?I4-`? ???(%(?L?????g\??EiY??e?|r@?????????R ????Ax?]?$r??2??5?xW<+?ja]~??6???m?/???\P?B??? 4gcK?h:}D?Y?KL?y3bZ????L??k??????D???u??_8?~??n(?C???te*????.MH???x???Zhp???.}??GU?????)?????`???T??Ni6h?b?????s???e(?Mw ? ?:??6??-?d?}??x?:G?????0???rt???T?6??R'y!?y??7[????0???68??????t??13C~?h????:+O? ????c??Z??8VU? h?]?+U??m?x?]v?&=????l?6???s8qi ?;=??s4u??V????kLp?V??I?W?m???!H??.??W#???t???@??a? L?;1?u f???J?7??h????B???o???y??p-??%f????a?.[W????????y??R3r???3????z?hA5P !ztj?P?????&?z??? ??'@??+om?+???`i*?????????5ZG?????i???G???#??p?@?>?B ????)?A?Q*?8????w? ??A??[???:?u??????S???????????=???U?J<??H?gw?I ??2??|?~?z?}?X???Wc? ??Q:9*??V?? ??9???????M.????%9 ?V??R?u{????7????@d+?&????:^??>vg??J??(??&dT?)??Vw?i????+5 ?4Kx??J???9o??3?J???Opr?Z`?12???7bT?l?2 Rz at R??g?b;?z???^??N$????7??m`???0???? b??'?J??c??m???"uY??????%,??yi????????X?? O??]?gJl????4B?/???????B?W]? ?S???^??-?oA??ZK???+3ZxeH?bi+<=u?}??]?(???c?m???y???V,P????V??p???A??V?????iu?Y??L?K?,*HaE??????? D?$]?GG?X????/?P???a.z????]??ZR??????3??7%?/b??^????o?f???r?W?-??M?_?E?F??0x??7?\?8????>FP?u????w???SQ??????y?r:`?6??}??r???;~???+ ?H$^\??#??w?????V*?J~]??fBN??=?????|/A??c,3??????~??$?*?3?C?????J^?4?w???r?????Gy? *?ue???uc?q????8b?c??k7? ????????r[ d?0Cp??_}X??AsJ#?t???^?9????(?&F??????r?mvq??G??D?:$wep?G >j?]\???|X?>??`V?ND)?;?*???~?G*????F|x????9??v???1?`;| qf*1?@7?B;??;a?m?[?? ?^?????4??a??#?63?Wn!????h?4???:K'???}?-?xa[1]j?~_;????#sw?Hc:m??'~??#?biT???{F?-w?;>?E???i8@? '?4(?~?L?X?? ?=???????T????????H(?4?fo(?? ?????j????}?&???m??4&sI??S?X? ?'??G???B??Ex\?#??As????-??=)n?_M&???+??^Tc??O???e?r???????H?!??X/ ???[??c???????d4j1; ???$??'?u^???n} X????5I?qJ4?e?v?_?_????'}b?o4lwcZm????s?xP?Y???????)mz|??I??p?W??'????B??|0?m????g?S?=?w?j."P???W?m",????FC??U??1??Vmg#T}1+lI?g`????r|?B4????f?%??m??t?|X????J???S??????b?/@,N?A?7???Xt??I?? HA?G????l????^??H?O* ?sh?70?NNU/?f??^??&3????nB??k?7?b???C?\????8???!?T!>?????6? ???D? ?ky?.??g?jA]?? 6?1??:???%????#?;?????x??}??}o? sw???zz?}?~}C??f???Aa????? ??i???6????Y`'???2???N??3?%????U??I?\???j???2?)=?4[?mG|?0.z???7E?? ??#+?:?E??~?(???q?!:5 <$???M??3b+?E?D?ug????r?L??uG??[kv??S??mz$?????+?2???????g*?'?l?cz?? ????????K?;??%?m?!*=???????U?r??4??]???%?c????=?V>??8? ??i??`?L {?x,?v?????pq/t?'?z?j?F??5k????d?~ ?Z ?????C??0???fSqvAB?i?RA'????yl?CA??|??F??%???Y??.????dY??(?D\G?q??Wd???7??n?~R?jt8\ Cj+:@?:?????u??u??u??? ?R6?J?P????>??f?y??K?????y!\?-?? Z????? ?!???????-?U??aX>`??%??c(}g?{???q?1?G?Tg?y%?qf.????4?-?z?zpK7RR????{?v????w?????$>>?~Q??XGr?s??(?????W??5U ??S????z????@~?j???h???+$t????r?L?? m???????8YB??c?;???G?o????????|5???:???6??x1???~`'0?C??????7"?9O #??i?/?W??&??2"??5?~H??o?T????H?8? (????S??8i?pP?l?i?#?>>)????!K o?? ???Er???????1??I????2g???*&] !???%?D??U*??f?????M????b?jdcE??E???6??????:?b{?@T?X?E6?v[??b*oV3PE?db;+U????p?q?k?6R?J?p5R??2?? TI?????0?9>w????iOv;K?????>)T?b??????J??Z?U4?H???????B.?????Ua?^??n?6~?$o??????N????n?P????>)?}?SiQ?z~????Q??{+?&???/?2|W RF?? [?I?Ta?? ????&S%??6??"????Bs?????????h?G?9G???K2S??Mw???R?_g???FA/?U?? ??????G?J??m??`??z??b ?B?E??7?o&Y5??ts?5??eW?d?"????B??? r???(??SJ<PZ\_???YK~:?P??DY?_? ??lu?3??+)?s3?????A5$??h?????K?H???0???????:?x)???c?e?&?U??t??????uB??? ?n?\??wALL????20????;???a?{?+?7?????k??2?X?J??T????q????v??9??? ;??_?-?N]uc??Z?????JW????s?i?z????????????V?????b0?G??A.???_31????u??io7??K??APF?????d????????S??C+ ???z?L?&<??? ?w??]}??????Ct?H??W?l??h????n{84???M?l??:v???6< ?????Q??S???T????????+?????`A???j?M???0?x???!???>+??n??n??????v??(S?"??Vl89????F???y???w??Y????[??K?W F??#?5??????U? ?~l!jR? m?l-??@???>??T??z?B?en[????????/??Dck0?? br?B?_?&XMendstream endobj 16 0 obj << /Type /Font /Subtype /Type1 /Encoding 29 0 R /FirstChar 11 /LastChar 122 /Widths 30 0 R /BaseFont /HKUFKS+CMR10 /FontDescriptor 14 0 R >> endobj 14 0 obj << /Ascent 694 /CapHeight 683 /Descent -194 /FontName /HKUFKS+CMR10 /ItalicAngle 0 /StemV 69 /XHeight 431 /FontBBox [-251 -250 1009 969] /Flags 4 /CharSet (/ff/fi/ampersand/parenleft/parenright/comma/hyphen/one/E/G/I/L/N/P/R/S/T/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z) /FontFile 15 0 R >> endobj 30 0 obj [583 556 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 778 0 389 389 0 0 278 333 0 0 0 500 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 681 0 785 0 361 0 0 625 0 750 0 681 0 736 556 722 0 0 0 0 0 0 0 0 0 0 0 0 500 556 444 556 444 306 500 556 278 0 528 278 833 556 500 556 528 392 394 389 556 528 722 528 528 444 ] endobj 29 0 obj << /Type /Encoding /Differences [ 0 /.notdef 11/ff/fi 13/.notdef 38/ampersand 39/.notdef 40/parenleft/parenright 42/.notdef 44/comma/hyphen 46/.notdef 49/one 50/.notdef 69/E 70/.notdef 71/G 72/.notdef 73/I 74/.notdef 76/L 77/.notdef 78/N 79/.notdef 80/P 81/.notdef 82/R/S/T 85/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z 123/.notdef] >> endobj 31 0 obj << /Length 189 /Filter /FlateDecode >> stream x?]?? ?@ ?S:Y?? ??R??(? ? ?? N????&?G????:??? ?p$?????HSDS???i?t?xEf?F??M?x????3???Q?5?o?3?t? ?*??D?d?<-@ ?????7 ??U s?@??????????????%32?UA??H?d??(?l???????????l?K?[??uJ]endstream endobj 32 0 obj << /Length 186 /Filter /FlateDecode >> stream x?]?1 ?@EG,?i]v???X4?\V?Z???@?r?D??(u??"p?6?S??AM??5o?i? ??Y~??T+d?D??m?kN?/E? %?????????'??&RKFendstream endobj 13 0 obj << /Type /Font /Subtype /Type3 /Name /F18 /FontMatrix [0.01205 0 0 0.01205 0 0] /FontBBox [ 5 -21 32 62 ] /Resources << /ProcSet [ /PDF /ImageB ] >> /FirstChar 60 /LastChar 62 /Widths 33 0 R /Encoding 34 0 R /CharProcs 35 0 R >> endobj 33 0 obj [37.1 0 37.1 ] endobj 34 0 obj << /Type /Encoding /Differences [60/a60 61/.notdef 62/a62] >> endobj 35 0 obj << /a60 31 0 R /a62 32 0 R >> endobj 11 0 obj << /Length1 1385 /Length2 8216 /Length3 532 /Length 9054 /Filter /FlateDecode >> stream x???U\[???q(?EK(R4?(??n!8 h?????8?)Z??{?kiq?????W{??~???? ???????s?{??pc?3 _??? ??????rq8???????p?p??????w???89Y???8la.?`??%~? |????_?????6??.?????/???M?q??$????8?? ????)*?? ?C?7??F????t?9???zT??G??a!???o????!.N???????u??oh??ml?@xc??@????p??N???q8??p ??p??? \???k????????p+???????? \??5|??????????~?$%!??????'*?m???o??7???!?M???'}?>????$????J??c?????/?/????.????V???T?zo??HV?w??8T????3???Kz???B?}?E?B_)]???t??L?q??????o4 *}?????u?<7?(?@?G?O?`'???Q8??9_?*a?7????F????s/??n??PFz??u?bi????~lO????Oy?????? A???v` s???a?p??2?q=[1??"_???@4??????3.ARI??{??q?'~?hF??*?#a^???!.??{???a?|N??IH?S???v Y??? ?????:?#??P????'???u???SD??;92?!=???y??c"eeo?6?? V?flA??????sxFK???6=??T?RH??2?????+???~U????Z????V?,r?BJG?x???yV???R?@?&????\?]h??? ?o?;12??Ho?5? ??c?C@??????;z?????OqSa/?I/??biwR??}?????b??#H>M??N????7??_?:?O?Z2, ?????Q?!????7?I2?9??y??qE?}??F??????~?;*??,??aj?'JdGk,?Y}?j,?O???t?'??Le???g???G??1?@|????\?n??GU???z???h???cG???/{J??4???????4?$+#??$UuXb\??GZg q???&?T? Dyqy??S"`?~93?k9HlamA?D?:?!6??Q_O?u?????u"??????? 8y@e,.8??d9 ????N??????,?\w??n&?j{ e?E{R=???? ?B?Q?pu???Z???:?{v????a????>?X?M??????^?g?? ? ?({????se?VF??-??NYI?aJ`rYs?hb?}????A?eM??????l!an ?c#.m?w?7???j?b?y??i?:b??&??Y???i)w????L,e??????iyH{(PR %?u?*G"3?h?BN??HU(+?? ??b? ?Uw)F??!??v$???n?nu?;[???c???{]A?QgCt?7??&? 0??U?u??X??Sz?E??$???^>?h???%z"o?Ss;?q???"_?(Y5qC7*D?????*?i^?x?1kn?'??RD7?7`?^???O7???_??????^??G~?7w5??6?c????????7`?,?1!3x???-?.?m=?a?+?{????d??????\?4xj????w~??Fn??z??_??)????>??????N?2~?S'.}&? ?+?}?0`?z)???3`O?1g???????D?D??[?*B)???????=???F"?8?????}??-?????o?^???6I???Pl????*????G5??l????2^?J????"??B????tHPd?n?!?S??f????n7?P????EP2?@ ????? ?23M?{?????X`?.?$?_ $?aWZ??Ysa\.?????@?r \??N.]|x5??p???Z??J/?y??&?????A??+?-????V?yW=?? yanoXZK?PW:?:`d:??!??{QK?w?? 7%?M8O ??D???r??????B???C??W?|????V?"??Dn??????0??U???F?m?0?6/S????-T}r??)?Rp???K? ?2?x??M[?;??HC?>??afC???r>Z?????F*??F?.??????.7'*???O???4?p]????~8`??????0y?????t???P?{??y?r>?oL ???~???-?e?%???)?Zo?9?k???z??s &%3.??$E?0????e???uc??,?????sF??>?1?H?V????u?pz-???k6y?3??Y8?7`??X??"??? ????]?O?g??s?"?)qv>c??? {???A?? ?7$???"??z?? ??????y???X??K??!??????? ?[????v;?VdY??R< ???z???'6????F?nM??X???????^:?=???{?6\Z??????:?9???A?@???[ywQ??????????? p ??6??;5)??4?????/??}????m? ?J? ??~?}N ??D?'+?~??Q8??{5?n??R?>I???3 Ej?? D?8??? ????/l??#??i) ??J ??Lj??????U??e????v???????Jy?&N?UA\'e?e??y?x??????i:AP?!???gZs ?o??k????B??>??4U???n7?C??lL???)?UT9???L??F????w??a?-??& ?;Tt X?????m???r6????""?d??????g??X??U??bX:[2_??F:?7?{??;40?MG.OZ6??` ???=v???%?v????????????k?T????g?D?g^?4???{zN????q cKCsx?M??C?H??07.?Q L??m???;K?? Yk??c????q??RST???R??/???Uk1+?? ????1E_??9??'`}??^????J6i????4h[6?-1.??=4?I??[?:???????9?LeaZ?e?????2o?*????#? Q?+???V]??%?f??{dg????? t??????jm??|?X?RJ?????8f??A6?????? ??%5??g?xz^???,J?????H?????U\????j??u>????{B@??qL??-?0t??g"ym9)^i??9;?x{2J%J??+??L???6N?!B ??W?????=9??O??????w??????&?6??`O??6??O??4??Fcu:??`????hNg$?H ?._ ???!??>??s2?F?L?B??x?c?DCU????u??IT?i9O?EC?%GK,$?Lk?;)??rq9sVU?\ q?|? eZ???=??%?[???Rripg?pi?A??m???? ?????sm???:?nfs??2dw???u Lj?y?(?r?XQ(??????r???(???gr???c?Z???Z??O????y??H c&?2Y???? ?kVE????? ?i?lwq'?x?6??;??Y????Ng?????JXX^?=????=?z?{eS???q^?x?\???]????? ?f??z=hI5???O?wi ????????X????N?z?#$??1???f-G?Yi??=?2?l =o{???f?;5??Zc?FH????Ov ??a?Z?????I?]y??t?7?9?)c?X??R??JH?#S?#3?o??????A D3??6F???????Z~????g??? ??p :Y?V???O{!????$3???????Ymt????jL?35\P???#?^Hr? ?x ?u?G?? ?PV?J(??a? nQsl?o5b???0|??p?&??e?????A?`?.;?%????N/%{o\?Co????i?&?{?j?`?.j{??,dzr??\??f ? ??'????? ?????E??d?*JJ,?f?Y?~??Lh?????`??u?U+YK?Yc???I?*P?Q?????9<??K?%??\i ??l???~?1V?8????V~E?U&?O????;???nw? |,??~i?d??`??????????c?c?l? ?? ????U?:K?N??? 0Qw??bO>Y??????({b?/???"?!??+?L??????#????kVg?j4?WNxNk>`*???????e??????U?`V~@??&?&??iZ ?&]d?>?F6?x??D??(?H????k??;???gK?$?t??`[V?(;?_x? W|?Kf????&???w\??g?t???Zo??? ?p?~0??? G???d?????"?/endstream endobj 12 0 obj << /Type /Font /Subtype /Type1 /Encoding 36 0 R /FirstChar 12 /LastChar 126 /Widths 37 0 R /BaseFont /GYERDI+CMBX10 /FontDescriptor 10 0 R >> endobj 10 0 obj << /Ascent 694 /CapHeight 686 /Descent -194 /FontName /GYERDI+CMBX10 /ItalicAngle 0 /StemV 114 /XHeight 444 /FontBBox [-301 -250 1164 946] /Flags 4 /CharSet (/fi/asterisk/comma/hyphen/period/four/five/colon/C/D/E/F/I/M/R/T/bracketright/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/w/x/y/z/tilde) /FontFile 11 0 R >> endobj 37 0 obj [639 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 575 0 319 383 319 0 0 0 0 0 575 575 0 0 0 0 319 0 0 0 0 0 0 0 0 831 882 756 724 0 0 436 0 0 0 1092 0 0 0 0 862 0 800 0 0 0 0 0 0 0 0 319 0 0 0 559 639 511 639 527 351 575 639 319 0 607 319 958 639 575 639 607 474 454 447 639 0 831 607 607 511 0 0 0 575 ] endobj 36 0 obj << /Type /Encoding /Differences [ 0 /.notdef 12/fi 13/.notdef 42/asterisk 43/.notdef 44/comma/hyphen/period 47/.notdef 52/four/five 54/.notdef 58/colon 59/.notdef 67/C/D/E/F 71/.notdef 73/I 74/.notdef 77/M 78/.notdef 82/R 83/.notdef 84/T 85/.notdef 93/bracketright 94/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u 118/.notdef 119/w/x/y/z 123/.notdef 126/tilde 127/.notdef] >> endobj 8 0 obj << /Length1 1106 /Length2 4777 /Length3 532 /Length 5490 /Filter /FlateDecode >> stream x???e\?k???r???H?0 ??H7?:?  1?Hw????H#% !)]?(?? ?zf??w????s>??y?/??u????g??? A v(?*? ?@??J???! D@???C? E#P??P4L ???X?|??h????Ysa= ????8u?-??;?~?,???7g?o?????g???8]?/??B??MU3??au??? ??e?"K^??'?K?!????| ?Pm7? ??????f7b??D?k*????y?????@??????f???6?,? ?~l????2????????B?3]bz?r?( q D??????8?????MK????3??r?T???Hzg??$e??`:9??n???;??????f?|?L??U??? f??Z? G???Hx'?U?}z-???an{(e^1??TL??0?U??'??????????*I?????P;%????? :nz???q?N^[1 ???}n???????v["?l{????????a????%???????%y???1?ls?Z?u>???????s?!??b`r??6?|>??e? !??a?d??[k]{?????=F&?Y???%=????D??5ag?C?+Q?pP???5>;????H??i?W?? ?cJ[-\???????XQ?+???Y??? O????'?G???&U??zh?GS??e?x?Gs?p??.??? /?<)??-??42???N?#:;y??K??p-v???;?5j??ogbE?|a?? ?+???kC yS[??????e??????U??qST&??i6???qO[4??Z h#??z??.H??(?H????????/z_??9????py???FDC?O???-??L???6>???????YC;6???%????M?J????#_?Z????X????"???|?Z?hT?;?f2q*)<6??_??p?t????.????o?q??i????6g????f<?? ???f4???D???EK9????T??N?zw?i??m?j_?????O^TD?t??9rd?8?)M?c /-????5? ???!????@_???q?t?.???WTg?s??? ??+w?E???h????^g?Y?s7?;?(@?y:%???3?DZ?* N/?????.;wc^?q?e=??? ?L?????R?+Pe? W??2#??{4a #???^?g????(J?&?1?s?h?I?M>?6??Z?Q? ??~??a?????Eu&?'?:?K9????d?w?= ??N????G??? ?E+Pa????g???????~??H??]??d??5=jm??O??lx????C ?`?N????;??@M??X??^??#?J??;94}?w??;1????0????X?m C0eYK?1?Kx? VD%??W?(?cf??{5aM?????u????? ???q2 ??W??N????@?5???@kM?nK???? !?D???^????/?{n/?Tpx? ?Wm?w?????K$?m?l?E???]%???W????f?&????9_;0?hA???????.[,?S?(?K ??~~tg??<?BQ???]>t???z??$h?w??t1???/??? [c?t?:aW?F???*???W??f?N?U?a?????? \?6z????????!~?4Y????b?????WEa??ihbB???c??kb?"???Y??^?#3a?????b??yt)?mDl?1?[?H?z?n?a^t?z?Kk??i????sk?\U?*??? ?+|??l>?$;?T[k???DJ??,???4???iTN??n ??6?????,??e?W#\keV4??? p????Q??^??z?j????.?F????JZ{ba?:O at l????> @??S?? P?????d??z??G???zRG;??????dS^?9??????'????????=???=???N???Q??d???i???'q???9????=?????4?%?S ?}???R???,???-z????2 vtr???r?;-a?c?'??F??0??:?r?h4?f 9?? ? ?_?~c????N*,??? j??? da'??/?????d?'?)???*&????nRO??I??b Uo3????????????qp7[?????r^FZ?!??0?%??q? ?? o0Y?[N??)E?????????[?A??????????x??n?}???Q[z???Y???????Pb&?c1?????nx???b?v)+h?8%??r??,?O?l??P2?5?}??@T%??????H?? J?????~?!????B???T? ]?x?e^~6 ?oI) ??Y???gB#O?Om)????NfE????gT??I???)???hv?9??\+?(?|L?,?[ ?8?????:?uN??:???(> ?X??P K??;????`???7???J?Bar?#??i?SS? 1??K??????I????V???#XO]v?R?|v>$r??hn?;z?}T?( ?k?s%??MPC???.p??!~?A???x?OA@PF??? EO???????????WPX???a|#????p???R"i7??R????VW?\t????|??Y????X)?/??(?Tm??????a?oa???w?5}????-??]|??:?????=b??{??&U??F?9??$m??\??O??,?/???+{??m?sU?W/> endobj 7 0 obj << /Ascent 694 /CapHeight 686 /Descent -194 /FontName /FFIEEE+CMBX12 /ItalicAngle 0 /StemV 109 /XHeight 444 /FontBBox [-53 -251 1139 750] /Flags 4 /CharSet (/slash/A/C/E/G/I/P/R/a/b/c/e/g/h/i/l/m/n/o/p/r/s/t/u/v/y) /FontFile 8 0 R >> endobj 39 0 obj [562 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 850 0 812 0 738 0 884 0 419 0 0 0 0 0 0 769 0 839 0 0 0 0 0 0 0 0 0 0 0 0 0 0 547 625 500 0 513 0 562 625 312 0 0 312 937 625 562 625 0 459 444 437 625 594 0 0 594 ] endobj 38 0 obj << /Type /Encoding /Differences [ 0 /.notdef 47/slash 48/.notdef 65/A 66/.notdef 67/C 68/.notdef 69/E 70/.notdef 71/G 72/.notdef 73/I 74/.notdef 80/P 81/.notdef 82/R 83/.notdef 97/a/b/c 100/.notdef 101/e 102/.notdef 103/g/h/i 106/.notdef 108/l/m/n/o/p 113/.notdef 114/r/s/t/u/v 119/.notdef 121/y 122/.notdef] >> endobj 5 0 obj << /Length1 981 /Length2 3845 /Length3 532 /Length 4511 /Filter /FlateDecode >> stream x???WXS???P:(EQ'??PB?% [117 lines skipped] --- /project/slime/cvsroot/slime/doc/slime-refcard.tex 2007/08/09 09:18:50 NONE +++ /project/slime/cvsroot/slime/doc/slime-refcard.tex 2007/08/09 09:18:50 1.1 [240 lines skipped] From trittweiler at common-lisp.net Wed Aug 15 13:45:43 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 15 Aug 2007 09:45:43 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070815134543.AFDA83F003@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4199 Modified Files: slime.el Log Message: Make `M-.' work on definitions outside the current restriction. `M-,' will also properly restore the narrowing as of before the jump. Similiarly for quiting from the compilation notes buffer and the Xref buffers. * slime.el (slime-narrowing-configuration, slime-emacs-snapshot), (current-slime-narrowing-configuration), (set-slime-narrowing-configuration), (current-slime-emacs-snapshot), (set-slime-emacs-snapshot), (current-slime-emacs-snapshot-fingerprint): New. Emacs' window configurations do not restore narrowing, so introduce a snapshot facility that contains the necessary information. * slime.el: Various renaming and adaptions in the Slime temp buffer, xref, goto-definition and compilation notes section to use the newly introduced snapshots instead of mere window configurations. * slime.el: (slime-highlight-notes, slime-remove-old-overlays): Still operate on whole buffer, but restore previous restriction if there was any. (slime-goto-location-position): Now widens the buffer to properly jump to definitions outside of the current restriction. * slime.el (slime-push-definition-stack), (slime-pop-find-definition-stack): Now also stores information about narrowing on the definition stack, in order to properly restore narrowing on `M-,'. * slime.el (def-slime-test narrowing): Test case for properly dealing with narrowing. * slime.el (slime-buffer-narrowed-p): New function, tests whether the current buffer is narrowed or not. (save-restriction-if-possibly): Like `save-restriction', but not as strict---see doc string. * slime.el (slime-length=): New function; semantically the same as (= (length seq) n), but more efficiently implemented for lists. Changed the above pattern into a call to SLIME-LENGTH= where appropriate. --- /project/slime/cvsroot/slime/slime.el 2007/08/02 15:42:23 1.795 +++ /project/slime/cvsroot/slime/slime.el 2007/08/15 13:45:43 1.796 @@ -1192,20 +1192,87 @@ (put 'slime-with-rigid-indentation 'lisp-indent-function 1) +;;;;; Snapshots of current Emacs state + +;;; Window configurations do not save (and hence not restore) +;;; any narrowing that could be applied to a buffer. +;;; +;;; For this purpose, we introduce a superset of a window +;;; configuration that does include the necessary information to +;;; properly restore narrowing. +;;; +;;; We call this superset an Emacs Snapshot. + +(defstruct (slime-narrowing-configuration + (:conc-name slime-narrowing-configuration.)) + narrowedp beg end) + +(defstruct (slime-emacs-snapshot (:conc-name slime-emacs-snapshot.)) + window-configuration narrowing-configuration) + +(defun current-slime-narrowing-configuration (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (make-slime-narrowing-configuration :narrowedp (slime-buffer-narrowed-p) + :beg (point-min-marker) + :end (point-max-marker)))) + +(defun set-slime-narrowing-configuration (narrowing-cfg) + (when (slime-narrowing-configuration.narrowedp narrowing-cfg) + (narrow-to-region (slime-narrowing-configuration.beg narrowing-cfg) + (slime-narrowing-configuration.end narrowing-cfg)))) + +(defun current-slime-emacs-snapshot (&optional frame) + "Returns a snapshot of the current state of FRAME, or the +currently active frame if FRAME is not given respectively." + (with-current-buffer + (if frame + (window-buffer (frame-selected-window (selected-frame))) + (current-buffer)) + (make-slime-emacs-snapshot + :window-configuration (current-window-configuration frame) + :narrowing-configuration (current-slime-narrowing-configuration)))) + +(defun set-slime-emacs-snapshot (snapshot) + "Restores the state of Emacs according to the information saved +in SNAPSHOT." + (let ((window-cfg (slime-emacs-snapshot.window-configuration snapshot)) + (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot))) + (set-window-configuration window-cfg) ; restores previously current buffer. + (set-slime-narrowing-configuration narrowing-cfg))) + +(defun current-slime-emacs-snapshot-fingerprint (&optional frame) + "Return a fingerprint of the current emacs snapshot. +Fingerprints are `equalp' if and only if they represent window +configurations that are very similar (same windows and buffers.) + +Unlike real window-configuration objects, fingerprints are not +sensitive to the point moving and they can't be restored." + (mapcar (lambda (window) (list window (window-buffer window))) + (slime-frame-windows frame))) + +(defun slime-frame-windows (&optional frame) + "Return the list of windows in FRAME." + (loop with last-window = (previous-window (frame-first-window frame)) + for window = (frame-first-window frame) then (next-window window) + collect window + until (eq window last-window))) + + ;;;;; Temporary popup buffers (make-variable-buffer-local - (defvar slime-temp-buffer-saved-window-configuration nil - "The window configuration before the temp-buffer was displayed. + (defvar slime-temp-buffer-saved-emacs-snapshot nil + "The snapshot of the current state in Emacs before the temp-buffer +was displayed, so that this state can be restored later on. Buffer local in temp-buffers.")) (make-variable-buffer-local - (defvar slime-temp-buffer-fingerprint nil - "The window config \"fingerprint\" after displaying the buffer.")) + (defvar slime-temp-buffer-saved-fingerprint nil + "The emacs snapshot \"fingerprint\" after displaying the buffer.")) ;; Interface (defun* slime-get-temp-buffer-create (name &key mode noselectp reusep - window-configuration) + emacs-snapshot) "Return a fresh temporary buffer called NAME in MODE. The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing `q' in the buffer will restore the window configuration to the way it @@ -1217,23 +1284,22 @@ If REUSEP is true and a buffer does already exist with name NAME, then the buffer will be reused instead of being killed. -If WINDOW-CONFIGURATION is non-NIL, it's used to restore the -original window configuration after closing the temporary -buffer. Otherwise, the current configuration will be saved and -that one used for restoration then. +If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous +state of Emacs after closing the temporary buffer. Otherwise, the +current state will be saved and later restored. " - (let ((window-config (or window-configuration (current-window-configuration))) + (let ((snapshot (or emacs-snapshot (current-slime-emacs-snapshot))) (buffer (get-buffer name))) (when (and buffer (not reusep)) (kill-buffer name) (setq buffer nil)) (with-current-buffer (or buffer (get-buffer-create name)) (when mode - (let ((original-configuration slime-temp-buffer-saved-window-configuration) - (original-fingerprint slime-temp-buffer-fingerprint)) + (let ((original-configuration slime-temp-buffer-saved-emacs-snapshot) + (original-fingerprint slime-temp-buffer-saved-fingerprint)) (funcall mode) - (setq slime-temp-buffer-saved-window-configuration original-configuration) - (setq slime-temp-buffer-fingerprint original-fingerprint))) + (setq slime-temp-buffer-saved-emacs-snapshot original-configuration) + (setq slime-temp-buffer-saved-fingerprint original-fingerprint))) (slime-temp-buffer-mode 1) (let ((window (get-buffer-window (current-buffer)))) (if window @@ -1244,16 +1310,18 @@ (display-buffer (current-buffer) t) (pop-to-buffer (current-buffer)) (selected-window)) - (setq slime-temp-buffer-saved-window-configuration window-config) - (setq slime-temp-buffer-fingerprint (slime-window-config-fingerprint))))) + (setq slime-temp-buffer-saved-emacs-snapshot snapshot) + (setq slime-temp-buffer-saved-fingerprint + (current-slime-emacs-snapshot-fingerprint))))) (current-buffer)))) ;; Interface (defmacro* slime-with-output-to-temp-buffer ((name &key mode reusep) package &rest body) "Similar to `with-output-to-temp-buffer'. -Also saves the window configuration, and inherits the current -`slime-connection' in a buffer-local variable." +Also saves the current state of Emacs (window configuration &c), +and inherits the current `slime-connection' in a buffer-local +variable. Cf. `slime-get-temp-buffer-create'" `(let ((connection (slime-connection)) (standard-output (slime-get-temp-buffer-create ,name :mode ',mode :reusep ,reusep))) @@ -1281,34 +1349,16 @@ "Get rid of the current (temp) buffer without asking. Restore the window configuration unless it was changed since we last activated the buffer." (interactive) - (let ((saved-window-config slime-temp-buffer-saved-window-configuration) + (let ((snapshot slime-temp-buffer-saved-emacs-snapshot) (temp-buffer (current-buffer))) - (setq slime-temp-buffer-saved-window-configuration nil) - (if (and saved-window-config - (equalp (slime-window-config-fingerprint) - slime-temp-buffer-fingerprint)) - (set-window-configuration saved-window-config) + (setq slime-temp-buffer-saved-emacs-snapshot nil) + (if (and snapshot (equalp (current-slime-emacs-snapshot-fingerprint) + slime-temp-buffer-saved-fingerprint)) + (set-slime-emacs-snapshot snapshot) (bury-buffer)) (when kill-buffer-p (kill-buffer temp-buffer)))) -(defun slime-window-config-fingerprint (&optional frame) - "Return a fingerprint of the current window configuration. -Fingerprints are `equalp' if and only if they represent window -configurations that are very similar (same windows and buffers.) - -Unlike window-configuration objects fingerprints are not sensitive to -the point moving and they can't be restored." - (mapcar (lambda (window) (list window (window-buffer window))) - (slime-frame-windows frame))) - -(defun slime-frame-windows (&optional frame) - "Return the list of windows in FRAME." - (loop with last-window = (previous-window (frame-first-window frame)) - for window = (frame-first-window frame) then (next-window window) - collect window - until (eq window last-window))) - ;;;;; Filename translation ;;; ;;; Filenames passed between Emacs and Lisp should be translated using @@ -2519,7 +2569,7 @@ "Evaluate EXPR on the superior Lisp and call CONT with the result." (slime-rex (cont) (sexp (or package (slime-current-package))) - ((:ok result) + ((:ok result) (when cont (funcall cont result))) ((:abort &optional reason) (message (or reason "Evaluation aborted."))))) @@ -4649,17 +4699,17 @@ (save-buffer)) (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max)) (let ((lisp-filename (slime-to-lisp-filename (buffer-file-name))) - (window-config (current-window-configuration))) + (snapshot (current-slime-emacs-snapshot))) (slime-insert-transcript-delimiter (format "Compile file %s" lisp-filename)) - ;; The following may alter the current window-config, so we saved - ;; it, to pass it on for it to be restored! + ;; The following may alter the current window configuration, so we saved + ;; it above to pass it on for it to be properly restored! (when slime-display-compilation-output (slime-display-output-buffer)) (slime-eval-async `(swank:compile-file-for-emacs ,lisp-filename ,(if load t nil)) - (slime-make-compilation-finished-continuation (current-buffer) window-config)) + (slime-make-compilation-finished-continuation (current-buffer) snapshot)) (message "Compiling %s.." lisp-filename))) (defun slime-find-asd (system-names) @@ -4775,14 +4825,7 @@ (replace-match " ")) (buffer-string))) -(defun slime-length> (list n) - "Test if (length LIST) is greater than N." - (while (and (> n 0) list) - (setq list (cdr list)) - (decf n)) - list) - -(defun slime-compilation-finished (result buffer &optional window-config) +(defun slime-compilation-finished (result buffer &optional emacs-snapshot) (let ((notes (slime-compiler-notes))) (with-current-buffer buffer (setf slime-compilation-just-finished t) @@ -4790,20 +4833,22 @@ (slime-show-note-counts notes secs) (when slime-highlight-compiler-notes (slime-highlight-notes notes)))) - (run-hook-with-args 'slime-compilation-finished-hook notes window-config))) + (run-hook-with-args 'slime-compilation-finished-hook notes emacs-snapshot))) -(defun slime-make-compilation-finished-continuation (current-buffer &optional window-config) - (lexical-let ((buffer current-buffer) (config window-config)) +(defun slime-make-compilation-finished-continuation (current-buffer &optional emacs-snapshot) + (lexical-let ((buffer current-buffer) (snapshot emacs-snapshot)) (lambda (result) - (slime-compilation-finished result buffer config)))) + (slime-compilation-finished result buffer snapshot)))) (defun slime-highlight-notes (notes) "Highlight compiler notes, warnings, and errors in the buffer." (interactive (list (slime-compiler-notes))) (with-temp-message "Highlighting notes..." (save-excursion - (slime-remove-old-overlays) - (mapc #'slime-overlay-note (slime-merge-notes-for-display notes))))) + (save-restriction + (widen) ; highlight notes on the whole buffer + (slime-remove-old-overlays) + (mapc #'slime-overlay-note (slime-merge-notes-for-display notes)))))) (defun slime-compiler-notes () "Return all compiler notes, warnings, and errors." @@ -4814,12 +4859,14 @@ (dolist (buffer (slime-filter-buffers (lambda () slime-mode))) (with-current-buffer buffer (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (dolist (o (overlays-at (point))) - (when (overlay-get o 'slime) - (delete-overlay o))) - (goto-char (next-overlay-change (point)))))))) + (save-restriction + (widen) ; remove overlays within the whole buffer. + (goto-char (point-min)) + (while (not (eobp)) + (dolist (o (overlays-at (point))) + (when (overlay-get o 'slime) + (delete-overlay o))) + (goto-char (next-overlay-change (point))))))))) (defun slime-filter-buffers (predicate) "Return a list of where PREDICATE returns true. @@ -4877,33 +4924,33 @@ ;;;;; Compiler notes list -(defun slime-maybe-show-xrefs-for-notes (&optional notes window-config) +(defun slime-maybe-show-xrefs-for-notes (&optional notes emacs-snapshot) "Show the compiler notes NOTES if they come from more than one file." (let* ((notes (or notes (slime-compiler-notes))) (xrefs (slime-xrefs-for-notes notes))) - (when (> (length xrefs) 1) ; >1 file + (when (slime-length> xrefs 1) ; >1 file (slime-show-xrefs xrefs 'definition "Compiler notes" (slime-current-package) - window-config)))) + emacs-snapshot)))) (defun slime-note-has-location-p (note) (not (eq ':error (car (slime-note.location note))))) -(defun slime-maybe-list-compiler-notes (notes &optional window-config) +(defun slime-maybe-list-compiler-notes (notes &optional emacs-snapshot) "Show the compiler notes if appropriate." ;; don't pop up a buffer if all notes will are already annotated in ;; the buffer itself (unless (every #'slime-note-has-location-p notes) - (slime-list-compiler-notes notes window-config))) + (slime-list-compiler-notes notes emacs-snapshot))) -(defun slime-list-compiler-notes (notes &optional window-config) +(defun slime-list-compiler-notes (notes &optional emacs-snapshot) "Show the compiler notes NOTES in tree view." (interactive (list (slime-compiler-notes))) (with-temp-message "Preparing compiler note tree..." (with-current-buffer (slime-get-temp-buffer-create "*compiler notes*" :mode 'slime-compiler-notes-mode - :window-configuration window-config) + :emacs-snapshot emacs-snapshot) (let ((inhibit-read-only t)) (erase-buffer) (when (null notes) @@ -5011,7 +5058,7 @@ (cond ((not (slime-tree-leaf-p tree)) (slime-tree-toggle tree)) (t - (slime-show-source-location (slime-note.location note)))))) + (slime-show-source-location (slime-note.location note) t))))) ;;;;;; Tree Widget @@ -5291,41 +5338,43 @@ (goto-char (point-min)))))) (defun slime-goto-location-position (position) - (destructure-case position - ((:position pos &optional align-p) - (goto-char pos) - (when align-p - (slime-forward-sexp) - (beginning-of-sexp))) - ((:line start &optional column) - (goto-line start) - (cond (column (move-to-column column)) - (t (skip-chars-forward " \t")))) - ((:function-name name) - (let ((case-fold-search t) - (name (regexp-quote name))) - (or - (re-search-forward - (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t) - (re-search-forward - (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t) - (re-search-forward - (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))) - (goto-char (match-beginning 0))) - ((:method name specializers &rest qualifiers) - (slime-search-method-location name specializers qualifiers)) - ((:source-path source-path start-position) - (cond (start-position - (goto-char start-position) - (slime-forward-positioned-source-path source-path)) - (t - (slime-forward-source-path source-path)))) - ;; Goes to "start" then looks for the anchor text, then moves - ;; delta from that position. - ((:text-anchored start text delta) - (goto-char start) - (slime-isearch text) - (forward-char delta)))) + (save-restriction-if-possible ; try to keep restriction if possible. + (widen) + (destructure-case position + ((:position pos &optional align-p) + (goto-char pos) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) + ((:line start &optional column) + (goto-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (or + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t) + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t) + (re-search-forward + (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))) + (goto-char (match-beginning 0))) + ((:method name specializers &rest qualifiers) [341 lines skipped] From trittweiler at common-lisp.net Wed Aug 15 13:52:56 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 15 Aug 2007 09:52:56 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070815135256.A846C4E024@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4782 Modified Files: ChangeLog Log Message: Make `M-.' work on definitions outside the current restriction. `M-,' will also properly restore the narrowing as of before the jump. Similiarly for quiting from the compilation notes buffer and the Xref buffers. * slime.el (slime-narrowing-configuration, slime-emacs-snapshot), (current-slime-narrowing-configuration), (set-slime-narrowing-configuration), (current-slime-emacs-snapshot), (set-slime-emacs-snapshot), (current-slime-emacs-snapshot-fingerprint): New. Emacs' window configurations do not restore narrowing, so introduce a snapshot facility that contains the necessary information. * slime.el: Various renaming and adaptions in the Slime temp buffer, xref, goto-definition and compilation notes section to use the newly introduced snapshots instead of mere window configurations. * slime.el: (slime-highlight-notes, slime-remove-old-overlays): Still operate on whole buffer, but restore previous restriction if there was any. (slime-goto-location-position): Now widens the buffer to properly jump to definitions outside of the current restriction. * slime.el (slime-push-definition-stack), (slime-pop-find-definition-stack): Now also stores information about narrowing on the definition stack, in order to properly restore narrowing on `M-,'. * slime.el (def-slime-test narrowing): Test case for properly dealing with narrowing. * slime.el (slime-buffer-narrowed-p): New function, tests whether the current buffer is narrowed or not. (save-restriction-if-possibly): Like `save-restriction', but not as strict---see doc string. * slime.el (slime-length=): New function; semantically the same as (= (length seq) n), but more efficiently implemented for lists. Changed the above pattern into a call to SLIME-LENGTH= where appropriate. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/06 03:20:28 1.1141 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/15 13:52:56 1.1142 @@ -1,3 +1,48 @@ +2007-08-15 Tobias C. Rittweiler + + Make `M-.' work on definitions outside the current restriction. + `M-,' will also properly restore the narrowing as of before the + jump. Similiarly for quiting from the compilation notes buffer and + the Xref buffers. + + * slime.el (slime-narrowing-configuration, slime-emacs-snapshot), + (current-slime-narrowing-configuration), + (set-slime-narrowing-configuration), + (current-slime-emacs-snapshot), + (set-slime-emacs-snapshot), + (current-slime-emacs-snapshot-fingerprint): New. Emacs' window + configurations do not restore narrowing, so introduce a + snapshot facility that contains the necessary information. + + * slime.el: Various renaming and adaptions in the Slime temp + buffer, xref, goto-definition and compilation notes section to use + the newly introduced snapshots instead of mere window + configurations. + + * slime.el: (slime-highlight-notes, slime-remove-old-overlays): + Still operate on whole buffer, but restore previous restriction if + there was any. + (slime-goto-location-position): Now widens the buffer to properly + jump to definitions outside of the current restriction. + + * slime.el (slime-push-definition-stack), + (slime-pop-find-definition-stack): Now also stores information + about narrowing on the definition stack, in order to properly + restore narrowing on `M-,'. + + * slime.el (def-slime-test narrowing): Test case for properly + dealing with narrowing. + + * slime.el (slime-buffer-narrowed-p): New function, tests whether + the current buffer is narrowed or not. + (save-restriction-if-possibly): Like `save-restriction', but not + as strict---see doc string. + + * slime.el (slime-length=): New function; semantically the same + as (= (length seq) n), but more efficiently implemented for lists. + Changed the above pattern into a call to SLIME-LENGTH= where + appropriate. + 2007-08-05 Matthias Koeppe * swank.lisp (backtrace): Handle printer errors while printing a From trittweiler at common-lisp.net Wed Aug 15 15:10:29 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 15 Aug 2007 11:10:29 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070815151029.5A851431BE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21036 Modified Files: slime.el Log Message: * slime.el (slime-process-available-input): Make sure that the event received from SWANK is processed in the context of the original buffer the request of the response was performed in. Previously, the clauses of `slime-rex' were processed in the internal *cl-connection* buffer. And as a result the continuations passed to `slime-eval' and `slime-eval-async' ditto. --- /project/slime/cvsroot/slime/slime.el 2007/08/15 13:45:43 1.796 +++ /project/slime/cvsroot/slime/slime.el 2007/08/15 15:10:29 1.797 @@ -2006,22 +2006,23 @@ (defun slime-process-available-input (process) "Process all complete messages that have arrived from Lisp." - (with-current-buffer (process-buffer process) - (while (slime-net-have-input-p) - (let ((event (condition-case error - (slime-net-read) - (error - (slime-net-close process t) - (error "net-read error: %S" error))))) - (slime-log-event event) - (let ((ok nil)) - (unwind-protect - (save-current-buffer - (slime-dispatch-event event process) - (setq ok t)) - (unless ok - (slime-run-when-idle - 'slime-process-available-input process)))))))) + (let ((original-buffer (current-buffer))) + (with-current-buffer (process-buffer process) + (while (slime-net-have-input-p) + (let ((event (condition-case error + (slime-net-read) + (error + (slime-net-close process t) + (error "net-read error: %S" error))))) + (slime-log-event event) + (let ((ok nil)) + (unwind-protect + (with-current-buffer original-buffer + (slime-dispatch-event event process) + (setq ok t)) + (unless ok + (slime-run-when-idle + 'slime-process-available-input process))))))))) (defun slime-net-have-input-p () "Return true if a complete message is available." From trittweiler at common-lisp.net Wed Aug 15 15:11:24 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 15 Aug 2007 11:11:24 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070815151124.A27F74E024@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21139 Modified Files: ChangeLog Log Message: * slime.el (slime-process-available-input): Make sure that the event received from SWANK is processed in the context of the original buffer the request of the response was performed in. Previously, the clauses of `slime-rex' were processed in the internal *cl-connection* buffer. And as a result the continuations passed to `slime-eval' and `slime-eval-async' ditto. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/15 13:52:56 1.1142 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/15 15:11:24 1.1143 @@ -1,5 +1,14 @@ 2007-08-15 Tobias C. Rittweiler + * slime.el (slime-process-available-input): Make sure that the + event received from SWANK is processed in the context of the + original buffer the request of the response was performed in. + Previously, the clauses of `slime-rex' were processed in the + internal *cl-connection* buffer. And as a result the continuations + passed to `slime-eval' and `slime-eval-async' ditto. + +2007-08-15 Tobias C. Rittweiler + Make `M-.' work on definitions outside the current restriction. `M-,' will also properly restore the narrowing as of before the jump. Similiarly for quiting from the compilation notes buffer and From trittweiler at common-lisp.net Thu Aug 16 08:26:48 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 16 Aug 2007 04:26:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070816082648.1691549024@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7740 Modified Files: slime.el Log Message: * slime.el (slime-process-available-input): Correct yesterday's change: the buffer a request was originally performed in doesn't necessarily exist at this time anymore, so we check for buffer liveness now. The problem arised when quitting in SLDB which would cause Swank to send a `:debug-return' message before the acknowledgement message for `sldb-quit' is sent. So the acknowledgement is received in a context where the sldb-buffer is closed already. --- /project/slime/cvsroot/slime/slime.el 2007/08/15 15:10:29 1.797 +++ /project/slime/cvsroot/slime/slime.el 2007/08/16 08:26:33 1.798 @@ -2017,7 +2017,10 @@ (slime-log-event event) (let ((ok nil)) (unwind-protect - (with-current-buffer original-buffer + (with-current-buffer + (if (buffer-live-p original-buffer) + original-buffer + (current-buffer)) (slime-dispatch-event event process) (setq ok t)) (unless ok From trittweiler at common-lisp.net Thu Aug 16 08:28:08 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 16 Aug 2007 04:28:08 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070816082808.28D6E4B02A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7814 Modified Files: ChangeLog Log Message: * slime.el (slime-process-available-input): Correct yesterday's change: the buffer a request was originally performed in doesn't necessarily exist at this time anymore, so we check for buffer liveness now. The problem arised when quitting in SLDB which would cause Swank to send a `:debug-return' message before the acknowledgement message for `sldb-quit' is sent. So the acknowledgement is received in a context where the sldb-buffer is closed already. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/15 15:11:24 1.1143 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/16 08:27:31 1.1144 @@ -1,3 +1,15 @@ +2007-08-16 Tobias C. Rittweiler + + * slime.el (slime-process-available-input): Correct yesterday's + change: the buffer a request was originally performed in doesn't + necessarily exist at this time anymore, so we check for buffer + liveness now. + + The problem arised when quitting in SLDB which would cause Swank + to send a `:debug-return' message before the acknowledgement + message for `sldb-quit' is sent. So the acknowledgement is + received in a context where the sldb-buffer is closed already. + 2007-08-15 Tobias C. Rittweiler * slime.el (slime-process-available-input): Make sure that the From heller at common-lisp.net Sun Aug 19 11:12:57 2007 From: heller at common-lisp.net (heller) Date: Sun, 19 Aug 2007 07:12:57 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070819111257.235DB1C0BA@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv3000/contrib Log Message: Directory /project/slime/cvsroot/slime/contrib added to the repository --> Using per-directory sticky tag `contrib' From heller at common-lisp.net Sun Aug 19 11:19:32 2007 From: heller at common-lisp.net (heller) Date: Sun, 19 Aug 2007 07:19:32 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070819111932.A77834E022@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv3412/contrib Added Files: Tag: contrib ChangeLog README slime-fuzzy.el swank-fuzzy.lisp Log Message: Add a contrib directory and move fuzzy completion code to that directory. * contrib: New directory. * swank.lisp (swank-require): New function to load contrib code. (*find-module*, module-filename, *load-path*, merged-directory) (find-module, module-canditates): New. Pathname acrobatics for swank-require. * swank-loader.lisp: Compile (but don't load) contribs. (*contribs*, contrib-source-files): New. * contrib/slime-fuzzy.el: New file. (slime-fuzzy-init): New function. Load CL code on startup. * contrib/swank-fuzzy.lisp: New file. Common Lisp code for fuzzy completion. From trittweiler at common-lisp.net Wed Aug 22 21:40:22 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 22 Aug 2007 17:40:22 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070822214022.984FC37053@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv30455 Modified Files: slime.el Log Message: * slime.el (slime-close-all-parens-in-sexp): Fix interplay with `slime-close-parens-limit'. This should also affect `slime-complete-form' (C-c C-s) in a positive way. --- /project/slime/cvsroot/slime/slime.el 2007/08/16 08:26:33 1.798 +++ /project/slime/cvsroot/slime/slime.el 2007/08/22 21:40:22 1.799 @@ -865,7 +865,7 @@ [ "List Callees..." slime-list-callees ,C ] [ "Next Location" slime-next-location t ]) ("Editing" - [ "Close All Parens" slime-close-all-sexp t] + [ "Close All Parens" slime-close-all-parens-in-sexp t] [ "Check Parens" check-parens t] [ "Update Indentation" slime-update-indentation ,C] [ "Select Buffer" slime-selector t]) @@ -9935,15 +9935,16 @@ (setq point (point)) (skip-chars-forward " \t\n)") (skip-chars-backward " \t\n") - (delete-region point (point)) - ;; We always insert as many parentheses as necessary, and only - ;; afterwards delete the superfluously-added parens because of - ;; "extra right parens" above (which is done this way, since the - ;; code works with regexps and it's hard to keep track of those - ;; extra right parentheses this way.) - (when slime-close-parens-limit - (dotimes (i (max 0 (- sexp-level slime-close-parens-limit))) - (delete-char -1)))))) + (let* ((deleted-region (delete-and-extract-region point (point))) + (deleted-text (substring-no-properties deleted-region)) + (prior-parens-count (count ?\) deleted-text))) + ;; Remember: we always insert as many parentheses as necessary + ;; and only afterwards delete the superfluously-added parens. + (when slime-close-parens-limit + (let ((missing-parens (- sexp-level prior-parens-count + slime-close-parens-limit))) + (dotimes (i (max 0 missing-parens)) + (delete-char -1)))))))) (defvar slime-close-parens-limit nil "Maxmimum parens for `slime-close-all-sexp' to insert. NIL From trittweiler at common-lisp.net Wed Aug 22 21:41:00 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 22 Aug 2007 17:41:00 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070822214100.9A2337E007@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv32177 Modified Files: ChangeLog Log Message: * slime.el (slime-close-all-parens-in-sexp): Fix interplay with `slime-close-parens-limit'. This should also affect `slime-complete-form' (C-c C-s) in a positive way. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/16 08:27:31 1.1144 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/22 21:41:00 1.1145 @@ -1,3 +1,9 @@ +2007-08-22 Tobias C. Rittweiler + + * slime.el (slime-close-all-parens-in-sexp): Fix interplay with + `slime-close-parens-limit'. This should also affect + `slime-complete-form' (C-c C-s) in a positive way. + 2007-08-16 Tobias C. Rittweiler * slime.el (slime-process-available-input): Correct yesterday's From heller at common-lisp.net Thu Aug 23 12:58:52 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 08:58:52 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070823125852.B99B172C1@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv31985/contrib Added Files: ChangeLog README slime-fuzzy.el swank-fuzzy.lisp Log Message: Merge contrib branch. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/19 11:19:32 1.1 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/23 12:58:52 1.2 @@ -0,0 +1,9 @@ +2007-08-19 Helmut Eller + + Moved fuzzy completion code to contrib directory. + + * slime-fuzzy.el: New file. + (slime-fuzzy-init): New function. Load CL code on startup. + + * swank-fuzzy.lisp: New file. Common Lisp code for fuzzy + completion. --- /project/slime/cvsroot/slime/contrib/README 2007/08/19 11:19:32 1.1 +++ /project/slime/cvsroot/slime/contrib/README 2007/08/23 12:58:52 1.2 @@ -0,0 +1,15 @@ +This directory contains source code which may be useful to some Slime +users. *.el files are Emacs Lisp source and *.lisp files contain +Common Lisp source code. If not otherwise stated in the file itself, +the files are placed in the Public Domain. + +The components in this directory are more or less detached from the +rest of Slime. They are essentially "add-ons". But Slime can also be +used without them. The code is maintained by the respective authors. + +To use the packages here, you should add this directory to your Emacs +load-path. E.g. for fuzzy completion add this to your .emacs: + + (add-to-list 'load-path "") + (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy))) + --- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2007/08/19 11:19:32 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2007/08/23 12:58:52 1.2 @@ -0,0 +1,609 @@ +;;; slime-fuzzy.el --- fuzzy symbol completion +;; +;; Author: Brian Downing and others +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy))) +;; + + +;;; Code + +(defcustom slime-fuzzy-completion-in-place t + "When non-NIL the fuzzy symbol completion is done in place as +opposed to moving the point to the completion buffer." + :group 'slime-mode + :type 'boolean) + +(defcustom slime-fuzzy-completion-limit 300 + "Only return and present this many symbols from swank." + :group 'slime-mode + :type 'integer) + +(defcustom slime-fuzzy-completion-time-limit-in-msec 1500 + "Limit the time spent (given in msec) in swank while gathering comletitions. +\(NOTE: currently it's rounded up the nearest second)" + :group 'slime-mode + :type 'integer) + +(defvar slime-fuzzy-target-buffer nil + "The buffer that is the target of the completion activities.") +(defvar slime-fuzzy-saved-window-configuration nil + "The saved window configuration before the fuzzy completion +buffer popped up.") +(defvar slime-fuzzy-start nil + "The beginning of the completion slot in the target buffer. +This is a non-advancing marker.") +(defvar slime-fuzzy-end nil + "The end of the completion slot in the target buffer. +This is an advancing marker.") +(defvar slime-fuzzy-original-text nil + "The original text that was in the completion slot in the +target buffer. This is what is put back if completion is +aborted.") +(defvar slime-fuzzy-text nil + "The text that is currently in the completion slot in the +target buffer. If this ever doesn't match, the target buffer has +been modified and we abort without touching it.") +(defvar slime-fuzzy-first nil + "The position of the first completion in the completions buffer. +The descriptive text and headers are above this.") +(defvar slime-fuzzy-last nil + "The position of the last completion in the completions buffer. +If the time limit has exhausted during generation possible completion +choices inside SWANK, an indication is printed below this.") +(defvar slime-fuzzy-current-completion nil + "The current completion object. If this is the same before and +after point moves in the completions buffer, the text is not +replaced in the target for efficiency.") +(defvar slime-fuzzy-current-completion-overlay nil + "The overlay representing the current completion in the completion +buffer. This is used to hightlight the text.") + +;;;;;;; slime-target-buffer-fuzzy-completions-mode +;; NOTE: this mode has to be able to override key mappings in slime-mode + +;; FIXME: clean this up + +(defun mimic-key-bindings (from-keymap to-keymap bindings-or-operation operation) + "Iterate on BINDINGS-OR-OPERATION. If an element is a symbol then +try to look it up (as an operation) in FROM-KEYMAP. Non symbols are taken +as default key bindings when none to be mimiced was found in FROM-KEYMAP. +Set the resulting list of keys in TO-KEYMAP to OPERATION." + (let ((mimic-keys nil) + (direct-keys nil)) + (dolist (key-or-operation bindings-or-operation) + (if (symbolp key-or-operation) + (setf mimic-keys (append mimic-keys (where-is-internal key-or-operation from-keymap nil t))) + (push key-or-operation direct-keys))) + (dolist (key (or mimic-keys direct-keys)) + (define-key to-keymap key operation)))) + +(defvar slime-target-buffer-fuzzy-completions-map + (let* ((map (make-sparse-keymap))) + (flet ((remap (keys to) + (mimic-key-bindings global-map map keys to))) + + (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort) + + (remap (list 'slime-fuzzy-indent-and-complete-symbol + 'slime-indent-and-complete-symbol + (kbd "")) + 'slime-fuzzy-select-or-update-completions) + (remap (list 'previous-line (kbd "")) 'slime-fuzzy-prev) + (remap (list 'next-line (kbd "")) 'slime-fuzzy-next) + (remap (list 'isearch-forward (kbd "C-s")) + (lambda () + (interactive) + (select-window (get-buffer-window (slime-get-fuzzy-buffer))) + (call-interactively 'isearch-forward))) + + ;; some unconditional direct bindings + (dolist (key (list (kbd "") (kbd "RET") (kbd "") "(" ")" "[" "]")) + (define-key map key 'slime-fuzzy-select-and-process-event-in-target-buffer))) + map + ) + "Keymap for slime-target-buffer-fuzzy-completions-mode. This will override the key +bindings in the target buffer temporarily during completion.") + +;; Make sure slime-fuzzy-target-buffer-completions-mode's map is +;; before everything else. +(setf minor-mode-map-alist + (stable-sort minor-mode-map-alist + (lambda (a b) + (eq a 'slime-fuzzy-target-buffer-completions-mode)) + :key #'car)) + + +(define-minor-mode slime-fuzzy-target-buffer-completions-mode + "This minor mode is intented to override key bindings during fuzzy +completions in the target buffer. Most of the bindings will do an implicit select +in the completion window and let the keypress be processed in the target buffer." + nil + nil + slime-target-buffer-fuzzy-completions-map) + +(add-to-list 'minor-mode-alist + '(slime-fuzzy-target-buffer-completions-mode + " Fuzzy Target Buffer Completions")) + +(define-derived-mode slime-fuzzy-completions-mode + fundamental-mode "Fuzzy Completions" + "Major mode for presenting fuzzy completion results. + +When you run `slime-fuzzy-complete-symbol', the symbol token at +point is completed using the Fuzzy Completion algorithm; this +means that the token is taken as a sequence of characters and all +the various possibilities that this sequence could meaningfully +represent are offered as selectable choices, sorted by how well +they deem to be a match for the token. (For instance, the first +choice of completing on \"mvb\" would be \"multiple-value-bind\".) + +Therefore, a new buffer (*Fuzzy Completions*) will pop up that +contains the different completion choices. Simultaneously, a +special minor-mode will be temporarily enabled in the original +buffer where you initiated fuzzy completion (also called the +``target buffer'') in order to navigate through the *Fuzzy +Completions* buffer without leaving. + +With focus in *Fuzzy Completions*: + Type `n' and `p' (`UP', `DOWN') to navigate between completions. + Type `RET' or `TAB' to select the completion near point. + Type `q' to abort. + +With focus in the target buffer: + Type `UP' and `DOWN' to navigate between completions. + Type a character that does not constitute a symbol name + to insert the current choice and then that character (`(', `)', + `SPACE', `RET'.) Use `TAB' to simply insert the current choice. + Use C-g to abort. + +Alternatively, you can click on a completion to select it. + + +Complete listing of keybindings within the target buffer: + +\\\ +\\{slime-target-buffer-fuzzy-completions-map} + +Complete listing of keybindings with *Fuzzy Completions*: + +\\\ +\\{slime-fuzzy-completions-map}" + (use-local-map slime-fuzzy-completions-map)) + +(defvar slime-fuzzy-completions-map + (let* ((map (make-sparse-keymap))) + (flet ((remap (keys to) + (mimic-key-bindings global-map map keys to))) + (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort) + (define-key map "q" 'slime-fuzzy-abort) + + (remap (list 'previous-line (kbd "")) 'slime-fuzzy-prev) + (remap (list 'next-line (kbd "")) 'slime-fuzzy-next) + + (define-key map "n" 'slime-fuzzy-next) + (define-key map "\M-n" 'slime-fuzzy-next) + + (define-key map "p" 'slime-fuzzy-prev) + (define-key map "\M-p" 'slime-fuzzy-prev) + + (define-key map "\d" 'scroll-down) + + (remap (list 'slime-fuzzy-indent-and-complete-symbol + 'slime-indent-and-complete-symbol + (kbd "")) + 'slime-fuzzy-select) + + (define-key map (kbd "") 'slime-fuzzy-select/mouse)) + + (define-key map (kbd "RET") 'slime-fuzzy-select) + (define-key map (kbd "") 'slime-fuzzy-select) + + map) + "Keymap for slime-fuzzy-completions-mode when in the completion buffer.") + +(defun slime-fuzzy-completions (prefix &optional default-package) + "Get the list of sorted completion objects from completing +`prefix' in `package' from the connected Lisp." + (let ((prefix (etypecase prefix + (symbol (symbol-name prefix)) + (string prefix)))) + (slime-eval `(swank:fuzzy-completions ,prefix + ,(or default-package + (slime-find-buffer-package) + (slime-current-package)) + :limit ,slime-fuzzy-completion-limit + :time-limit-in-msec ,slime-fuzzy-completion-time-limit-in-msec)))) + +(defun slime-fuzzy-selected (prefix completion) + "Tell the connected Lisp that the user selected completion +`completion' as the completion for `prefix'." + (let ((no-properties (copy-sequence prefix))) + (set-text-properties 0 (length no-properties) nil no-properties) + (slime-eval `(swank:fuzzy-completion-selected ,no-properties + ',completion)))) + +(defun slime-fuzzy-indent-and-complete-symbol () + "Indent the current line and perform fuzzy symbol completion. First +indent the line. If indenting doesn't move point, complete the +symbol. If there's no symbol at the point, show the arglist for the +most recently enclosed macro or function." + (interactive) + (let ((pos (point))) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (slime-fuzzy-complete-symbol)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(defun* slime-fuzzy-complete-symbol () + "Fuzzily completes the abbreviation at point into a symbol." + (interactive) + (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) + (return-from slime-fuzzy-complete-symbol + (if slime-when-complete-filename-expand + (comint-replace-by-expanded-filename) + (comint-dynamic-complete-as-filename)))) + (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) + (beg (move-marker (make-marker) (slime-symbol-start-pos))) + (prefix (buffer-substring-no-properties beg end))) + (destructuring-bind (completion-set interrupted-p) + (slime-fuzzy-completions prefix) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-fuzzy-done)) + (goto-char end) + (cond ((slime-length= completion-set 1) + (insert-and-inherit (caar completion-set)) ; insert completed string + (delete-region beg end) + (goto-char (+ beg (length (caar completion-set)))) + (slime-minibuffer-respecting-message "Sole completion") + (slime-fuzzy-done)) + ;; Incomplete + (t + (slime-minibuffer-respecting-message "Complete but not unique") + (slime-fuzzy-choices-buffer completion-set interrupted-p beg end))))))) + + +(defun slime-get-fuzzy-buffer () + (get-buffer-create "*Fuzzy Completions*")) + +(defvar slime-fuzzy-explanation + "For help on how the use this buffer, see `slime-fuzzy-completions-mode'. + +Flags: boundp fboundp generic-function class macro special-operator package +\n" + "The explanation that gets inserted at the beginning of the +*Fuzzy Completions* buffer.") + +(defun slime-fuzzy-insert-completion-choice (completion max-length) + "Inserts the completion object `completion' as a formatted +completion choice into the current buffer, and mark it with the +proper text properties." + (let ((start (point)) + (symbol-name (first completion)) + (score (second completion)) + (chunks (third completion)) + (flags (fourth completion))) + (insert symbol-name) + (let ((end (point))) + (dolist (chunk chunks) + (put-text-property (+ start (first chunk)) + (+ start (first chunk) + (length (second chunk))) + 'face 'bold)) + (put-text-property start (point) 'mouse-face 'highlight) + (dotimes (i (- max-length (- end start))) + (insert " ")) + (insert (format " %s%s%s%s%s%s%s %8.2f" + (if (member :boundp flags) "b" "-") + (if (member :fboundp flags) "f" "-") + (if (member :generic-function flags) "g" "-") + (if (member :class flags) "c" "-") + (if (member :macro flags) "m" "-") + (if (member :special-operator flags) "s" "-") + (if (member :package flags) "p" "-") + score)) + (insert "\n") + (put-text-property start (point) 'completion completion)))) + +(defun slime-fuzzy-insert (text) + "Inserts `text' into the target buffer in the completion slot. +If the buffer has been modified in the meantime, abort the +completion process. Otherwise, update all completion variables +so that the new text is present." + (with-current-buffer slime-fuzzy-target-buffer + (cond + ((not (string-equal slime-fuzzy-text + (buffer-substring slime-fuzzy-start + slime-fuzzy-end))) + (slime-fuzzy-done) + (beep) + (message "Target buffer has been modified!")) + (t + (goto-char slime-fuzzy-start) + (delete-region slime-fuzzy-start slime-fuzzy-end) + (insert-and-inherit text) + (setq slime-fuzzy-text text) + (goto-char slime-fuzzy-end))))) + +(defun slime-fuzzy-choices-buffer (completions interrupted-p start end) + "Creates (if neccessary), populates, and pops up the *Fuzzy +Completions* buffer with the completions from `completions' and +the completion slot in the current buffer bounded by `start' and +`end'. This saves the window configuration before popping the +buffer so that it can possibly be restored when the user is +done." + (let ((new-completion-buffer (not slime-fuzzy-target-buffer))) + (when new-completion-buffer + (slime-fuzzy-save-window-configuration)) + (slime-fuzzy-enable-target-buffer-completions-mode) + (setq slime-fuzzy-target-buffer (current-buffer)) + (setq slime-fuzzy-start (move-marker (make-marker) start)) + (setq slime-fuzzy-end (move-marker (make-marker) end)) + (set-marker-insertion-type slime-fuzzy-end t) + (setq slime-fuzzy-original-text (buffer-substring start end)) + (setq slime-fuzzy-text slime-fuzzy-original-text) + (slime-fuzzy-fill-completions-buffer completions interrupted-p) + (pop-to-buffer (slime-get-fuzzy-buffer)) + (when new-completion-buffer + (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort) + (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc + (when slime-fuzzy-completion-in-place + ;; switch back to the original buffer + (switch-to-buffer-other-window slime-fuzzy-target-buffer)))) + +(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p) + "Erases and fills the completion buffer with the given completions." + (with-current-buffer (slime-get-fuzzy-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (slime-fuzzy-completions-mode) + (insert slime-fuzzy-explanation) + (let ((max-length 12)) + (dolist (completion completions) + (setf max-length (max max-length (length (first completion))))) + + (insert "Completion:") + (dotimes (i (- max-length 10)) (insert " ")) + ;; Flags: Score: + ;; ... ------- -------- + ;; bfgcmsp + (insert "Flags: Score:\n") + (dotimes (i max-length) (insert "-")) + (insert " ------- --------\n") + (setq slime-fuzzy-first (point)) + + (dolist (completion completions) + (setq slime-fuzzy-last (point)) ; will eventually become the last entry + (slime-fuzzy-insert-completion-choice completion max-length)) + + (when interrupted-p + (insert "...\n") + (insert "[Interrupted: time limit exhausted]")) + + (setq buffer-read-only t)) + (setq slime-fuzzy-current-completion + (caar completions)) [212 lines skipped] --- /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/19 11:19:32 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/23 12:58:52 1.2 @@ -0,0 +1,563 @@ +;;; swank-fuzzy.lisp --- fuzzy symbol completion +;; +;; Author: Brian Downing and others +;; License: Public Domain +;; + + +(in-package :swank) + +;;; For nomenclature of the fuzzy completion section, please read +;;; through the following docstring. + +(defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec) +"Returns a list of two values: + + An (optionally limited to LIMIT best results) list of fuzzy + completions for a symbol designator STRING. The list will be + sorted by score, most likely match first. + + A flag that indicates whether or not TIME-LIMIT-IN-MSEC has + been exhausted during computation. If that parameter's value is + NIL or 0, no time limit is assumed. + +The main result is a list of completion objects, where a completion +object is: + + (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS) + +where a CHUNK is a description of a matched substring: + + (OFFSET SUBSTRING) + +and FLAGS is a list of keywords describing properties of the +symbol (see CLASSIFY-SYMBOL). + +E.g., completing \"mvb\" in a package that uses COMMON-LISP would +return something like: + + ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\")) + (:FBOUNDP :MACRO)) + ...) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +Which symbols are candidates for matching depends on the symbol +designator's format. The cases are as follows: + FOO - Symbols accessible in the buffer package. + PKG:FOO - Symbols external in package PKG. + PKG::FOO - Symbols accessible in package PKG." + ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC + ;; to denote an infinite time limit. Internally, we only use NIL for + ;; that purpose, to be able to distinguish between "no time limit + ;; alltogether" and "current time limit already exhausted." So we've + ;; got to canonicalize its value at first: + (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec))) + (time-limit (if no-time-limit-p nil time-limit-in-msec))) + (multiple-value-bind (completion-set interrupted-p) + (fuzzy-completion-set string default-package-name :limit limit + :time-limit-in-msec time-limit) + ;; We may send this as elisp [] arrays to spare a coerce here, + ;; but then the network serialization were slower by handling arrays. + ;; Instead we limit the number of completions that is transferred + ;; (the limit is set from Emacs.) + (list (coerce completion-set 'list) interrupted-p)))) + + +;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion +;;; object that will be sent back to Emacs, as described above. + +(defstruct (fuzzy-matching (:conc-name fuzzy-matching.) + (:predicate fuzzy-matching-p) + (:constructor %make-fuzzy-matching)) + symbol ; The symbol that has been found to match. + score ; The higher the better symbol is a match. + package-chunks ; Chunks pertaining to the package identifier of the symbol. + symbol-chunks) ; Chunks pertaining to the symbol's name. + +(defun make-fuzzy-matching (symbol score package-chunks symbol-chunks) + (declare (inline %make-fuzzy-matching)) + (%make-fuzzy-matching :symbol symbol :score score + :package-chunks package-chunks + :symbol-chunks symbol-chunks)) + + +(defun fuzzy-convert-matching-for-emacs (fuzzy-matching converter + internal-p package-name) + "Converts a result from the fuzzy completion core into +something that emacs is expecting. Converts symbols to strings, +fixes case issues, and adds information describing if the symbol +is :bound, :fbound, a :class, a :macro, a :generic-function, +a :special-operator, or a :package." + (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching + (multiple-value-bind (name added-length) + (format-completion-result + (funcall (or converter #'identity) (symbol-name symbol)) + internal-p package-name) + (list name + score + (append package-chunks + (mapcar #'(lambda (chunk) + ;; Fix up chunk positions to account for possible + ;; added package identifier. + (let ((offset (first chunk)) (string (second chunk))) + (list (+ added-length offset) string))) + symbol-chunks)) + (classify-symbol symbol))))) + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according +to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a +special variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO, +:SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (let (result) + (when (boundp symbol) (push :boundp result)) + (when (fboundp symbol) (push :fboundp result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (push :generic-function result)) + result)) + +(defun symbol-classification->string (flags) + (format nil "~A~A~A~A~A~A~A" + (if (member :boundp flags) "b" "-") + (if (member :fboundp flags) "f" "-") + (if (member :generic-function flags) "g" "-") + (if (member :class flags) "c" "-") + (if (member :macro flags) "m" "-") + (if (member :special-operator flags) "s" "-") + (if (member :package flags) "p" "-"))) + + +(defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec) + "Returns two values: an array of completion objects, sorted by +their score, that is how well they are a match for STRING +according to the fuzzy completion algorithm. If LIMIT is set, +only the top LIMIT results will be returned. Additionally, a flag +is returned that indicates whether or not TIME-LIMIT-IN-MSEC was +exhausted." + (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) + (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum)))) + (multiple-value-bind (completion-set interrupted-p) + (fuzzy-create-completion-set string default-package-name + time-limit-in-msec) + (when (and limit + (> limit 0) + (< limit (length completion-set))) + (if (array-has-fill-pointer-p completion-set) + (setf (fill-pointer completion-set) limit) + (setf completion-set (make-array limit :displaced-to completion-set)))) + (values completion-set interrupted-p))) + + +(defun fuzzy-create-completion-set (string default-package-name time-limit-in-msec) + "Does all the hard work for FUZZY-COMPLETION-SET. If +TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." + (multiple-value-bind (parsed-name parsed-package-name package internal-p) + (parse-completion-arguments string default-package-name) + (flet ((convert (matchings package-name &optional converter) + ;; Converts MATCHINGS to completion objects for Emacs. + ;; PACKAGE-NAME is the package identifier that's used as prefix + ;; during formatting. If NIL, the identifier is omitted. + (map-into matchings + #'(lambda (m) + (fuzzy-convert-matching-for-emacs m converter + internal-p + package-name)) + matchings)) + (fix-up (matchings parent-package-matching) + ;; The components of each matching in MATCHINGS have been computed + ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. + (let* ((p parent-package-matching) + (p.score (fuzzy-matching.score p)) + (p.chunks (fuzzy-matching.package-chunks p))) + (map-into matchings + #'(lambda (m) + (let ((m.score (fuzzy-matching.score m))) + (setf (fuzzy-matching.package-chunks m) p.chunks) + (setf (fuzzy-matching.score m) + (if (string= parsed-name "") + ;; (Make package matchings be sorted before all the + ;; relative symbol matchings while preserving over + ;; all orderness.) + (/ p.score 100) + (+ p.score m.score))) + m)) + matchings))) + (find-symbols (designator package time-limit) + (fuzzy-find-matching-symbols designator package + :time-limit-in-msec time-limit + :external-only (not internal-p))) + (find-packages (designator time-limit) + (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit))) + (let ((symbol-normalizer (completion-output-symbol-converter string)) + (package-normalizer #'(lambda (package-name) + (let ((converter (completion-output-package-converter string))) + ;; Present packages with a trailing colon for maximum convenience! + (concatenate 'string (funcall converter package-name) ":")))) + (time-limit time-limit-in-msec) (symbols) (packages) (results)) + (cond ((not parsed-package-name) ; E.g. STRING = "asd" + ;; We don't know if user is searching for a package or a symbol + ;; within his current package. So we try to find either. + (setf (values packages time-limit) (find-packages parsed-name time-limit)) + (setf (values symbols time-limit) (find-symbols parsed-name package time-limit)) + (setf symbols (convert symbols nil symbol-normalizer)) + (setf packages (convert packages nil package-normalizer))) + ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" + (setf (values symbols time-limit) (find-symbols parsed-name package time-limit)) + (setf symbols (convert symbols "" symbol-normalizer))) + (t ; E.g. STRING = "asd:" or "asd:foo" + ;; Find fuzzy matchings of the denoted package identifier part. + ;; After that, find matchings for the denoted symbol identifier + ;; relative to all the packages found. + (multiple-value-bind (found-packages rest-time-limit) + (find-packages parsed-package-name time-limit-in-msec) + (loop + for package-matching across found-packages + for package-sym = (fuzzy-matching.symbol package-matching) + for package-name = (funcall symbol-normalizer (symbol-name package-sym)) + for package = (find-package package-sym) + while (or (not time-limit) (> rest-time-limit 0)) do + (multiple-value-bind (matchings remaining-time) + (find-symbols parsed-name package rest-time-limit) + (setf matchings (fix-up matchings package-matching)) + (setf matchings (convert matchings package-name symbol-normalizer)) + (setf symbols (concatenate 'vector symbols matchings)) + (setf rest-time-limit remaining-time)) + finally ; CONVERT is destructive. So we have to do this at last. + (setf time-limit rest-time-limit) + (setf packages (when (string= parsed-name "") + (convert found-packages nil package-normalizer))))))) + ;; Sort alphabetically before sorting by score. (Especially useful when + ;; PARSED-NAME is empty, and all possible completions are to be returned.) + (setf results (concatenate 'vector symbols packages)) + (setf results (sort results #'string< :key #'first)) ; SORT + #'STRING-LESSP + (setf results (stable-sort results #'> :key #'second)); conses on at least SBCL 0.9.18. + (values results (and time-limit (<= time-limit 0))))))) + + +(defun get-real-time-in-msecs () + (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) + (values (floor (get-internal-real-time) units-per-msec)))) ; return just one value! + + +(defun fuzzy-find-matching-symbols (string package &key external-only time-limit-in-msec) + "Returns two values: a vector of fuzzy matchings for matching +symbols in PACKAGE, using the fuzzy completion algorithm; the +remaining time limit. + +If EXTERNAL-ONLY is true, only external symbols are considered. A +TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or +negative, perform a NOP." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (count 0)) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) + + (flet ((recompute-remaining-time (old-remaining-time) + (cond ((not time-limit-p) + (values nil nil)) ; propagate NIL back as infinite time limit. + ((> count 0) ; ease up on getting internal time like crazy. + (setf count (mod (1+ count) 128)) + (values nil old-remaining-time)) + (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)) + (remaining (- time-limit elapsed-time))) + (values (<= remaining 0) remaining))))) + (perform-fuzzy-match (string symbol-name) + (let* ((converter (completion-output-symbol-converter string)) + (converted-symbol-name (funcall converter symbol-name))) + (compute-highest-scoring-completion string converted-symbol-name)))) + (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) + (rest-time-limit time-limit)) + (block loop + (do-symbols* (symbol package) + (multiple-value-bind (exhausted? remaining-time) + (recompute-remaining-time rest-time-limit) + (setf rest-time-limit remaining-time) + (cond (exhausted? (return-from loop)) + ((or (not external-only) (symbol-external-p symbol package)) + (if (string= "" string) ; "" matchs always + (vector-push-extend (make-fuzzy-matching symbol 0.0 '() '()) + completions) + (multiple-value-bind (match-result score) + (perform-fuzzy-match string (symbol-name symbol)) + (when match-result + (vector-push-extend + (make-fuzzy-matching symbol score '() match-result) + completions))))))))) + (values completions rest-time-limit))))) + + +(defun fuzzy-find-matching-packages (name &key time-limit-in-msec) + "Returns a vector of fuzzy matchings for each package that is +similiar to NAME, and the remaining time limit. +Cf. FUZZY-FIND-MATCHING-SYMBOLS." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (converter (completion-output-package-converter name)) + (completions (make-array 32 :adjustable t :fill-pointer 0))) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type function converter)) + (if (and time-limit-p (<= time-limit 0)) + (values #() time-limit) + (loop for package-name in (mapcan #'package-names (list-all-packages)) + for converted-name = (funcall converter package-name) + for package-symbol = (or (find-symbol package-name) + (make-symbol package-name)) ; no INTERN + do (multiple-value-bind (result score) + (compute-highest-scoring-completion name converted-name) + (when result + (vector-push-extend (make-fuzzy-matching package-symbol score result '()) + completions))) + finally + (return + (values completions + (and time-limit-p + (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))) + (- time-limit elapsed-time))))))))) + + +(defslimefun fuzzy-completion-selected (original-string completion) + "This function is called by Slime when a fuzzy completion is +selected by the user. It is for future expansion to make +testing, say, a machine learning algorithm for completion scoring +easier. + +ORIGINAL-STRING is the string the user completed from, and +COMPLETION is the completion object (see docstring for +SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the +user selected." + (declare (ignore original-string completion)) + nil) + + +;;;;; Fuzzy completion core + +(defparameter *fuzzy-recursion-soft-limit* 30 + "This is a soft limit for recursion in +RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, +completing a string such as \"ZZZZZZ\" with a symbol named +\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to +find all the ways it can match. + +Most natural language searches and symbols do not have this +problem -- this is only here as a safeguard.") +(declaim (fixnum *fuzzy-recursion-soft-limit*)) + +(defun compute-highest-scoring-completion (short full) + "Finds the highest scoring way to complete the abbreviation +SHORT onto the string FULL, using CHAR= as a equality function for +letters. Returns two values: The first being the completion +chunks of the highest scorer, and the second being the score." + (let* ((scored-results + (mapcar #'(lambda (result) + (cons (score-completion result short full) result)) + (compute-most-completions short full))) + (winner (first (sort scored-results #'> :key #'first)))) + (values (rest winner) (first winner)))) + +(defun compute-most-completions (short full) + "Finds most possible ways to complete FULL with the letters in SHORT. +Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns +a list of (&rest CHUNKS), where each CHUNKS is a description of +how a completion matches." + (let ((*all-chunks* nil)) + (declare (special *all-chunks*)) + (recursively-compute-most-completions short full 0 0 nil nil nil t) + *all-chunks*)) + +(defun recursively-compute-most-completions + (short full + short-index initial-full-index + chunks current-chunk current-chunk-pos + recurse-p) + "Recursively (if RECURSE-P is true) find /most/ possible ways +to fuzzily map the letters in SHORT onto FULL, using CHAR= to +determine if two letters match. + +A chunk is a list of elements that have matched consecutively. +When consecutive matches stop, it is coerced into a string, +paired with the starting position of the chunk, and pushed onto +CHUNKS. + +Whenever a letter matches, if RECURSE-P is true, [167 lines skipped] From heller at common-lisp.net Thu Aug 23 13:02:32 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 09:02:32 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823130232.A8BB21D10B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2715 Modified Files: slime.el ChangeLog Log Message: Display a "Please upgrade" style message when C-c M-i is pressed. --- /project/slime/cvsroot/slime/slime.el 2007/08/23 12:58:51 1.800 +++ /project/slime/cvsroot/slime/slime.el 2007/08/23 13:02:32 1.801 @@ -11119,6 +11119,48 @@ (if (local-variable-p hook (current-buffer)) (remove-hook hook function t))) +;;; Some "nice" backward compatiblity bindings for lusers. + +(unless (lookup-key slime-mode-map "\C-c\M-i") + (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-upgrade-notice) + (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-upgrade-notice)) + +(defun slime-fuzzy-upgrade-notice () + (interactive) + (slime-timebomb "slime-fuzzy-complete-symbol is not loaded. + +Fuzzy completion has been moved to contrib. +Please consult the README file in the contrib directory for details. + +To fetch the contrib directoy use: cvs update -d contrib" + 15)) + +;;;; ... with gratuitous bloat + +(defun slime-timebomb (message timeout) + (with-current-buffer (generate-new-buffer "*warning*") + (insert message "\n\n") + (slime-timebomb-progress (point-marker) timeout) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)))) + +(defun slime-timebomb-progress (mark timeout) + (let ((buffer (marker-buffer mark))) + (cond ((not (buffer-live-p buffer))) + ((zerop timeout) (kill-buffer buffer)) + (t (with-current-buffer buffer + (save-excursion + (delete-region mark (point-max)) + (goto-char mark) + (slime-timebomb-message timeout)) + (run-with-timer 1 nil + 'slime-timebomb-progress mark (1- timeout))))))) + +(defun slime-timebomb-message (timeout) + (slime-insert-propertized + (list 'face (if (zerop (mod timeout 2)) 'highlight 'default)) + (format "This message will destroy itself in %d seconds." timeout))) + ;;;; Finishing up --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 12:58:51 1.1146 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 13:02:32 1.1147 @@ -1,3 +1,8 @@ +2007-08-23 Helmut Eller + + * slime.el (slime-fuzzy-upgrade-notice): New function. Bound to + the key where slime-fuzzy-complete-symbol used to be. + 2007-08-22 Tobias C. Rittweiler * slime.el (slime-close-all-parens-in-sexp): Fix interplay with From heller at common-lisp.net Thu Aug 23 13:56:24 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 09:56:24 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823135624.302D62F060@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12799 Modified Files: ChangeLog slime.el swank-backend.lisp swank.lisp Log Message: Some inspector cleanups. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 13:02:32 1.1147 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 13:56:22 1.1148 @@ -1,5 +1,24 @@ 2007-08-23 Helmut Eller + Some inspector cleanups. + + * slime.el (slime-inspect): Remove dwim stuff and drop keyword + args. + (slime-read-object): Killed. + (slime-open-inspector): Drop keyword args. Update callers + accodordingly, expect presentation related code. Presentations no + longer work in the inspector. + + * swank.lisp (*inspector-dwim-lookup-hooks*) + (default-dwim-inspector-lookup-hook): Deleted. + (init-inspector): Sanitize arglist. + (inspect-object): Don't return an :id for *inspectee-parts*. + + * swank-backend (type-for-emacs): Removed. No backend implemented + it. + +2007-08-23 Helmut Eller + * slime.el (slime-fuzzy-upgrade-notice): New function. Bound to the key where slime-fuzzy-complete-symbol used to be. --- /project/slime/cvsroot/slime/slime.el 2007/08/23 13:02:32 1.801 +++ /project/slime/cvsroot/slime/slime.el 2007/08/23 13:56:22 1.802 @@ -8338,28 +8338,22 @@ (lambda (result) (slime-show-description result nil))))) + + (defun sldb-inspect-in-frame (string) "Prompt for an expression and inspect it in the selected frame." - (interactive (list (slime-read-object - "Inspect in frame (evaluated): "))) - (slime-eval-async `(swank:inspect-in-frame ,string ,(sldb-frame-number-at-point)) - (with-lexical-bindings (slime-current-thread - slime-buffer-package) - (lambda (thing) - (slime-open-inspector thing - :thread slime-current-thread - :package slime-buffer-package))))) + (interactive (list (slime-read-from-minibuffer + "Inspect in frame (evaluated): " + (slime-sexp-at-point)))) + (let ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:inspect-in-frame ,string ,number) + 'slime-open-inspector))) (defun sldb-inspect-var () (let ((frame (sldb-frame-number-at-point)) (var (sldb-var-number-at-point))) (slime-eval-async `(swank:inspect-frame-var ,frame ,var) - (lexical-let ((thread slime-current-thread) - (package (slime-current-package))) - (lambda (thing) - (slime-open-inspector thing - :thread thread - :package package)))))) + 'slime-open-inspector))) (defun sldb-inspect-condition () "Inspect the current debugger condition." @@ -8784,60 +8778,12 @@ (defvar slime-inspector-mark-stack '()) (defvar slime-saved-window-config) -(defun* slime-inspect (form &key no-reset eval dwim-mode - thread (package (slime-current-package))) - "Take an expression FORM and inspect it. -If DWIM-MODE is non-nil (the interactive default), try to be -smart about what was the intention. Otherwise, if EVAL is -non-nil (interactively, if invoked with a prefix argument), -evaluate FORM and inspect the result. Otherwise, inspect FORM -itself." - (interactive - (multiple-value-bind (presentation start end) - (slime-presentation-around-point (point)) - (if presentation - ;; Point is within a presentation, so don't prompt, just - ;; inspect the presented object; don't play DWIM. - (cons (slime-presentation-expression presentation) - '(:eval t :dwim-mode nil)) - ;; Not in a presentation, read form from minibuffer. - (cons (slime-read-object (if current-prefix-arg - "Inspect value (evaluated): " - "Inspect value (dwim mode): ") - :return-names-unconfirmed (not current-prefix-arg)) - (if current-prefix-arg - '(:eval t :dwim-mode nil) - '(:eval nil :dwim-mode t)))))) - (slime-eval-async `(swank:init-inspector ,form - :reset ,(not no-reset) - :eval ,eval - :dwim-mode ,dwim-mode) - (with-lexical-bindings (thread package form) - (lambda (thing) - (if thing - (slime-open-inspector thing - :thread thread - :package package) - (message "Couldn't read anything from '%s' (hint: prefix for debugger with details)" form)))))) - -(defun* slime-read-object (prompt &key return-names-unconfirmed - initial-value (history 'slime-read-expression-history)) - "Read a Common Lisp expression from the minibuffer, providing -defaults from the s-expression at point. If point is within a -presentation, don't prompt, just return the presentation." - (multiple-value-bind (presentation start end) - (slime-presentation-around-point (point)) - (if presentation - (slime-presentation-expression presentation) - (let ((sexp (slime-sexp-at-point))) - (if (and sexp - return-names-unconfirmed - ;; an string with alphanumeric chars and hyphens only? - (and (string-match "\\([-|.:0-9a-zA-Z]*\\)" sexp) - (= (match-end 0) (length sexp)))) - sexp - (slime-read-from-minibuffer prompt - (or initial-value sexp))))))) +(defun slime-inspect (string) + "Eval an expression and inspect the result." + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector)) (define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector" (set-syntax-table lisp-mode-syntax-table) @@ -8857,24 +8803,17 @@ (defmacro slime-inspector-fontify (face string) `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) -(defun* slime-open-inspector (inspected-parts &key point thread package) +(defun slime-open-inspector (inspected-parts &optional point) "Display INSPECTED-PARTS in a new inspector window. Optionally set point to POINT." (with-current-buffer (slime-inspector-buffer) (setq slime-buffer-connection (slime-current-connection)) - (when thread - (setq slime-current-thread thread)) - (when package - (setq slime-buffer-package package)) (let ((inhibit-read-only t)) (erase-buffer) - (destructuring-bind (&key title type content id) inspected-parts + (destructuring-bind (&key title type content) inspected-parts (macrolet ((fontify (face string) - `(slime-inspector-fontify ,face ,string))) - (slime-propertize-region (list 'slime-part-number id - 'mouse-face 'highlight - 'face 'slime-inspector-action-face) - (slime-insert-presentation title `(:inspected-part ,id))) + `(slime-inspector-fontify ,face ,string))) + (insert (fontify topline title)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n [" (fontify label "type:") " " (fontify type type) "]\n" @@ -8882,12 +8821,11 @@ (save-excursion (mapc #'slime-inspector-insert-ispec content)) (pop-to-buffer (current-buffer)) - (when point - (if (consp point) - (ignore-errors - (goto-line (car point)) - (move-to-column (cdr point))) - (goto-char (min (point-max) point))))))))) + (when point + (check-type point cons) + (ignore-errors + (goto-line (car point)) + (move-to-column (cdr point))))))))) (defun slime-inspector-insert-ispec (ispec) (if (stringp ispec) @@ -8928,11 +8866,11 @@ (opener (lexical-let ((point (slime-inspector-position))) (lambda (parts) (when parts - (slime-open-inspector parts :point point)))))) + (slime-open-inspector parts point)))))) (cond (part-number (slime-eval-async `(swank:inspect-nth-part ,part-number) opener) - (push (point) slime-inspector-mark-stack)) + (push (slime-inspector-position) slime-inspector-mark-stack)) (action-number (slime-eval-async `(swank::inspector-call-nth-action ,action-number) opener))))) @@ -8962,7 +8900,7 @@ `(swank:inspector-pop) (lambda (result) (cond (result - (slime-open-inspector result :point (pop slime-inspector-mark-stack))) + (slime-open-inspector result (pop slime-inspector-mark-stack))) (t (message "No previous object") (ding)))))) @@ -8971,7 +8909,7 @@ (interactive) (let ((result (slime-eval `(swank:inspector-next)))) (cond (result - (push (point) slime-inspector-mark-stack) + (push (slime-inspector-position) slime-inspector-mark-stack) (slime-open-inspector result)) (t (message "No next object") (ding))))) @@ -9055,7 +8993,7 @@ (slime-eval-async `(swank:inspector-reinspect) (lexical-let ((point (slime-inspector-position))) (lambda (parts) - (slime-open-inspector parts :point point))))) + (slime-open-inspector parts point))))) (slime-define-keys slime-inspector-mode-map ([return] 'slime-inspector-operate-on-point) --- /project/slime/cvsroot/slime/swank-backend.lisp 2007/04/19 16:36:12 1.118 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2007/08/23 13:56:22 1.119 @@ -38,7 +38,6 @@ #:fancy-inspection #:label-value-line #:label-value-line* - #:type-for-emacs #:with-struct )) @@ -890,20 +889,6 @@ ` (append ,@(loop for (label value) in label-values collect `(label-value-line ,label ,value)))) -(defgeneric type-for-emacs (object) - (:documentation - "Return a type specifier suitable for display in the Emacs inspector.") - (:method (object) - (type-of object)) - (:method ((object integer)) - ;; Some lisps report integer types as (MOD ...), which while nice - ;; in a sense doesn't answer the often more immediate question of - ;; fixnumness. - (if (typep object 'fixnum) - 'fixnum - 'bignum))) - - (definterface describe-primitive-type (object) "Return a string describing the primitive type of object." (declare (ignore object)) --- /project/slime/cvsroot/slime/swank.lisp 2007/08/23 12:58:52 1.492 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/23 13:56:22 1.493 @@ -40,7 +40,6 @@ #:*default-worker-thread-bindings* #:*macroexpand-printer-bindings* #:*record-repl-results* - #:*inspector-dwim-lookup-hooks* #:*debug-on-swank-error* ;; These are re-exported directly from the backend: #:buffer-first-change @@ -4828,62 +4827,10 @@ (not (third form)) (eq (first form) 'setf)))) -(defvar *inspector-dwim-lookup-hooks* '(default-dwim-inspector-lookup-hook) - "A list of funcallables with one argument. It can be used to register user hooks that look up various things when inspecting in dwim mode.") - -(defun default-dwim-inspector-lookup-hook (form) - (let ((result '())) - (when (and (symbolp form) - (boundp form)) - (push (symbol-value form) result)) - (when (and (valid-function-name-p form) - (fboundp form)) - (push (fdefinition form) result)) - (when (and (symbolp form) - (find-class form nil)) - (push (find-class form) result)) - (when (and (consp form) - (valid-function-name-p (first form)) - (fboundp (first form))) - (push (eval form) result)) - (values result (not (null result))))) - -(defslimefun init-inspector (string &key (reset t) (eval t) (dwim-mode nil)) +(defslimefun init-inspector (string) (with-buffer-syntax () - (when reset - (reset-inspector)) - (let* ((form (block reading - (handler-bind - ((error (lambda (e) - (declare (ignore e)) - (when dwim-mode - (return-from reading 'nothing))))) - (read-from-string string nil 'nothing)))) - (value)) - (unless (eq form 'nothing) - (setf value (cond - (dwim-mode - (let ((things (loop for hook :in *inspector-dwim-lookup-hooks* - for (result foundp) = (multiple-value-list - (funcall hook form)) - when foundp - append (if (consp result) - result - (list result))))) - (if (rest things) - things - (first things)))) - (eval (eval form)) - (t form))) - (when (and dwim-mode - form - value) - ;; push the form to the inspector stack, so you can go back to it - ;; with slime-inspector-pop if dwim missed the intention - (push form *inspector-stack*)) - (inspect-object (if dwim-mode - (or value form) - value)))))) + (reset-inspector) + (inspect-object (eval (read-from-string string))))) (defun print-part-to-string (value) (let ((string (to-string value)) @@ -4919,7 +4866,7 @@ (defun action-part-for-emacs (label lambda refreshp) (list :action label (assign-index (list lambda refreshp) *inspectee-actions*))) - + (defun inspect-object (object &optional (inspector (make-default-inspector))) (push (setq *inspectee* object) *inspector-stack*) (unless (find object *inspector-history*) @@ -4927,12 +4874,10 @@ (let ((*print-pretty* nil) ; print everything in the same line (*print-circle* t) (*print-readably* nil)) - (multiple-value-bind (title content) - (inspect-for-emacs object inspector) + (multiple-value-bind (title content) (inspect-for-emacs object inspector) (list :title title - :type (to-string (type-for-emacs object)) - :content (inspector-content-for-emacs content) - :id (assign-index object *inspectee-parts*))))) + :type (to-string (type-of object)) + :content (inspector-content-for-emacs content))))) (defslimefun inspector-nth-part (index) (aref *inspectee-parts* index)) From trittweiler at common-lisp.net Thu Aug 23 16:19:56 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 23 Aug 2007 12:19:56 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823161956.E8850281EF@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5660 Modified Files: swank.lisp Log Message: Added arglist display for declaration specifiers and type specifiers. Examples: `(declare (type' will display (declare (type type-specifier &rest vars)) `(declare (type (float' will display [Typespec] (float &optional lower-limit upper-limit) `(declare (optimize' will display (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) &ANY is a new lambda keyword that is introduced for arglist description purpose, and is very similiar to &KEY, but isn't based upon plists; they're more based upon *FEATURES* lists. (See the comment near the ARGLIST defstruct in `swank.lisp'.) * slime.el: (slime-to-feature-keyword): Renamed to `slime-keywordify'. (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. (slime-ensure-list): New utility. (slime-sexp-at-point): Now takes an argument that specify how many sexps at point should be returned. (slime-enclosing-operator-names): Renamed to `slime-enclosing-form-specs'. (slime-enclosing-form-specs): Returns a list of ``raw form specs'' instead of what was called ``extended operator names'' before, see `swank::parse-form-spec' for more information. This is a simplified superset. Additionally as tertiary return value return a list of points to let the caller see where each form spec is located. Adapted callers accordingly. Extended docstring. (slime-parse-extended-operator-name): Adapted to changes in `slime-enclosing-form-specs'. Now gets more context, and is such more powerful. This was needed to allow parsing DECLARE forms. (slime-make-extended-operator-parser/look-ahead): Because the protocol for arglist display was simplified, it was possible to replace the plethora of parsing function just by this one. (slime-extended-operator-name-parser-alist): Use it. Also add parser for DECLARE forms. (slime-parse-extended-operator/declare): Responsible for parsing DECLARE forms. (%slime-in-mid-of-typespec-p): Helper function for `slime-parse-extended-operator/declare'. (slime-incomplete-form-at-point): New. Return the ``raw form spec'' near point. (slime-complete-form): Use `slime-incomplete-form-at-point'. * swank.lisp: New Helper functions. (length=, ensure-list, recursively-empty-p): New. (maybecall, exactly-one-p): New. * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form specs'' from Slime. (parse-form-spec): New. Takes a ``raw form spec'' and returns a ``form spec'' for further processing in Swank. Docstring documents these two terms. (split-form-spec): New. Return relevant information from a form spec. (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. (find-valid-operator-name): Removed. (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. (defstruct arglist): Add `any-p' and `any-args' slots to contain arguments belonging to the &ANY lambda keyword. (print-arglist): Adapted to also print &ANY args. (print-decoded-arglist-as-template): Likewise. (decode-arglist): Adapted to also decode &ANY args. (remove-actual-args): Adapted to also remove &ANY args. (remove-&key-args): Split out from `remove-actual-args'. (remove-&any-args): New. Removes already provided &ANY args. (arglist-from-form-spec): New. Added detailed docstring. (arglist-dispatch): Dispatching generic function for `arglist-from-form-spec' that does all the work. Renamed from prior `form-completion'. (arglist-dispatch) Added methods for dealing with declaration and type-specifiers. (complete-form): Adapted to take ``raw form specs'' from Slime. (completions-for-keyword): Likewise. (format-arglist-for-echo-area): Removed. Not needed anymore. * swank-backend.lisp (declaration-arglist): New generic function. Returns the arglist for a given declaration identifier. (Backends are supposed to specialize it if they can provide additional information.) (type-specifier-arglist): New generic function. Returns the arglist for a given type-specifier operator. (Backends are supposed to specialize it if they can provide additional information.) (*type-specifier-arglists*): New variable. Contains the arglists for the type specifiers in Common Lisp. * swank-sbcl.lisp: Now depends upon sb-cltl2. (declaration-arglist 'optimize): Specialize the `optimize' declaration identifier to pass it to sb-cltl2:declaration-information. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/23 13:56:22 1.493 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/23 16:19:56 1.494 @@ -390,6 +390,40 @@ (defun ascii-char-p (c) (<= (char-code c) 127)) +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + +(defun recursively-empty-p (list) + "Returns whether LIST consists only of arbitrarily nested empty lists." + (cond ((not (listp list)) nil) + ((null list) t) + (t (every #'recursively-empty-p list)))) + +(defun maybecall (bool fn &rest args) + "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values." + (if bool (apply fn args) (values-list args))) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body) "Just like do-symbols, but makes sure a symbol is visited only once." (let ((seen-ht (gensym "SEEN-HT"))) @@ -1513,54 +1547,124 @@ ;;;; Arglists -(defun find-valid-operator-name (names) - "As a secondary result, returns its index." - (let ((index - (position-if (lambda (name) - (or (consp name) - (valid-operator-name-p name))) - names))) - (if index - (values (elt names index) index) - (values nil nil)))) - -(defslimefun arglist-for-echo-area (names &key print-right-margin - print-lines arg-indices) - "Return the arglist for the first function, macro, or special-op in NAMES." - (handler-case +(defslimefun arglist-for-echo-area (raw-specs &key arg-indices + print-right-margin print-lines) + "Return the arglist for the first valid ``form spec'' in +RAW-SPECS. A ``form spec'' is a superset of functions, macros, +special-ops, declarations and type specifiers. + +For more information about the format of ``raw form specs'' and +``form specs'', please see PARSE-FORM-SPEC." + (handler-case (with-buffer-syntax () - (multiple-value-bind (name which) - (find-valid-operator-name names) - (when which - (let ((arg-index (and arg-indices (elt arg-indices which)))) - (multiple-value-bind (form operator-name) - (operator-designator-to-form name) - (let ((*print-right-margin* print-right-margin)) - (format-arglist-for-echo-area - form operator-name - :print-right-margin print-right-margin - :print-lines print-lines - :highlight (and arg-index - (not (zerop arg-index)) - ;; don't highlight the operator - arg-index)))))))) + (multiple-value-bind (form-spec arg-index) + (parse-first-valid-form-spec raw-specs arg-indices) + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (multiple-value-bind (type operator arguments) + (split-form-spec form-spec) + (declare (ignore arguments)) + (multiple-value-bind (stringified-arglist) + (decoded-arglist-to-string + arglist + :operator operator + :print-right-margin print-right-margin + :print-lines print-lines + :highlight (and arg-index + (not (zerop arg-index)) + ;; don't highlight the operator + arg-index)) + (case type + (:declaration (format nil "(declare ~A)" stringified-arglist)) + (:type-specifier (format nil "[Typespec] ~A" stringified-arglist)) + (t stringified-arglist))))))))) (error (cond) - (format nil "ARGLIST: ~A" cond)))) + (format nil "ARGLIST (error): ~A" cond)) + )) + +(defun parse-form-spec (raw-spec) + "Takes a raw (i.e. unparsed) form spec from SLIME and returns a +proper form spec for further processing within SWANK. Returns NIL +if RAW-SPEC could not be parsed. + +A ``raw form spec'' can be either: + + i) a string representing a Common Lisp symbol, + + ii) a string representing a Common Lisp form, + + iii) a list: + + a) (:declaration declspec) + + where DECLSPEC is the string representation of a /declaration specifier/, + + b) (:type-specifier typespec) + + where TYPESPEC is the string representation of a /type specifier/. + + +A ``form spec'' is either + + 1) a normal Common Lisp form + + 2) a Common Lisp form with a list as its CAR specifying what namespace + the operator is supposed to be interpreted in: + + a) ((:declaration decl-identifier) declarg1 declarg2 ...) + + b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...) + + +Examples: + + \"defmethod\" => (defmethod) + \"cl:defmethod\" => (cl:defmethod) + \"(defmethod print-object)\" => (defmethod print-object) + (:declaration \"(optimize)\") => ((:declaration optimize)) + (:declaration \"(type string)\") => ((:declaration type) string) + (:type-specifier \"(float)\") => ((:type-specifier float)) + (:type-specifier \"(float 0 100)\") => ((:type-specifier float) 0 100) +" + (typecase raw-spec + (string (ensure-list (read-incomplete-form-from-string raw-spec))) + (cons ; compound form spec + (destructure-case raw-spec + ((:declaration raw-declspec) + (let ((declspec (from-string raw-declspec))) + (unless (recursively-empty-p declspec) ; (:DECLARATION "(())") &c. + (destructuring-bind (decl-identifier &rest decl-args) declspec + `((:declaration ,decl-identifier) , at decl-args))))) + ((:type-specifier raw-typespec) + (let ((typespec (from-string raw-typespec))) + (unless (recursively-empty-p typespec) + (destructuring-bind (typespec-op &rest typespec-args) typespec + `((:type-specifier ,typespec-op) , at typespec-args))))))) + (otherwise nil))) + +(defun split-form-spec (spec) + "Returns all three relevant information a ``form spec'' +contains: the operator type, the operator, and the operands." + (destructuring-bind (operator-designator &rest arguments) spec + (multiple-value-bind (type operator) + (if (listp operator-designator) + (values (first operator-designator) (second operator-designator)) + (values :function operator-designator)) ; functions, macros, special ops + (values type operator arguments)))) ; are all fbound. + +(defun parse-first-valid-form-spec (raw-specs &optional arg-indices) + "Returns the first parsed form spec in RAW-SPECS that can +successfully be parsed. Additionally returns its respective index +in ARG-INDICES (or NIL.)" + (block traversal + (mapc #'(lambda (raw-spec index) + (let ((spec (parse-form-spec raw-spec))) + (when spec (return-from traversal + (values spec index))))) + raw-specs + (append arg-indices '#1=(nil . #1#))))) -(defun operator-designator-to-form (name) - (etypecase name - (cons - (destructure-case name - ((:make-instance class-name operator-name &rest args) - (let ((parsed-operator-name (parse-symbol operator-name))) - (values `(,parsed-operator-name , at args ',(parse-symbol class-name)) - operator-name))) - ((:defmethod generic-name) - (values `(defmethod ,(parse-symbol generic-name)) - 'defmethod)))) - (string - (values `(,(parse-symbol name)) - name)))) (defun clean-arglist (arglist) "Remove &whole, &enviroment, and &aux elements from ARGLIST." @@ -1571,6 +1675,7 @@ '()) (t (cons (car arglist) (clean-arglist (cdr arglist)))))) + (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) provided-args ; list of the provided actual arguments required-args ; list of the required arguments @@ -1581,9 +1686,43 @@ body-p ; whether the rest argument is a &body allow-other-keys-p ; whether &allow-other-keys appeared aux-args ; list of &aux variables + any-p ; whether &any appeared + any-args ; list of &any arguments [*] known-junk ; &whole, &environment unknown-junk) ; unparsed stuff +;;; +;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, +;;; and is only used to describe certain arglists that cannot be +;;; described in another way. +;;; +;;; &ANY is very similiar to &KEY but while &KEY is based upon +;;; the idea of a plist (key1 value1 key2 value2), &ANY is a +;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: +;;; +;;; a) (&ANY :A :B :C) means that you can provide any (non-null) +;;; set consisting of the keywords `:A', `:B', or `:C' in +;;; the arglist. E.g. (:A) or (:C :B :A). +;;; +;;; (This is not restricted to keywords only, but any self-evaluating +;;; expression is allowed.) +;;; +;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can +;;; provide any (non-null) set consisting of lists where +;;; the CAR of the list is one of `key1', `key2', or `key3'. +;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) +;;; +;;; +;;; For example, a) let us describe the situations of EVAL-WHEN as +;;; +;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) +;;; +;;; and b) let us describe the optimization qualifiers that are valid +;;; in the declaration specifier `OPTIMIZE': +;;; +;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) +;;; + (defun print-arglist (arglist &key operator highlight) (let ((index 0) (need-space nil)) @@ -1654,6 +1793,10 @@ (arglist.keyword-args arglist))) (when (arglist.allow-other-keys-p arglist) (print-with-space '&allow-other-keys)) + (when (arglist.any-args arglist) + (print-with-space '&any) + (mapc #'print-with-space + (arglist.any-args arglist))) (cond ((not (arglist.rest arglist))) ((arglist.body-p arglist) (print-with-space '&body) @@ -1664,9 +1807,9 @@ (mapc #'print-with-space (arglist.unknown-junk arglist)))))) -(defun decoded-arglist-to-string (arglist package - &key operator print-right-margin - print-lines highlight) +(defun decoded-arglist-to-string (arglist + &key operator highlight (package *package*) + print-right-margin print-lines) "Print the decoded ARGLIST for display in the echo area. The argument name are printed without package qualifiers and pretty printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is @@ -1678,7 +1821,8 @@ (*print-pretty* t) (*print-circle* nil) (*print-readably* nil) (*print-level* 10) (*print-length* 20) (*print-right-margin* print-right-margin) - (*print-lines* print-lines)) + (*print-lines* print-lines) + (*print-escape* nil)) ; no package qualifies. (print-arglist arglist :operator operator :highlight highlight))))) (defslimefun variable-desc-for-echo-area (variable-name) @@ -1813,6 +1957,10 @@ ((member arg '(&whole &environment)) (setq mode arg) (push arg (arglist.known-junk result))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&ANY))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) ((member arg lambda-list-keywords) (setq mode '&unknown-junk) (push arg (arglist.unknown-junk result))) @@ -1837,13 +1985,18 @@ (arglist.required-args result))) ((&whole &environment) (setf mode nil) - (push arg (arglist.known-junk result))))))) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result))))))) (nreversef (arglist.required-args result)) (nreversef (arglist.optional-args result)) (nreversef (arglist.keyword-args result)) (nreversef (arglist.aux-args result)) + (nreversef (arglist.any-args result)) (nreversef (arglist.known-junk result)) (nreversef (arglist.unknown-junk result)) + (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) (arglist.any-p result)))) result)) (defun encode-arglist (decoded-arglist) @@ -1856,6 +2009,8 @@ (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist)) (when (arglist.allow-other-keys-p decoded-arglist) '(&allow-other-keys)) + (when (arglist.any-args decoded-arglist) + `(&any ,@(arglist.any-args decoded-arglist))) (cond ((not (arglist.rest decoded-arglist)) '()) ((arglist.body-p decoded-arglist) @@ -1946,6 +2101,9 @@ (format t "~W " (if (keywordp keyword) keyword `',keyword)) (print-arg-or-pattern arg-name))) + (dolist (any-arg (arglist.any-args decoded-arglist)) + (space) + (print-arg-or-pattern any-arg)) (when (and (arglist.rest decoded-arglist) (or (not (arglist.keyword-args decoded-arglist)) (arglist.allow-other-keys-p decoded-arglist))) @@ -1955,6 +2113,7 @@ (format t "~A..." (arglist.rest decoded-arglist))))) (pprint-newline :fill))) + (defgeneric extra-keywords (operator &rest args) (:documentation "Return a list of extra keywords of OPERATOR (a symbol) when applied to the (unevaluated) ARGS. @@ -1962,6 +2121,18 @@ As a tertiary value, return the initial sublist of ARGS that was needed to determine the extra keywords.")) +(defun keywords-of-operator (operator) + "Return a list of KEYWORD-ARGs that OPERATOR accepts. +This function is useful for writing EXTRA-KEYWORDS methods for +user-defined functions which are declared &ALLOW-OTHER-KEYS and which +forward keywords to OPERATOR." + (let ((arglist (arglist-from-form-spec (ensure-list operator) + :remove-args nil))) + (unless (eql arglist :not-available) + (values + (arglist.keyword-args arglist) + (arglist.allow-other-keys-p arglist))))) + (defmethod extra-keywords (operator &rest args) ;; default method (declare (ignore args)) @@ -2164,7 +2335,7 @@ argument-forms) (let ((function-name-form (car argument-forms))) (when (and (listp function-name-form) - (= (length function-name-form) 2) + (length= function-name-form 2) (member (car function-name-form) '(quote function))) (let ((function-name (cadr function-name-form))) (when (valid-operator-symbol-p function-name) @@ -2214,6 +2385,10 @@ (defun remove-actual-args (decoded-arglist actual-arglist) "Remove from DECODED-ARGLIST the arguments that have already been provided in ACTUAL-ARGLIST." + (assert (or (and (not (arglist.key-p decoded-arglist)) + (not (arglist.any-p decoded-arglist))) + (exactly-one-p (arglist.key-p decoded-arglist) + (arglist.any-p decoded-arglist)))) (loop while (and actual-arglist (arglist.required-args decoded-arglist)) do (progn (pop actual-arglist) @@ -2222,22 +2397,71 @@ (arglist.optional-args decoded-arglist)) do (progn (pop actual-arglist) (pop (arglist.optional-args decoded-arglist)))) [307 lines skipped] From trittweiler at common-lisp.net Thu Aug 23 16:20:12 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 23 Aug 2007 12:20:12 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823162012.C6F503700F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5875 Modified Files: swank-sbcl.lisp Log Message: Added arglist display for declaration specifiers and type specifiers. Examples: `(declare (type' will display (declare (type type-specifier &rest vars)) `(declare (type (float' will display [Typespec] (float &optional lower-limit upper-limit) `(declare (optimize' will display (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) &ANY is a new lambda keyword that is introduced for arglist description purpose, and is very similiar to &KEY, but isn't based upon plists; they're more based upon *FEATURES* lists. (See the comment near the ARGLIST defstruct in `swank.lisp'.) * slime.el: (slime-to-feature-keyword): Renamed to `slime-keywordify'. (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. (slime-ensure-list): New utility. (slime-sexp-at-point): Now takes an argument that specify how many sexps at point should be returned. (slime-enclosing-operator-names): Renamed to `slime-enclosing-form-specs'. (slime-enclosing-form-specs): Returns a list of ``raw form specs'' instead of what was called ``extended operator names'' before, see `swank::parse-form-spec' for more information. This is a simplified superset. Additionally as tertiary return value return a list of points to let the caller see where each form spec is located. Adapted callers accordingly. Extended docstring. (slime-parse-extended-operator-name): Adapted to changes in `slime-enclosing-form-specs'. Now gets more context, and is such more powerful. This was needed to allow parsing DECLARE forms. (slime-make-extended-operator-parser/look-ahead): Because the protocol for arglist display was simplified, it was possible to replace the plethora of parsing function just by this one. (slime-extended-operator-name-parser-alist): Use it. Also add parser for DECLARE forms. (slime-parse-extended-operator/declare): Responsible for parsing DECLARE forms. (%slime-in-mid-of-typespec-p): Helper function for `slime-parse-extended-operator/declare'. (slime-incomplete-form-at-point): New. Return the ``raw form spec'' near point. (slime-complete-form): Use `slime-incomplete-form-at-point'. * swank.lisp: New Helper functions. (length=, ensure-list, recursively-empty-p): New. (maybecall, exactly-one-p): New. * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form specs'' from Slime. (parse-form-spec): New. Takes a ``raw form spec'' and returns a ``form spec'' for further processing in Swank. Docstring documents these two terms. (split-form-spec): New. Return relevant information from a form spec. (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. (find-valid-operator-name): Removed. (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. (defstruct arglist): Add `any-p' and `any-args' slots to contain arguments belonging to the &ANY lambda keyword. (print-arglist): Adapted to also print &ANY args. (print-decoded-arglist-as-template): Likewise. (decode-arglist): Adapted to also decode &ANY args. (remove-actual-args): Adapted to also remove &ANY args. (remove-&key-args): Split out from `remove-actual-args'. (remove-&any-args): New. Removes already provided &ANY args. (arglist-from-form-spec): New. Added detailed docstring. (arglist-dispatch): Dispatching generic function for `arglist-from-form-spec' that does all the work. Renamed from prior `form-completion'. (arglist-dispatch) Added methods for dealing with declaration and type-specifiers. (complete-form): Adapted to take ``raw form specs'' from Slime. (completions-for-keyword): Likewise. (format-arglist-for-echo-area): Removed. Not needed anymore. * swank-backend.lisp (declaration-arglist): New generic function. Returns the arglist for a given declaration identifier. (Backends are supposed to specialize it if they can provide additional information.) (type-specifier-arglist): New generic function. Returns the arglist for a given type-specifier operator. (Backends are supposed to specialize it if they can provide additional information.) (*type-specifier-arglists*): New variable. Contains the arglists for the type specifiers in Common Lisp. * swank-sbcl.lisp: Now depends upon sb-cltl2. (declaration-arglist 'optimize): Specialize the `optimize' declaration identifier to pass it to sb-cltl2:declaration-information. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2007/05/23 14:22:06 1.178 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2007/08/23 16:20:11 1.179 @@ -16,7 +16,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-bsd-sockets) (require 'sb-introspect) - (require 'sb-posix)) + (require 'sb-posix) + (require 'sb-cltl2)) (declaim (optimize (debug 2) (sb-c:insert-step-conditions 0))) @@ -273,6 +274,18 @@ (check-type f function) (sb-impl::%fun-name f)) +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the FLAGS would + ;; have to be fully qualified when used inside a declaration. So we + ;; strip those as long as there's no better way. (FIXME) + `(&any ,@(remove-if-not #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + (defvar *buffer-name* nil) (defvar *buffer-offset*) (defvar *buffer-substring* nil) From trittweiler at common-lisp.net Thu Aug 23 16:20:23 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 23 Aug 2007 12:20:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823162023.2840D554BB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6366 Modified Files: swank-backend.lisp Log Message: Added arglist display for declaration specifiers and type specifiers. Examples: `(declare (type' will display (declare (type type-specifier &rest vars)) `(declare (type (float' will display [Typespec] (float &optional lower-limit upper-limit) `(declare (optimize' will display (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) &ANY is a new lambda keyword that is introduced for arglist description purpose, and is very similiar to &KEY, but isn't based upon plists; they're more based upon *FEATURES* lists. (See the comment near the ARGLIST defstruct in `swank.lisp'.) * slime.el: (slime-to-feature-keyword): Renamed to `slime-keywordify'. (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. (slime-ensure-list): New utility. (slime-sexp-at-point): Now takes an argument that specify how many sexps at point should be returned. (slime-enclosing-operator-names): Renamed to `slime-enclosing-form-specs'. (slime-enclosing-form-specs): Returns a list of ``raw form specs'' instead of what was called ``extended operator names'' before, see `swank::parse-form-spec' for more information. This is a simplified superset. Additionally as tertiary return value return a list of points to let the caller see where each form spec is located. Adapted callers accordingly. Extended docstring. (slime-parse-extended-operator-name): Adapted to changes in `slime-enclosing-form-specs'. Now gets more context, and is such more powerful. This was needed to allow parsing DECLARE forms. (slime-make-extended-operator-parser/look-ahead): Because the protocol for arglist display was simplified, it was possible to replace the plethora of parsing function just by this one. (slime-extended-operator-name-parser-alist): Use it. Also add parser for DECLARE forms. (slime-parse-extended-operator/declare): Responsible for parsing DECLARE forms. (%slime-in-mid-of-typespec-p): Helper function for `slime-parse-extended-operator/declare'. (slime-incomplete-form-at-point): New. Return the ``raw form spec'' near point. (slime-complete-form): Use `slime-incomplete-form-at-point'. * swank.lisp: New Helper functions. (length=, ensure-list, recursively-empty-p): New. (maybecall, exactly-one-p): New. * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form specs'' from Slime. (parse-form-spec): New. Takes a ``raw form spec'' and returns a ``form spec'' for further processing in Swank. Docstring documents these two terms. (split-form-spec): New. Return relevant information from a form spec. (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. (find-valid-operator-name): Removed. (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. (defstruct arglist): Add `any-p' and `any-args' slots to contain arguments belonging to the &ANY lambda keyword. (print-arglist): Adapted to also print &ANY args. (print-decoded-arglist-as-template): Likewise. (decode-arglist): Adapted to also decode &ANY args. (remove-actual-args): Adapted to also remove &ANY args. (remove-&key-args): Split out from `remove-actual-args'. (remove-&any-args): New. Removes already provided &ANY args. (arglist-from-form-spec): New. Added detailed docstring. (arglist-dispatch): Dispatching generic function for `arglist-from-form-spec' that does all the work. Renamed from prior `form-completion'. (arglist-dispatch) Added methods for dealing with declaration and type-specifiers. (complete-form): Adapted to take ``raw form specs'' from Slime. (completions-for-keyword): Likewise. (format-arglist-for-echo-area): Removed. Not needed anymore. * swank-backend.lisp (declaration-arglist): New generic function. Returns the arglist for a given declaration identifier. (Backends are supposed to specialize it if they can provide additional information.) (type-specifier-arglist): New generic function. Returns the arglist for a given type-specifier operator. (Backends are supposed to specialize it if they can provide additional information.) (*type-specifier-arglists*): New variable. Contains the arglists for the type specifiers in Common Lisp. * swank-sbcl.lisp: Now depends upon sb-cltl2. (declaration-arglist 'optimize): Specialize the `optimize' declaration identifier to pass it to sb-cltl2:declaration-information. --- /project/slime/cvsroot/slime/swank-backend.lisp 2007/08/23 13:56:22 1.119 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2007/08/23 16:20:22 1.120 @@ -31,6 +31,8 @@ #:quit-lisp #:references #:unbound-slot-filler + #:declaration-arglist + #:type-specifier-arglist ;; inspector related symbols #:inspector #:inspect-for-emacs @@ -481,11 +483,55 @@ "Return the lambda list for the symbol NAME. NAME can also be a lisp function object, on lisps which support this. -The result can be a list or the :not-available if the arglist -cannot be determined." +The result can be a list or the :not-available keyword if the +arglist cannot be determined." (declare (ignore name)) :not-available) +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest vars)) + (ignore '(&rest vars)) + (ignorable '(&rest vars)) + (special '(&rest vars)) + (inline '(&rest function-names)) + (notinline '(&rest function-name)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest vars)) + ((and (listp decl-identifier) (typespec-p (first decl-identifier))) + '(&rest vars)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + (definterface function-name (function) "Return the name of the function object FUNCTION. @@ -1025,3 +1071,37 @@ when (funcall matchp prefix name) collect name)) + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + )) \ No newline at end of file From trittweiler at common-lisp.net Thu Aug 23 16:20:51 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 23 Aug 2007 12:20:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823162051.D43FB72C3@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6845 Modified Files: slime.el Log Message: Added arglist display for declaration specifiers and type specifiers. Examples: `(declare (type' will display (declare (type type-specifier &rest vars)) `(declare (type (float' will display [Typespec] (float &optional lower-limit upper-limit) `(declare (optimize' will display (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) &ANY is a new lambda keyword that is introduced for arglist description purpose, and is very similiar to &KEY, but isn't based upon plists; they're more based upon *FEATURES* lists. (See the comment near the ARGLIST defstruct in `swank.lisp'.) * slime.el: (slime-to-feature-keyword): Renamed to `slime-keywordify'. (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. (slime-ensure-list): New utility. (slime-sexp-at-point): Now takes an argument that specify how many sexps at point should be returned. (slime-enclosing-operator-names): Renamed to `slime-enclosing-form-specs'. (slime-enclosing-form-specs): Returns a list of ``raw form specs'' instead of what was called ``extended operator names'' before, see `swank::parse-form-spec' for more information. This is a simplified superset. Additionally as tertiary return value return a list of points to let the caller see where each form spec is located. Adapted callers accordingly. Extended docstring. (slime-parse-extended-operator-name): Adapted to changes in `slime-enclosing-form-specs'. Now gets more context, and is such more powerful. This was needed to allow parsing DECLARE forms. (slime-make-extended-operator-parser/look-ahead): Because the protocol for arglist display was simplified, it was possible to replace the plethora of parsing function just by this one. (slime-extended-operator-name-parser-alist): Use it. Also add parser for DECLARE forms. (slime-parse-extended-operator/declare): Responsible for parsing DECLARE forms. (%slime-in-mid-of-typespec-p): Helper function for `slime-parse-extended-operator/declare'. (slime-incomplete-form-at-point): New. Return the ``raw form spec'' near point. (slime-complete-form): Use `slime-incomplete-form-at-point'. * swank.lisp: New Helper functions. (length=, ensure-list, recursively-empty-p): New. (maybecall, exactly-one-p): New. * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form specs'' from Slime. (parse-form-spec): New. Takes a ``raw form spec'' and returns a ``form spec'' for further processing in Swank. Docstring documents these two terms. (split-form-spec): New. Return relevant information from a form spec. (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. (find-valid-operator-name): Removed. (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. (defstruct arglist): Add `any-p' and `any-args' slots to contain arguments belonging to the &ANY lambda keyword. (print-arglist): Adapted to also print &ANY args. (print-decoded-arglist-as-template): Likewise. (decode-arglist): Adapted to also decode &ANY args. (remove-actual-args): Adapted to also remove &ANY args. (remove-&key-args): Split out from `remove-actual-args'. (remove-&any-args): New. Removes already provided &ANY args. (arglist-from-form-spec): New. Added detailed docstring. (arglist-dispatch): Dispatching generic function for `arglist-from-form-spec' that does all the work. Renamed from prior `form-completion'. (arglist-dispatch) Added methods for dealing with declaration and type-specifiers. (complete-form): Adapted to take ``raw form specs'' from Slime. (completions-for-keyword): Likewise. (format-arglist-for-echo-area): Removed. Not needed anymore. * swank-backend.lisp (declaration-arglist): New generic function. Returns the arglist for a given declaration identifier. (Backends are supposed to specialize it if they can provide additional information.) (type-specifier-arglist): New generic function. Returns the arglist for a given type-specifier operator. (Backends are supposed to specialize it if they can provide additional information.) (*type-specifier-arglists*): New variable. Contains the arglists for the type specifiers in Common Lisp. * swank-sbcl.lisp: Now depends upon sb-cltl2. (declaration-arglist 'optimize): Specialize the `optimize' declaration identifier to pass it to sb-cltl2:declaration-information. --- /project/slime/cvsroot/slime/slime.el 2007/08/23 13:56:22 1.802 +++ /project/slime/cvsroot/slime/slime.el 2007/08/23 16:20:51 1.803 @@ -5492,17 +5492,21 @@ ;; skip this sexp (slime-forward-sexp))))) -(defun slime-to-feature-keyword (symbol) - (let ((name (downcase (symbol-name symbol)))) +(defun slime-keywordify (symbol-designator) + "Makes a keyword out of SYMBOL-DESIGNATOR, which may either be +a symbol or a string." + (let ((name (downcase (etypecase symbol-designator + (symbol (symbol-name symbol-designator)) + (string symbol-designator))))) (intern (if (eq ?: (aref name 0)) name - (concat ":" name))))) + (concat ":" name))))) (defun slime-eval-feature-conditional (e) "Interpret a reader conditional expression." (if (symbolp e) - (memq (slime-to-feature-keyword e) (slime-lisp-features)) - (funcall (ecase (slime-to-feature-keyword (car e)) + (memq (slime-keywordify rd e) (slime-lisp-features)) + (funcall (ecase (slime-keywordify (car e)) (:and #'every) (:or #'some) (:not (lambda (f l) (not (apply f l))))) @@ -5715,16 +5719,31 @@ (save-excursion (insert arglist)))))) + +(defun slime-incomplete-form-at-point () + "Looks for a ``raw form spec'' around point to be processed by +SWANK::PARSE-FORM-SPEC. It is similiar to +SLIME-INCOMPLETE-SEXP-AT-POINT but looks further back than just +one sexp to find out the context." + (multiple-value-bind (operators arg-indices points) + (slime-enclosing-form-specs) + (if (null operators) + "" + (let ((op (first operators))) + (destructure-case (slime-ensure-list op) + ((:declaration declspec) op) + ((:type-specifier typespec) op) + (t (format "(%s)" (buffer-substring-no-properties + (save-excursion (goto-char (first points)) (point)) + (point))))))))) + (defun slime-complete-form () "Complete the form at point. This is a superset of the functionality of `slime-insert-arglist'." (interactive) ;; Find the (possibly incomplete) form around point. - (let* ((start (save-excursion (backward-up-list 1) (point))) - (end (point)) - (form-string - (concat (buffer-substring-no-properties start end) ")"))) - (let ((result (slime-eval `(swank:complete-form ,form-string)))) + (let ((form-string (slime-incomplete-form-at-point))) + (let ((result (slime-eval `(swank:complete-form ',form-string)))) (if (eq result :not-available) (error "Arglist not available") (progn @@ -5740,6 +5759,7 @@ (backward-up-list 1) (indent-sexp))))))) + (defun slime-get-arglist (symbol-name) "Return the argument list for SYMBOL-NAME." (slime-eval `(swank:arglist-for-echo-area (quote (,symbol-name))))) @@ -5841,8 +5861,8 @@ (if global (values (slime-qualify-cl-symbol-name global) `(swank:variable-desc-for-echo-area ,global)) - (multiple-value-bind (operators arg-indices) - (slime-enclosing-operator-names) + (multiple-value-bind (operators arg-indices points) + (slime-enclosing-form-specs) (values (mapcar* (lambda (designator arg-index) (cons (if (symbolp designator) @@ -6317,10 +6337,10 @@ ((and (< beg (point-max)) (string= (buffer-substring-no-properties beg (1+ beg)) ":")) ;; Contextual keyword completion - (multiple-value-bind (operator-names arg-indices) + (multiple-value-bind (operator-names arg-indices points) (save-excursion (goto-char beg) - (slime-enclosing-operator-names)) + (slime-enclosing-form-specs)) (when operator-names (let ((completions (slime-completions-for-keyword operator-names token @@ -9293,7 +9313,7 @@ (skip-chars-backward " \t\n") (let* ((deleted-region (delete-and-extract-region point (point))) (deleted-text (substring-no-properties deleted-region)) - (prior-parens-count (count ?\) deleted-text))) + (prior-parens-count (count ?\) deleted-text))) ;; Remember: we always insert as many parentheses as necessary ;; and only afterwards delete the superfluously-added parens. (when slime-close-parens-limit @@ -10474,6 +10494,8 @@ (or (< n 0) (and seq t))) (sequence (> (length seq) n)))) +(defun slime-ensure-list (thing) + (if (listp thing) thing (list thing))) ;;;;; Buffer related @@ -10631,127 +10653,222 @@ (let ((name (slime-symbol-name-at-point))) (and name (intern name)))) -(defun slime-sexp-at-point () +(defun slime-sexp-at-point (&optional n) "Return the sexp at point as a string, otherwise nil." - (let ((string (or (slime-symbol-name-at-point) - (thing-at-point 'sexp)))) - (if string (substring-no-properties string) nil))) + (interactive "p") (or n (setq n 1)) + (flet ((sexp-at-point () + (let ((string (or (slime-symbol-name-at-point) + (thing-at-point 'sexp)))) + (if string (substring-no-properties string) nil)))) + (save-excursion + (let ((result "")) + (callf concat result (format "%s" (sexp-at-point))) + (dotimes (i (1- n)) + (forward-sexp) (forward-char 1) + (callf concat result (format " %s" (sexp-at-point)))) + result)))) (defun slime-sexp-at-point-or-error () "Return the sexp at point as a string, othwise signal an error." (or (slime-sexp-at-point) (error "No expression at point."))) -(defun slime-parse-extended-operator-name (name) - "Assume that point is at the operator NAME in the -current buffer. If NAME is MAKE-INSTANCE or another operator in -`slime-extendeded-operator-name-parser-alist', collect additional -information from the operator call and encode it as an extended -operator name like (MAKE-INSTANCE CLASS \"make-instance\"). Return -NAME or the extended operator name." +(defun slime-incomplete-sexp-at-point (&optional n) + (interactive "p") (or n (setq n 1)) + (buffer-substring-no-properties (save-excursion (backward-up-list n) (point)) + (point))) + + +(defun slime-parse-extended-operator-name (user-point ops indices points) + "Assume that point is directly at the operator that should be parsed. +USER-POINT is the value of `point' where the user was looking at. +OPS, INDICES and POINTS are updated to reflect the new values after +parsing, and are then returned back as multiple values." + ;; OPS, INDICES and POINTS are like the finally returned values of + ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order, + ;; i.e. the leftmost operator (that is the latest) operator comes + ;; first. (save-excursion (ignore-errors (forward-char (1+ (length name))) (slime-forward-blanks) - (let* ((symbol-name (upcase (slime-cl-symbol-name name))) - (assoc (assoc symbol-name slime-extended-operator-name-parser-alist))) + (let* ((current-op (first ops)) + (op-name (upcase (slime-cl-symbol-name current-op))) + (assoc (assoc op-name slime-extended-operator-name-parser-alist))) (when assoc - (setq name (funcall (cdr assoc) name)))))) - name) + (let* ((entry (cdr assoc)) + (parser (if (listp entry) + (apply (first entry) (rest entry)) + entry))) + (multiple-value-setq (ops indices points) + (funcall parser op-name user-point ops indices points))))))) + (values ops indices points)) + (defvar slime-extended-operator-name-parser-alist - '(("MAKE-INSTANCE" . slime-parse-extended-operator-name/make-instance) - ("MAKE-CONDITION" . slime-parse-extended-operator-name/make-instance) - ("ERROR" . slime-parse-extended-operator-name/make-instance) - ("SIGNAL" . slime-parse-extended-operator-name/make-instance) - ("WARN" . slime-parse-extended-operator-name/make-instance) - ("CERROR" . slime-parse-extended-operator-name/cerror) - ("CHANGE-CLASS" . slime-parse-extended-operator-name/cerror) - ("DEFMETHOD" . slime-parse-extended-operator-name/defmethod) - ("APPLY" . slime-parse-extended-operator-name/apply))) - -(defun slime-parse-extended-operator-name/make-instance (name) - (let ((str (slime-sexp-at-point))) - (when (= (aref str 0) ?') - (setq name (list :make-instance (substring str 1) - name)))) - name) - -(defun slime-parse-extended-operator-name/apply (name) - (let ((str (slime-sexp-at-point))) - (when (string-match "^#?'\\(.*\\)" str) - (setq name (list :make-instance (match-string 1 str) - name)))) - name) - -(defun slime-parse-extended-operator-name/cerror (name) - (let ((continue-string-sexp (slime-sexp-at-point)) - (class-sexp (progn (forward-sexp) (forward-char 1) (slime-sexp-at-point)))) - (when (= (aref class-sexp 0) ?') - (setq name (list :make-instance (substring class-sexp 1) - name - continue-string-sexp)))) - name) - -(defun slime-parse-extended-operator-name/defmethod (name) - (let ((str (slime-sexp-at-point))) - (setq name (list :defmethod str)))) - -(defun slime-enclosing-operator-names (&optional max-levels) - "Return the list of operator names of the forms containing point. -As a secondary value, return the indices of the respective argument to -the operator. When MAX-LEVELS is non-nil, go up at most this many -levels of parens." - (let ((result '()) - (arg-indices '()) - (level 1) - (parse-sexp-lookup-properties nil)) + '(("MAKE-INSTANCE" . (slime-make-extended-operator-parser/look-ahead 1)) + ("MAKE-CONDITION" . (slime-make-extended-operator-parser/look-ahead 1)) + ("ERROR" . (slime-make-extended-operator-parser/look-ahead 1)) + ("SIGNAL" . (slime-make-extended-operator-parser/look-ahead 1)) + ("WARN" . (slime-make-extended-operator-parser/look-ahead 1)) + ("CERROR" . (slime-make-extended-operator-parser/look-ahead 2)) + ("CHANGE-CLASS" . (slime-make-extended-operator-parser/look-ahead 2)) + ("DEFMETHOD" . (slime-make-extended-operator-parser/look-ahead 1)) + ("APPLY" . (slime-make-extended-operator-parser/look-ahead 1)) + ("DECLARE" . slime-parse-extended-operator/declare))) + + +(defun slime-make-extended-operator-parser/look-ahead (steps) + "Returns a parser that parses the current operator at point +plus STEPS-many additional sexps on the right side of the +operator." + (lexical-let ((n steps)) + #'(lambda (name user-point current-ops current-indices current-points) + (let ((old-ops (rest current-ops))) + (let ((str (slime-sexp-at-point n))) + (setq current-ops + (cons (format "(%s %s)" name str) old-ops))) + (values current-ops current-indices current-points))))) + + +(defun slime-parse-extended-operator/declare + (name user-point current-ops current-indices current-points) + (when (string= (thing-at-point 'char) "(") + (let ((orig-point (point))) + (save-excursion + (goto-char user-point) + (slime-end-of-symbol) + ;; Head of CURRENT-OPS is "declare" at this point, but we're + ;; interested in what comes next. + (let ((decl-ops (rest current-ops)) (new-indices (rest current-indices))) + (if (%slime-in-mid-of-typespec-p decl-ops) + ;; Parse type-specifier: + (let ((rightmost-operator (first (last decl-ops))) + (rightmost-index (first (last new-indices))) ; arg# in the typespec. + (rightmost-op-pos (first (last points)))) + (goto-char rightmost-op-pos) + (let ((typespec (format "(%s)" (slime-sexp-at-point rightmost-index)))) + (setq current-ops (list `(:type-specifier ,typespec))) + (setq current-indicies (list rightmost-index)) + (setq current-points (list rightmost-op-pos)))) + ;; Parse declaration specifier: + (let ((nesting 0)) + (while (> (point) orig-point) + (backward-up-list) + (incf nesting)) + (when (= (point) orig-point) + (goto-char user-point) + (let ((declspec (concat (slime-incomplete-sexp-at-point nesting) + (make-string nesting ?\))))) + (setq current-ops (list `(:declaration ,declspec))) + (setq current-indices new-indices))))))))) + (values current-ops current-indices current-points)) + +(defun %slime-in-mid-of-typespec-p (decl-ops) + (let ((rightmost-operator (first (last decl-ops))) + (leftmost-operator (first decl-ops))) + (or (and (equalp leftmost-operator "type") ; `(declare (type' ? + (not (slime-length= decl-ops 1))) ; `(declare (type (' ? + (and (null leftmost-operator) ; `(declare (' ? + (not (null rightmost-operator)))))) ; `(declare ((' ? + + +(defun slime-enclosing-form-specs (&optional max-levels) + "Return the list of ``raw form specs'' of all the forms +containing point from right to left. + +As a secondary value, return a list of indices: Each index tells +for each corresponding form spec in what argument position the +user's point is. + +As tertiary value, return the positions of the operators that are +contained in the returned form specs. + + When MAX-LEVELS is non-nil, go up at most this many levels of +parens. + +\(See SWANK::PARSE-FORM-SPEC for more information about what +exactly constitutes a ``raw form specs'') + +Example: + + A return value like the following + + (values (\"quux\" \"bar\" \"foo\") (3 2 1) (p1 p2 p3)) + + can be interpreted as follows: + + The user point is located in the 3rd argument position of a + form with the operator name \"quux\" (which starts at P1.) + + This form is located in the 2nd argument position of a form + with the operator name \"bar\" (which starts at P2.) + + This form again is in the 1st argument position of a form + with the operator name \"foo\" (which itself begins at P3.) + + For instance, the corresponding buffer content could have looked + like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point. +" + (let ((level 1) + (parse-sexp-lookup-properties nil) + (initial-point (point)) + (result '()) (arg-indices '()) (points '())) ;; The expensive lookup of syntax-class text properties is only ;; used for interactive balancing of #<...> in presentations; we ;; do not need them in navigating through the nested lists. ;; This speeds up this function significantly. (ignore-errors - (save-excursion - ;; Make sure we get the whole operator name. - (slime-end-of-symbol) - (save-restriction - ;; Don't parse more than 20000 characters before point, so we don't spend - ;; too much time. - (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) - (narrow-to-region (save-excursion (beginning-of-defun) (point)) - (min (1+ (point)) (point-max))) - (while (or (not max-levels) - (<= level max-levels)) - (let ((arg-index 0)) - ;; Move to the beginning of the current sexp if not already there. - (if (or (and (char-after) - (member (char-syntax (char-after)) '(?\( ?'))) - (member (char-syntax (char-before)) '(?\ ?>))) + (save-excursion + ;; Make sure we get the whole operator name. + (slime-end-of-symbol) + (save-restriction + ;; Don't parse more than 20000 characters before point, so we don't spend + ;; too much time. + (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) + (narrow-to-region (save-excursion (beginning-of-defun) (point)) + (min (1+ (point)) (point-max))) + (while (or (not max-levels) + (<= level max-levels)) + (let ((arg-index 0)) + ;; Move to the beginning of the current sexp if not already there. + (if (or (and (char-after) + (member (char-syntax (char-after)) '(?\( ?'))) + (member (char-syntax (char-before)) '(?\ ?>))) + (incf arg-index)) + (ignore-errors (backward-sexp 1)) + (while (and (< arg-index 64) + (ignore-errors (backward-sexp 1) + (> (point) (point-min)))) (incf arg-index)) - (ignore-errors - (backward-sexp 1)) - (while (and (< arg-index 64) - (ignore-errors (backward-sexp 1) - (> (point) (point-min)))) - (incf arg-index)) - (backward-up-list 1) - (when (member (char-syntax (char-after)) '(?\( ?')) - (incf level) - (forward-char 1) - (let ((name (slime-symbol-name-at-point))) - (cond - (name - (push (slime-parse-extended-operator-name name) result) - (push arg-index arg-indices)) [48 lines skipped] From trittweiler at common-lisp.net Thu Aug 23 16:21:24 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 23 Aug 2007 12:21:24 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823162124.3CF2A1D120@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7571 Modified Files: ChangeLog Log Message: Added arglist display for declaration specifiers and type specifiers. Examples: `(declare (type' will display (declare (type type-specifier &rest vars)) `(declare (type (float' will display [Typespec] (float &optional lower-limit upper-limit) `(declare (optimize' will display (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) &ANY is a new lambda keyword that is introduced for arglist description purpose, and is very similiar to &KEY, but isn't based upon plists; they're more based upon *FEATURES* lists. (See the comment near the ARGLIST defstruct in `swank.lisp'.) * slime.el: (slime-to-feature-keyword): Renamed to `slime-keywordify'. (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. (slime-ensure-list): New utility. (slime-sexp-at-point): Now takes an argument that specify how many sexps at point should be returned. (slime-enclosing-operator-names): Renamed to `slime-enclosing-form-specs'. (slime-enclosing-form-specs): Returns a list of ``raw form specs'' instead of what was called ``extended operator names'' before, see `swank::parse-form-spec' for more information. This is a simplified superset. Additionally as tertiary return value return a list of points to let the caller see where each form spec is located. Adapted callers accordingly. Extended docstring. (slime-parse-extended-operator-name): Adapted to changes in `slime-enclosing-form-specs'. Now gets more context, and is such more powerful. This was needed to allow parsing DECLARE forms. (slime-make-extended-operator-parser/look-ahead): Because the protocol for arglist display was simplified, it was possible to replace the plethora of parsing function just by this one. (slime-extended-operator-name-parser-alist): Use it. Also add parser for DECLARE forms. (slime-parse-extended-operator/declare): Responsible for parsing DECLARE forms. (%slime-in-mid-of-typespec-p): Helper function for `slime-parse-extended-operator/declare'. (slime-incomplete-form-at-point): New. Return the ``raw form spec'' near point. (slime-complete-form): Use `slime-incomplete-form-at-point'. * swank.lisp: New Helper functions. (length=, ensure-list, recursively-empty-p): New. (maybecall, exactly-one-p): New. * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form specs'' from Slime. (parse-form-spec): New. Takes a ``raw form spec'' and returns a ``form spec'' for further processing in Swank. Docstring documents these two terms. (split-form-spec): New. Return relevant information from a form spec. (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. (find-valid-operator-name): Removed. (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. (defstruct arglist): Add `any-p' and `any-args' slots to contain arguments belonging to the &ANY lambda keyword. (print-arglist): Adapted to also print &ANY args. (print-decoded-arglist-as-template): Likewise. (decode-arglist): Adapted to also decode &ANY args. (remove-actual-args): Adapted to also remove &ANY args. (remove-&key-args): Split out from `remove-actual-args'. (remove-&any-args): New. Removes already provided &ANY args. (arglist-from-form-spec): New. Added detailed docstring. (arglist-dispatch): Dispatching generic function for `arglist-from-form-spec' that does all the work. Renamed from prior `form-completion'. (arglist-dispatch) Added methods for dealing with declaration and type-specifiers. (complete-form): Adapted to take ``raw form specs'' from Slime. (completions-for-keyword): Likewise. (format-arglist-for-echo-area): Removed. Not needed anymore. * swank-backend.lisp (declaration-arglist): New generic function. Returns the arglist for a given declaration identifier. (Backends are supposed to specialize it if they can provide additional information.) (type-specifier-arglist): New generic function. Returns the arglist for a given type-specifier operator. (Backends are supposed to specialize it if they can provide additional information.) (*type-specifier-arglists*): New variable. Contains the arglists for the type specifiers in Common Lisp. * swank-sbcl.lisp: Now depends upon sb-cltl2. (declaration-arglist 'optimize): Specialize the `optimize' declaration identifier to pass it to sb-cltl2:declaration-information. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 13:56:22 1.1148 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 16:21:23 1.1149 @@ -1,3 +1,106 @@ +2007-08-23 Tobias C. Rittweiler + + Added arglist display for declaration specifiers and type + specifiers. + + Examples: + + `(declare (type' will display + + (declare (type type-specifier &rest vars)) + + `(declare (type (float' will display + + [Typespec] (float &optional lower-limit upper-limit) + + `(declare (optimize' will display + + (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) + + &ANY is a new lambda keyword that is introduced for arglist + description purpose, and is very similiar to &KEY, but isn't based + upon plists; they're more based upon *FEATURES* lists. (See the + comment near the ARGLIST defstruct in `swank.lisp'.) + + * slime.el: + (slime-to-feature-keyword): Renamed to `slime-keywordify'. + (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. + (slime-ensure-list): New utility. + (slime-sexp-at-point): Now takes an argument that specify how many + sexps at point should be returned. + (slime-enclosing-operator-names): Renamed to + `slime-enclosing-form-specs'. + (slime-enclosing-form-specs): Returns a list of ``raw form specs'' + instead of what was called ``extended operator names'' before, see + `swank::parse-form-spec' for more information. This is a + simplified superset. Additionally as tertiary return value return + a list of points to let the caller see where each form spec is + located. Adapted callers accordingly. Extended docstring. + (slime-parse-extended-operator-name): Adapted to changes in + `slime-enclosing-form-specs'. Now gets more context, and is such + more powerful. This was needed to allow parsing DECLARE forms. + (slime-make-extended-operator-parser/look-ahead): Because the + protocol for arglist display was simplified, it was possible to + replace the plethora of parsing function just by this one. + (slime-extended-operator-name-parser-alist): Use it. Also add + parser for DECLARE forms. + (slime-parse-extended-operator/declare): Responsible for parsing + DECLARE forms. + (%slime-in-mid-of-typespec-p): Helper function for + `slime-parse-extended-operator/declare'. + (slime-incomplete-form-at-point): New. Return the ``raw form + spec'' near point. + (slime-complete-form): Use `slime-incomplete-form-at-point'. + + * swank.lisp: New Helper functions. + (length=, ensure-list, recursively-empty-p): New. + (maybecall, exactly-one-p): New. + + * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form + specs'' from Slime. + (parse-form-spec): New. Takes a ``raw form spec'' and returns a + ``form spec'' for further processing in Swank. Docstring documents + these two terms. + (split-form-spec): New. Return relevant information from a form spec. + (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. + (find-valid-operator-name): Removed. + (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. + + (defstruct arglist): Add `any-p' and `any-args' slots to contain + arguments belonging to the &ANY lambda keyword. + (print-arglist): Adapted to also print &ANY args. + (print-decoded-arglist-as-template): Likewise. + (decode-arglist): Adapted to also decode &ANY args. + (remove-actual-args): Adapted to also remove &ANY args. + (remove-&key-args): Split out from `remove-actual-args'. + (remove-&any-args): New. Removes already provided &ANY args. + (arglist-from-form-spec): New. Added detailed docstring. + (arglist-dispatch): Dispatching generic function for + `arglist-from-form-spec' that does all the work. Renamed from + prior `form-completion'. + (arglist-dispatch) Added methods for dealing with declaration and + type-specifiers. + (complete-form): Adapted to take ``raw form specs'' from Slime. + (completions-for-keyword): Likewise. + (format-arglist-for-echo-area): Removed. Not needed anymore. + + * swank-backend.lisp (declaration-arglist): New generic + function. Returns the arglist for a given declaration + identifier. (Backends are supposed to specialize it if they can + provide additional information.) + (type-specifier-arglist): New generic function. Returns the + arglist for a given type-specifier operator. (Backends are + supposed to specialize it if they can provide additional + information.) + (*type-specifier-arglists*): New variable. Contains the arglists + for the type specifiers in Common Lisp. + + * swank-sbcl.lisp: Now depends upon sb-cltl2. + (declaration-arglist 'optimize): Specialize the `optimize' + declaration identifier to pass it to + sb-cltl2:declaration-information. + + 2007-08-23 Helmut Eller Some inspector cleanups. From heller at common-lisp.net Thu Aug 23 17:45:44 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 13:45:44 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823174544.62B79A143@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22138 Modified Files: ChangeLog swank.lisp Log Message: Moved Marco Baringer's inspector to contrib. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 16:21:23 1.1149 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 17:45:43 1.1150 @@ -1,3 +1,11 @@ +2007-08-23 Helmut Eller + + Move Marco Baringer's inspector to contrib. + + * swank.lisp (*default-inspector*): New variable. Set this + variable dispatch to different inspectors. + (inspect-object): Use it. + 2007-08-23 Tobias C. Rittweiler Added arglist display for declaration specifiers and type --- /project/slime/cvsroot/slime/swank.lisp 2007/08/23 16:19:56 1.494 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/23 17:45:44 1.495 @@ -4312,701 +4312,6 @@ (:value ,*readtable*) ") it is a macro character: " (:value ,(get-macro-character char))))))) -(defun docstring-ispec (label object kind) - "Return a inspector spec if OBJECT has a docstring of of kind KIND." - (let ((docstring (documentation object kind))) - (cond ((not docstring) nil) - ((< (+ (length label) (length docstring)) - 75) - (list label ": " docstring '(:newline))) - (t - (list label ": " '(:newline) " " docstring '(:newline)))))) - -(defmethod inspect-for-emacs ((symbol symbol) inspector) - (declare (ignore inspector)) - (let ((package (symbol-package symbol))) - (multiple-value-bind (_symbol status) - (and package (find-symbol (string symbol) package)) - (declare (ignore _symbol)) - (values - "A symbol." - (append - (label-value-line "Its name is" (symbol-name symbol)) - ;; - ;; Value - (cond ((boundp symbol) - (label-value-line (if (constantp symbol) - "It is a constant of value" - "It is a global variable bound to") - (symbol-value symbol))) - (t '("It is unbound." (:newline)))) - (docstring-ispec "Documentation" symbol 'variable) - (multiple-value-bind (expansion definedp) (macroexpand symbol) - (if definedp - (label-value-line "It is a symbol macro with expansion" - expansion))) - ;; - ;; Function - (if (fboundp symbol) - (append (if (macro-function symbol) - `("It a macro with macro-function: " - (:value ,(macro-function symbol))) - `("It is a function: " - (:value ,(symbol-function symbol)))) - `(" " (:action "[make funbound]" - ,(lambda () (fmakunbound symbol)))) - `((:newline))) - `("It has no function value." (:newline))) - (docstring-ispec "Function Documentation" symbol 'function) - (if (compiler-macro-function symbol) - (label-value-line "It also names the compiler macro" - (compiler-macro-function symbol))) - (docstring-ispec "Compiler Macro Documentation" - symbol 'compiler-macro) - ;; - ;; Package - (if package - `("It is " ,(string-downcase (string status)) - " to the package: " - (:value ,package ,(package-name package)) - ,@(if (eq :internal status) - `(" " - (:action "[export it]" - ,(lambda () (export symbol package))))) - " " - (:action "[unintern it]" - ,(lambda () (unintern symbol package))) - (:newline)) - '("It is a non-interned symbol." (:newline))) - ;; - ;; Plist - (label-value-line "Property list" (symbol-plist symbol)) - ;; - ;; Class - (if (find-class symbol nil) - `("It names the class " - (:value ,(find-class symbol) ,(string symbol)) - " " - (:action "[remove]" - ,(lambda () (setf (find-class symbol) nil))) - (:newline))) - ;; - ;; More package - (if (find-package symbol) - (label-value-line "It names the package" (find-package symbol))) - ))))) - -(defmethod inspect-for-emacs ((f function) inspector) - (declare (ignore inspector)) - (values "A function." - (append - (label-value-line "Name" (function-name f)) - `("Its argument list is: " - ,(inspector-princ (arglist f)) (:newline)) - (docstring-ispec "Documentation" f t) - (if (function-lambda-expression f) - (label-value-line "Lambda Expression" - (function-lambda-expression f)))))) - -(defun method-specializers-for-inspect (method) - "Return a \"pretty\" list of the method's specializers. Normal - specializers are replaced by the name of the class, eql - specializers are replaced by `(eql ,object)." - (mapcar (lambda (spec) - (typecase spec - (swank-mop:eql-specializer - `(eql ,(swank-mop:eql-specializer-object spec))) - (t (swank-mop:class-name spec)))) - (swank-mop:method-specializers method))) - -(defun method-for-inspect-value (method) - "Returns a \"pretty\" list describing METHOD. The first element - of the list is the name of generic-function method is - specialiazed on, the second element is the method qualifiers, - the rest of the list is the method's specialiazers (as per - method-specializers-for-inspect)." - (append (list (swank-mop:generic-function-name - (swank-mop:method-generic-function method))) - (swank-mop:method-qualifiers method) - (method-specializers-for-inspect method))) - -(defmethod inspect-for-emacs ((object standard-object) inspector) - (let ((class (class-of object))) - (values "An object." - `("Class: " (:value ,class) (:newline) - ,@(all-slots-for-inspector object inspector))))) - -(defvar *gf-method-getter* 'methods-by-applicability - "This function is called to get the methods of a generic function. -The default returns the method sorted by applicability. -See `methods-by-applicability'.") - -(defun specializer< (specializer1 specializer2) - "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." - (let ((s1 specializer1) (s2 specializer2) ) - (cond ((typep s1 'swank-mop:eql-specializer) - (not (typep s2 'swank-mop:eql-specializer))) - (t - (flet ((cpl (class) - (and (swank-mop:class-finalized-p class) - (swank-mop:class-precedence-list class)))) - (member s2 (cpl s1))))))) - -(defun methods-by-applicability (gf) - "Return methods ordered by most specific argument types. - -`method-specializer<' is used for sorting." - ;; FIXME: argument-precedence-order and qualifiers are ignored. - (labels ((method< (meth1 meth2) - (loop for s1 in (swank-mop:method-specializers meth1) - for s2 in (swank-mop:method-specializers meth2) - do (cond ((specializer< s2 s1) (return nil)) - ((specializer< s1 s2) (return t)))))) - (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<))) - -(defun abbrev-doc (doc &optional (maxlen 80)) - "Return the first sentence of DOC, but not more than MAXLAN characters." - (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) - maxlen - (length doc)))) - -(defgeneric inspect-slot-for-emacs (class object slot) - (:method (class object slot) - (let ((slot-name (swank-mop:slot-definition-name slot)) - (boundp (swank-mop:slot-boundp-using-class class object slot))) - `(,@(if boundp - `((:value ,(swank-mop:slot-value-using-class class object slot))) - `("#")) - " " - (:action "[set value]" - ,(lambda () (with-simple-restart - (abort "Abort setting slot ~S" slot-name) - (let ((value-string (eval-in-emacs - `(condition-case c - (slime-read-object - ,(format nil "Set slot ~S to (evaluated) : " slot-name)) - (quit nil))))) - (when (and value-string - (not (string= value-string ""))) - (setf (swank-mop:slot-value-using-class class object slot) - (eval (read-from-string value-string)))))))) - ,@(when boundp - `(" " (:action "[make unbound]" - ,(lambda () (swank-mop:slot-makunbound-using-class class object slot))))))))) - -(defgeneric all-slots-for-inspector (object inspector) - (:method ((object standard-object) inspector) - (declare (ignore inspector)) - (append '("--------------------" (:newline) - "All Slots:" (:newline)) - (let* ((class (class-of object)) - (direct-slots (swank-mop:class-direct-slots class)) - (effective-slots (sort (copy-seq (swank-mop:class-slots class)) - #'string< :key #'swank-mop:slot-definition-name)) - (slot-presentations (loop for effective-slot :in effective-slots - collect (inspect-slot-for-emacs - class object effective-slot))) - (longest-slot-name-length - (loop for slot :in effective-slots - maximize (length (symbol-name - (swank-mop:slot-definition-name slot)))))) - (loop - for effective-slot :in effective-slots - for slot-presentation :in slot-presentations - for direct-slot = (find (swank-mop:slot-definition-name effective-slot) - direct-slots :key #'swank-mop:slot-definition-name) - for slot-name = (inspector-princ - (swank-mop:slot-definition-name effective-slot)) - for padding-length = (- longest-slot-name-length - (length (symbol-name - (swank-mop:slot-definition-name - effective-slot)))) - collect `(:value ,(if direct-slot - (list direct-slot effective-slot) - effective-slot) - ,slot-name) - collect (make-array padding-length - :element-type 'character - :initial-element #\Space) - collect " = " - append slot-presentation - collect '(:newline)))))) - -(defmethod inspect-for-emacs ((gf standard-generic-function) inspector) - (flet ((lv (label value) (label-value-line label value))) - (values - "A generic function." - (append - (lv "Name" (swank-mop:generic-function-name gf)) - (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) - (docstring-ispec "Documentation" gf t) - (lv "Method class" (swank-mop:generic-function-method-class gf)) - (lv "Method combination" - (swank-mop:generic-function-method-combination gf)) - `("Methods: " (:newline)) - (loop for method in (funcall *gf-method-getter* gf) append - `((:value ,method ,(inspector-princ - ;; drop the name of the GF - (cdr (method-for-inspect-value method)))) - " " - (:action "[remove method]" - ,(let ((m method)) ; LOOP reassigns method - (lambda () - (remove-method gf m)))) - (:newline))) - `((:newline)) - (all-slots-for-inspector gf inspector))))) - -(defmethod inspect-for-emacs ((method standard-method) inspector) - (values "A method." - `("Method defined on the generic function " - (:value ,(swank-mop:method-generic-function method) - ,(inspector-princ - (swank-mop:generic-function-name - (swank-mop:method-generic-function method)))) - (:newline) - ,@(docstring-ispec "Documentation" method t) - "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) - (:newline) - "Specializers: " (:value ,(swank-mop:method-specializers method) - ,(inspector-princ (method-specializers-for-inspect method))) - (:newline) - "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) - (:newline) - "Method function: " (:value ,(swank-mop:method-function method)) - (:newline) - ,@(all-slots-for-inspector method inspector)))) - -(defmethod inspect-for-emacs ((class standard-class) inspector) - (values "A class." - `("Name: " (:value ,(class-name class)) - (:newline) - "Super classes: " - ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) - (:newline) - "Direct Slots: " - ,@(common-seperated-spec - (swank-mop:class-direct-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) - (:newline) - "Effective Slots: " - ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec - (swank-mop:class-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ - (swank-mop:slot-definition-name slot))))) - '("#")) - (:newline) - ,@(let ((doc (documentation class t))) - (when doc - `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) - "Sub classes: " - ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) - (lambda (sub) - `(:value ,sub ,(inspector-princ (class-name sub))))) - (:newline) - "Precedence List: " - ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec (swank-mop:class-precedence-list class) - (lambda (class) - `(:value ,class ,(inspector-princ (class-name class))))) - '("#")) - (:newline) - ,@(when (swank-mop:specializer-direct-methods class) - `("It is used as a direct specializer in the following methods:" (:newline) - ,@(loop - for method in (sort (copy-seq (swank-mop:specializer-direct-methods class)) - #'string< :key (lambda (x) - (symbol-name - (let ((name (swank-mop::generic-function-name - (swank-mop::method-generic-function x)))) - (if (symbolp name) name (second name)))))) - collect " " - collect `(:value ,method ,(inspector-princ (method-for-inspect-value method))) - collect '(:newline) - if (documentation method t) - collect " Documentation: " and - collect (abbrev-doc (documentation method t)) and - collect '(:newline)))) - "Prototype: " ,(if (swank-mop:class-finalized-p class) - `(:value ,(swank-mop:class-prototype class)) - '"#") - (:newline) - ,@(all-slots-for-inspector class inspector)))) - -(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) inspector) - (values "A slot." - `("Name: " (:value ,(swank-mop:slot-definition-name slot)) - (:newline) - ,@(when (swank-mop:slot-definition-documentation slot) - `("Documentation:" (:newline) - (:value ,(swank-mop:slot-definition-documentation slot)) - (:newline))) - "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) - "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) - `(:value ,(swank-mop:slot-definition-initform slot)) - "#") (:newline) - "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) - (:newline) - ,@(all-slots-for-inspector slot inspector)))) - - -;; Wrapper structure over the list of symbols of a package that should -;; be displayed with their respective classification flags. This is -;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS. -;; Used by the Inspector for packages. -(defstruct (%package-symbols-container (:conc-name %container.) - (:constructor %%make-package-symbols-container)) - title ;; A string; the title of the inspector page in Emacs. - description ;; A list of renderable objects; used as description. - symbols ;; A list of symbols. Supposed to be sorted alphabetically. - grouping-kind ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING. - ) - -(defun %make-package-symbols-container (&key title description symbols) - (%%make-package-symbols-container :title title :description description - :symbols symbols :grouping-kind :symbol)) - -(defgeneric make-symbols-listing (grouping-kind symbols)) - -(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) - "Returns an object renderable by Emacs' inspector side that -alphabetically lists all the symbols in SYMBOLS together with a -concise string representation of what each symbol -represents (cf. CLASSIFY-SYMBOL & Fuzzy Completion.)" - (let ((max-length (loop for s in symbols maximizing (length (symbol-name s)))) - (distance 10)) ; empty distance between name and classification - (flet ((string-representations (symbol) - (let* ((name (symbol-name symbol)) - (length (length name)) - (padding (- max-length length)) - (classification (classify-symbol symbol))) - (values - (concatenate 'string - name - (make-string (+ padding distance) :initial-element #\Space)) - (symbol-classification->string classification))))) - `("" ; 8 is (length "Symbols:") - "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:" - (:newline) - ,(concatenate 'string ; underlining dashes - (make-string (+ max-length distance -1) :initial-element #\-) - " " - (let* ((dummy (classify-symbol (gensym))) - (dummy (symbol-classification->string dummy)) - (classification-length (length dummy))) - (make-string classification-length :initial-element #\-))) - (:newline) - ,@(loop for symbol in symbols appending - (multiple-value-bind (symbol-string classification-string) - (string-representations symbol) - `((:value ,symbol ,symbol-string) ,classification-string - (:newline) - ))))))) - [321 lines skipped] From heller at common-lisp.net Thu Aug 23 17:46:31 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 13:46:31 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070823174631.47417240C1@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv22479 Modified Files: ChangeLog Added Files: slime-fancy-inspector.el swank-fancy-inspector.lisp Log Message: Moved Marco Baringer's inspector to contrib. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/23 12:58:52 1.2 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/23 17:46:31 1.3 @@ -1,3 +1,14 @@ +2007-08-23 Helmut Eller + + Move Marco Baringer's inspector to contrib. + + * swank-fancy-inspector.lisp: New file. The only difference to the + code is that inspect-for-emacs methods in this file are + specialized to the new class `fancy-inspector'. + (fancy-inspector): New class. + + * slime-fancy-inspector.el: New file. + 2007-08-19 Helmut Eller Moved fuzzy completion code to contrib directory. --- /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2007/08/23 17:46:31 NONE +++ /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2007/08/23 17:46:31 1.1 ;;; slime-fancy-inspector.el --- Fancy inspector for CLOS objects ;; ;; Author: Marco Baringer and others ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation ;; ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "") ;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy-inspector))) ;; (add-hook 'slime-connected-hook 'slime-install-fancy-inspector) (defun slime-install-fancy-inspector () (slime-eval-async '(swank:swank-require :swank-fancy-inspector))) (provide 'slime-fancy-inspector)--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2007/08/23 17:46:31 NONE +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2007/08/23 17:46:31 1.1 ;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects ;; ;; Author: Marco Baringer and others ;; License: Public Domain ;; (in-package :swank) (defclass fancy-inspector (inspector) ()) (defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector)) (declare (ignore inspector)) (let ((package (symbol-package symbol))) (multiple-value-bind (_symbol status) (and package (find-symbol (string symbol) package)) (declare (ignore _symbol)) (values "A symbol." (append (label-value-line "Its name is" (symbol-name symbol)) ;; ;; Value (cond ((boundp symbol) (label-value-line (if (constantp symbol) "It is a constant of value" "It is a global variable bound to") (symbol-value symbol))) (t '("It is unbound." (:newline)))) (docstring-ispec "Documentation" symbol 'variable) (multiple-value-bind (expansion definedp) (macroexpand symbol) (if definedp (label-value-line "It is a symbol macro with expansion" expansion))) ;; ;; Function (if (fboundp symbol) (append (if (macro-function symbol) `("It a macro with macro-function: " (:value ,(macro-function symbol))) `("It is a function: " (:value ,(symbol-function symbol)))) `(" " (:action "[make funbound]" ,(lambda () (fmakunbound symbol)))) `((:newline))) `("It has no function value." (:newline))) (docstring-ispec "Function Documentation" symbol 'function) (if (compiler-macro-function symbol) (label-value-line "It also names the compiler macro" (compiler-macro-function symbol))) (docstring-ispec "Compiler Macro Documentation" symbol 'compiler-macro) ;; ;; Package (if package `("It is " ,(string-downcase (string status)) " to the package: " (:value ,package ,(package-name package)) ,@(if (eq :internal status) `(" " (:action "[export it]" ,(lambda () (export symbol package))))) " " (:action "[unintern it]" ,(lambda () (unintern symbol package))) (:newline)) '("It is a non-interned symbol." (:newline))) ;; ;; Plist (label-value-line "Property list" (symbol-plist symbol)) ;; ;; Class (if (find-class symbol nil) `("It names the class " (:value ,(find-class symbol) ,(string symbol)) " " (:action "[remove]" ,(lambda () (setf (find-class symbol) nil))) (:newline))) ;; ;; More package (if (find-package symbol) (label-value-line "It names the package" (find-package symbol))) ))))) (defun docstring-ispec (label object kind) "Return a inspector spec if OBJECT has a docstring of of kind KIND." (let ((docstring (documentation object kind))) (cond ((not docstring) nil) ((< (+ (length label) (length docstring)) 75) (list label ": " docstring '(:newline))) (t (list label ": " '(:newline) " " docstring '(:newline)))))) (defmethod inspect-for-emacs ((f function) (inspector fancy-inspector)) (declare (ignore inspector)) (values "A function." (append (label-value-line "Name" (function-name f)) `("Its argument list is: " ,(inspector-princ (arglist f)) (:newline)) (docstring-ispec "Documentation" f t) (if (function-lambda-expression f) (label-value-line "Lambda Expression" (function-lambda-expression f)))))) (defun method-specializers-for-inspect (method) "Return a \"pretty\" list of the method's specializers. Normal specializers are replaced by the name of the class, eql specializers are replaced by `(eql ,object)." (mapcar (lambda (spec) (typecase spec (swank-mop:eql-specializer `(eql ,(swank-mop:eql-specializer-object spec))) (t (swank-mop:class-name spec)))) (swank-mop:method-specializers method))) (defun method-for-inspect-value (method) "Returns a \"pretty\" list describing METHOD. The first element of the list is the name of generic-function method is specialiazed on, the second element is the method qualifiers, the rest of the list is the method's specialiazers (as per method-specializers-for-inspect)." (append (list (swank-mop:generic-function-name (swank-mop:method-generic-function method))) (swank-mop:method-qualifiers method) (method-specializers-for-inspect method))) (defmethod inspect-for-emacs ((object standard-object) (inspector fancy-inspector)) (let ((class (class-of object))) (values "An object." `("Class: " (:value ,class) (:newline) ,@(all-slots-for-inspector object inspector))))) (defvar *gf-method-getter* 'methods-by-applicability "This function is called to get the methods of a generic function. The default returns the method sorted by applicability. See `methods-by-applicability'.") (defun specializer< (specializer1 specializer2) "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." (let ((s1 specializer1) (s2 specializer2) ) (cond ((typep s1 'swank-mop:eql-specializer) (not (typep s2 'swank-mop:eql-specializer))) (t (flet ((cpl (class) (and (swank-mop:class-finalized-p class) (swank-mop:class-precedence-list class)))) (member s2 (cpl s1))))))) (defun methods-by-applicability (gf) "Return methods ordered by most specific argument types. `method-specializer<' is used for sorting." ;; FIXME: argument-precedence-order and qualifiers are ignored. (labels ((method< (meth1 meth2) (loop for s1 in (swank-mop:method-specializers meth1) for s2 in (swank-mop:method-specializers meth2) do (cond ((specializer< s2 s1) (return nil)) ((specializer< s1 s2) (return t)))))) (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<))) (defun abbrev-doc (doc &optional (maxlen 80)) "Return the first sentence of DOC, but not more than MAXLAN characters." (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) maxlen (length doc)))) (defgeneric inspect-slot-for-emacs (class object slot) (:method (class object slot) (let ((slot-name (swank-mop:slot-definition-name slot)) (boundp (swank-mop:slot-boundp-using-class class object slot))) `(,@(if boundp `((:value ,(swank-mop:slot-value-using-class class object slot))) `("#")) " " (:action "[set value]" ,(lambda () (with-simple-restart (abort "Abort setting slot ~S" slot-name) (let ((value-string (eval-in-emacs `(condition-case c (slime-read-object ,(format nil "Set slot ~S to (evaluated) : " slot-name)) (quit nil))))) (when (and value-string (not (string= value-string ""))) (setf (swank-mop:slot-value-using-class class object slot) (eval (read-from-string value-string)))))))) ,@(when boundp `(" " (:action "[make unbound]" ,(lambda () (swank-mop:slot-makunbound-using-class class object slot))))))))) (defgeneric all-slots-for-inspector (object inspector) (:method ((object standard-object) inspector) (declare (ignore inspector)) (append '("--------------------" (:newline) "All Slots:" (:newline)) (let* ((class (class-of object)) (direct-slots (swank-mop:class-direct-slots class)) (effective-slots (sort (copy-seq (swank-mop:class-slots class)) #'string< :key #'swank-mop:slot-definition-name)) (slot-presentations (loop for effective-slot :in effective-slots collect (inspect-slot-for-emacs class object effective-slot))) (longest-slot-name-length (loop for slot :in effective-slots maximize (length (symbol-name (swank-mop:slot-definition-name slot)))))) (loop for effective-slot :in effective-slots for slot-presentation :in slot-presentations for direct-slot = (find (swank-mop:slot-definition-name effective-slot) direct-slots :key #'swank-mop:slot-definition-name) for slot-name = (inspector-princ (swank-mop:slot-definition-name effective-slot)) for padding-length = (- longest-slot-name-length (length (symbol-name (swank-mop:slot-definition-name effective-slot)))) collect `(:value ,(if direct-slot (list direct-slot effective-slot) effective-slot) ,slot-name) collect (make-array padding-length :element-type 'character :initial-element #\Space) collect " = " append slot-presentation collect '(:newline)))))) (defmethod inspect-for-emacs ((gf standard-generic-function) (inspector fancy-inspector)) (flet ((lv (label value) (label-value-line label value))) (values "A generic function." (append (lv "Name" (swank-mop:generic-function-name gf)) (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) (docstring-ispec "Documentation" gf t) (lv "Method class" (swank-mop:generic-function-method-class gf)) (lv "Method combination" (swank-mop:generic-function-method-combination gf)) `("Methods: " (:newline)) (loop for method in (funcall *gf-method-getter* gf) append `((:value ,method ,(inspector-princ ;; drop the name of the GF (cdr (method-for-inspect-value method)))) " " (:action "[remove method]" ,(let ((m method)) ; LOOP reassigns method (lambda () (remove-method gf m)))) (:newline))) `((:newline)) (all-slots-for-inspector gf inspector))))) (defmethod inspect-for-emacs ((method standard-method) (inspector fancy-inspector)) (values "A method." `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) ,(inspector-princ (swank-mop:generic-function-name (swank-mop:method-generic-function method)))) (:newline) ,@(docstring-ispec "Documentation" method t) "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) (:newline) "Specializers: " (:value ,(swank-mop:method-specializers method) ,(inspector-princ (method-specializers-for-inspect method))) (:newline) "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) (:newline) "Method function: " (:value ,(swank-mop:method-function method)) (:newline) ,@(all-slots-for-inspector method inspector)))) (defmethod inspect-for-emacs ((class standard-class) (inspector fancy-inspector)) (values "A class." `("Name: " (:value ,(class-name class)) (:newline) "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) (:newline) "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class) (lambda (slot) `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) (:newline) "Effective Slots: " ,@(if (swank-mop:class-finalized-p class) (common-seperated-spec (swank-mop:class-slots class) (lambda (slot) `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) '("#")) (:newline) ,@(let ((doc (documentation class t))) (when doc `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) (lambda (sub) `(:value ,sub ,(inspector-princ (class-name sub))))) (:newline) "Precedence List: " ,@(if (swank-mop:class-finalized-p class) (common-seperated-spec (swank-mop:class-precedence-list class) (lambda (class) `(:value ,class ,(inspector-princ (class-name class))))) '("#")) (:newline) ,@(when (swank-mop:specializer-direct-methods class) `("It is used as a direct specializer in the following methods:" (:newline) ,@(loop for method in (sort (copy-seq (swank-mop:specializer-direct-methods class)) #'string< :key (lambda (x) (symbol-name (let ((name (swank-mop::generic-function-name (swank-mop::method-generic-function x)))) (if (symbolp name) name (second name)))))) collect " " collect `(:value ,method ,(inspector-princ (method-for-inspect-value method))) collect '(:newline) if (documentation method t) collect " Documentation: " and collect (abbrev-doc (documentation method t)) and collect '(:newline)))) "Prototype: " ,(if (swank-mop:class-finalized-p class) `(:value ,(swank-mop:class-prototype class)) '"#") (:newline) ,@(all-slots-for-inspector class inspector)))) (defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) (inspector fancy-inspector)) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) ,@(when (swank-mop:slot-definition-documentation slot) `("Documentation:" (:newline) (:value ,(swank-mop:slot-definition-documentation slot)) (:newline))) "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) `(:value ,(swank-mop:slot-definition-initform slot)) "#") (:newline) "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline) ,@(all-slots-for-inspector slot inspector)))) ;; Wrapper structure over the list of symbols of a package that should ;; be displayed with their respective classification flags. This is ;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS. ;; Used by the Inspector for packages. (defstruct (%package-symbols-container (:conc-name %container.) (:constructor %%make-package-symbols-container)) title ;; A string; the title of the inspector page in Emacs. description ;; A list of renderable objects; used as description. [360 lines skipped] From heller at common-lisp.net Thu Aug 23 18:09:22 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 14:09:22 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823180922.1F8A63F011@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv26706 Modified Files: ChangeLog swank-loader.lisp Log Message: List swank-fancy-inspector in *contribs* --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 17:45:43 1.1150 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 18:09:21 1.1151 @@ -6,6 +6,8 @@ variable dispatch to different inspectors. (inspect-object): Use it. + * swank-loader.lisp (*contribs*): Add 'swank-fancy-inspector. + 2007-08-23 Tobias C. Rittweiler Added arglist display for declaration specifiers and type --- /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/23 12:58:52 1.66 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/23 18:09:21 1.67 @@ -198,7 +198,7 @@ (defvar *fasl-directory* (default-fasl-directory) "The directory where fasl files should be placed.") -(defvar *contribs* '(swank-fuzzy) +(defvar *contribs* '(swank-fuzzy swank-fancy-inspector) "List of names for contrib modules.") (defun append-dir (absolute name) From heller at common-lisp.net Thu Aug 23 19:03:37 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 15:03:37 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823190337.D86B5830A3@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2762 Modified Files: ChangeLog swank-abcl.lisp swank-allegro.lisp swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-corman.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp swank-scl.lisp Log Message: Introduce backend-inspector class. * swank-backend.lisp (backend-inspector): New class. Introduce a named class to give as another way to dispatch to backend methods. * swank-cmucl.lisp: Use backend-inspector class. * swank-sbcl.lisp: Use backend-inspector class. * swank-clisp.lisp: Use backend-inspector class. * swank-lispworks.lisp: Use backend-inspector class. * swank-allegro.lisp: Use backend-inspector class. * swank-openmcl.lisp: Use backend-inspector class. * swank-abcl.lisp: Use backend-inspector class. * swank-corman.lisp: Use backend-inspector class. * swank-scl.lisp: Use backend-inspector class. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 18:09:21 1.1151 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 19:03:37 1.1152 @@ -8,6 +8,19 @@ * swank-loader.lisp (*contribs*): Add 'swank-fancy-inspector. + * swank-backend.lisp (backend-inspector): New class. Introduce a + named class to give as another way to dispatch to backend methods. + + * swank-cmucl.lisp: Use backend-inspector class. + * swank-sbcl.lisp: Use backend-inspector class. + * swank-clisp.lisp: Use backend-inspector class. + * swank-lispworks.lisp: Use backend-inspector class. + * swank-allegro.lisp: Use backend-inspector class. + * swank-openmcl.lisp: Use backend-inspector class. + * swank-abcl.lisp: Use backend-inspector class. + * swank-corman.lisp: Use backend-inspector class. + * swank-scl.lisp: Use backend-inspector class. + 2007-08-23 Tobias C. Rittweiler Added arglist display for declaration specifiers and type --- /project/slime/cvsroot/slime/swank-abcl.lisp 2006/11/19 21:33:03 1.41 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2007/08/23 19:03:37 1.42 @@ -10,7 +10,6 @@ (in-package :swank-backend) - (eval-when (:compile-toplevel :load-toplevel :execute) (require :collect) ;just so that it doesn't spoil the flying letters (require :pprint)) @@ -392,13 +391,13 @@ ;;;; Inspecting -(defclass abcl-inspector (inspector) - ()) +(defclass abcl-inspector (backend-inspector) ()) (defimplementation make-default-inspector () (make-instance 'abcl-inspector)) -(defmethod inspect-for-emacs ((slot mop::slot-definition) (inspector abcl-inspector)) +(defmethod inspect-for-emacs ((slot mop::slot-definition) + (inspector backend-inspector)) (declare (ignore inspector)) (values "A slot." `("Name: " (:value ,(mop::%slot-definition-name slot)) @@ -414,7 +413,7 @@ " Function: " (:value ,(mop::%slot-definition-initfunction slot)) (:newline)))) -(defmethod inspect-for-emacs ((f function) (inspector abcl-inspector)) +(defmethod inspect-for-emacs ((f function) (inspector backend-inspector)) (declare (ignore inspector)) (values "A function." `(,@(when (function-name f) @@ -432,7 +431,7 @@ #| -(defmethod inspect-for-emacs ((o t) (inspector abcl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (let* ((class (class-of o)) (slots (mop::class-slots class))) (values (format nil "~A~% is a ~A" o class) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2006/12/19 10:47:36 1.95 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2007/08/23 19:03:37 1.96 @@ -568,8 +568,7 @@ ;;;; Inspecting -(defclass acl-inspector (inspector) - ()) +(defclass acl-inspector (backend-inspector) ()) (defimplementation make-default-inspector () (make-instance 'acl-inspector)) @@ -584,15 +583,16 @@ (when doc `("Documentation:" (:newline) ,doc)))))) -(defmethod inspect-for-emacs ((o t) (inspector acl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) inspector (values "A value." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o function) (inspector acl-inspector)) +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) inspector (values "A function." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o standard-object) (inspector acl-inspector)) +(defmethod inspect-for-emacs ((o standard-object) + (inspector backend-inspector)) inspector (values (format nil "~A is a standard-object." o) (allegro-inspect o))) --- /project/slime/cvsroot/slime/swank-backend.lisp 2007/08/23 16:20:22 1.120 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2007/08/23 19:03:37 1.121 @@ -879,6 +879,8 @@ Implementations should sub class in order to dispatch off of the inspect-for-emacs method.")) +(defclass backend-inspector (inspector) ()) + (definterface make-default-inspector () "Return an inspector object suitable for passing to inspect-for-emacs.") @@ -1104,4 +1106,4 @@ (unsigned-byte . (&optional size)) (values . (&rest typespecs)) (vector . (&optional element-type size)) - )) \ No newline at end of file + )) --- /project/slime/cvsroot/slime/swank-clisp.lisp 2007/04/08 14:02:37 1.63 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2007/08/23 19:03:37 1.64 @@ -627,12 +627,11 @@ ;;;; Inspecting -(defclass clisp-inspector (inspector) ()) +(defclass clisp-inspector (backend-inspector) ()) -(defimplementation make-default-inspector () - (make-instance 'clisp-inspector)) +(defimplementation make-default-inspector () (make-instance 'clisp-inspector)) -(defmethod inspect-for-emacs ((o t) (inspector clisp-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (declare (ignore inspector)) (let* ((*print-array* nil) (*print-pretty* t) (*print-circle* t) (*print-escape* t) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2007/01/10 23:53:47 1.170 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2007/08/23 19:03:37 1.171 @@ -1817,8 +1817,7 @@ ;;;; Inspecting -(defclass cmucl-inspector (inspector) - ()) +(defclass cmucl-inspector (backend-inspector) ()) (defimplementation make-default-inspector () (make-instance 'cmucl-inspector)) @@ -1865,7 +1864,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t) (inspector cmucl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1883,7 +1882,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function) (inspector cmucl-inspector)) +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) (declare (ignore inspector)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) @@ -1912,7 +1911,7 @@ (call-next-method))))) (defmethod inspect-for-emacs ((o kernel:funcallable-instance) - (i cmucl-inspector)) + (i backend-inspector)) (declare (ignore i)) (values (format nil "~A is a funcallable-instance." o) @@ -1922,7 +1921,7 @@ (:layout (kernel:%funcallable-instance-layout o))) (nth-value 1 (cmucl-inspect o))))) -(defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector)) +(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) (declare (ignore _)) (values (format nil "~A is a code data-block." o) (append @@ -1950,7 +1949,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector cmucl-inspector)) +(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) (declare (ignore inspector)) (values (format nil "~A is a fdenf object." o) (label-value-line* @@ -1960,7 +1959,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array) (inspector cmucl-inspector)) +(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) inspector (if (typep o 'simple-array) (call-next-method) @@ -1976,7 +1975,7 @@ (:displaced-p (kernel:%array-displaced-p o)) (:dimensions (array-dimensions o)))))) -(defmethod inspect-for-emacs ((o simple-vector) (inspector cmucl-inspector)) +(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) inspector (values (format nil "~A is a simple-vector." o) (append --- /project/slime/cvsroot/slime/swank-corman.lisp 2006/11/19 21:33:03 1.10 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2007/08/23 19:03:37 1.11 @@ -387,7 +387,7 @@ ;; Hack to make swank.lisp load, at least (defclass file-stream ()) -(defclass corman-inspector (inspector) +(defclass corman-inspector (backend-inspector) ()) (defimplementation make-default-inspector () @@ -400,7 +400,7 @@ collect ", "))) (defmethod inspect-for-emacs ((class standard-class) - (inspector corman-inspector)) + (inspector backend-inspector)) (declare (ignore inspector)) (values "A class." `("Name: " (:value ,(class-name class)) @@ -438,9 +438,9 @@ '("#")) (:newline)))) -(defmethod inspect-for-emacs ((slot cons) (inspector corman-inspector)) +(defmethod inspect-for-emacs ((slot cons) (inspector backend-inspector)) ;; Inspects slot definitions - (declare (ignore corman-inspector)) + (declare (ignore inspector)) (if (eq (car slot) :name) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) @@ -475,7 +475,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((o t) (inspector corman-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (cond ((cl::structurep o) (inspect-structure o)) (t (call-next-method)))) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2007/05/17 16:52:31 1.91 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2007/08/23 19:03:37 1.92 @@ -636,25 +636,24 @@ append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) ;;; Inspector -(defclass lispworks-inspector (inspector) - ()) +(defclass lispworks-inspector (backend-inspector) ()) (defimplementation make-default-inspector () (make-instance 'lispworks-inspector)) -(defmethod inspect-for-emacs ((o t) (inspector lispworks-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (declare (ignore inspector)) (lispworks-inspect o)) (defmethod inspect-for-emacs ((o function) - (inspector lispworks-inspector)) + (inspector backend-inspector)) (declare (ignore inspector)) (lispworks-inspect o)) ;; FIXME: slot-boundp-using-class in LW works with names so we can't ;; use our method in swank.lisp. (defmethod inspect-for-emacs ((o standard-object) - (inspector lispworks-inspector)) + (inspector backend-inspector)) (declare (ignore inspector)) (lispworks-inspect o)) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2007/04/16 14:47:34 1.118 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2007/08/23 19:03:37 1.119 @@ -784,8 +784,7 @@ ;;;; Inspection -(defclass openmcl-inspector (inspector) - ()) +(defclass openmcl-inspector (backend-inspector) ()) (defimplementation make-default-inspector () (make-instance 'openmcl-inspector)) @@ -796,7 +795,7 @@ (string (gethash typecode *value2tag*)) (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) -(defmethod inspect-for-emacs ((o t) (inspector openmcl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (declare (ignore inspector)) (let* ((i (inspector::make-inspector o)) (count (inspector::compute-line-count i)) @@ -815,7 +814,7 @@ (pprint o s))) lines))) -(defmethod inspect-for-emacs :around ((o t) (inspector openmcl-inspector)) +(defmethod inspect-for-emacs :around ((o t) (inspector backend-inspector)) (if (or (uvector-inspector-p o) (not (ccl:uvectorp o))) (call-next-method) @@ -835,7 +834,8 @@ (:method ((object t)) nil) (:method ((object uvector-inspector)) t)) -(defmethod inspect-for-emacs ((uv uvector-inspector) (inspector openmcl-inspector)) +(defmethod inspect-for-emacs ((uv uvector-inspector) + (inspector backend-inspector)) (with-slots (object) uv (values (format nil "The UVECTOR for ~S." object) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2007/08/23 16:20:11 1.179 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2007/08/23 19:03:37 1.180 @@ -981,13 +981,12 @@ ;;;; Inspector -(defclass sbcl-inspector (inspector) - ()) +(defclass sbcl-inspector (make-inspector) ()) (defimplementation make-default-inspector () (make-instance 'sbcl-inspector)) -(defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (declare (ignore inspector)) (cond ((sb-di::indirect-value-cell-p o) (values "A value cell." (label-value-line* @@ -1000,7 +999,7 @@ (values text (loop for value in parts for i from 0 append (label-value-line i value)))))))) -(defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector)) +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) (declare (ignore inspector)) (let ((header (sb-kernel:widetag-of o))) (cond ((= header sb-vm:simple-fun-header-widetag) @@ -1022,7 +1021,7 @@ i (sb-kernel:%closure-index-ref o i)))))) (t (call-next-method o))))) -(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector)) +(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ backend-inspector)) (declare (ignore _)) (values (format nil "~A is a code data-block." o) (append @@ -1051,13 +1050,13 @@ (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector sbcl-inspector)) +(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector backend-inspector)) (declare (ignore inspector)) (values "A weak pointer." (label-value-line* (:value (sb-ext:weak-pointer-value o))))) -(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector)) +(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector backend-inspector)) (declare (ignore inspector)) (values "A fdefn object." (label-value-line* @@ -1065,7 +1064,7 @@ (:function (sb-kernel:fdefn-fun o))))) (defmethod inspect-for-emacs :around ((o generic-function) - (inspector sbcl-inspector)) + (inspector backend-inspector)) (declare (ignore inspector)) (multiple-value-bind (title contents) (call-next-method) (values title --- /project/slime/cvsroot/slime/swank-scl.lisp 2006/11/19 21:33:03 1.12 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2007/08/23 19:03:37 1.13 @@ -1691,8 +1691,7 @@ ;;;; Inspecting -(defclass scl-inspector (inspector) - ()) +(defclass scl-inspector (backend-inspector) ()) (defimplementation make-default-inspector () (make-instance 'scl-inspector)) @@ -1739,7 +1738,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t) (inspector scl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1758,7 +1757,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function) (inspector scl-inspector)) +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) (declare (ignore inspector)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) @@ -1788,7 +1787,7 @@ (call-next-method))))) -(defmethod inspect-for-emacs ((o kernel:code-component) (_ scl-inspector)) +(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) (declare (ignore _)) (values (format nil "~A is a code data-block." o) (append @@ -1816,7 +1815,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector scl-inspector)) +(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) (declare (ignore inspector)) (values (format nil "~A is a fdenf object." o) (label-value-line* @@ -1826,7 +1825,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array) (inspector scl-inspector)) +(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) inspector (cond ((kernel:array-header-p o) (values (format nil "~A is an array." o) @@ -1846,7 +1845,7 @@ (:header (describe-primitive-type o)) (:length (length o))))))) -(defmethod inspect-for-emacs ((o simple-vector) (inspector scl-inspector)) +(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) inspector (values (format nil "~A is a vector." o) (append From heller at common-lisp.net Thu Aug 23 19:04:15 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 15:04:15 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070823190415.EB3AF830A4@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv3084 Modified Files: swank-fancy-inspector.lisp Log Message: * swank-fancy-inspector.lisp: Use backend-inspector class. --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2007/08/23 17:46:31 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2007/08/23 19:04:15 1.2 @@ -6,7 +6,9 @@ (in-package :swank) -(defclass fancy-inspector (inspector) ()) +;; Subclass `backend-inspector' so that backend specific methods are +;; also considered. +(defclass fancy-inspector (backend-inspector) ()) (defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector)) (declare (ignore inspector)) From heller at common-lisp.net Thu Aug 23 19:32:56 2007 From: heller at common-lisp.net (heller) Date: Thu, 23 Aug 2007 15:32:56 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823193256.C14BC44140@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7694 Modified Files: swank-backend.lisp Log Message: swank.lisp: (backend-inspector): Export the symbol. --- /project/slime/cvsroot/slime/swank-backend.lisp 2007/08/23 19:03:37 1.121 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2007/08/23 19:32:56 1.122 @@ -35,6 +35,7 @@ #:type-specifier-arglist ;; inspector related symbols #:inspector + #:backend-inspector #:inspect-for-emacs #:raw-inspection #:fancy-inspection From mkoeppe at common-lisp.net Thu Aug 23 22:50:07 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Thu, 23 Aug 2007 18:50:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823225007.C911B83049@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6968 Modified Files: slime.el Log Message: (slime-inspect-presentation-at-mouse): Use swank:inspect-presentation here. --- /project/slime/cvsroot/slime/slime.el 2007/08/23 16:20:51 1.803 +++ /project/slime/cvsroot/slime/slime.el 2007/08/23 22:50:06 1.804 @@ -3494,9 +3494,8 @@ (let ((reset-p (with-current-buffer buffer (not (eq major-mode 'slime-inspector-mode))))) - (slime-inspect (slime-presentation-expression presentation) - :no-reset (not reset-p) - :eval t :dwim-mode nil)))) + (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p) + 'slime-open-inspector)))) (defun slime-copy-presentation-at-mouse (event) (interactive "e") From mkoeppe at common-lisp.net Thu Aug 23 22:50:42 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Thu, 23 Aug 2007 18:50:42 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823225042.11FE95B069@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7048 Modified Files: swank.lisp Log Message: (inspect-presentation): New slimefun. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/23 17:45:44 1.495 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/23 22:50:40 1.496 @@ -4780,4 +4780,10 @@ (declare (ignore choice id)) (disassemble object))))) +(defslimefun inspect-presentation (id reset-p) + (let ((what (lookup-presented-object id))) + (when reset-p + (reset-inspector)) + (inspect-object what))) + ;;; swank.lisp ends here From mkoeppe at common-lisp.net Thu Aug 23 22:50:57 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Thu, 23 Aug 2007 18:50:57 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070823225057.3F0BF601AD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7082 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 19:03:37 1.1152 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 22:50:57 1.1153 @@ -1,3 +1,10 @@ +2007-08-23 Matthias Koeppe + + Repair inspection of presentations. + + * swank.lisp (inspect-presentation): New slimefun. + * slime.el (slime-inspect-presentation-at-mouse): Use it here. + 2007-08-23 Helmut Eller Move Marco Baringer's inspector to contrib. From heller at common-lisp.net Fri Aug 24 06:41:55 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 02:41:55 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824064155.20736111CE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28053 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (sbcl-inspector): Fix typo. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 22:50:57 1.1153 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 06:41:54 1.1154 @@ -1,3 +1,7 @@ +2007-08-24 Helmut Eller + + * swank-sbcl.lisp (sbcl-inspector): Fix typo. + 2007-08-23 Matthias Koeppe Repair inspection of presentations. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2007/08/23 19:03:37 1.180 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2007/08/24 06:41:54 1.181 @@ -981,7 +981,7 @@ ;;;; Inspector -(defclass sbcl-inspector (make-inspector) ()) +(defclass sbcl-inspector (backend-inspector) ()) (defimplementation make-default-inspector () (make-instance 'sbcl-inspector)) From mkoeppe at common-lisp.net Fri Aug 24 07:00:05 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 03:00:05 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070824070005.7584243215@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv884/contrib Added Files: slime-presentation-streams.el Log Message: * slime-presentation-streams.el: New file. --- /project/slime/cvsroot/slime/contrib/slime-presentation-streams.el 2007/08/24 07:00:05 NONE +++ /project/slime/cvsroot/slime/contrib/slime-presentation-streams.el 2007/08/24 07:00:05 1.1 ;;; swank-presentation-streams.el --- Streams that allow attaching object identities ;;; to portions of output ;;; ;;; Authors: Alan Ruttenberg ;;; Matthias Koeppe ;;; Helmut Eller ;;; ;;; License: GNU GPL (same license as Emacs) ;;; ;;; Installation ;; ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "") ;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentation-streams))) ;; ;;; Initialization (add-hook 'slime-connected-hook 'slime-install-presentation-streams) (defun slime-install-presentation-streams () (slime-eval-async '(swank:swank-require :swank-presentation-streams))) (provide 'slime-presentation-streams) From heller at common-lisp.net Fri Aug 24 12:28:38 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 08:28:38 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824122838.02D5324004@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv29331 Modified Files: slime.el ChangeLog Log Message: Don't use rectangle code, because it inappropriately sets the mark. * slime.el (slime-with-rigid-indentation): Fix evaluation order. (slime-indent-rigidly): New. (slime-insert-possibly-as-rectange): Don't set mark. --- /project/slime/cvsroot/slime/slime.el 2007/08/23 22:50:06 1.804 +++ /project/slime/cvsroot/slime/slime.el 2007/08/24 12:28:38 1.805 @@ -1183,13 +1183,23 @@ (defmacro slime-with-rigid-indentation (level &rest body) "Execute BODY and then rigidly indent its text insertions. Assumes all insertions are made at point." - (let ((start (gensym))) - `(let ((,start (point))) + (let ((start (gensym)) (l (gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) (prog1 (progn , at body) - (indent-rigidly ,start (point) ,level))))) + (slime-indent-rigidly ,start (point) ,l))))) (put 'slime-with-rigid-indentation 'lisp-indent-function 1) +(defun slime-indent-rigidly (start end column) + "Similar to `indent-rigidly' but doesn't inherit text props." + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (save-excursion (insert-char ?\ column)) + (zerop (forward-line -1))))))) + ;;;;; Snapshots of current Emacs state ;;; Window configurations do not save (and hence not restore) @@ -3020,20 +3030,8 @@ (delete-overlay overlay))))) (defun slime-insert-possibly-as-rectangle (&rest strings) - (if (zerop (current-column)) - (apply #'insert strings) - (dolist (string strings) - (if (string= string "\n") - (newline) - (let ((lines (split-string string "\n"))) - (when (rest lines) - (save-excursion - (dotimes (i (length lines)) - (newline)))) - (insert-rectangle lines) - (when (rest lines) - (forward-char 1) - (delete-backward-char 1))))))) + (slime-with-rigid-indentation nil + (apply #'insert strings))) (defun slime-insert-presentation (string output-id) (cond ((not slime-repl-enable-presentations) --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 06:41:54 1.1154 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 12:28:38 1.1155 @@ -1,18 +1,24 @@ 2007-08-24 Helmut Eller + * slime.el (slime-with-rigid-indentation): Fix evaluation order. + (slime-indent-rigidly): New. + (slime-insert-possibly-as-rectange): Don't set mark. + +2007-08-24 Helmut Eller + * swank-sbcl.lisp (sbcl-inspector): Fix typo. 2007-08-23 Matthias Koeppe Repair inspection of presentations. - + * swank.lisp (inspect-presentation): New slimefun. * slime.el (slime-inspect-presentation-at-mouse): Use it here. 2007-08-23 Helmut Eller Move Marco Baringer's inspector to contrib. - + * swank.lisp (*default-inspector*): New variable. Set this variable dispatch to different inspectors. (inspect-object): Use it. From heller at common-lisp.net Fri Aug 24 12:49:51 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 08:49:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824124951.D72A92B129@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv32467 Modified Files: slime.el ChangeLog Log Message: Simplify slime-insert-propertized. * slime.el (slime-insert-propertized): Use plain insert instead of slime-insert-possibly-as-rectange. --- /project/slime/cvsroot/slime/slime.el 2007/08/24 12:28:38 1.805 +++ /project/slime/cvsroot/slime/slime.el 2007/08/24 12:49:51 1.806 @@ -1163,7 +1163,7 @@ ;; Interface (defsubst slime-insert-propertized (props &rest args) "Insert all ARGS and then add text-PROPS to the inserted text." - (slime-propertize-region props (apply #'slime-insert-possibly-as-rectangle args))) + (slime-propertize-region props (apply #'insert args))) (defun slime-indent-and-complete-symbol () "Indent the current line and perform symbol completion. First --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 12:28:38 1.1155 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 12:49:51 1.1156 @@ -1,8 +1,12 @@ 2007-08-24 Helmut Eller + Various cleanups related to slime-insert-propertized. + * slime.el (slime-with-rigid-indentation): Fix evaluation order. (slime-indent-rigidly): New. (slime-insert-possibly-as-rectange): Don't set mark. + (slime-insert-propertized): Use plain insert instead of + slime-insert-possibly-as-rectange. 2007-08-24 Helmut Eller From heller at common-lisp.net Fri Aug 24 13:15:45 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 09:15:45 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824131545.D3B1737012@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4836 Modified Files: slime.el ChangeLog Log Message: Move slime-scratch to contrib. --- /project/slime/cvsroot/slime/slime.el 2007/08/24 12:49:51 1.806 +++ /project/slime/cvsroot/slime/slime.el 2007/08/24 13:15:44 1.807 @@ -830,7 +830,6 @@ [ "Eval Last Expression" slime-eval-last-expression ,C ] [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] [ "Eval Region" slime-eval-region ,C ] - [ "Scratch Buffer" slime-scratch ,C ] [ "Interactive Eval..." slime-interactive-eval ,C ] [ "Edit Lisp Value..." slime-edit-value ,C ] [ "Call Defun" slime-call-defun ,C ]) @@ -4632,38 +4631,6 @@ (kill-buffer buf)))) -;;;; Scratch - -(defvar slime-scratch-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-map) - map)) - -(defun slime-scratch-buffer () - "Return the scratch buffer, create it if necessary." - (or (get-buffer "*slime-scratch*") - (with-current-buffer (get-buffer-create "*slime-scratch*") - (lisp-mode) - (use-local-map slime-scratch-mode-map) - (slime-mode t) - (when slime-repl-enable-presentations - ;; Respect the syntax text properties of presentations. - (set (make-local-variable 'parse-sexp-lookup-properties) t)) - (current-buffer)))) - -(defun slime-switch-to-scratch-buffer () - (set-buffer (slime-scratch-buffer)) - (unless (eq (current-buffer) (window-buffer)) - (pop-to-buffer (current-buffer) t))) - -(defun slime-scratch () - (interactive) - (slime-switch-to-scratch-buffer)) - -(slime-define-keys slime-scratch-mode-map - ("\C-j" 'slime-eval-print-last-expression)) - - ;;;; Compilation and the creation of compiler-note annotations (defvar slime-before-compile-functions nil @@ -9193,10 +9160,6 @@ ((y-or-n-p "No connection: start Slime? ") (slime)))) -(def-slime-selector-method ?s - "*slime-scratch* buffer." - (slime-scratch-buffer)) - (def-slime-selector-method ?i "*inferior-lisp* buffer." (cond ((and (slime-connected-p) (slime-process)) --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 12:49:51 1.1156 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 13:15:45 1.1157 @@ -1,5 +1,11 @@ 2007-08-24 Helmut Eller + Move slime-scratch to contrib. + + * slime.el (slime-scratch): Gone. + +2007-08-24 Helmut Eller + Various cleanups related to slime-insert-propertized. * slime.el (slime-with-rigid-indentation): Fix evaluation order. From heller at common-lisp.net Fri Aug 24 13:15:46 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 09:15:46 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070824131546.367807E005@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv4836/contrib Modified Files: ChangeLog Added Files: slime-scratch.el Log Message: Move slime-scratch to contrib. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/23 17:46:31 1.3 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 13:15:45 1.4 @@ -1,3 +1,7 @@ +2007-08-24 Helmut Eller + + * slime-scratch.el: New file. + 2007-08-23 Helmut Eller Move Marco Baringer's inspector to contrib. --- /project/slime/cvsroot/slime/contrib/slime-scratch.el 2007/08/24 13:15:46 NONE +++ /project/slime/cvsroot/slime/contrib/slime-scratch.el 2007/08/24 13:15:46 1.1 ;;; slime-scratch.el --- imitate Emacs' *scratch* buffer ;; ;; Author: Helmut Eller ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation: ;; ;; Add something like this your .emacs: ;; ;; (add-to-list 'load-path ".../slime/contrib") ;; (add-hook 'slime-load-hook (lambda () (require 'slime-scratch))) ;; (defvar slime-scratch-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map lisp-mode-map) map)) (defun slime-scratch () (interactive) (slime-switch-to-scratch-buffer)) (defun slime-switch-to-scratch-buffer () (set-buffer (slime-scratch-buffer)) (unless (eq (current-buffer) (window-buffer)) (pop-to-buffer (current-buffer) t))) (defun slime-scratch-buffer () "Return the scratch buffer, create it if necessary." (or (get-buffer "*slime-scratch*") (with-current-buffer (get-buffer-create "*slime-scratch*") (lisp-mode) (use-local-map slime-scratch-mode-map) (slime-mode t) (when slime-repl-enable-presentations ;; Respect the syntax text properties of presentations. (set (make-local-variable 'parse-sexp-lookup-properties) t)) (current-buffer)))) (slime-define-keys slime-scratch-mode-map ("\C-j" 'slime-eval-print-last-expression)) (def-slime-selector-method ?s "*slime-scratch* buffer." (slime-scratch-buffer)) (provide 'slime-scratch) From heller at common-lisp.net Fri Aug 24 13:43:03 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 09:43:03 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824134303.47AB02E1D8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10689 Modified Files: slime.el ChangeLog Log Message: Move slime-highlight-edits-mode to contrib. --- /project/slime/cvsroot/slime/slime.el 2007/08/24 13:15:44 1.807 +++ /project/slime/cvsroot/slime/slime.el 2007/08/24 13:43:02 1.808 @@ -67,9 +67,6 @@ (defvar slime-use-autodoc-mode nil "When non-nil always enable slime-autodoc-mode in slime-mode.") -(defvar slime-use-highlight-edits-mode nil - "When non-nil always enable slime-highlight-edits-mode in slime-mode") - (defvar slime-highlight-compiler-notes t "When non-nil highlight buffers with compilation notes, warnings and errors." ) @@ -88,9 +85,7 @@ (defun slime-shared-lisp-mode-hook () (slime-mode 1) (when slime-use-autodoc-mode - (slime-autodoc-mode 1)) - (when slime-use-highlight-edits-mode - (slime-highlight-edits-mode 1))) + (slime-autodoc-mode 1))) (defun slime-lisp-mode-hook () (slime-shared-lisp-mode-hook) @@ -5970,85 +5965,6 @@ (slime-make-typeout-frame))) -;;;; edit highlighting - -(defface slime-highlight-edits-face - `((((class color) (background light)) - (:background "lightgray")) - (((class color) (background dark)) - (:background "dimgray")) - (t (:background "yellow"))) - "Face for displaying edit but not compiled code." - :group 'slime-mode-faces) - -(define-minor-mode slime-highlight-edits-mode - "Minor mode to highlight not-yet-compiled code." nil) - -(add-hook 'slime-highlight-edits-mode-on-hook - 'slime-highlight-edits-init-buffer) - -(add-hook 'slime-highlight-edits-mode-off-hook - 'slime-highlight-edits-reset-buffer) - -(defun slime-highlight-edits-init-buffer () - (make-local-variable 'after-change-functions) - (add-to-list 'after-change-functions - 'slime-highlight-edits) - (add-to-list 'slime-before-compile-functions - 'slime-highlight-edits-compile-hook)) - -(defun slime-highlight-edits-reset-buffer () - (setq after-change-functions - (remove 'slime-highlight-edits after-change-functions)) - (slime-remove-edits (point-min) (point-max))) - -(defun slime-highlight-edits (beg end &optional len) - (save-match-data - (when (and (slime-connected-p) - (not (slime-inside-comment-p beg end)) - (not (slime-only-whitespace-p beg end))) - (let ((overlay (make-overlay beg end))) - (overlay-put overlay 'face 'slime-highlight-edits-face) - (overlay-put overlay 'slime-edit t))))) - -(defun slime-remove-edits (start end) - "Delete the existing Slime edit hilights in the current buffer." - (save-excursion - (goto-char start) - (while (< (point) end) - (dolist (o (overlays-at (point))) - (when (overlay-get o 'slime-edit) - (delete-overlay o))) - (goto-char (next-overlay-change (point)))))) - -(defun slime-highlight-edits-compile-hook (start end) - (when slime-highlight-edits-mode - (let ((start (save-excursion (goto-char start) - (skip-chars-backward " \t\n\r") - (point))) - (end (save-excursion (goto-char end) - (skip-chars-forward " \t\n\r") - (point)))) - (slime-remove-edits start end)))) - -(defun slime-inside-comment-p (beg end) - "Is the region from BEG to END in a comment?" - (save-excursion - (goto-char beg) - (let* ((hs-c-start-regexp ";\\|#|") - (comment (hs-inside-comment-p))) - (and comment - (destructuring-bind (cbeg cend) comment - (<= end cend)))))) - -(defun slime-only-whitespace-p (beg end) - "Contains the region from BEG to END only whitespace?" - (save-excursion - (goto-char beg) - (skip-chars-forward " \n\t\r" end) - (<= end (point)))) - - ;;;; Completion ;; XXX those long names are ugly to read; long names an indicator for --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 13:15:45 1.1157 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 13:43:03 1.1158 @@ -1,5 +1,9 @@ 2007-08-24 Helmut Eller + Move slime-highlight-edits-mode to contrib. + +2007-08-24 Helmut Eller + Move slime-scratch to contrib. * slime.el (slime-scratch): Gone. From heller at common-lisp.net Fri Aug 24 13:43:03 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 09:43:03 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070824134303.7BF9B2F047@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv10689/contrib Modified Files: ChangeLog Added Files: slime-highlight-edits.el Log Message: Move slime-highlight-edits-mode to contrib. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 13:15:45 1.4 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 13:43:03 1.5 @@ -1,5 +1,9 @@ 2007-08-24 Helmut Eller + * slime-highlight-edits.el: New file. + +2007-08-24 Helmut Eller + * slime-scratch.el: New file. 2007-08-23 Helmut Eller --- /project/slime/cvsroot/slime/contrib/slime-highlight-edits.el 2007/08/24 13:43:03 NONE +++ /project/slime/cvsroot/slime/contrib/slime-highlight-edits.el 2007/08/24 13:43:03 1.1 ;;; slme-higlight-edits --- highlight edited, i.e. not yet compiled, code ;; ;; Author: William Bland and others ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation: ;; ;; Add something like this your .emacs: ;; ;; (add-to-list 'load-path "") ;; (autoload 'slime-highlight-edits-mode "slime-highlight-edits") ;; (add-hook 'slime-mode-hook (lambda () (slime-highlight-edits-mode 1))) (defface slime-highlight-edits-face `((((class color) (background light)) (:background "lightgray")) (((class color) (background dark)) (:background "dimgray")) (t (:background "yellow"))) "Face for displaying edit but not compiled code." :group 'slime-mode-faces) (define-minor-mode slime-highlight-edits-mode "Minor mode to highlight not-yet-compiled code." nil) (add-hook 'slime-highlight-edits-mode-on-hook 'slime-highlight-edits-init-buffer) (add-hook 'slime-highlight-edits-mode-off-hook 'slime-highlight-edits-reset-buffer) (defun slime-highlight-edits-init-buffer () (make-local-variable 'after-change-functions) (add-to-list 'after-change-functions 'slime-highlight-edits) (add-to-list 'slime-before-compile-functions 'slime-highlight-edits-compile-hook)) (defun slime-highlight-edits-reset-buffer () (setq after-change-functions (remove 'slime-highlight-edits after-change-functions)) (slime-remove-edits (point-min) (point-max))) ;; FIXME: what's the LEN arg for? (defun slime-highlight-edits (beg end &optional len) (save-match-data (when (and (slime-connected-p) (not (slime-inside-comment-p beg end)) (not (slime-only-whitespace-p beg end))) (let ((overlay (make-overlay beg end))) (overlay-put overlay 'face 'slime-highlight-edits-face) (overlay-put overlay 'slime-edit t))))) (defun slime-remove-edits (start end) "Delete the existing Slime edit hilights in the current buffer." (save-excursion (goto-char start) (while (< (point) end) (dolist (o (overlays-at (point))) (when (overlay-get o 'slime-edit) (delete-overlay o))) (goto-char (next-overlay-change (point)))))) (defun slime-highlight-edits-compile-hook (start end) (when slime-highlight-edits-mode (let ((start (save-excursion (goto-char start) (skip-chars-backward " \t\n\r") (point))) (end (save-excursion (goto-char end) (skip-chars-forward " \t\n\r") (point)))) (slime-remove-edits start end)))) (defun slime-inside-comment-p (beg end) "Is the region from BEG to END in a comment?" (save-excursion (goto-char beg) (let* ((hs-c-start-regexp ";\\|#|") (comment (hs-inside-comment-p))) (and comment (destructuring-bind (cbeg cend) comment (<= end cend)))))) (defun slime-only-whitespace-p (beg end) "Contains the region from BEG to END only whitespace?" (save-excursion (goto-char beg) (skip-chars-forward " \n\t\r" end) (<= end (point)))) (provide 'slime-highlight-edits) From trittweiler at common-lisp.net Fri Aug 24 13:55:25 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 24 Aug 2007 09:55:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824135525.71CB7554BA@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11971 Modified Files: swank.lisp Log Message: * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' (slime-sexp-at-point): Return results as a list of strings, rather than just one big string if called with arg > 1. (slime-parse-extended-operator-name): Wrapping some movement code in `ignore-errors'. Adapted to new return value of `slime-enclosing-form-specs'. Minor cosmetic changes. (slime-make-extended-operator-parser/look-ahead): Adapted to changes of the ``raw form spec'' format; returns a form of strings, instead of a string of a form. (slime-parse-extended-operator/declare): Simplified. Adapted to changes of the ``raw form spec'' format; passes decl-identifiers, or typespec-operators respectively, along the decl/type-spec. (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp based approach. (%slime-nesting-until-point): New helper for `slime-parse-extended-operator/declare'. * swank.lisp (parse-form-spec): Adapted to new ``raw form spec'' format. Updated format description in docstring accordingly. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/23 22:50:40 1.496 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/24 13:55:25 1.497 @@ -1590,20 +1590,24 @@ A ``raw form spec'' can be either: - i) a string representing a Common Lisp symbol, + i) a list of strings representing a Common Lisp form - ii) a string representing a Common Lisp form, + ii) one of: - iii) a list: + a) (:declaration decl-identifier declspec) - a) (:declaration declspec) + where DECL-IDENTIFIER is the string representation of a /decl identifier/, + DECLSPEC is the string representation of a /declaration specifier/. - where DECLSPEC is the string representation of a /declaration specifier/, - - b) (:type-specifier typespec) + b) (:type-specifier typespec-operator typespec) - where TYPESPEC is the string representation of a /type specifier/. + where TYPESPEC-OPERATOR is the string representation of the CAR of a /type specifier/, + TYPESPEC is the string representation of a /type specifier/. + (DECL-IDENTIFIER, and TYPESPEC-OPERATOR are actually redundant (as they're both + already provided in DECLSPEC, or TYPESPEC respectively, but this separation + allows to check if these raw form specs are valid before the whole spec is READ, + and thus all contained symbols interned.) A ``form spec'' is either @@ -1619,29 +1623,35 @@ Examples: - \"defmethod\" => (defmethod) - \"cl:defmethod\" => (cl:defmethod) - \"(defmethod print-object)\" => (defmethod print-object) - (:declaration \"(optimize)\") => ((:declaration optimize)) - (:declaration \"(type string)\") => ((:declaration type) string) - (:type-specifier \"(float)\") => ((:type-specifier float)) - (:type-specifier \"(float 0 100)\") => ((:type-specifier float) 0 100) + (\"defmethod\") => (defmethod) + (\"cl:defmethod\") => (cl:defmethod) + (\"defmethod\" \"print-object\") => (defmethod print-object) + + (:declaration \"optimize\" \"(optimize)\") => ((:declaration optimize)) + (:declaration \"type\" \"(type string)\") => ((:declaration type) string) + (:type-specifier \"float\" \"(float)\") => ((:type-specifier float)) + (:type-specifier \"float\" \"(float 0 100)\") => ((:type-specifier float) 0 100) " - (typecase raw-spec - (string (ensure-list (read-incomplete-form-from-string raw-spec))) - (cons ; compound form spec - (destructure-case raw-spec - ((:declaration raw-declspec) - (let ((declspec (from-string raw-declspec))) - (unless (recursively-empty-p declspec) ; (:DECLARATION "(())") &c. - (destructuring-bind (decl-identifier &rest decl-args) declspec - `((:declaration ,decl-identifier) , at decl-args))))) - ((:type-specifier raw-typespec) - (let ((typespec (from-string raw-typespec))) - (unless (recursively-empty-p typespec) - (destructuring-bind (typespec-op &rest typespec-args) typespec - `((:type-specifier ,typespec-op) , at typespec-args))))))) - (otherwise nil))) + (flet ((parse-extended-spec (raw-extension-op raw-extension extension-flag) + (when (nth-value 1 (parse-symbol raw-extension-op)) + (let ((extension (read-incomplete-form-from-string raw-extension))) + (unless (recursively-empty-p extension) ; (:DECLARATION "(())") &c. + (destructuring-bind (identifier &rest args) extension + `((,extension-flag ,identifier) , at args))))))) + (when (consp raw-spec) + (destructure-case raw-spec + ((:declaration raw-decl-identifier raw-declspec) + (parse-extended-spec raw-decl-identifier raw-declspec :declaration)) + ((:type-specifier raw-typespec-op raw-typespec) + (parse-extended-spec raw-typespec-op raw-typespec :type-specifier)) + (t + (when (every #'stringp raw-spec) + (destructuring-bind (raw-operator &rest raw-args) raw-spec + (multiple-value-bind (operator found?) (parse-symbol raw-operator) + (when (and found? (valid-operator-symbol-p operator)) + `(,operator ,@(read-incomplete-form-from-string + (format nil "(~A)" + (apply #'concatenate 'string raw-args))))))))))))) (defun split-form-spec (spec) "Returns all three relevant information a ``form spec'' @@ -2432,9 +2442,9 @@ (arglist-from-form-spec '(defun foo)) - ~=> (args &body body)) + ~=> (args &body body) - (arglist-from-form-spec '(defun foo) :remove-args nil) + (arglist-from-form-spec '(defun foo) :remove-args nil)) ~=> (name args &body body)) From trittweiler at common-lisp.net Fri Aug 24 13:55:52 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 24 Aug 2007 09:55:52 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824135552.61AA32017@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12019 Modified Files: slime.el Log Message: * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' (slime-sexp-at-point): Return results as a list of strings, rather than just one big string if called with arg > 1. (slime-parse-extended-operator-name): Wrapping some movement code in `ignore-errors'. Adapted to new return value of `slime-enclosing-form-specs'. Minor cosmetic changes. (slime-make-extended-operator-parser/look-ahead): Adapted to changes of the ``raw form spec'' format; returns a form of strings, instead of a string of a form. (slime-parse-extended-operator/declare): Simplified. Adapted to changes of the ``raw form spec'' format; passes decl-identifiers, or typespec-operators respectively, along the decl/type-spec. (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp based approach. (%slime-nesting-until-point): New helper for `slime-parse-extended-operator/declare'. * swank.lisp (parse-form-spec): Adapted to new ``raw form spec'' format. Updated format description in docstring accordingly. --- /project/slime/cvsroot/slime/slime.el 2007/08/24 13:43:02 1.808 +++ /project/slime/cvsroot/slime/slime.el 2007/08/24 13:55:52 1.809 @@ -5422,10 +5422,11 @@ (defun slime-forward-blanks () "Move forward over all whitespace and newlines at point." - (while (slime-point-moves-p - (skip-syntax-forward " ") - ;; newlines aren't in lisp-mode's whitespace syntax class - (when (eolp) (forward-char))))) + (ignore-errors + (while (slime-point-moves-p + (skip-syntax-forward " ") + ;; newlines aren't in lisp-mode's whitespace syntax class + (when (eolp) (forward-char)))))) ;; Emacs 21's forward-sexp understands #| |# comments in lisp-mode ;; buffers, but (at least) Emacs 20's doesn't, so here it is. @@ -5690,11 +5691,11 @@ "" (let ((op (first operators))) (destructure-case (slime-ensure-list op) - ((:declaration declspec) op) - ((:type-specifier typespec) op) - (t (format "(%s)" (buffer-substring-no-properties - (save-excursion (goto-char (first points)) (point)) - (point))))))))) + ((:declaration decl-identifier declspec) op) + ((:type-specifier typespec-op typespec) op) + (t (slime-ensure-list + (save-excursion (goto-char (first points)) + (slime-sexp-at-point (first arg-indices)))))))))) (defun slime-complete-form () "Complete the form at point. @@ -5704,7 +5705,7 @@ (let ((form-string (slime-incomplete-form-at-point))) (let ((result (slime-eval `(swank:complete-form ',form-string)))) (if (eq result :not-available) - (error "Arglist not available") + (error "Could not generate completion for the form `%s'" form-string) (progn (just-one-space) (save-excursion @@ -10537,12 +10538,14 @@ (thing-at-point 'sexp)))) (if string (substring-no-properties string) nil)))) (save-excursion - (let ((result "")) - (callf concat result (format "%s" (sexp-at-point))) + (let ((result nil)) + (push (format "%s" (sexp-at-point)) result) (dotimes (i (1- n)) (forward-sexp) (forward-char 1) - (callf concat result (format " %s" (sexp-at-point)))) - result)))) + (push (format " %s" (sexp-at-point)) result)) + (if (slime-length= result 1) + (first result) + (nreverse result)))))) (defun slime-sexp-at-point-or-error () "Return the sexp at point as a string, othwise signal an error." @@ -10555,7 +10558,7 @@ (point))) -(defun slime-parse-extended-operator-name (user-point ops indices points) +(defun slime-parse-extended-operator-name (user-point forms indices points) "Assume that point is directly at the operator that should be parsed. USER-POINT is the value of `point' where the user was looking at. OPS, INDICES and POINTS are updated to reflect the new values after @@ -10566,19 +10569,20 @@ ;; first. (save-excursion (ignore-errors - (forward-char (1+ (length name))) - (slime-forward-blanks) - (let* ((current-op (first ops)) + (let* ((current-op (first (first forms))) (op-name (upcase (slime-cl-symbol-name current-op))) - (assoc (assoc op-name slime-extended-operator-name-parser-alist))) - (when assoc - (let* ((entry (cdr assoc)) - (parser (if (listp entry) - (apply (first entry) (rest entry)) - entry))) - (multiple-value-setq (ops indices points) - (funcall parser op-name user-point ops indices points))))))) - (values ops indices points)) + (assoc (assoc op-name slime-extended-operator-name-parser-alist)) + (entry (cdr assoc)) + (parser (if (and entry (listp entry)) + (apply (first entry) (rest entry)) + entry))) + (ignore-errors + (forward-char (1+ (length current-op))) + (slime-forward-blanks)) + (when parser + (multiple-value-setq (forms indices points) + (funcall parser op-name user-point forms indices points)))))) + (values forms indices points)) (defvar slime-extended-operator-name-parser-alist @@ -10599,54 +10603,55 @@ plus STEPS-many additional sexps on the right side of the operator." (lexical-let ((n steps)) - #'(lambda (name user-point current-ops current-indices current-points) - (let ((old-ops (rest current-ops))) - (let ((str (slime-sexp-at-point n))) - (setq current-ops - (cons (format "(%s %s)" name str) old-ops))) - (values current-ops current-indices current-points))))) + #'(lambda (name user-point current-forms current-indices current-points) + (let ((old-forms (rest current-forms))) + (let ((args (slime-ensure-list (slime-sexp-at-point n)))) + (setq current-forms + (cons `(,name , at args) old-forms))) + (values current-forms current-indices current-points))))) (defun slime-parse-extended-operator/declare - (name user-point current-ops current-indices current-points) + (name user-point current-forms current-indices current-points) (when (string= (thing-at-point 'char) "(") (let ((orig-point (point))) (save-excursion (goto-char user-point) (slime-end-of-symbol) - ;; Head of CURRENT-OPS is "declare" at this point, but we're + ;; Head of CURRENT-FORMS is "declare" at this point, but we're ;; interested in what comes next. - (let ((decl-ops (rest current-ops)) (new-indices (rest current-indices))) - (if (%slime-in-mid-of-typespec-p decl-ops) - ;; Parse type-specifier: - (let ((rightmost-operator (first (last decl-ops))) - (rightmost-index (first (last new-indices))) ; arg# in the typespec. - (rightmost-op-pos (first (last points)))) - (goto-char rightmost-op-pos) - (let ((typespec (format "(%s)" (slime-sexp-at-point rightmost-index)))) - (setq current-ops (list `(:type-specifier ,typespec))) - (setq current-indicies (list rightmost-index)) - (setq current-points (list rightmost-op-pos)))) - ;; Parse declaration specifier: - (let ((nesting 0)) - (while (> (point) orig-point) - (backward-up-list) - (incf nesting)) - (when (= (point) orig-point) - (goto-char user-point) - (let ((declspec (concat (slime-incomplete-sexp-at-point nesting) - (make-string nesting ?\))))) - (setq current-ops (list `(:declaration ,declspec))) - (setq current-indices new-indices))))))))) - (values current-ops current-indices current-points)) - -(defun %slime-in-mid-of-typespec-p (decl-ops) - (let ((rightmost-operator (first (last decl-ops))) - (leftmost-operator (first decl-ops))) - (or (and (equalp leftmost-operator "type") ; `(declare (type' ? - (not (slime-length= decl-ops 1))) ; `(declare (type (' ? - (and (null leftmost-operator) ; `(declare (' ? - (not (null rightmost-operator)))))) ; `(declare ((' ? + (let* ((decl-ops (rest current-forms)) + (decl-indices (rest current-indices)) + (decl-points (rest current-points)) + (decl-pos (1- (first decl-points))) + (nesting (%slime-nesting-until-point decl-pos)) + (declspec (concat (slime-incomplete-sexp-at-point nesting) + (make-string nesting ?\))))) + ;; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? + (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec)) + (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec))) + (let ((typespec-op (first (second decl-ops))) + (typespec (match-string 1 declspec))) + (setq current-forms (list `(:type-specifier ,typespec-op ,typespec))) + (setq current-indices (list (second decl-indices))) + (setq current-points (list (second decl-points)))) + (let ((decl-identifier (first (first decl-ops)))) + (setq current-forms (list `(:declaration ,decl-identifier ,declspec))) + (setq current-indices (list (first decl-indices))) + (setq current-points (list (first decl-points))))))))) + (values current-forms current-indices current-points)) + +(defun %slime-nesting-until-point (target-point) + (save-excursion + (let ((nesting 0)) + (while (> (point) target-point) + (backward-up-list) + (incf nesting)) + (if (= (point) target-point) + nesting + 0)))) + + (defun slime-enclosing-form-specs (&optional max-levels) @@ -10728,7 +10733,7 @@ (widen) ; to allow looking-ahead/back in extended parsing. (multiple-value-bind (new-result new-indices new-points) (slime-parse-extended-operator-name initial-point - (cons name result) + (cons `(,name) result) ; minimal form spec (cons arg-index arg-indices) (cons (point) points)) (setq result new-result) From trittweiler at common-lisp.net Fri Aug 24 13:59:25 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 24 Aug 2007 09:59:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824135925.E0FDB13026@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12213 Modified Files: ChangeLog Log Message: * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' (slime-sexp-at-point): Return results as a list of strings, rather than just one big string if called with arg > 1. (slime-parse-extended-operator-name): Wrapping some movement code in `ignore-errors'. Adapted to new return value of `slime-enclosing-form-specs'. Minor cosmetic changes. (slime-make-extended-operator-parser/look-ahead): Adapted to changes of the ``raw form spec'' format; returns a form of strings, instead of a string of a form. (slime-parse-extended-operator/declare): Simplified. Adapted to changes of the ``raw form spec'' format; passes decl-identifiers, or typespec-operators respectively, along the decl/type-spec. (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp based approach. (%slime-nesting-until-point): New helper for `slime-parse-extended-operator/declare'. * swank.lisp (parse-form-spec): Adapted to new ``raw form spec'' format. Updated format description in docstring accordingly. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 13:43:03 1.1158 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 13:59:25 1.1159 @@ -1,3 +1,27 @@ +2007-08-24 Tobias C. Rittweiler + + * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' + (slime-sexp-at-point): Return results as a list of strings, rather + than just one big string if called with arg > 1. + (slime-parse-extended-operator-name): Wrapping some movement code + in `ignore-errors'. Adapted to new return value of + `slime-enclosing-form-specs'. Minor cosmetic changes. + (slime-make-extended-operator-parser/look-ahead): Adapted to + changes of the ``raw form spec'' format; returns a form of + strings, instead of a string of a form. + (slime-parse-extended-operator/declare): Simplified. Adapted to + changes of the ``raw form spec'' format; passes decl-identifiers, + or typespec-operators respectively, along the decl/type-spec. + (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp + based approach. + (%slime-nesting-until-point): New helper for + `slime-parse-extended-operator/declare'. + + * swank.lisp (parse-form-spec): Adapted to new ``raw form spec'' + format. Updated format description in docstring accordingly. The + new format allows less interning of wrong symbols names comming + from Slime. Thanks to Matthias Koeppe for spotting this. + 2007-08-24 Helmut Eller Move slime-highlight-edits-mode to contrib. From heller at common-lisp.net Fri Aug 24 14:47:11 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 10:47:11 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824144711.BC7F34321F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21494 Modified Files: slime.el ChangeLog Log Message: Move xref broser to contrib. --- /project/slime/cvsroot/slime/slime.el 2007/08/24 13:55:52 1.809 +++ /project/slime/cvsroot/slime/slime.el 2007/08/24 14:47:11 1.810 @@ -8914,96 +8914,6 @@ ("\M-." 'slime-edit-definition)) -;;;; classes browser - -(defun slime-expand-class-node (widget) - (or (widget-get widget :args) - (let ((name (widget-get widget :tag))) - (loop for kid in (slime-eval `(swank:mop :subclasses ,name)) - collect `(tree-widget :tag ,kid - :dynargs slime-expand-class-node - :has-children t))))) - -(defun slime-browse-classes (name) - "Read the name of a class and show its subclasses." - (interactive (list (slime-read-symbol-name "Class Name: "))) - (slime-call-with-browser-setup - "*slime class browser*" (slime-current-package) "Class Browser" - (lambda () - (widget-create 'tree-widget :tag name - :dynargs 'slime-expand-class-node - :has-echildren t)))) - -(defvar slime-browser-map nil - "Keymap for tree widget browsers") - -(require 'tree-widget) -(unless slime-browser-map - (setq slime-browser-map (make-sparse-keymap)) - (set-keymap-parent slime-browser-map widget-keymap) - (define-key slime-browser-map "q" 'bury-buffer)) - -(defun slime-call-with-browser-setup (buffer package title fn) - (switch-to-buffer buffer) - (kill-all-local-variables) - (setq slime-buffer-package package) - (let ((inhibit-read-only t)) (erase-buffer)) - (widget-insert title "\n\n") - (save-excursion - (funcall fn)) - (lisp-mode-variables t) - (slime-mode t) - (use-local-map slime-browser-map) - (widget-setup)) - - -;;;; Xref browser - -(defun slime-fetch-browsable-xrefs (type name) - "Return a list ((LABEL DSPEC)). -LABEL is just a string for display purposes. -DSPEC can be used to expand the node." - (let ((xrefs '())) - (loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do - (loop for (dspec . _location) in specs do - (let ((exp (ignore-errors (read (downcase dspec))))) - (cond ((and (consp exp) (eq 'flet (car exp))) - ;; we can't expand FLET references so they're useless - ) - ((and (consp exp) (eq 'method (car exp))) - ;; this isn't quite right, but good enough for now - (push (list dspec (string (second exp))) xrefs)) - (t - (push (list dspec dspec) xrefs)))))) - xrefs)) - -(defun slime-expand-xrefs (widget) - (or (widget-get widget :args) - (let* ((type (widget-get widget :xref-type)) - (dspec (widget-get widget :xref-dspec)) - (xrefs (slime-fetch-browsable-xrefs type dspec))) - (loop for (label dspec) in xrefs - collect `(tree-widget :tag ,label - :xref-type ,type - :xref-dspec ,dspec - :dynargs slime-expand-xrefs - :has-children t))))) - -(defun slime-browse-xrefs (name type) - "Show the xref graph of a function in a tree widget." - (interactive - (list (slime-read-from-minibuffer "Name: " - (slime-symbol-name-at-point)) - (read (completing-read "Type: " (slime-bogus-completion-alist - '(":callers" ":callees" ":calls")) - nil t ":")))) - (slime-call-with-browser-setup - "*slime xref browser*" (slime-current-package) "Xref Browser" - (lambda () - (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name - :dynargs 'slime-expand-xrefs :has-echildren t)))) - - ;;;; Buffer selector (defvar slime-selector-methods nil --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 13:59:25 1.1159 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 14:47:11 1.1160 @@ -1,3 +1,10 @@ +2007-08-24 Helmut Eller + + Move xref and class browser to contrib. + + * slime.el (slime-browse-classes, slime-browse-xrefs): Gone. The + Common Lisp part is still there. + 2007-08-24 Tobias C. Rittweiler * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' From heller at common-lisp.net Fri Aug 24 14:47:12 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 10:47:12 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070824144712.AE9DC4507D@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv21494/contrib Modified Files: ChangeLog Added Files: slime-xref-browser.el Log Message: Move xref broser to contrib. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 13:43:03 1.5 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 14:47:11 1.6 @@ -1,9 +1,7 @@ 2007-08-24 Helmut Eller + * slime-xref-browser.el: New file. * slime-highlight-edits.el: New file. - -2007-08-24 Helmut Eller - * slime-scratch.el: New file. 2007-08-23 Helmut Eller --- /project/slime/cvsroot/slime/contrib/slime-xref-browser.el 2007/08/24 14:47:12 NONE +++ /project/slime/cvsroot/slime/contrib/slime-xref-browser.el 2007/08/24 14:47:12 1.1 ;;; slime-xref-browser.el --- xref browsing with tree-widget ;; ;; Author: Rui Patroc?nio ;; Licencse: GNU GPL (same license as Emacs) ;; ;;; Installation: ;; ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "") ;; (add-hook 'slime-load-hook (lambda () (require 'slime-xref-browser))) ;; ;;;; classes browser (defun slime-expand-class-node (widget) (or (widget-get widget :args) (let ((name (widget-get widget :tag))) (loop for kid in (slime-eval `(swank:mop :subclasses ,name)) collect `(tree-widget :tag ,kid :dynargs slime-expand-class-node :has-children t))))) (defun slime-browse-classes (name) "Read the name of a class and show its subclasses." (interactive (list (slime-read-symbol-name "Class Name: "))) (slime-call-with-browser-setup "*slime class browser*" (slime-current-package) "Class Browser" (lambda () (widget-create 'tree-widget :tag name :dynargs 'slime-expand-class-node :has-echildren t)))) (defvar slime-browser-map nil "Keymap for tree widget browsers") (require 'tree-widget) (unless slime-browser-map (setq slime-browser-map (make-sparse-keymap)) (set-keymap-parent slime-browser-map widget-keymap) (define-key slime-browser-map "q" 'bury-buffer)) (defun slime-call-with-browser-setup (buffer package title fn) (switch-to-buffer buffer) (kill-all-local-variables) (setq slime-buffer-package package) (let ((inhibit-read-only t)) (erase-buffer)) (widget-insert title "\n\n") (save-excursion (funcall fn)) (lisp-mode-variables t) (slime-mode t) (use-local-map slime-browser-map) (widget-setup)) ;;;; Xref browser (defun slime-fetch-browsable-xrefs (type name) "Return a list ((LABEL DSPEC)). LABEL is just a string for display purposes. DSPEC can be used to expand the node." (let ((xrefs '())) (loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do (loop for (dspec . _location) in specs do (let ((exp (ignore-errors (read (downcase dspec))))) (cond ((and (consp exp) (eq 'flet (car exp))) ;; we can't expand FLET references so they're useless ) ((and (consp exp) (eq 'method (car exp))) ;; this isn't quite right, but good enough for now (push (list dspec (string (second exp))) xrefs)) (t (push (list dspec dspec) xrefs)))))) xrefs)) (defun slime-expand-xrefs (widget) (or (widget-get widget :args) (let* ((type (widget-get widget :xref-type)) (dspec (widget-get widget :xref-dspec)) (xrefs (slime-fetch-browsable-xrefs type dspec))) (loop for (label dspec) in xrefs collect `(tree-widget :tag ,label :xref-type ,type :xref-dspec ,dspec :dynargs slime-expand-xrefs :has-children t))))) (defun slime-browse-xrefs (name type) "Show the xref graph of a function in a tree widget." (interactive (list (slime-read-from-minibuffer "Name: " (slime-symbol-name-at-point)) (read (completing-read "Type: " (slime-bogus-completion-alist '(":callers" ":callees" ":calls")) nil t ":")))) (slime-call-with-browser-setup "*slime xref browser*" (slime-current-package) "Xref Browser" (lambda () (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name :dynargs 'slime-expand-xrefs :has-echildren t)))) (provide 'slime-xref-browser) From heller at common-lisp.net Fri Aug 24 15:48:44 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 11:48:44 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070824154844.C46132B12A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv30357 Modified Files: slime.el ChangeLog Log Message: Move typeout frame to contrib. * slime.el (slime-message-function, slime-background-message-function) (slime-autodoc-message-function): New variables. (slime-message, slime-background-message) (slime-autodoc-message): Call the function in the respective variable, so that the typeout window can be plugged in. --- /project/slime/cvsroot/slime/slime.el 2007/08/24 14:47:11 1.810 +++ /project/slime/cvsroot/slime/slime.el 2007/08/24 15:48:44 1.811 @@ -1053,18 +1053,22 @@ ;;;;; Very-commonly-used functions +(defvar slime-message-function 'message) + ;; Interface (defun slime-message (format &rest args) "Like `message' but with special support for multi-line messages. Single-line messages use the echo area." - (if (slime-typeout-active-p) - (apply #'slime-typeout-message format args) - (if (or (featurep 'xemacs) - (= emacs-major-version 20)) - (slime-display-message (apply #'format format args) "*SLIME Note*") - (apply 'message format args)))) + (apply slime-message-function format args)) + +(when (or (featurep 'xemacs) + (= emacs-major-version 20)) + (setq slime-message-function 'slime-format-display-message)) + +(defun slime-format-display-message (format &rest args) + (slime-display-message (apply #'format format args))) -(defun slime-display-message (message buffer-name) +(defun slime-display-message (message) "Display MESSAGE in the echo area or in BUFFER-NAME. Use the echo area if MESSAGE needs only a single line. If the MESSAGE requires more than one line display it in BUFFER-NAME and add a hook @@ -1073,19 +1077,17 @@ (when (get-buffer-window buffer-name) (delete-windows-on buffer-name)) (cond ((or (string-match "\n" message) (> (length message) (1- (frame-width)))) - (if (slime-typeout-active-p) - (slime-typeout-message "%s" message) - (lexical-let ((buffer (get-buffer-create buffer-name))) - (with-current-buffer buffer - (erase-buffer) - (insert message) - (goto-char (point-min)) - (let ((win (slime-create-message-window))) - (set-window-buffer win (current-buffer)) - (shrink-window-if-larger-than-buffer - (display-buffer (current-buffer))))) - (push (lambda () (delete-windows-on buffer) (bury-buffer buffer)) - slime-pre-command-actions)))) + (lexical-let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (erase-buffer) + (insert message) + (goto-char (point-min)) + (let ((win (slime-create-message-window))) + (set-window-buffer win (current-buffer)) + (shrink-window-if-larger-than-buffer + (display-buffer (current-buffer))))) + (push (lambda () (delete-windows-on buffer) (bury-buffer buffer)) + slime-pre-command-actions))) (t (message "%s" message)))) (defun slime-create-message-window () @@ -1098,17 +1100,20 @@ (window-height previous))))) (split-window previous))) +(defvar slime-background-message-function 'slime-display-oneliner) + ;; Interface (defun slime-background-message (format-string &rest format-args) "Display a message in passing. This is like `slime-message', but less distracting because it will never pop up a buffer or display multi-line messages. It should be used for \"background\" messages such as argument lists." - (if (slime-typeout-active-p) - (slime-typeout-message (apply #'format format-string format-args)) - (let* ((msg (apply #'format format-string format-args))) - (unless (minibuffer-window-active-p (minibuffer-window)) - (message "%s" (slime-oneliner msg)))))) + (apply slime-background-message-function format-string format-args)) + +(defun slime-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (slime-oneliner msg))))) (defun slime-oneliner (string) "Return STRING truncated to fit in a single echo-area line." @@ -5779,27 +5784,22 @@ :type 'boolean :group 'slime-ui) +(defvar slime-autodoc-message-function 'slime-autodoc-show-message) + (defun slime-autodoc-message (doc) "Display the autodoc documentation string DOC." - (cond - ((slime-typeout-active-p) - (setq slime-autodoc-last-message "") ; no need for refreshing - (slime-typeout-message doc)) - (t - (unless slime-autodoc-use-multiline-p - (setq doc (slime-oneliner doc))) - (setq slime-autodoc-last-message doc) - (message "%s" doc)))) + (funcall slime-autodoc-message-function doc)) + +(defun slime-autodoc-show-message (doc) + (unless slime-autodoc-use-multiline-p + (setq doc (slime-oneliner doc))) + (setq slime-autodoc-last-message doc) + (message "%s" doc)) (defun slime-autodoc-message-dimensions () "Return the available width and height for pretty printing autodoc messages." (cond - ((slime-typeout-active-p) - ;; Use the full width of the typeout window; - ;; we don't care about the height, as typeout window can be scrolled - (values (window-width slime-typeout-window) - nil)) (slime-autodoc-use-multiline-p ;; Use the full width of the minibuffer; ;; minibuffer will grow vertically if necessary @@ -5928,44 +5928,6 @@ (slime-background-activities-enabled-p))) -;;;; Typeout frame - -;; When a "typeout frame" exists it is used to display certain -;; messages instead of the echo area or pop-up windows. - -(defvar slime-typeout-window nil - "The current typeout window.") - -(defvar slime-typeout-frame-properties - '((height . 10) (minibuffer . nil)) - "The typeout frame properties (passed to `make-frame').") - -(defun slime-typeout-active-p () - (and slime-typeout-window - (window-live-p slime-typeout-window))) - -(defun slime-typeout-message (format-string &rest format-args) - (assert (slime-typeout-active-p)) - (with-current-buffer (window-buffer slime-typeout-window) - (erase-buffer) - (insert (apply #'format format-string format-args)))) - -(defun slime-make-typeout-frame () - "Create a frame for displaying messages (e.g. arglists)." - (interactive) - (let ((frame (make-frame slime-typeout-frame-properties))) - (save-selected-window - (select-window (frame-selected-window frame)) - (switch-to-buffer "*SLIME-Typeout*") - (setq slime-typeout-window (selected-window))))) - -(defun slime-ensure-typeout-frame () - "Create the typeout frame unless it already exists." - (interactive) - (unless (slime-typeout-active-p) - (slime-make-typeout-frame))) - - ;;;; Completion ;; XXX those long names are ugly to read; long names an indicator for --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 14:47:11 1.1160 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/24 15:48:44 1.1161 @@ -1,5 +1,15 @@ 2007-08-24 Helmut Eller + Move typeout frame to contrib. + + * slime.el (slime-message-function, slime-background-message-function) + (slime-autodoc-message-function): New variables. + (slime-message, slime-background-message) + (slime-autodoc-message): Call the function in the respective + variable, so that the typeout window can be plugged in. + +2007-08-24 Helmut Eller + Move xref and class browser to contrib. * slime.el (slime-browse-classes, slime-browse-xrefs): Gone. The From heller at common-lisp.net Fri Aug 24 15:48:45 2007 From: heller at common-lisp.net (heller) Date: Fri, 24 Aug 2007 11:48:45 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070824154845.061632B12A@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv30357/contrib Modified Files: ChangeLog Added Files: slime-typeout-frame.el Log Message: Move typeout frame to contrib. * slime.el (slime-message-function, slime-background-message-function) (slime-autodoc-message-function): New variables. (slime-message, slime-background-message) (slime-autodoc-message): Call the function in the respective variable, so that the typeout window can be plugged in. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 14:47:11 1.6 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 15:48:44 1.7 @@ -1,5 +1,6 @@ 2007-08-24 Helmut Eller + * slime-typeout-frame.el: New file. * slime-xref-browser.el: New file. * slime-highlight-edits.el: New file. * slime-scratch.el: New file. --- /project/slime/cvsroot/slime/contrib/slime-typeout-frame.el 2007/08/24 15:48:45 NONE +++ /project/slime/cvsroot/slime/contrib/slime-typeout-frame.el 2007/08/24 15:48:45 1.1 ;;; slime-typeout-frame.el --- display some message in a dedicated frame ;; ;; Author: Luke Gorrie ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation: ;; ;; Add something like this to your .emacs: ;; ;; (add-to-list 'load-path "") ;; (add-hook 'slime-load-hook (lambda () (require 'slime-typeout-frame))) ;; ;;;; Typeout frame ;; When a "typeout frame" exists it is used to display certain ;; messages instead of the echo area or pop-up windows. (defvar slime-typeout-window nil "The current typeout window.") (defvar slime-typeout-frame-properties '((height . 10) (minibuffer . nil)) "The typeout frame properties (passed to `make-frame').") (defun slime-typeout-active-p () (and slime-typeout-window (window-live-p slime-typeout-window))) (defun slime-typeout-message (format-string &rest format-args) (slime-ensure-typeout-frame) (with-current-buffer (window-buffer slime-typeout-window) (erase-buffer) (insert (apply #'format format-string format-args)))) (defun slime-make-typeout-frame () "Create a frame for displaying messages (e.g. arglists)." (interactive) (let ((frame (make-frame slime-typeout-frame-properties))) (save-selected-window (select-window (frame-selected-window frame)) (switch-to-buffer "*SLIME-Typeout*") (setq slime-typeout-window (selected-window))))) (defun slime-ensure-typeout-frame () "Create the typeout frame unless it already exists." (interactive) (unless (slime-typeout-active-p) (slime-make-typeout-frame))) (defun slime-typeout-autodoc-message (doc) (setq slime-autodoc-last-message "") ; no need for refreshing (slime-typeout-message doc)) ;;; Initialization (defun slime-install-typeout-frame () (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) (setq slime-message-function #'slime-typeout-message) (setq slime-background-message-function #'slime-typeout-message) (setq slime-autodoc-message-function #'slime-typeout-autodoc-message)) (slime-install-typeout-frame) (provide 'slime-typeout-frame) From mkoeppe at common-lisp.net Sat Aug 25 00:37:26 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 20:37:26 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825003726.AFC63830A1@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13318 Modified Files: slime.el Log Message: * slime.el (slime-dispatch-event): Handle new optionals args of messages :presentation-start and :presentation-end. * slime.el (slime-mark-presentation-start) (slime-mark-presentation-end): New arg "target"; record presentation boundaries separately for REPL results and regular process output. This fixes the presentation markup of REPL results when the presentation-streams contrib is loaded. --- /project/slime/cvsroot/slime/slime.el 2007/08/24 15:48:44 1.811 +++ /project/slime/cvsroot/slime/slime.el 2007/08/25 00:37:26 1.812 @@ -2645,10 +2645,10 @@ (destructure-case event ((:write-string output &optional id target) (slime-write-string output id target)) - ((:presentation-start id) - (slime-mark-presentation-start id)) - ((:presentation-end id) - (slime-mark-presentation-end id)) + ((:presentation-start id &optional target) + (slime-mark-presentation-start id target)) + ((:presentation-end id &optional target) + (slime-mark-presentation-end id target)) ;; ((:emacs-rex form package thread continuation) (slime-set-state "|eval...") @@ -2927,10 +2927,14 @@ (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) -(defun slime-mark-presentation-start (id) +(defun slime-mark-presentation-start (id target) + "Mark the beginning of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." (setf (gethash id slime-presentation-start-to-point) (with-current-buffer (slime-output-buffer) - (marker-position (symbol-value 'slime-output-end))))) + (if (eq target :repl-result) + (point-max) + (marker-position (symbol-value 'slime-output-end)))))) (defun slime-mark-presentation-start-handler (process string) (if (and string (string-match "<\\([-0-9]+\\)" string)) @@ -2938,13 +2942,19 @@ (id (car (read-from-string match)))) (slime-mark-presentation-start id)))) -(defun slime-mark-presentation-end (id) +(defun slime-mark-presentation-end (id target) + "Mark the end of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." (let ((start (gethash id slime-presentation-start-to-point))) (remhash id slime-presentation-start-to-point) (when start (with-current-buffer (slime-output-buffer) - (slime-add-presentation-properties start (symbol-value 'slime-output-end) - id nil))))) + (let ((end + (if (eq target :repl-result) + (point-max) + (symbol-value 'slime-output-end)))) + (slime-add-presentation-properties start end + id nil)))))) (defun slime-mark-presentation-end-handler (process string) (if (and string (string-match ">\\([-0-9]+\\)" string)) From mkoeppe at common-lisp.net Sat Aug 25 00:38:19 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 20:38:19 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825003819.94A9072097@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13414 Modified Files: swank-loader.lisp Log Message: (*contribs*): Add swank-presentation-streams. --- /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/23 18:09:21 1.67 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/25 00:38:19 1.68 @@ -198,7 +198,8 @@ (defvar *fasl-directory* (default-fasl-directory) "The directory where fasl files should be placed.") -(defvar *contribs* '(swank-fuzzy swank-fancy-inspector) +(defvar *contribs* '(swank-fuzzy swank-fancy-inspector + swank-presentation-streams) "List of names for contrib modules.") (defun append-dir (absolute name) From mkoeppe at common-lisp.net Sat Aug 25 00:38:58 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 20:38:58 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825003858.93557111CD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13475 Removed Files: present.lisp Log Message: Moved to contrib/swank-presentation-streams.lisp. From mkoeppe at common-lisp.net Sat Aug 25 00:51:52 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 20:51:52 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070825005152.78CB52107C@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv15975/contrib Added Files: swank-presentation-streams.lisp Log Message: * swank-presentation-streams.lisp [sbcl]: Load the pretty-printer patch only at load time. Add some trickery so that SBCL does not complain about the changed layout of the pretty-stream class. * swank-presentation-streams.lisp (slime-stream-p): Using special return values, indicate whether we are printing to the REPL-results stream, or a dedicated stream. (presentation-record): New slot "target". (presentation-start, presentation-end): Use it (rather than the global variable *use-dedicated-output-stream*) to decide whether to use the bridge protocol or the :presentation-start/-end protocol. Also use it as the TARGET argument of :presentation-start/-end messages. (presenting-object-1): Use the new return values of slime-stream-p. * swank-presentation-streams.lisp: New file, moved here from ../present.lisp --- /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 00:51:52 NONE +++ /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 00:51:52 1.1 ;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities ;;; to portions of output ;;; ;;; Authors: Alan Ruttenberg ;;; Matthias Koeppe ;;; Helmut Eller ;;; ;;; License: This code has been placed in the Public Domain. All warranties ;;; are disclaimed. (in-package :swank) ;; A mechanism for printing to the slime repl so that the printed ;; result remembers what object it is associated with. Depends on the ;; ilisp bridge code being installed and ready to intercept messages ;; in the printed stream. We encode the information with a message ;; saying that we are starting to print an object corresponding to a ;; given id and another when we are done. The process filter notices these ;; and adds the necessary text properties to the output. ;; We only do this if we know we are printing to a slime stream, ;; checked with the method slime-stream-p. Initially this checks for ;; the knows slime streams looking at *connections*. In cmucl and ;; openmcl it also checks if it is a pretty-printing stream which ;; ultimately prints to a slime stream. ;; Control (defvar *enable-presenting-readable-objects* t "set this to enable automatically printing presentations for some subset of readable objects, such as pathnames." ) ;; doing it (defmacro presenting-object (object stream &body body) "What you use in your code. Wrap this around some printing and that text will be sensitive and remember what object it is in the repl" `(presenting-object-1 ,object ,stream #'(lambda () , at body))) (defmacro presenting-object-if (predicate object stream &body body) "What you use in your code. Wrap this around some printing and that text will be sensitive and remember what object it is in the repl if predicate is true" (let ((continue (gensym))) `(let ((,continue #'(lambda () , at body))) (if ,predicate (presenting-object-1 ,object ,stream ,continue) (funcall ,continue))))) ;;; Get pretty printer patches for SBCL at load (not compile) time. #+sbcl (eval-when (:load-toplevel) (handler-bind ((simple-error (lambda (c) (declare (ignore c)) (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) (when clobber-it (invoke-restart clobber-it)))))) (sb-ext:without-package-locks (swank-backend::with-debootstrapping (load (make-pathname :name "sbcl-pprint-patch" :type "lisp" :directory (pathname-directory swank-loader:*source-directory*))))))) (let ((last-stream nil) (last-answer nil)) (defun slime-stream-p (stream) "Check if stream is one of the slime streams, since if it isn't we don't want to present anything. Two special return values: :DEDICATED -- Output ends up on a dedicated output stream :REPL-RESULT -- Output ends up on the :repl-results target. " (if (eq last-stream stream) last-answer (progn (setq last-stream stream) (if (eq stream t) (setq stream *standard-output*)) (setq last-answer (or #+openmcl (and (typep stream 'ccl::xp-stream) ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) #+cmu (or (and (typep stream 'lisp::indenting-stream) (slime-stream-p (lisp::indenting-stream-stream stream))) (and (typep stream 'pretty-print::pretty-stream) (fboundp 'pretty-print::enqueue-annotation) (not *use-dedicated-output-stream*) ;; Printing through CMUCL pretty streams ;; is only cleanly possible if we are ;; using the bridge-less protocol with ;; annotations, because the bridge escape ;; sequences disturb the pretty printer ;; layout. (slime-stream-p (pretty-print::pretty-stream-target stream)))) #+sbcl (let () (declare (notinline sb-pretty::pretty-stream-target)) (or (and (typep stream 'sb-impl::indenting-stream) (slime-stream-p (sb-impl::indenting-stream-stream stream))) (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) (not *use-dedicated-output-stream*) (slime-stream-p (sb-pretty::pretty-stream-target stream))))) #+allegro (and (typep stream 'excl:xp-simple-stream) (slime-stream-p (excl::stream-output-handle stream))) (loop for connection in *connections* thereis (or (and (eq stream (connection.dedicated-output connection)) :dedicated) (eq stream (connection.socket-io connection)) (eq stream (connection.user-output connection)) (eq stream (connection.user-io connection)) (and (eq stream (connection.repl-results connection)) :repl-result))))))))) (defun can-present-readable-objects (&optional stream) (declare (ignore stream)) *enable-presenting-readable-objects*) ;; If we are printing to an XP (pretty printing) stream, printing the ;; escape sequences directly would mess up the layout because column ;; counting is disturbed. Use "annotations" instead. #+allegro (defun write-annotation (stream function arg) (if (typep stream 'excl:xp-simple-stream) (excl::schedule-annotation stream function arg) (funcall function arg stream nil))) #+cmu (defun write-annotation (stream function arg) (if (and (typep stream 'pp:pretty-stream) (fboundp 'pp::enqueue-annotation)) (pp::enqueue-annotation stream function arg) (funcall function arg stream nil))) #+sbcl (defun write-annotation (stream function arg) (let ((enqueue-annotation (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) (if (and enqueue-annotation (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) (funcall enqueue-annotation stream function arg) (funcall function arg stream nil)))) #-(or allegro cmu sbcl) (defun write-annotation (stream function arg) (funcall function arg stream nil)) (defstruct presentation-record (id) (printed-p) (target)) (defun presentation-start (record stream truncatep) (unless truncatep ;; Don't start new presentations when nothing is going to be ;; printed due to *print-lines*. (let ((pid (presentation-record-id record)) (target (presentation-record-target record))) (case target (:dedicated ;; Use bridge protocol (write-string "<" stream) (prin1 pid stream) (write-string "" stream)) (t (finish-output stream) (send-to-emacs `(:presentation-start ,pid ,target))))) (setf (presentation-record-printed-p record) t))) (defun presentation-end (record stream truncatep) (declare (ignore truncatep)) ;; Always end old presentations that were started. (when (presentation-record-printed-p record) (let ((pid (presentation-record-id record)) (target (presentation-record-target record))) (case target (:dedicated ;; Use bridge protocol (write-string ">" stream) (prin1 pid stream) (write-string "" stream)) (t (finish-output stream) (send-to-emacs `(:presentation-end ,pid ,target))))))) (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and ) (pp-end-block stream ">")) nil)) (defmethod print-object :around ((pathname pathname) stream) (swank::presenting-object-if (swank::can-present-readable-objects stream) pathname stream (call-next-method)))) #+openmcl (ccl::def-load-pointers clear-presentations () (swank::clear-presentation-tables)) (in-package :swank) #+cmu (progn (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) (presenting-object object stream (fwrappers:call-next-function))) (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) (presenting-object-if (can-present-readable-objects stream) pathname stream (fwrappers:call-next-function))) (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper) ) #+sbcl (progn (defvar *saved-%print-unreadable-object* (fdefinition 'sb-impl::%print-unreadable-object)) (sb-ext:without-package-locks (setf (fdefinition 'sb-impl::%print-unreadable-object) (lambda (object stream type identity body) (presenting-object object stream (funcall *saved-%print-unreadable-object* object stream type identity body)))) (defmethod print-object :around ((object pathname) stream) (presenting-object object stream (call-next-method))))) #+allegro (progn (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) (swank::presenting-object object stream (excl:call-next-fwrapper))) (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) (presenting-object-if (can-present-readable-objects stream) pathname stream (excl:call-next-fwrapper))) (excl:fwrap 'excl::print-unreadable-object-1 'print-unreadable-present 'presenting-unreadable-wrapper) (excl:fwrap 'excl::pathname-printer 'print-pathname-present 'presenting-pathname-wrapper)) (provide :swank-presentation-streams) From mkoeppe at common-lisp.net Sat Aug 25 00:52:06 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 20:52:06 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070825005206.3F05C2D07D@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv16017/contrib Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/24 15:48:44 1.7 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/25 00:52:06 1.8 @@ -1,3 +1,33 @@ +2007-08-24 Matthias Koeppe + + Some fixes to the presentation-streams contrib. + + * swank-presentation-streams.lisp [sbcl]: Load the pretty-printer + patch only at load time. Add some trickery so that SBCL does not + complain about the changed layout of the pretty-stream class. + + * swank-presentation-streams.lisp (slime-stream-p): Using special + return values, indicate whether we are printing to the + REPL-results stream, or a dedicated stream. + (presentation-record): New slot "target". + (presentation-start, presentation-end): Use it (rather than the + global variable *use-dedicated-output-stream*) to decide whether + to use the bridge protocol or the :presentation-start/-end + protocol. Also use it as the TARGET argument of + :presentation-start/-end messages. + (presenting-object-1): Use the new return values of + slime-stream-p. + +2007-08-24 Matthias Koeppe + + Make the fancy "presentation streams" feature a contrib. + Previously, it was only available if "present.lisp" was loaded + manually. + + * slime-presentation-streams.el: New file. + * swank-presentation-streams.lisp: New file, moved here from + ../present.lisp + 2007-08-24 Helmut Eller * slime-typeout-frame.el: New file. From mkoeppe at common-lisp.net Sat Aug 25 00:52:06 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 20:52:06 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825005206.A2E552E1D6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16017 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2007/08/24 15:48:44 1.1161 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/25 00:52:06 1.1162 @@ -1,3 +1,32 @@ +2007-08-24 Matthias Koeppe + + Some fixes to the presentation-streams contrib. + + * slime.el (slime-dispatch-event): Handle new optionals args of + messages :presentation-start and :presentation-end. + + * slime.el (slime-mark-presentation-start) + (slime-mark-presentation-end): New arg "target"; record + presentation boundaries separately for REPL results and regular + process output. This fixes the presentation markup of REPL + results when the presentation-streams contrib is loaded. + +2007-08-24 Matthias Koeppe + + Make the fancy presentation-streams feature a contrib. + Previously, it was only available if "present.lisp" was loaded + manually. Now it can be loaded automatically using: + + (add-hook 'slime-load-hook + (lambda () (require 'slime-presentation-streams))) + + Note that the normal presentations that are created by REPL + results, the inspector, and the debugger are NOT dependent on this + code. + + * present.lisp: Moved to contrib/swank-presentation-streams.lisp. + * swank-loader.lisp (*contribs*): Add swank-presentation-streams. + 2007-08-24 Helmut Eller Move typeout frame to contrib. From mkoeppe at common-lisp.net Sat Aug 25 01:10:24 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 21:10:24 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070825011024.9E9F844063@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18846 Modified Files: swank-presentation-streams.lisp Log Message: (slime-stream-p) [cmu]: Use the return value of slime-stream-p rather than the global variable *use-dedicated-output-stream* to decide whether printing through pretty streams is safe for the layout. --- /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 00:51:52 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 01:10:24 1.2 @@ -85,14 +85,21 @@ (slime-stream-p (lisp::indenting-stream-stream stream))) (and (typep stream 'pretty-print::pretty-stream) (fboundp 'pretty-print::enqueue-annotation) - (not *use-dedicated-output-stream*) - ;; Printing through CMUCL pretty streams - ;; is only cleanly possible if we are - ;; using the bridge-less protocol with - ;; annotations, because the bridge escape - ;; sequences disturb the pretty printer - ;; layout. - (slime-stream-p (pretty-print::pretty-stream-target stream)))) + (let ((slime-stream-p + (slime-stream-p (pretty-print::pretty-stream-target stream)))) + (and ;; Printing through CMUCL pretty + ;; streams is only cleanly + ;; possible if we are using the + ;; bridge-less protocol with + ;; annotations, because the bridge + ;; escape sequences disturb the + ;; pretty printer layout. + (not (eql slime-stream-p :dedicated-output)) + ;; If OK, return the return value + ;; we got from slime-stream-p on + ;; the target stream (could be + ;; :repl-result): + slime-stream-p)))) #+sbcl (let () (declare (notinline sb-pretty::pretty-stream-target)) From mkoeppe at common-lisp.net Sat Aug 25 01:10:36 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 21:10:36 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070825011036.1C2D45538E@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18889 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/25 00:52:06 1.8 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/25 01:10:36 1.9 @@ -18,6 +18,11 @@ (presenting-object-1): Use the new return values of slime-stream-p. + * swank-presentation-streams.lisp (slime-stream-p) [cmu]: Use the + return value of slime-stream-p rather than the global variable + *use-dedicated-output-stream* to decide whether printing through + pretty streams is safe for the layout. + 2007-08-24 Matthias Koeppe Make the fancy "presentation streams" feature a contrib. From mkoeppe at common-lisp.net Sat Aug 25 03:59:56 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 24 Aug 2007 23:59:56 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070825035956.79459830A0@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv11241 Modified Files: swank-presentation-streams.lisp Log Message: Update documentation --- /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 01:10:24 1.2 +++ /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 03:59:56 1.3 @@ -10,19 +10,35 @@ (in-package :swank) -;; A mechanism for printing to the slime repl so that the printed -;; result remembers what object it is associated with. Depends on the -;; ilisp bridge code being installed and ready to intercept messages -;; in the printed stream. We encode the information with a message -;; saying that we are starting to print an object corresponding to a -;; given id and another when we are done. The process filter notices these -;; and adds the necessary text properties to the output. - +;; This file contains a mechanism for printing to the slime repl so +;; that the printed result remembers what object it is associated +;; with. This extends the recording of REPL results. +;; +;; There are two methods: +;; +;; 1. Depends on the ilisp bridge code being installed and ready to +;; intercept messages in the printed stream. We encode the +;; information with a message saying that we are starting to print +;; an object corresponding to a given id and another when we are +;; done. The process filter notices these and adds the necessary +;; text properties to the output. +;; +;; 2. Use separate protocol messages :presentation-start and +;; :presentation-end for sending presentations. +;; ;; We only do this if we know we are printing to a slime stream, ;; checked with the method slime-stream-p. Initially this checks for -;; the knows slime streams looking at *connections*. In cmucl and +;; the knows slime streams looking at *connections*. In cmucl, sbcl, and ;; openmcl it also checks if it is a pretty-printing stream which ;; ultimately prints to a slime stream. +;; +;; Method 1 seems to be faster, but the printed escape sequences can +;; disturb the column counting, and thus the layout in pretty-printing. +;; We use method 1 when a dedicated output stream is used. +;; +;; Method 2 is cleaner and works with pretty printing if the pretty +;; printers support "annotations". We use method 2 when no dedicated +;; output stream is used. ;; Control (defvar *enable-presenting-readable-objects* t From mkoeppe at common-lisp.net Sat Aug 25 04:56:50 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 25 Aug 2007 00:56:50 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825045650.776BA3001B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv27020 Modified Files: swank.lisp Log Message: (arglist-for-insertion): Now unused, removed. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/24 13:55:25 1.497 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/25 04:56:50 1.498 @@ -2373,21 +2373,6 @@ t))))))) (call-next-method)) -(defslimefun arglist-for-insertion (name) - (with-buffer-syntax () - (let ((symbol (parse-symbol name))) - (cond - ((and symbol - (valid-operator-name-p name)) - (let ((decoded-arglist - (compute-enriched-decoded-arglist symbol nil))) - (if (eql decoded-arglist :not-available) - :not-available - (decoded-arglist-to-template-string decoded-arglist - *buffer-package*)))) - (t - :not-available))))) - (defvar *remove-keywords-alist* '((:test :test-not) (:test-not :test))) From mkoeppe at common-lisp.net Sat Aug 25 04:57:04 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 25 Aug 2007 00:57:04 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825045704.722CC3001B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv27072 Modified Files: slime.el Log Message: (slime-insert-arglist): Removed, superseded by slime-complete-form since 2005-02-20. --- /project/slime/cvsroot/slime/slime.el 2007/08/25 00:37:26 1.812 +++ /project/slime/cvsroot/slime/slime.el 2007/08/25 04:57:04 1.813 @@ -5679,22 +5679,6 @@ (message "%s" (slime-fontify-string arglist)) (error "Arglist not available"))))) -(defun slime-insert-arglist (name) - "Insert the argument list for NAME behind the symbol point is -currently looking at." - (interactive (list (slime-read-symbol-name "Arglist of: "))) - (let ((arglist (slime-eval `(swank:arglist-for-insertion ',name)))) - (cond ((eq arglist :not-available) - (error "Arglist not available")) - ((string-match "^(" arglist) - (insert " ") - (save-excursion - (insert (substring arglist 1)))) - (t - (save-excursion - (insert arglist)))))) - - (defun slime-incomplete-form-at-point () "Looks for a ``raw form spec'' around point to be processed by SWANK::PARSE-FORM-SPEC. It is similiar to From mkoeppe at common-lisp.net Sat Aug 25 04:57:42 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 25 Aug 2007 00:57:42 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825045742.8D9B73700F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv27129 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/25 00:52:06 1.1162 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/25 04:57:42 1.1163 @@ -1,5 +1,12 @@ 2007-08-24 Matthias Koeppe + * slime.el (slime-insert-arglist): Removed, superseded by + slime-complete-form since 2005-02-20. + + * swank.lisp (arglist-for-insertion): Now unused, removed. + +2007-08-24 Matthias Koeppe + Some fixes to the presentation-streams contrib. * slime.el (slime-dispatch-event): Handle new optionals args of From trittweiler at common-lisp.net Sat Aug 25 07:31:44 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sat, 25 Aug 2007 03:31:44 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825073144.F35D5130A1@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20166 Modified Files: slime.el Log Message: * slime.el (save-restriction-if-possible): Fixed typo in macroexpansion. Thanks to Matthias Koeppe for reporting. --- /project/slime/cvsroot/slime/slime.el 2007/08/25 04:57:04 1.813 +++ /project/slime/cvsroot/slime/slime.el 2007/08/25 07:31:44 1.814 @@ -10277,7 +10277,7 @@ `(let ((,gcfg (current-slime-narrowing-configuration))) (unwind-protect (progn , at body) (let ((,gbeg (slime-narrowing-configuration.beg ,gcfg)) - (,gbeg (slime-narrowing-configuration.end ,gcfg))) + (,gend (slime-narrowing-configuration.end ,gcfg))) (when (and (>= (point) ,gbeg) (<= (point) ,gend)) (set-slime-current-narrowing-configuration ,gcfg))))))) From trittweiler at common-lisp.net Sat Aug 25 07:32:15 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sat, 25 Aug 2007 03:32:15 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825073215.E76E32105C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20248 Modified Files: ChangeLog Log Message: * slime.el (save-restriction-if-possible): Fixed typo in macroexpansion. Thanks to Matthias Koeppe for reporting. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/25 04:57:42 1.1163 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/25 07:32:15 1.1164 @@ -1,3 +1,8 @@ +2007-08-25 Tobias C. Rittweiler + + * slime.el (save-restriction-if-possible): Fixed typo in + macroexpansion. Thanks to Matthias Koeppe for reporting. + 2007-08-24 Matthias Koeppe * slime.el (slime-insert-arglist): Removed, superseded by From mkoeppe at common-lisp.net Sat Aug 25 20:03:57 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 25 Aug 2007 16:03:57 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825200357.4C0A3260C0@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv481 Modified Files: slime.el Log Message: * slime.el (slime-last-output-target-id): New variable. (slime-output-target-to-marker): New variable. (slime-write-string): Handle general "target" arguments using slime-output-target-to-marker. (slime-redirect-trace-output): New command. (slime-easy-menu): Add a menu item for it. * slime.el (slime-mark-presentation-start) (slime-mark-presentation-end): Make "target" argument optional. --- /project/slime/cvsroot/slime/slime.el 2007/08/25 07:31:44 1.814 +++ /project/slime/cvsroot/slime/slime.el 2007/08/25 20:03:56 1.815 @@ -831,6 +831,7 @@ ("Debugging" [ "Macroexpand Once..." slime-macroexpand-1 ,C ] [ "Macroexpand All..." slime-macroexpand-all ,C ] + [ "Create Trace Buffer" slime-redirect-trace-output ,C ] [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] [ "Untrace All" slime-untrace-all ,C] [ "Disassemble..." slime-disassemble-symbol ,C ] @@ -2927,7 +2928,7 @@ (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) -(defun slime-mark-presentation-start (id target) +(defun slime-mark-presentation-start (id &optional target) "Mark the beginning of a presentation with the given ID. TARGET can be nil (regular process output) or :repl-result." (setf (gethash id slime-presentation-start-to-point) @@ -2942,7 +2943,7 @@ (id (car (read-from-string match)))) (slime-mark-presentation-start id)))) -(defun slime-mark-presentation-end (id target) +(defun slime-mark-presentation-end (id &optional target) "Mark the end of a presentation with the given ID. TARGET can be nil (regular process output) or :repl-result." (let ((start (gethash id slime-presentation-start-to-point))) @@ -3100,13 +3101,20 @@ (switch-to-buffer (process-buffer proc)) (goto-char (point-max))))) +(defvar slime-last-output-target-id 0 + "The last integer we used as a TARGET id.") + +(defvar slime-output-target-to-marker + (make-hash-table) + "Map from TARGET ids to Emacs markers that indicate where +output should be inserted.") + (defun slime-write-string (string &optional id target) "Insert STRING in the REPL buffer. If ID is non-nil, insert STRING as a presentation. If TARGET is nil, insert STRING as regular process output. If TARGET is :repl-result, insert STRING as the result of the -evaluation." - ;; Other values of TARGET are reserved for future extension, - ;; for instance asynchronous output in scratch buffers. --mkoeppe +evaluation. Other values of TARGET map to an Emacs marker via the +hashtable `slime-output-target-to-marker'; output is inserted at this marker." (ecase target ((nil) ; Regular process output (with-current-buffer (slime-output-buffer) @@ -3130,7 +3138,18 @@ (if (>= (marker-position slime-output-end) (point)) ;; If the output-end marker was moved by our insertion, ;; set it back to the beginning of the REPL result. - (set-marker slime-output-end result-start))))))) + (set-marker slime-output-end result-start))))) + (t + (let* ((marker (gethash target slime-output-target-to-marker)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))))) (defun slime-switch-to-output-buffer (&optional connection) "Select the output buffer, preferably in a different window." @@ -6654,6 +6673,17 @@ ;;;; Tracing +(defun slime-redirect-trace-output () + "Redirect the trace output to a separate Emacs buffer." + (interactive) + (let ((buffer (get-buffer-create "*SLIME Trace Output*"))) + (with-current-buffer buffer + (let ((marker (copy-marker (buffer-size))) + (target (incf slime-last-output-target-id))) + (puthash target marker slime-output-target-to-marker) + (slime-eval `(swank:redirect-trace-output ,target)))) + (pop-to-buffer buffer))) + (defun slime-untrace-all () "Untrace all functions." (interactive) From mkoeppe at common-lisp.net Sat Aug 25 20:04:19 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 25 Aug 2007 16:04:19 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825200419.863D028236@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv533 Modified Files: swank.lisp Log Message: * swank.lisp (make-output-stream-for-target): New function, factored out from open-streams. (open-streams): Use it here. * swank.lisp (connection): New slot "trace-output". (call-with-redirected-io): Use it here. (redirect-trace-output): New slimefun; set the slot to a new target stream. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/25 04:56:50 1.498 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/25 20:04:19 1.499 @@ -199,6 +199,8 @@ (user-input nil :type (or stream null)) (user-output nil :type (or stream null)) (user-io nil :type (or stream null)) + ;; A stream that we use for *trace-output*; if nil, we user user-output. + (trace-output nil :type (or stream null)) ;; A stream where we send REPL results. (repl-results nil :type (or stream null)) ;; In multithreaded systems we delegate certain tasks to specific @@ -573,13 +575,8 @@ (let ((out (or dedicated-output out))) (let ((io (make-two-way-stream in out))) (mapc #'make-stream-interactive (list in out io)) - (let* ((repl-results-fn - (make-output-function-for-target connection :repl-result)) - (repl-results - (nth-value 1 (make-fn-streams - (lambda () - (error "Should never be called")) - repl-results-fn)))) + (let ((repl-results + (make-output-stream-for-target connection :repl-result))) (values dedicated-output in out io repl-results)))))))) (defun make-output-function (connection) @@ -609,6 +606,13 @@ (abort "Abort sending output to Emacs.") (send-to-emacs `(:write-string ,string nil ,target)))))) +(defun make-output-stream-for-target (connection target) + "Create a stream that sends output to a specific TARGET in Emacs." + (nth-value 1 (make-fn-streams + (lambda () + (error "Should never be called")) + (make-output-function-for-target connection target)))) + (defun open-dedicated-output-stream (socket-io) "Open a dedicated output connection to the Emacs on SOCKET-IO. Return an output stream suitable for writing program output. @@ -1150,9 +1154,10 @@ (let* ((io (connection.user-io connection)) (in (connection.user-input connection)) (out (connection.user-output connection)) + (trace (or (connection.trace-output connection) out)) (*standard-output* out) (*error-output* out) - (*trace-output* out) + (*trace-output* trace) (*debug-io* io) (*query-io* io) (*standard-input* in) @@ -4035,6 +4040,11 @@ (defslimefun untrace-all () (untrace)) +(defslimefun redirect-trace-output (target) + (setf (connection.trace-output *emacs-connection*) + (make-output-stream-for-target *emacs-connection* target)) + nil) + ;;;; Undefing From mkoeppe at common-lisp.net Sat Aug 25 20:05:00 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 25 Aug 2007 16:05:00 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070825200500.A7A982D07D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv585 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2007/08/25 07:32:15 1.1164 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/25 20:05:00 1.1165 @@ -1,3 +1,27 @@ +2007-08-25 Matthias Koeppe + + New command slime-redirect-trace-output creates a separate Emacs + buffer, where all subsequent trace output is sent. + + * slime.el (slime-last-output-target-id): New variable. + (slime-output-target-to-marker): New variable. + (slime-write-string): Handle general "target" arguments using + slime-output-target-to-marker. + (slime-redirect-trace-output): New command. + (slime-easy-menu): Add a menu item for it. + + * slime.el (slime-mark-presentation-start) + (slime-mark-presentation-end): Make "target" argument optional. + + * swank.lisp (make-output-stream-for-target): New function, + factored out from open-streams. + (open-streams): Use it here. + + * swank.lisp (connection): New slot "trace-output". + (call-with-redirected-io): Use it here. + (redirect-trace-output): New slimefun; set the slot to a new + target stream. + 2007-08-25 Tobias C. Rittweiler * slime.el (save-restriction-if-possible): Fixed typo in From mkoeppe at common-lisp.net Sun Aug 26 05:25:09 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 26 Aug 2007 01:25:09 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826052509.DE33D1D10B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv32269 Modified Files: slime.el Log Message: (slime-output-target-marker): New function. (slime-mark-presentation-start) (slime-mark-presentation-end): Use slime-output-target-to-marker. (slime-write-string): Likewise. --- /project/slime/cvsroot/slime/slime.el 2007/08/25 20:03:56 1.815 +++ /project/slime/cvsroot/slime/slime.el 2007/08/26 05:25:07 1.816 @@ -2932,10 +2932,9 @@ "Mark the beginning of a presentation with the given ID. TARGET can be nil (regular process output) or :repl-result." (setf (gethash id slime-presentation-start-to-point) - (with-current-buffer (slime-output-buffer) - (if (eq target :repl-result) - (point-max) - (marker-position (symbol-value 'slime-output-end)))))) + ;; We use markers because text can also be inserted before this presentation. + ;; (Output arrives while we are writing presentations within REPL results.) + (copy-marker (slime-output-target-marker target) nil))) (defun slime-mark-presentation-start-handler (process string) (if (and string (string-match "<\\([-0-9]+\\)" string)) @@ -2949,13 +2948,12 @@ (let ((start (gethash id slime-presentation-start-to-point))) (remhash id slime-presentation-start-to-point) (when start - (with-current-buffer (slime-output-buffer) - (let ((end - (if (eq target :repl-result) - (point-max) - (symbol-value 'slime-output-end)))) - (slime-add-presentation-properties start end - id nil)))))) + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (with-current-buffer buffer + (let ((end (marker-position marker))) + (slime-add-presentation-properties start end + id nil))))))) (defun slime-mark-presentation-end-handler (process string) (if (and string (string-match ">\\([-0-9]+\\)" string)) @@ -3108,6 +3106,25 @@ (make-hash-table) "Map from TARGET ids to Emacs markers that indicate where output should be inserted.") +;; Note: We would like the entries to disappear when the buffers are +;; killed. We cannot just make the hash-table ":weakness 'value" -- +;; there is no reference from the buffers to the markers in the +;; buffer, so entries would disappear even though the buffers are +;; alive. Best solution might be to make buffer-local variables that +;; keep the markers. --mkoeppe + +(defun slime-output-target-marker (target) + "Return a marker that indicates where output for TARGET should +be inserted." + (case target + ((nil) + (with-current-buffer (slime-output-buffer) + slime-output-end)) + (:repl-result + (with-current-buffer (slime-output-buffer) + slime-repl-input-start-mark)) + (t + (gethash target slime-output-target-to-marker)))) (defun slime-write-string (string &optional id target) "Insert STRING in the REPL buffer. If ID is non-nil, insert STRING @@ -3140,7 +3157,7 @@ ;; set it back to the beginning of the REPL result. (set-marker slime-output-end result-start))))) (t - (let* ((marker (gethash target slime-output-target-to-marker)) + (let* ((marker (slime-output-target-marker target)) (buffer (and marker (marker-buffer marker)))) (when buffer (with-current-buffer buffer From mkoeppe at common-lisp.net Sun Aug 26 05:28:02 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 26 Aug 2007 01:28:02 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826052802.CE4A52608B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv32487 Modified Files: slime.el Log Message: (slime-write-string): Make sure text properties are rear-nonsticky, so typed-ahead user input does not pick up the text properties. Fix up some markers. (slime-reset-repl-markers): Make the marker slime-output-end of insertion type nil (no automatic advances on insertions). (slime-with-output-end-mark): Update the location of slime-output-end here manually. (slime-repl-update-banner): Use insert-before-markers. --- /project/slime/cvsroot/slime/slime.el 2007/08/26 05:25:07 1.816 +++ /project/slime/cvsroot/slime/slime.el 2007/08/26 05:28:01 1.817 @@ -2808,7 +2808,11 @@ (set markname (make-marker)) (set-marker (symbol-value markname) (point))) (set-marker-insertion-type slime-repl-input-end-mark t) - (set-marker-insertion-type slime-output-end t) + ;;; We manage the movement of the slime-output-end marker ourselves + ;;; when output arrives; we do not wish it moves behind typed-ahead + ;;; user input. Therefore, don't make the marker advance + ;;; automatically. --mkoeppe + ;;(set-marker-insertion-type slime-output-end t) (set-marker-insertion-type slime-repl-prompt-start-mark t)) (defun slime-output-buffer (&optional noprompt) @@ -2845,7 +2849,7 @@ "- ChangeLog file not found")))) (if animantep (animate-string hello-message 0 0) - (insert hello-message)))) + (insert-before-markers hello-message)))) (pop-to-buffer (current-buffer)) (slime-repl-insert-prompt))) @@ -2900,6 +2904,7 @@ (cond ((= (point) slime-output-end) (let ((start.. (point))) (funcall body..) + (set-marker slime-output-end (point)) (when (= start.. slime-repl-input-start-mark) (set-marker slime-repl-input-start-mark (point))))) (t @@ -3138,24 +3143,29 @@ (slime-with-output-end-mark (if id (slime-insert-presentation string id) - (slime-propertize-region '(face slime-repl-output-face) + (slime-propertize-region '(face slime-repl-output-face + rear-nonsticky (face)) (insert string))) + (set-marker slime-output-end (point)) (when (and (= (point) slime-repl-prompt-start-mark) (not (bolp))) (insert "\n") - (set-marker slime-output-end (1- (point))))))) + (set-marker slime-output-end (1- (point)))) + (if (< slime-repl-input-start-mark (point)) + (set-marker slime-repl-input-start-mark + (point)))))) (:repl-result (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (let ((result-start (point))) - (if id - (slime-insert-presentation string id) - (slime-propertize-region `(face slime-repl-result-face) - (insert string))) - (if (>= (marker-position slime-output-end) (point)) - ;; If the output-end marker was moved by our insertion, - ;; set it back to the beginning of the REPL result. - (set-marker slime-output-end result-start))))) + (let ((marker (slime-output-target-marker target))) + (goto-char marker) + (let ((result-start (point))) + (if id + (slime-insert-presentation string id) + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert string))) + ;; Move the input-start marker after the REPL result. + (set-marker marker (point)))))) (t (let* ((marker (slime-output-target-marker target)) (buffer (and marker (marker-buffer marker)))) @@ -3713,7 +3723,7 @@ (defun slime-repl-insert-prompt () "Goto to point max, and insert the prompt." - (goto-char (point-max)) + (goto-char (if slime-repl-input-start-mark slime-repl-input-start-mark (point-max))) (unless (bolp) (insert "\n")) (let ((prompt-start (point)) (prompt (format "%s> " (slime-lisp-package-prompt-string)))) @@ -3725,11 +3735,11 @@ ;; xemacs stuff start-open t end-open t) (insert-before-markers prompt)) + (slime-mark-input-start) (set-marker slime-repl-prompt-start-mark prompt-start) (goto-char slime-repl-prompt-start-mark) (slime-mark-output-start) - (goto-char (point-max)) - (slime-mark-input-start)) + (goto-char (point-max))) (slime-repl-show-maximum-output)) (defun slime-repl-show-maximum-output (&optional force) From mkoeppe at common-lisp.net Sun Aug 26 05:36:20 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 26 Aug 2007 01:36:20 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826053620.96EFC3001A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv546 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/25 20:05:00 1.1165 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/26 05:36:15 1.1166 @@ -1,18 +1,34 @@ 2007-08-25 Matthias Koeppe + Fix handling of user-input type-ahead in the REPL. + Reported by Madhu on 2007-04-24. + + * slime.el (slime-write-string): Make sure text properties are + rear-nonsticky, so typed-ahead user input does not pick up the + text properties. Fix up some markers. + (slime-reset-repl-markers): Make the marker slime-output-end of + insertion type nil (no automatic advances on insertions). + (slime-with-output-end-mark): Update the location of + slime-output-end here manually. + (slime-repl-update-banner): Use insert-before-markers. + +2007-08-25 Matthias Koeppe + New command slime-redirect-trace-output creates a separate Emacs buffer, where all subsequent trace output is sent. * slime.el (slime-last-output-target-id): New variable. (slime-output-target-to-marker): New variable. + (slime-output-target-marker): New function. (slime-write-string): Handle general "target" arguments using - slime-output-target-to-marker. + slime-output-target-marker. (slime-redirect-trace-output): New command. (slime-easy-menu): Add a menu item for it. * slime.el (slime-mark-presentation-start) (slime-mark-presentation-end): Make "target" argument optional. - + Use slime-output-target-to-marker. + * swank.lisp (make-output-stream-for-target): New function, factored out from open-streams. (open-streams): Use it here. From mkoeppe at common-lisp.net Sun Aug 26 06:11:57 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 26 Aug 2007 02:11:57 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826061157.E4CC1111D2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7047 Modified Files: slime.el Log Message: (slime-insert-presentation): Make the rectangle-ification of multi-line presentations, introduced 2006-12-19, optional. (slime-write-string): Use it here only for regular output, but not for REPL results. (sldb-insert-locals): Use it here. (slime-inspector-insert-ispec): Use it here. --- /project/slime/cvsroot/slime/slime.el 2007/08/26 05:28:01 1.817 +++ /project/slime/cvsroot/slime/slime.el 2007/08/26 06:11:56 1.818 @@ -3046,13 +3046,20 @@ (slime-with-rigid-indentation nil (apply #'insert strings))) -(defun slime-insert-presentation (string output-id) - (cond ((not slime-repl-enable-presentations) - (slime-insert-possibly-as-rectangle string)) - (t - (let ((start (point))) - (slime-insert-possibly-as-rectangle string) - (slime-add-presentation-properties start (point) output-id t))))) +(defun slime-insert-presentation (string output-id &optional rectangle) + "Insert STRING in current buffer and mark it as a presentation +corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line +strings to line up below the current point." + (flet ((insert-it () + (if rectangle + (slime-insert-possibly-as-rectangle string) + (insert string)))) + (cond ((not slime-repl-enable-presentations) + (insert-it)) + (t + (let ((start (point))) + (insert-it) + (slime-add-presentation-properties start (point) output-id t)))))) (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" @@ -3142,7 +3149,7 @@ (with-current-buffer (slime-output-buffer) (slime-with-output-end-mark (if id - (slime-insert-presentation string id) + (slime-insert-presentation string id t) (slime-propertize-region '(face slime-repl-output-face rear-nonsticky (face)) (insert string))) @@ -8196,7 +8203,7 @@ " = ") (slime-insert-presentation (in-sldb-face local-value value) - `(:frame-var ,slime-current-thread ,(car frame) ,i)) + `(:frame-var ,slime-current-thread ,(car frame) ,i) t) (insert "\n"))))) (defun sldb-hide-frame-details () @@ -8750,7 +8757,7 @@ (list 'slime-part-number id 'mouse-face 'highlight 'face 'slime-inspector-value-face) - (slime-insert-presentation string `(:inspected-part ,id)))) + (slime-insert-presentation string `(:inspected-part ,id) t))) ((:action string id) (slime-insert-propertized (list 'slime-action-number id 'mouse-face 'highlight From mkoeppe at common-lisp.net Sun Aug 26 06:12:32 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 26 Aug 2007 02:12:32 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826061232.60EC1240C4@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7086 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/26 05:36:15 1.1166 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/26 06:12:32 1.1167 @@ -1,5 +1,18 @@ 2007-08-25 Matthias Koeppe + Fix a bug where REPL results would sometimes be indented by a + random amount. + + * slime.el (slime-insert-presentation): Make the + rectangle-ification of multi-line presentations, introduced + 2006-12-19, optional. + (slime-write-string): Use it here only for regular output, but not + for REPL results. + (sldb-insert-locals): Use it here. + (slime-inspector-insert-ispec): Use it here. + +2007-08-25 Matthias Koeppe + Fix handling of user-input type-ahead in the REPL. Reported by Madhu on 2007-04-24. From trittweiler at common-lisp.net Sun Aug 26 09:57:07 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 05:57:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826095707.C14B2601B2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11778 Modified Files: slime.el Log Message: * slime.el (slime-cl-symbol-name): Handle vertical bars (|) (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'. --- /project/slime/cvsroot/slime/slime.el 2007/08/26 06:11:56 1.818 +++ /project/slime/cvsroot/slime/slime.el 2007/08/26 09:57:07 1.819 @@ -10352,7 +10352,10 @@ (defun slime-cl-symbol-name (symbol) (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) (if (string-match ":\\([^:]*\\)$" n) - (match-string 1 n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\\(.*\\)|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) n))) (defun slime-cl-symbol-package (symbol &optional default) @@ -10554,7 +10557,7 @@ (decl-indices (rest current-indices)) (decl-points (rest current-points)) (decl-pos (1- (first decl-points))) - (nesting (%slime-nesting-until-point decl-pos)) + (nesting (slime-nesting-until-point decl-pos)) (declspec (concat (slime-incomplete-sexp-at-point nesting) (make-string nesting ?\))))) ;; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? @@ -10571,7 +10574,7 @@ (setq current-points (list (first decl-points))))))))) (values current-forms current-indices current-points)) -(defun %slime-nesting-until-point (target-point) +(defun slime-nesting-until-point (target-point) (save-excursion (let ((nesting 0)) (while (> (point) target-point) From trittweiler at common-lisp.net Sun Aug 26 09:57:47 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 05:57:47 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826095747.85C212017@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11874 Modified Files: ChangeLog Log Message: * slime.el (slime-cl-symbol-name): Handle vertical bars (|) (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/26 06:12:32 1.1167 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/26 09:57:47 1.1168 @@ -1,3 +1,8 @@ +2007-08-26 Tobias C. Rittweiler + + * slime.el (slime-cl-symbol-name): Handle vertical bars (|) + (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'. + 2007-08-25 Matthias Koeppe Fix a bug where REPL results would sometimes be indented by a From trittweiler at common-lisp.net Sun Aug 26 10:07:17 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 06:07:17 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826100717.BA41C240C6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15112 Modified Files: slime.el Log Message: * slime.el (save-restriction-if-possible): Fixed another typo, duh! Thanks again to Matthias Koeppe. --- /project/slime/cvsroot/slime/slime.el 2007/08/26 09:57:07 1.819 +++ /project/slime/cvsroot/slime/slime.el 2007/08/26 10:07:17 1.820 @@ -10343,7 +10343,7 @@ (let ((,gbeg (slime-narrowing-configuration.beg ,gcfg)) (,gend (slime-narrowing-configuration.end ,gcfg))) (when (and (>= (point) ,gbeg) (<= (point) ,gend)) - (set-slime-current-narrowing-configuration ,gcfg))))))) + (set-slime-narrowing-configuration ,gcfg))))))) (put 'save-restriction-if-possible 'lisp-indent-function 0) From trittweiler at common-lisp.net Sun Aug 26 10:07:51 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 06:07:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826100751.015F3260C1@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15163 Modified Files: ChangeLog Log Message: * slime.el (save-restriction-if-possible): Fixed another typo, duh! Thanks again to Matthias Koeppe. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/26 09:57:47 1.1168 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/26 10:07:51 1.1169 @@ -1,5 +1,10 @@ 2007-08-26 Tobias C. Rittweiler + * slime.el (save-restriction-if-possible): Fixed another typo, + duh! Thanks again to Matthias Koeppe. + +2007-08-26 Tobias C. Rittweiler + * slime.el (slime-cl-symbol-name): Handle vertical bars (|) (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'. From trittweiler at common-lisp.net Sun Aug 26 10:39:00 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 06:39:00 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826103900.5ECC43C047@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20141 Modified Files: slime.el Log Message: * slime.el (current-slime-narrowing-configuration): Renamed to `slime-current-narrowing-configuration'. (set-slime-narrowing-configuration): Renamed to `slime-set-narrowing-configuration'. (current-slime-emacs-snapshot): Renamed to `slime-current-emacs-snapshot'. (current-slime-emacs-snapshot-fingerprint): Renamed to `slime-current-emacs-snapshot-fingerprint'. (set-slime-emacs-snapshot): Renamed to `slime-set-emacs-snapshot'. --- /project/slime/cvsroot/slime/slime.el 2007/08/26 10:07:17 1.820 +++ /project/slime/cvsroot/slime/slime.el 2007/08/26 10:38:59 1.821 @@ -1218,18 +1218,18 @@ (defstruct (slime-emacs-snapshot (:conc-name slime-emacs-snapshot.)) window-configuration narrowing-configuration) -(defun current-slime-narrowing-configuration (&optional buffer) +(defun slime-current-narrowing-configuration (&optional buffer) (with-current-buffer (or buffer (current-buffer)) (make-slime-narrowing-configuration :narrowedp (slime-buffer-narrowed-p) :beg (point-min-marker) :end (point-max-marker)))) -(defun set-slime-narrowing-configuration (narrowing-cfg) +(defun slime-set-narrowing-configuration (narrowing-cfg) (when (slime-narrowing-configuration.narrowedp narrowing-cfg) (narrow-to-region (slime-narrowing-configuration.beg narrowing-cfg) (slime-narrowing-configuration.end narrowing-cfg)))) -(defun current-slime-emacs-snapshot (&optional frame) +(defun slime-current-emacs-snapshot (&optional frame) "Returns a snapshot of the current state of FRAME, or the currently active frame if FRAME is not given respectively." (with-current-buffer @@ -1238,17 +1238,17 @@ (current-buffer)) (make-slime-emacs-snapshot :window-configuration (current-window-configuration frame) - :narrowing-configuration (current-slime-narrowing-configuration)))) + :narrowing-configuration (slime-current-narrowing-configuration)))) -(defun set-slime-emacs-snapshot (snapshot) +(defun slime-set-emacs-snapshot (snapshot) "Restores the state of Emacs according to the information saved in SNAPSHOT." (let ((window-cfg (slime-emacs-snapshot.window-configuration snapshot)) (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot))) (set-window-configuration window-cfg) ; restores previously current buffer. - (set-slime-narrowing-configuration narrowing-cfg))) + (slime-set-narrowing-configuration narrowing-cfg))) -(defun current-slime-emacs-snapshot-fingerprint (&optional frame) +(defun slime-current-emacs-snapshot-fingerprint (&optional frame) "Return a fingerprint of the current emacs snapshot. Fingerprints are `equalp' if and only if they represent window configurations that are very similar (same windows and buffers.) @@ -1296,7 +1296,7 @@ state of Emacs after closing the temporary buffer. Otherwise, the current state will be saved and later restored. " - (let ((snapshot (or emacs-snapshot (current-slime-emacs-snapshot))) + (let ((snapshot (or emacs-snapshot (slime-current-emacs-snapshot))) (buffer (get-buffer name))) (when (and buffer (not reusep)) (kill-buffer name) @@ -1320,7 +1320,7 @@ (selected-window)) (setq slime-temp-buffer-saved-emacs-snapshot snapshot) (setq slime-temp-buffer-saved-fingerprint - (current-slime-emacs-snapshot-fingerprint))))) + (slime-current-emacs-snapshot-fingerprint))))) (current-buffer)))) ;; Interface @@ -1360,9 +1360,9 @@ (let ((snapshot slime-temp-buffer-saved-emacs-snapshot) (temp-buffer (current-buffer))) (setq slime-temp-buffer-saved-emacs-snapshot nil) - (if (and snapshot (equalp (current-slime-emacs-snapshot-fingerprint) + (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) slime-temp-buffer-saved-fingerprint)) - (set-slime-emacs-snapshot snapshot) + (slime-set-emacs-snapshot snapshot) (bury-buffer)) (when kill-buffer-p (kill-buffer temp-buffer)))) @@ -4728,7 +4728,7 @@ (save-buffer)) (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max)) (let ((lisp-filename (slime-to-lisp-filename (buffer-file-name))) - (snapshot (current-slime-emacs-snapshot))) + (snapshot (slime-current-emacs-snapshot))) (slime-insert-transcript-delimiter (format "Compile file %s" lisp-filename)) ;; The following may alter the current window configuration, so we saved @@ -6276,7 +6276,7 @@ (ring-insert-at-beginning slime-find-definition-history-ring (list (or marker (point-marker)) (or narrowing-configuration - (current-slime-narrowing-configuration))))) + (slime-current-narrowing-configuration))))) (defun slime-pop-find-definition-stack () "Pop the edit-definition stack and goto the location." @@ -7187,7 +7187,7 @@ `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package)) ;; We don't want the the xref buffer to be the current buffer ;; in the snapshot, so we gotta take the snapshot here. - (let ((,snapshot (or ,emacs-snapshot (current-slime-emacs-snapshot)))) + (let ((,snapshot (or ,emacs-snapshot (slime-current-emacs-snapshot)))) (with-current-buffer (get-buffer-create (format "*XREF[%s: %s]*" ,type ,sym)) (prog2 (progn @@ -7294,7 +7294,7 @@ ;; We have to take the snapshot here, because SLIME-EVAL-ASYNC ;; is invoking its continuation within the extent of a different ;; buffer. (2007-08-14) - (snapshot (current-slime-emacs-snapshot))) + (snapshot (slime-current-emacs-snapshot))) (lambda (result) (slime-show-xrefs result type symbol package snapshot))))) @@ -7355,7 +7355,7 @@ (interactive) (let ((snapshot slime-xref-saved-emacs-snapshot)) (slime-xref-cleanup) - (set-slime-emacs-snapshot snapshot))) + (slime-set-emacs-snapshot snapshot))) (defun slime-xref-cleanup () "Delete overlays created by xref mode and kill the xref buffer." @@ -10338,12 +10338,12 @@ (let ((gcfg (gensym "NARROWING-CFG+")) (gbeg (gensym "OLDBEG+")) (gend (gensym "OLDEND+"))) - `(let ((,gcfg (current-slime-narrowing-configuration))) + `(let ((,gcfg (slime-current-narrowing-configuration))) (unwind-protect (progn , at body) (let ((,gbeg (slime-narrowing-configuration.beg ,gcfg)) (,gend (slime-narrowing-configuration.end ,gcfg))) (when (and (>= (point) ,gbeg) (<= (point) ,gend)) - (set-slime-narrowing-configuration ,gcfg))))))) + (slime-set-narrowing-configuration ,gcfg))))))) (put 'save-restriction-if-possible 'lisp-indent-function 0) From trittweiler at common-lisp.net Sun Aug 26 10:40:47 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 06:40:47 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826104047.F15F049092@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20593 Modified Files: ChangeLog Log Message: * slime.el (current-slime-narrowing-configuration): Renamed to `slime-current-narrowing-configuration'. (set-slime-narrowing-configuration): Renamed to `slime-set-narrowing-configuration'. (current-slime-emacs-snapshot): Renamed to `slime-current-emacs-snapshot'. (current-slime-emacs-snapshot-fingerprint): Renamed to `slime-current-emacs-snapshot-fingerprint'. (set-slime-emacs-snapshot): Renamed to `slime-set-emacs-snapshot'. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/26 10:07:51 1.1169 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/26 10:40:47 1.1170 @@ -1,5 +1,18 @@ 2007-08-26 Tobias C. Rittweiler + * slime.el (current-slime-narrowing-configuration): + Renamed to `slime-current-narrowing-configuration'. + (set-slime-narrowing-configuration): + Renamed to `slime-set-narrowing-configuration'. + (current-slime-emacs-snapshot): + Renamed to `slime-current-emacs-snapshot'. + (current-slime-emacs-snapshot-fingerprint): + Renamed to `slime-current-emacs-snapshot-fingerprint'. + (set-slime-emacs-snapshot): + Renamed to `slime-set-emacs-snapshot'. + +2007-08-26 Tobias C. Rittweiler + * slime.el (save-restriction-if-possible): Fixed another typo, duh! Thanks again to Matthias Koeppe. From mkoeppe at common-lisp.net Sun Aug 26 18:42:23 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 26 Aug 2007 14:42:23 -0400 (EDT) Subject: [slime-cvs] CVS slime/doc Message-ID: <20070826184223.9E3001D12B@common-lisp.net> Update of /project/slime/cvsroot/slime/doc In directory clnet:/tmp/cvs-serv5212 Modified Files: slime.texi Log Message: Document limitations of *USE-DEDICATED-OUTPUT-STREAM* = t. --- /project/slime/cvsroot/slime/doc/slime.texi 2007/01/27 18:42:35 1.54 +++ /project/slime/cvsroot/slime/doc/slime.texi 2007/08/26 18:42:23 1.55 @@ -10,7 +10,7 @@ @set EDITION 2.0 @c @set UPDATED @today{} - at set UPDATED @code{$Date: 2007/01/27 18:42:35 $} + at set UPDATED @code{$Date: 2007/08/26 18:42:23 $} @set TITLE SLIME User Manual @settitle @value{TITLE}, version @value{EDITION} @@ -518,7 +518,7 @@ @subsection Programming commands Programming commands are divided into the following categories: - at strong{Completion, Documentation, Coss-reference, Finding + at strong{Completion, Documentation, Cross-reference, Finding definitions, Macro-expansion, and Disassembly}, discussed in separate sections below. @@ -1796,12 +1796,20 @@ @end example @item SWANK:*USE-DEDICATED-OUTPUT-STREAM* -This variable controls an optimization for sending printed output from -Lisp to Emacs. When @code{t} a separate socket is established solely for -Lisp to send printed output to Emacs through. Without the optimization -it is necessary to send output in protocol-messages to Emacs which must -then be decoded, and this doesn't always keep up if Lisp starts -``spewing'' copious output. +This variable controls whether to use an unsafe efficiency hack for +sending printed output from Lisp to Emacs. The default is @code{nil}, +don't use it, and is strongly recommended to keep. + +When @code{t}, a separate socket is established solely for Lisp to send +printed output to Emacs through, which is faster than sending the output +in protocol-messages to Emacs. However, as nothing can be guaranteed +about the timing between the dedicated output stream and the stream of +protocol messages, the output of a Lisp command can arrive before or +after the corresponding REPL results. Thus output and REPL results can +end up in the wrong order, or even interleaved, in the REPL buffer. +Using a dedicated output stream also makes it more difficult to +communicate to a Lisp running on a remote host via SSH +(@pxref{Connecting to a remote lisp}). @item SWANK:*DEDICATED-OUTPUT-STREAM-PORT* When @code{*USE-DEDICATED-OUTPUT-STREAM*} is @code{t} the stream will @@ -1873,7 +1881,7 @@ has the side-effect of giving the entire world access to your lisp image, so we're not going to talk about it} and we'll only have one port open we want to tell swank to not use an extra connection for -output: +output (this is actually the default in current SLIME): @example (setf swank:*use-dedicated-output-stream* nil) From trittweiler at common-lisp.net Sun Aug 26 23:34:51 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 19:34:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826233451.EDBCB5903E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22638 Modified Files: swank.lisp Log Message: Reduces needless interning of symbols that was introduced by my recent work on autodoc to a minimum. Also fixes this issue for `slime-complete-form' which always interned symbols even before my changes. * slime.el (slime-sexp-at-point): If N is given, but there aren't N sexps available at point, make it return a list of just as many as there are. (slime-make-form-spec-from-string): New. Creates a ``raw form spec'' from a string that's suited for determining newly interned symbols later in Swank. (slime-parse-extended-operator/declare): Uses it. * swank.lisp (parse-symbol): Returns internal knowledge, to provide a means for callers to perform a sanity check. (call-with-ignored-reader-errors): New. Abstracted out from `read-incomplete-form-from-string.' * swank.lisp (read-form-spec): New. Only READs elements of a form spec if necessary. And if it does have to READ, it keeps track of newly interned symbols which are returned as secondary return value. (parse-form-spec): Use it. Propagate newly interned symbols. (parse-first-valid-form-spec): Likewise. (arglist-for-echo-area, complete-form, completions-for-keyword): Adapted to unintern the newly interned symbols. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/25 20:04:19 1.499 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/26 23:34:50 1.500 @@ -1491,8 +1491,9 @@ (pname (find-package pname)) (t package)))) (if package - (find-symbol sname package) - (values nil nil))))) + (multiple-value-bind (symbol flag) (find-symbol sname package) + (values symbol flag sname package)) + (values nil nil nil nil))))) (defun parse-symbol-or-lose (string &optional (package *package*)) (multiple-value-bind (symbol status) (parse-symbol string package) @@ -1562,28 +1563,30 @@ ``form specs'', please see PARSE-FORM-SPEC." (handler-case (with-buffer-syntax () - (multiple-value-bind (form-spec arg-index) + (multiple-value-bind (form-spec arg-index newly-interned-symbols) (parse-first-valid-form-spec raw-specs arg-indices) - (when form-spec - (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) - (unless (eql arglist :not-available) - (multiple-value-bind (type operator arguments) - (split-form-spec form-spec) - (declare (ignore arguments)) - (multiple-value-bind (stringified-arglist) - (decoded-arglist-to-string - arglist - :operator operator - :print-right-margin print-right-margin - :print-lines print-lines - :highlight (and arg-index - (not (zerop arg-index)) - ;; don't highlight the operator - arg-index)) - (case type - (:declaration (format nil "(declare ~A)" stringified-arglist)) - (:type-specifier (format nil "[Typespec] ~A" stringified-arglist)) - (t stringified-arglist))))))))) + (unwind-protect + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (multiple-value-bind (type operator arguments) + (split-form-spec form-spec) + (declare (ignore arguments)) + (multiple-value-bind (stringified-arglist) + (decoded-arglist-to-string + arglist + :operator operator + :print-right-margin print-right-margin + :print-lines print-lines + :highlight (and arg-index + (not (zerop arg-index)) + ;; don't highlight the operator + arg-index)) + (case type + (:declaration (format nil "(declare ~A)" stringified-arglist)) + (:type-specifier (format nil "[Typespec] ~A" stringified-arglist)) + (t stringified-arglist))))))) + (mapc #'unintern newly-interned-symbols)))) (error (cond) (format nil "ARGLIST (error): ~A" cond)) )) @@ -1591,28 +1594,26 @@ (defun parse-form-spec (raw-spec) "Takes a raw (i.e. unparsed) form spec from SLIME and returns a proper form spec for further processing within SWANK. Returns NIL -if RAW-SPEC could not be parsed. +if RAW-SPEC could not be parsed. Symbols that had to be interned +in course of the conversion, are returned as secondary return value. A ``raw form spec'' can be either: i) a list of strings representing a Common Lisp form - ii) one of: + ii) a list of strings as of i), but which additionally + contains other raw form specs - a) (:declaration decl-identifier declspec) + iii) one of: - where DECL-IDENTIFIER is the string representation of a /decl identifier/, - DECLSPEC is the string representation of a /declaration specifier/. + a) (:declaration declspec) - b) (:type-specifier typespec-operator typespec) + where DECLSPEC is a raw form spec. + + b) (:type-specifier typespec) - where TYPESPEC-OPERATOR is the string representation of the CAR of a /type specifier/, - TYPESPEC is the string representation of a /type specifier/. + where TYPESPEC is a raw form spec. - (DECL-IDENTIFIER, and TYPESPEC-OPERATOR are actually redundant (as they're both - already provided in DECLSPEC, or TYPESPEC respectively, but this separation - allows to check if these raw form specs are valid before the whole spec is READ, - and thus all contained symbols interned.) A ``form spec'' is either @@ -1628,35 +1629,40 @@ Examples: - (\"defmethod\") => (defmethod) - (\"cl:defmethod\") => (cl:defmethod) - (\"defmethod\" \"print-object\") => (defmethod print-object) + (\"defmethod\") => (defmethod) + (\"cl:defmethod\") => (cl:defmethod) + (\"defmethod\" \"print-object\") => (defmethod print-object) + + (\"foo\" (\"bar\" (\"quux\")) \"baz\" => (foo (bar (quux)) baz) (:declaration \"optimize\" \"(optimize)\") => ((:declaration optimize)) (:declaration \"type\" \"(type string)\") => ((:declaration type) string) (:type-specifier \"float\" \"(float)\") => ((:type-specifier float)) (:type-specifier \"float\" \"(float 0 100)\") => ((:type-specifier float) 0 100) " - (flet ((parse-extended-spec (raw-extension-op raw-extension extension-flag) - (when (nth-value 1 (parse-symbol raw-extension-op)) - (let ((extension (read-incomplete-form-from-string raw-extension))) - (unless (recursively-empty-p extension) ; (:DECLARATION "(())") &c. + (flet ((parse-extended-spec (raw-extension extension-flag) + (when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d")) + (nth-value 1 (parse-symbol (first raw-extension)))) + (multiple-value-bind (extension introduced-symbols) + (read-form-spec raw-extension) + (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c. (destructuring-bind (identifier &rest args) extension - `((,extension-flag ,identifier) , at args))))))) + (values `((,extension-flag ,identifier) , at args) + introduced-symbols))))))) (when (consp raw-spec) (destructure-case raw-spec - ((:declaration raw-decl-identifier raw-declspec) - (parse-extended-spec raw-decl-identifier raw-declspec :declaration)) - ((:type-specifier raw-typespec-op raw-typespec) - (parse-extended-spec raw-typespec-op raw-typespec :type-specifier)) + ((:declaration raw-declspec) + (parse-extended-spec raw-declspec :declaration)) + ((:type-specifier raw-typespec) + (parse-extended-spec raw-typespec :type-specifier)) (t (when (every #'stringp raw-spec) (destructuring-bind (raw-operator &rest raw-args) raw-spec (multiple-value-bind (operator found?) (parse-symbol raw-operator) (when (and found? (valid-operator-symbol-p operator)) - `(,operator ,@(read-incomplete-form-from-string - (format nil "(~A)" - (apply #'concatenate 'string raw-args))))))))))))) + (multiple-value-bind (parsed-args introduced-symbols) + (read-form-spec raw-args) + (values `(,operator , at parsed-args) introduced-symbols))))))))))) (defun split-form-spec (spec) "Returns all three relevant information a ``form spec'' @@ -1671,14 +1677,51 @@ (defun parse-first-valid-form-spec (raw-specs &optional arg-indices) "Returns the first parsed form spec in RAW-SPECS that can successfully be parsed. Additionally returns its respective index -in ARG-INDICES (or NIL.)" +in ARG-INDICES (or NIL.), and all newly interned symbols as tertiary +return value." (block traversal (mapc #'(lambda (raw-spec index) - (let ((spec (parse-form-spec raw-spec))) + (multiple-value-bind (spec symbols) (parse-form-spec raw-spec) (when spec (return-from traversal - (values spec index))))) + (values spec index symbols))))) raw-specs - (append arg-indices '#1=(nil . #1#))))) + (append arg-indices '#1=(nil . #1#))) + nil)) ; found nothing + +(defun read-form-spec (spec) + "Turns the ``raw form spec'' SPEC into a proper Common Lisp form. + +It returns symbols that had to interned for the conversion as +secondary return value." + (when spec + (with-buffer-syntax () + (call-with-ignored-reader-errors + #'(lambda () + (let ((result) (newly-interned-symbols)) + (dolist (element spec) + (etypecase element + (string + (multiple-value-bind (symbol found? symbol-name package) + (parse-symbol element) + (if found? + (push symbol result) + (let ((sexp (read-from-string element))) + (when (symbolp sexp) + (push sexp newly-interned-symbols) + ;; assert that PARSE-SYMBOL didn't parse incorrectly. + (assert (and (equal symbol-name (symbol-name sexp)) + (eq package (symbol-package sexp))))) + (push sexp result))))) + (cons + (multiple-value-bind (read-spec interned-symbols) + (read-form-spec element) + (push read-spec result) + (setf newly-interned-symbols + (append interned-symbols + newly-interned-symbols)))))) + (values (nreverse result) + (nreverse newly-interned-symbols)))))))) + (defun clean-arglist (arglist) @@ -2523,27 +2566,35 @@ (defun read-incomplete-form-from-string (form-string) (with-buffer-syntax () - (handler-case - (read-from-string form-string) - (reader-error (c) - (declare (ignore c)) - nil) - (stream-error (c) - (declare (ignore c)) - nil)))) - + (call-with-ignored-reader-errors + #'(lambda () + (read-from-string form-string))))) + +(defun call-with-ignored-reader-errors (thunk) + (declare (type (function () (values &rest t)) thunk)) + (declare (optimize (speed 3) (safety 1))) + (handler-case (funcall thunk) + (reader-error (c) + (declare (ignore c)) + nil) + (stream-error (c) + (declare (ignore c)) + nil))) (defslimefun complete-form (form-string) "Read FORM-STRING in the current buffer package, then complete it by adding a template for the missing arguments." - (let ((form (parse-form-spec form-string))) - (when (consp form) - (let ((form-completion (arglist-from-form-spec form))) - (unless (eql form-completion :not-available) - (return-from complete-form - (decoded-arglist-to-template-string form-completion - *buffer-package* - :prefix ""))))) + (multiple-value-bind (form newly-interned-symbols) + (parse-form-spec form-string) + (unwind-protect + (when (consp form) + (let ((form-completion (arglist-from-form-spec form))) + (unless (eql form-completion :not-available) + (return-from complete-form + (decoded-arglist-to-template-string form-completion + *buffer-package* + :prefix ""))))) + (mapc #'unintern newly-interned-symbols)) :not-available)) @@ -2563,35 +2614,37 @@ (defslimefun completions-for-keyword (raw-specs keyword-string arg-indices) (with-buffer-syntax () - (multiple-value-bind (form-spec index) + (multiple-value-bind (form-spec index newly-interned-symbols) (parse-first-valid-form-spec raw-specs arg-indices) - (when form-spec - (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) - (unless (eql arglist :not-available) - (multiple-value-bind (type operator arguments) (split-form-spec form-spec) - (declare (ignore type arguments)) - (let* ((indices (butlast (reverse (last arg-indices (1+ index))))) - (arglist (apply #'arglist-ref arglist operator indices))) - (when (and arglist (arglist-p arglist)) - ;; It would be possible to complete keywords only if we - ;; are in a keyword position, but it is not clear if we - ;; want that. - (let* ((keywords - (mapcar #'keyword-arg.keyword - (arglist.keyword-args arglist))) - (keyword-name - (tokenize-symbol keyword-string)) - (matching-keywords - (find-matching-symbols-in-list keyword-name keywords - #'compound-prefix-match)) - (converter (completion-output-symbol-converter keyword-string)) - (strings - (mapcar converter - (mapcar #'symbol-name matching-keywords))) - (completion-set - (format-completion-set strings nil ""))) - (list completion-set - (longest-compound-prefix completion-set)))))))))))) + (unwind-protect + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (multiple-value-bind (type operator arguments) (split-form-spec form-spec) + (declare (ignore type arguments)) + (let* ((indices (butlast (reverse (last arg-indices (1+ index))))) + (arglist (apply #'arglist-ref arglist operator indices))) + (when (and arglist (arglist-p arglist)) + ;; It would be possible to complete keywords only if we + ;; are in a keyword position, but it is not clear if we + ;; want that. + (let* ((keywords + (mapcar #'keyword-arg.keyword + (arglist.keyword-args arglist))) + (keyword-name + (tokenize-symbol keyword-string)) + (matching-keywords + (find-matching-symbols-in-list keyword-name keywords + #'compound-prefix-match)) + (converter (completion-output-symbol-converter keyword-string)) + (strings + (mapcar converter + (mapcar #'symbol-name matching-keywords))) + (completion-set + (format-completion-set strings nil ""))) + (list completion-set + (longest-compound-prefix completion-set))))))))) + (mapc #'unintern newly-interned-symbols))))) (defun arglist-to-string (arglist package &key print-right-margin highlight) From trittweiler at common-lisp.net Sun Aug 26 23:35:25 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 19:35:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826233525.5D282610DD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22769 Modified Files: slime.el Log Message: Reduces needless interning of symbols that was introduced by my recent work on autodoc to a minimum. Also fixes this issue for `slime-complete-form' which always interned symbols even before my changes. * slime.el (slime-sexp-at-point): If N is given, but there aren't N sexps available at point, make it return a list of just as many as there are. (slime-make-form-spec-from-string): New. Creates a ``raw form spec'' from a string that's suited for determining newly interned symbols later in Swank. (slime-parse-extended-operator/declare): Uses it. * swank.lisp (parse-symbol): Returns internal knowledge, to provide a means for callers to perform a sanity check. (call-with-ignored-reader-errors): New. Abstracted out from `read-incomplete-form-from-string.' * swank.lisp (read-form-spec): New. Only READs elements of a form spec if necessary. And if it does have to READ, it keeps track of newly interned symbols which are returned as secondary return value. (parse-form-spec): Use it. Propagate newly interned symbols. (parse-first-valid-form-spec): Likewise. (arglist-for-echo-area, complete-form, completions-for-keyword): Adapted to unintern the newly interned symbols. --- /project/slime/cvsroot/slime/slime.el 2007/08/26 10:38:59 1.821 +++ /project/slime/cvsroot/slime/slime.el 2007/08/26 23:35:25 1.822 @@ -1,3 +1,4 @@ + ;;; slime.el -- Superior Lisp Interaction Mode for Emacs ;; ;;;; License @@ -5743,11 +5744,11 @@ "" (let ((op (first operators))) (destructure-case (slime-ensure-list op) - ((:declaration decl-identifier declspec) op) - ((:type-specifier typespec-op typespec) op) + ((:declaration declspec) op) + ((:type-specifier typespec) op) (t (slime-ensure-list (save-excursion (goto-char (first points)) - (slime-sexp-at-point (first arg-indices)))))))))) + (slime-sexp-at-point (1+ (first arg-indices))))))))))) (defun slime-complete-form () "Complete the form at point. @@ -10464,7 +10465,10 @@ (and name (intern name)))) (defun slime-sexp-at-point (&optional n) - "Return the sexp at point as a string, otherwise nil." + "Return the sexp at point as a string, otherwise nil. +If N is given and greater than 1, a list of all such sexps +following the sexp at point is returned. (If there are not +as many sexps as N, a list with < N sexps is returned.)" (interactive "p") (or n (setq n 1)) (flet ((sexp-at-point () (let ((string (or (slime-symbol-name-at-point) @@ -10472,10 +10476,12 @@ (if string (substring-no-properties string) nil)))) (save-excursion (let ((result nil)) - (push (format "%s" (sexp-at-point)) result) - (dotimes (i (1- n)) - (forward-sexp) (forward-char 1) - (push (format " %s" (sexp-at-point)) result)) + (dotimes (i n) + (push (sexp-at-point) result) + (ignore-errors (forward-sexp) (forward-char 1)) + (save-excursion + (unless (slime-point-moves-p (ignore-errors (forward-sexp))) + (return)))) (if (slime-length= result 1) (first result) (nreverse result)))))) @@ -10558,18 +10564,18 @@ (decl-points (rest current-points)) (decl-pos (1- (first decl-points))) (nesting (slime-nesting-until-point decl-pos)) - (declspec (concat (slime-incomplete-sexp-at-point nesting) + (declspec-str (concat (slime-incomplete-sexp-at-point nesting) (make-string nesting ?\))))) ;; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? - (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec)) - (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec))) - (let ((typespec-op (first (second decl-ops))) - (typespec (match-string 1 declspec))) - (setq current-forms (list `(:type-specifier ,typespec-op ,typespec))) + (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec-str)) + (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec-str))) + (let* ((typespec-str (match-string 1 declspec-str)) + (typespec (slime-make-form-spec-from-string typespec-str))) + (setq current-forms (list `(:type-specifier ,typespec))) (setq current-indices (list (second decl-indices))) (setq current-points (list (second decl-points)))) - (let ((decl-identifier (first (first decl-ops)))) - (setq current-forms (list `(:declaration ,decl-identifier ,declspec))) + (let ((declspec (slime-make-form-spec-from-string declspec-str))) + (setq current-forms (list `(:declaration ,declspec))) (setq current-indices (list (first decl-indices))) (setq current-points (list (first decl-points))))))))) (values current-forms current-indices current-points)) @@ -10584,7 +10590,26 @@ nesting 0)))) - +(defun slime-make-form-spec-from-string (string &optional temp-buffer) + (let ((tmpbuf (or temp-buffer (generate-new-buffer "TMP")))) + (if (slime-length= string 0) + "" + (unwind-protect + (with-current-buffer tmpbuf + (erase-buffer) + (insert string) (backward-char 1) + (multiple-value-bind (forms indices points) + (slime-enclosing-form-specs 1) + (if (null forms) + string + (progn + (beginning-of-line) (forward-char 1) + (mapcar #'(lambda (string) + (slime-make-form-spec-from-string string tmpbuf)) + (slime-ensure-list + (slime-sexp-at-point (1+ (first (last indices)))))))))) + (when (not temp-buffer) + (kill-buffer tmpbuf)))))) (defun slime-enclosing-form-specs (&optional max-levels) @@ -10602,13 +10627,13 @@ parens. \(See SWANK::PARSE-FORM-SPEC for more information about what -exactly constitutes a ``raw form specs'') +exactly constitutes a ``raw form specs'' -Example: +Example:) A return value like the following - (values (\"quux\" \"bar\" \"foo\") (3 2 1) (p1 p2 p3)) + (values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3)) can be interpreted as follows: @@ -11055,7 +11080,10 @@ slime-insert-propertized slime-insert-possibly-as-rectangle slime-tree-insert - slime-enclosing-form-specs))) + slime-enclosing-form-specs + slime-make-form-spec-from-string + slime-parse-extended-operator/declare +))) (run-hooks 'slime-load-hook) From trittweiler at common-lisp.net Sun Aug 26 23:36:44 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 26 Aug 2007 19:36:44 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070826233644.155C5A148@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22868 Modified Files: ChangeLog Log Message: Reduces needless interning of symbols that was introduced by my recent work on autodoc to a minimum. Also fixes this issue for `slime-complete-form' which always interned symbols even before my changes. * slime.el (slime-sexp-at-point): If N is given, but there aren't N sexps available at point, make it return a list of just as many as there are. (slime-make-form-spec-from-string): New. Creates a ``raw form spec'' from a string that's suited for determining newly interned symbols later in Swank. (slime-parse-extended-operator/declare): Uses it. * swank.lisp (parse-symbol): Returns internal knowledge, to provide a means for callers to perform a sanity check. (call-with-ignored-reader-errors): New. Abstracted out from `read-incomplete-form-from-string.' * swank.lisp (read-form-spec): New. Only READs elements of a form spec if necessary. And if it does have to READ, it keeps track of newly interned symbols which are returned as secondary return value. (parse-form-spec): Use it. Propagate newly interned symbols. (parse-first-valid-form-spec): Likewise. (arglist-for-echo-area, complete-form, completions-for-keyword): Adapted to unintern the newly interned symbols. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/26 10:40:47 1.1170 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/26 23:36:43 1.1171 @@ -1,5 +1,35 @@ 2007-08-26 Tobias C. Rittweiler + Reduces needless interning of symbols that was introduced by my + recent work on autodoc to a minimum. Also fixes this issue for + `slime-complete-form' which always interned symbols even before my + changes. + + * slime.el (slime-sexp-at-point): If N is given, but there aren't + N sexps available at point, make it return a list of just as many + as there are. + (slime-make-form-spec-from-string): New. Creates a ``raw form + spec'' from a string that's suited for determining newly interned + symbols later in Swank. + (slime-parse-extended-operator/declare): Uses it. + + * swank.lisp (parse-symbol): Returns internal knowledge, to + provide a means for callers to perform a sanity check. + (call-with-ignored-reader-errors): New. Abstracted out from + `read-incomplete-form-from-string.' + + * swank.lisp (read-form-spec): New. Only READs elements of a form + spec if necessary. And if it does have to READ, it keeps track + of newly interned symbols which are returned as secondary + return value. + (parse-form-spec): Use it. Propagate newly interned symbols. + (parse-first-valid-form-spec): Likewise. + (arglist-for-echo-area, complete-form, completions-for-keyword): + Adapted to unintern the newly interned symbols. + + +2007-08-26 Tobias C. Rittweiler + * slime.el (current-slime-narrowing-configuration): Renamed to `slime-current-narrowing-configuration'. (set-slime-narrowing-configuration): From heller at common-lisp.net Mon Aug 27 12:36:11 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 08:36:11 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827123611.171B93C079@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv8431 Modified Files: slime.el ChangeLog Log Message: Move presentations to contrib. Part I. * slime.el (slime-event-hooks, slime-dispatch-event): New hook. (slime-write-string-function, slime-write-string): New hook. (slime-repl-return-hooks, slime-repl-return): New hook. (slime-repl-current-input-hooks, slime-repl-current-input): New hook. (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook. (sldb-insert-locals, slime-inspector-insert-ispec): Don't use presentations. * contrib/slime-presentations.el: New file --- /project/slime/cvsroot/slime/slime.el 2007/08/26 23:35:25 1.822 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 12:36:10 1.823 @@ -411,15 +411,6 @@ :type '(character) :group 'slime-repl) -(defcustom slime-repl-enable-presentations - (cond ((and (not (featurep 'xemacs)) (= emacs-major-version 20)) - ;; mouseable text sucks in Emacs 20 - nil) - (t t)) - "*Should we enable presentations" - :type '(boolean) - :group 'slime-repl) - (defcustom slime-repl-only-save-lisp-buffers t "When T we only attempt to save lisp-mode file buffers. When NIL slime will attempt to save all buffers (as per @@ -466,20 +457,6 @@ "Face for Lisp output in the SLIME REPL." :group 'slime-repl) - -(defface slime-repl-output-mouseover-face - (if (featurep 'xemacs) - '((t (:bold t))) - (if (slime-face-inheritance-possible-p) - '((t - (:box - (:line-width 1 :color "black" :style released-button) - :inherit - slime-repl-inputed-output-face))) - '((t (:box (:line-width 1 :color "black")))))) - "Face for Lisp output in the SLIME REPL, when the mouse hovers over it" - :group 'slime-repl) - (defface slime-repl-input-face '((t (:bold t))) "Face for previous input in the SLIME REPL." @@ -490,13 +467,6 @@ "Face for the result of an evaluation in the SLIME REPL." :group 'slime-repl) -(defface slime-repl-inputed-output-face - '((((class color) (background light)) (:foreground "Red")) - (((class color) (background dark)) (:foreground "Red")) - (t (:slant italic))) - "Face for the result of an evaluation in the SLIME REPL." - :group 'slime-repl) - (defcustom slime-repl-history-file "~/.slime-history.eld" "File to save the persistent REPL history to." :type 'string @@ -969,9 +939,7 @@ (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." (add-local-hook 'pre-command-hook 'slime-pre-command-hook) - (add-local-hook 'post-command-hook 'slime-post-command-hook) - (when slime-repl-enable-presentations - (add-local-hook 'after-change-functions 'slime-after-change-function))) + (add-local-hook 'post-command-hook 'slime-post-command-hook)) ;;;; Framework'ey bits @@ -1201,6 +1169,10 @@ (save-excursion (insert-char ?\ column)) (zerop (forward-line -1))))))) +(defun slime-insert-possibly-as-rectangle (&rest strings) + (slime-with-rigid-indentation nil + (apply #'insert strings))) + ;;;;; Snapshots of current Emacs state ;;; Window configurations do not save (and hence not restore) @@ -2642,79 +2614,77 @@ (slime-def-connection-var slime-continuation-counter 0 "Continuation serial number counter.") +(defvar slime-event-hooks) + (defun slime-dispatch-event (event &optional process) (let ((slime-dispatching-connection (or process (slime-connection)))) - (destructure-case event - ((:write-string output &optional id target) - (slime-write-string output id target)) - ((:presentation-start id &optional target) - (slime-mark-presentation-start id target)) - ((:presentation-end id &optional target) - (slime-mark-presentation-end id target)) - ;; - ((:emacs-rex form package thread continuation) - (slime-set-state "|eval...") - (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) - (message "; pipelined request... %S" form)) - (let ((id (incf (slime-continuation-counter)))) - (push (cons id continuation) (slime-rex-continuations)) - (slime-send `(:emacs-rex ,form ,package ,thread ,id)))) - ((:return value id) - (let ((rec (assq id (slime-rex-continuations)))) - (cond (rec (setf (slime-rex-continuations) - (remove rec (slime-rex-continuations))) - (when (null (slime-rex-continuations)) - (slime-set-state "")) - (funcall (cdr rec) value)) - (t - (error "Unexpected reply: %S %S" id value))))) - ((:debug-activate thread level) - (assert thread) - (sldb-activate thread level)) - ((:debug thread level condition restarts frames conts) - (assert thread) - (sldb-setup thread level condition restarts frames conts)) - ((:debug-return thread level stepping) - (assert thread) - (sldb-exit thread level stepping)) - ((:emacs-interrupt thread) - (slime-send `(:emacs-interrupt ,thread))) - ((:read-string thread tag) - (assert thread) - (slime-repl-read-string thread tag)) - ((:y-or-n-p thread tag question) - (slime-y-or-n-p thread tag question)) - ((:read-aborted thread tag) - (assert thread) - (slime-repl-abort-read thread tag)) - ((:emacs-return-string thread tag string) - (slime-send `(:emacs-return-string ,thread ,tag ,string))) - ;; - ((:new-package package prompt-string) - (setf (slime-lisp-package) package) - (setf (slime-lisp-package-prompt-string) prompt-string)) - ((:new-features features) - (setf (slime-lisp-features) features)) - ((:indentation-update info) - (slime-handle-indentation-update info)) - ((:open-dedicated-output-stream port) - (slime-open-stream-to-lisp port)) - ((:eval-no-wait fun args) - (apply (intern fun) args)) - ((:eval thread tag form-string) - (slime-check-eval-in-emacs-enabled) - (slime-eval-for-lisp thread tag form-string)) - ((:emacs-return thread tag value) - (slime-send `(:emacs-return ,thread ,tag ,value))) - ((:ed what) - (slime-ed what)) - ((:inspect what) - (slime-open-inspector what)) - ((:background-message message) - (slime-background-message "%s" message)) - ((:debug-condition thread message) - (assert thread) - (message "%s" message))))) + (or (run-hook-with-args-until-success 'slime-event-hooks event) + (destructure-case event + ((:write-string output &optional id target) + (slime-write-string output id target)) + ((:emacs-rex form package thread continuation) + (slime-set-state "|eval...") + (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) + (message "; pipelined request... %S" form)) + (let ((id (incf (slime-continuation-counter)))) + (push (cons id continuation) (slime-rex-continuations)) + (slime-send `(:emacs-rex ,form ,package ,thread ,id)))) + ((:return value id) + (let ((rec (assq id (slime-rex-continuations)))) + (cond (rec (setf (slime-rex-continuations) + (remove rec (slime-rex-continuations))) + (when (null (slime-rex-continuations)) + (slime-set-state "")) + (funcall (cdr rec) value)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level) + (assert thread) + (sldb-activate thread level)) + ((:debug thread level condition restarts frames conts) + (assert thread) + (sldb-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (assert thread) + (sldb-exit thread level stepping)) + ((:emacs-interrupt thread) + (slime-send `(:emacs-interrupt ,thread))) + ((:read-string thread tag) + (assert thread) + (slime-repl-read-string thread tag)) + ((:y-or-n-p thread tag question) + (slime-y-or-n-p thread tag question)) + ((:read-aborted thread tag) + (assert thread) + (slime-repl-abort-read thread tag)) + ((:emacs-return-string thread tag string) + (slime-send `(:emacs-return-string ,thread ,tag ,string))) + ;; + ((:new-package package prompt-string) + (setf (slime-lisp-package) package) + (setf (slime-lisp-package-prompt-string) prompt-string)) + ((:new-features features) + (setf (slime-lisp-features) features)) + ((:indentation-update info) + (slime-handle-indentation-update info)) + ((:open-dedicated-output-stream port) + (slime-open-stream-to-lisp port)) + ((:eval-no-wait fun args) + (apply (intern fun) args)) + ((:eval thread tag form-string) + (slime-check-eval-in-emacs-enabled) + (slime-eval-for-lisp thread tag form-string)) + ((:emacs-return thread tag value) + (slime-send `(:emacs-return ,thread ,tag ,value))) + ((:ed what) + (slime-ed what)) + ((:inspect what) + (slime-open-inspector what)) + ((:background-message message) + (slime-background-message "%s" message)) + ((:debug-condition thread message) + (assert thread) + (message "%s" message)))))) (defun slime-send (sexp) "Send SEXP directly over the wire on the current connection." @@ -2922,145 +2892,7 @@ (eq (process-status slime-buffer-connection) 'open)) (slime-write-string string)))) -;; FIXME: This conditional is not right - just used because the code -;; here does not work in XEmacs. -(when slime-repl-enable-presentations - (when (boundp 'text-property-default-nonsticky) - (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky - :test 'equal) - (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky - :test 'equal))) - -(make-variable-buffer-local - (defvar slime-presentation-start-to-point (make-hash-table))) - -(defun slime-mark-presentation-start (id &optional target) - "Mark the beginning of a presentation with the given ID. -TARGET can be nil (regular process output) or :repl-result." - (setf (gethash id slime-presentation-start-to-point) - ;; We use markers because text can also be inserted before this presentation. - ;; (Output arrives while we are writing presentations within REPL results.) - (copy-marker (slime-output-target-marker target) nil))) - -(defun slime-mark-presentation-start-handler (process string) - (if (and string (string-match "<\\([-0-9]+\\)" string)) - (let* ((match (substring string (match-beginning 1) (match-end 1))) - (id (car (read-from-string match)))) - (slime-mark-presentation-start id)))) - -(defun slime-mark-presentation-end (id &optional target) - "Mark the end of a presentation with the given ID. -TARGET can be nil (regular process output) or :repl-result." - (let ((start (gethash id slime-presentation-start-to-point))) - (remhash id slime-presentation-start-to-point) - (when start - (let* ((marker (slime-output-target-marker target)) - (buffer (and marker (marker-buffer marker)))) - (with-current-buffer buffer - (let ((end (marker-position marker))) - (slime-add-presentation-properties start end - id nil))))))) - -(defun slime-mark-presentation-end-handler (process string) - (if (and string (string-match ">\\([-0-9]+\\)" string)) - (let* ((match (substring string (match-beginning 1) (match-end 1))) - (id (car (read-from-string match)))) - (slime-mark-presentation-end id)))) - -(defstruct slime-presentation text id) - -(defvar slime-presentation-syntax-table - (let ((table (copy-syntax-table lisp-mode-syntax-table))) - ;; We give < and > parenthesis syntax, so that #< ... > is treated - ;; as a balanced expression. This allows to use C-M-k, C-M-SPC, - ;; etc. to deal with a whole presentation. (For Lisp mode, this - ;; is not desirable, since we do not wish to get a mismatched - ;; paren highlighted everytime we type < or >.) - (modify-syntax-entry ?< "(>" table) - (modify-syntax-entry ?> ")<" table) - table) - "Syntax table for presentations.") - -(defun slime-add-presentation-properties (start end id result-p) - "Make the text between START and END a presentation with ID. -RESULT-P decides whether a face for a return value or output text is used." - (let* ((text (buffer-substring-no-properties start end)) - (presentation (make-slime-presentation :text text :id id))) - (let ((inhibit-modification-hooks t)) - (add-text-properties start end - `(modification-hooks (slime-after-change-function) - insert-in-front-hooks (slime-after-change-function) - insert-behind-hooks (slime-after-change-function) - syntax-table ,slime-presentation-syntax-table - rear-nonsticky t)) - ;; Use the presentation as the key of a text property - (case (- end start) - (0) - (1 - (add-text-properties start end - `(slime-repl-presentation ,presentation - ,presentation :start-and-end))) - (t - (add-text-properties start (1+ start) - `(slime-repl-presentation ,presentation - ,presentation :start)) - (when (> (- end start) 2) - (add-text-properties (1+ start) (1- end) - `(,presentation :interior))) - (add-text-properties (1- end) end - `(slime-repl-presentation ,presentation - ,presentation :end)))) - ;; Also put an overlay for the face and the mouse-face. This enables - ;; highlighting of nested presentations. However, overlays get lost - ;; when we copy a presentation; their removal is also not undoable. - ;; In these cases the mouse-face text properties need to take over --- - ;; but they do not give nested highlighting. - (slime-ensure-presentation-overlay start end presentation)))) - -(defun slime-ensure-presentation-overlay (start end presentation) - (unless (find presentation (overlays-at start) - :key (lambda (overlay) - (overlay-get overlay 'slime-repl-presentation))) - (let ((overlay (make-overlay start end (current-buffer) t nil))) - (overlay-put overlay 'slime-repl-presentation presentation) - (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) - (overlay-put overlay 'help-echo - (if (eq major-mode 'slime-repl-mode) - "mouse-2: copy to input; mouse-3: menu" - "mouse-2: inspect; mouse-3: menu")) - (overlay-put overlay 'face 'slime-repl-inputed-output-face) - (overlay-put overlay 'keymap slime-presentation-map)))) - -(defun slime-remove-presentation-properties (from to presentation) - (let ((inhibit-read-only t)) - (remove-text-properties from to - `(,presentation t syntax-table t rear-nonsticky t)) - (when (eq (get-text-property from 'slime-repl-presentation) presentation) - (remove-text-properties from (1+ from) `(slime-repl-presentation t))) - (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) - (remove-text-properties (1- to) to `(slime-repl-presentation t))) - (dolist (overlay (overlays-at from)) - (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) - (delete-overlay overlay))))) - -(defun slime-insert-possibly-as-rectangle (&rest strings) - (slime-with-rigid-indentation nil - (apply #'insert strings))) - -(defun slime-insert-presentation (string output-id &optional rectangle) - "Insert STRING in current buffer and mark it as a presentation -corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line -strings to line up below the current point." - (flet ((insert-it () - (if rectangle - (slime-insert-possibly-as-rectangle string) - (insert string)))) - (cond ((not slime-repl-enable-presentations) - (insert-it)) - (t - (let ((start (point))) - (insert-it) - (slime-add-presentation-properties start (point) output-id t)))))) +(defvar slime-open-stream-hooks) (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" @@ -3069,21 +2901,11 @@ slime-lisp-host port))) (slime-set-query-on-exit-flag stream) (set-process-filter stream 'slime-output-filter) - (when slime-repl-enable-presentations - (require 'bridge) - (defun bridge-insert (process output) - (slime-output-filter process (or output ""))) - (install-bridge) - (setq bridge-destination-insert nil) - (setq bridge-source-insert nil) - (setq bridge-handlers - (list* '("<" . slime-mark-presentation-start-handler) - '(">" . slime-mark-presentation-end-handler) - bridge-handlers))) (let ((pcs (process-coding-system (slime-current-connection)))) (set-process-coding-system stream (car pcs) (cdr pcs))) (when-let (secret (slime-secret)) (slime-net-send secret stream)) + (run-hook-with-args slime-open-stream-hooks stream) stream)) (defun slime-io-speed-test (&optional profile) @@ -3112,48 +2934,25 @@ (switch-to-buffer (process-buffer proc)) (goto-char (point-max))))) -(defvar slime-last-output-target-id 0 - "The last integer we used as a TARGET id.") [582 lines skipped] --- /project/slime/cvsroot/slime/ChangeLog 2007/08/26 23:36:43 1.1171 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/27 12:36:10 1.1172 @@ -1,3 +1,15 @@ +2007-08-27 Helmut Eller + + Move presentations to contrib. Part I. + + * slime.el (slime-event-hooks, slime-dispatch-event): New hook. + (slime-write-string-function, slime-write-string): New hook. + (slime-repl-return-hooks, slime-repl-return): New hook. + (slime-repl-current-input-hooks, slime-repl-current-input): New hook. + (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook. + (sldb-insert-locals, slime-inspector-insert-ispec): Don't use + presentations. + 2007-08-26 Tobias C. Rittweiler Reduces needless interning of symbols that was introduced by my From heller at common-lisp.net Mon Aug 27 12:36:11 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 08:36:11 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070827123611.94DCE3C079@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv8431/contrib Modified Files: ChangeLog Added Files: slime-presentations.el Log Message: Move presentations to contrib. Part I. * slime.el (slime-event-hooks, slime-dispatch-event): New hook. (slime-write-string-function, slime-write-string): New hook. (slime-repl-return-hooks, slime-repl-return): New hook. (slime-repl-current-input-hooks, slime-repl-current-input): New hook. (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook. (sldb-insert-locals, slime-inspector-insert-ispec): Don't use presentations. * contrib/slime-presentations.el: New file --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/25 01:10:36 1.9 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/27 12:36:11 1.10 @@ -1,3 +1,9 @@ +2007-08-27 Helmut Eller + + Move presentations to contrib. (ELisp part) + + * slime-presentations.el: New file. + 2007-08-24 Matthias Koeppe Some fixes to the presentation-streams contrib. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/27 12:36:11 NONE +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/27 12:36:11 1.1 ;;; swank-presentations.el --- imitat LispM' presentations ;;; ;;; Authors: Alan Ruttenberg ;;; Matthias Koeppe ;;; ;;; License: GNU GPL (same license as Emacs) ;;; ;;; Installation ;; ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "") ;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentations))) ;; (defface slime-repl-output-mouseover-face (if (featurep 'xemacs) '((t (:bold t))) (if (slime-face-inheritance-possible-p) '((t (:box (:line-width 1 :color "black" :style released-button) :inherit slime-repl-inputed-output-face))) '((t (:box (:line-width 1 :color "black")))))) "Face for Lisp output in the SLIME REPL, when the mouse hovers over it" :group 'slime-repl) (defface slime-repl-inputed-output-face '((((class color) (background light)) (:foreground "Red")) (((class color) (background dark)) (:foreground "Red")) (t (:slant italic))) "Face for the result of an evaluation in the SLIME REPL." :group 'slime-repl) ;; FIXME: This conditional is not right - just used because the code ;; here does not work in XEmacs. (when (boundp 'text-property-default-nonsticky) (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky :test 'equal) (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky :test 'equal)) (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) (defun slime-mark-presentation-start (id &optional target) "Mark the beginning of a presentation with the given ID. TARGET can be nil (regular process output) or :repl-result." (setf (gethash id slime-presentation-start-to-point) ;; We use markers because text can also be inserted before this presentation. ;; (Output arrives while we are writing presentations within REPL results.) (copy-marker (slime-output-target-marker target) nil))) (defun slime-mark-presentation-start-handler (process string) (if (and string (string-match "<\\([-0-9]+\\)" string)) (let* ((match (substring string (match-beginning 1) (match-end 1))) (id (car (read-from-string match)))) (slime-mark-presentation-start id)))) (defun slime-mark-presentation-end (id &optional target) "Mark the end of a presentation with the given ID. TARGET can be nil (regular process output) or :repl-result." (let ((start (gethash id slime-presentation-start-to-point))) (remhash id slime-presentation-start-to-point) (when start (let* ((marker (slime-output-target-marker target)) (buffer (and marker (marker-buffer marker)))) (with-current-buffer buffer (let ((end (marker-position marker))) (slime-add-presentation-properties start end id nil))))))) (defun slime-mark-presentation-end-handler (process string) (if (and string (string-match ">\\([-0-9]+\\)" string)) (let* ((match (substring string (match-beginning 1) (match-end 1))) (id (car (read-from-string match)))) (slime-mark-presentation-end id)))) (defstruct slime-presentation text id) (defvar slime-presentation-syntax-table (let ((table (copy-syntax-table lisp-mode-syntax-table))) ;; We give < and > parenthesis syntax, so that #< ... > is treated ;; as a balanced expression. This allows to use C-M-k, C-M-SPC, ;; etc. to deal with a whole presentation. (For Lisp mode, this ;; is not desirable, since we do not wish to get a mismatched ;; paren highlighted everytime we type < or >.) (modify-syntax-entry ?< "(>" table) (modify-syntax-entry ?> ")<" table) table) "Syntax table for presentations.") (defun slime-add-presentation-properties (start end id result-p) "Make the text between START and END a presentation with ID. RESULT-P decides whether a face for a return value or output text is used." (let* ((text (buffer-substring-no-properties start end)) (presentation (make-slime-presentation :text text :id id))) (let ((inhibit-modification-hooks t)) (add-text-properties start end `(modification-hooks (slime-after-change-function) insert-in-front-hooks (slime-after-change-function) insert-behind-hooks (slime-after-change-function) syntax-table ,slime-presentation-syntax-table rear-nonsticky t)) ;; Use the presentation as the key of a text property (case (- end start) (0) (1 (add-text-properties start end `(slime-repl-presentation ,presentation ,presentation :start-and-end))) (t (add-text-properties start (1+ start) `(slime-repl-presentation ,presentation ,presentation :start)) (when (> (- end start) 2) (add-text-properties (1+ start) (1- end) `(,presentation :interior))) (add-text-properties (1- end) end `(slime-repl-presentation ,presentation ,presentation :end)))) ;; Also put an overlay for the face and the mouse-face. This enables ;; highlighting of nested presentations. However, overlays get lost ;; when we copy a presentation; their removal is also not undoable. ;; In these cases the mouse-face text properties need to take over --- ;; but they do not give nested highlighting. (slime-ensure-presentation-overlay start end presentation)))) (defun slime-ensure-presentation-overlay (start end presentation) (unless (find presentation (overlays-at start) :key (lambda (overlay) (overlay-get overlay 'slime-repl-presentation))) (let ((overlay (make-overlay start end (current-buffer) t nil))) (overlay-put overlay 'slime-repl-presentation presentation) (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) (overlay-put overlay 'help-echo (if (eq major-mode 'slime-repl-mode) "mouse-2: copy to input; mouse-3: menu" "mouse-2: inspect; mouse-3: menu")) (overlay-put overlay 'face 'slime-repl-inputed-output-face) (overlay-put overlay 'keymap slime-presentation-map)))) (defun slime-remove-presentation-properties (from to presentation) (let ((inhibit-read-only t)) (remove-text-properties from to `(,presentation t syntax-table t rear-nonsticky t)) (when (eq (get-text-property from 'slime-repl-presentation) presentation) (remove-text-properties from (1+ from) `(slime-repl-presentation t))) (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) (remove-text-properties (1- to) to `(slime-repl-presentation t))) (dolist (overlay (overlays-at from)) (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) (delete-overlay overlay))))) (defun slime-insert-presentation (string output-id &optional rectangle) "Insert STRING in current buffer and mark it as a presentation corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line strings to line up below the current point." (flet ((insert-it () (if rectangle (slime-insert-possibly-as-rectangle string) (insert string)))) (let ((start (point))) (insert-it) (slime-add-presentation-properties start (point) output-id t)))) (defvar slime-last-output-target-id 0 "The last integer we used as a TARGET id.") (defvar slime-output-target-to-marker (make-hash-table) "Map from TARGET ids to Emacs markers that indicate where output should be inserted.") ;; Note: We would like the entries to disappear when the buffers are ;; killed. We cannot just make the hash-table ":weakness 'value" -- ;; there is no reference from the buffers to the markers in the ;; buffer, so entries would disappear even though the buffers are ;; alive. Best solution might be to make buffer-local variables that ;; keep the markers. --mkoeppe (defun slime-output-target-marker (target) "Return a marker that indicates where output for TARGET should be inserted." (case target ((nil) (with-current-buffer (slime-output-buffer) slime-output-end)) (:repl-result (with-current-buffer (slime-output-buffer) slime-repl-input-start-mark)) (t (gethash target slime-output-target-to-marker)))) (defun slime-redirect-trace-output () "Redirect the trace output to a separate Emacs buffer." (interactive) (let ((buffer (get-buffer-create "*SLIME Trace Output*"))) (with-current-buffer buffer (let ((marker (copy-marker (buffer-size))) (target (incf slime-last-output-target-id))) (puthash target marker slime-output-target-to-marker) (slime-eval `(swank:redirect-trace-output ,target)))) (pop-to-buffer buffer))) (defun slime-presentation-whole-p (presentation start end &optional object) (let ((object (or object (current-buffer)))) (string= (etypecase object (buffer (with-current-buffer object (buffer-substring-no-properties start end))) (string (substring-no-properties object start end))) (slime-presentation-text presentation)))) (defun slime-presentations-around-point (point &optional object) (let ((object (or object (current-buffer)))) (loop for (key value . rest) on (text-properties-at point object) by 'cddr when (slime-presentation-p key) collect key))) (defun slime-presentation-start-p (tag) (memq tag '(:start :start-and-end))) (defun slime-presentation-stop-p (tag) (memq tag '(:end :start-and-end))) (defun* slime-presentation-start (point presentation &optional (object (current-buffer))) "Find start of `presentation' at `point' in `object'. Return buffer index and whether a start-tag was found." (let* ((this-presentation (get-text-property point presentation object))) (while (not (slime-presentation-start-p this-presentation)) (let ((change-point (previous-single-property-change point presentation object))) (unless change-point (return-from slime-presentation-start (values (etypecase object (buffer (with-current-buffer object 1)) (string 0)) nil))) (setq this-presentation (get-text-property change-point presentation object)) (unless this-presentation (return-from slime-presentation-start (values point nil))) (setq point change-point))) (values point t))) (defun* slime-presentation-end (point presentation &optional (object (current-buffer))) "Find end of presentation at `point' in `object'. Return buffer index (after last character of the presentation) and whether an end-tag was found." (let* ((this-presentation (get-text-property point presentation object))) (while (not (slime-presentation-stop-p this-presentation)) (let ((change-point (next-single-property-change point presentation object))) (unless change-point (return-from slime-presentation-end (values (etypecase object (buffer (with-current-buffer object (point-max))) (string (length object))) nil))) (setq point change-point) (setq this-presentation (get-text-property point presentation object)))) (if this-presentation (let ((after-end (next-single-property-change point presentation object))) (if (not after-end) (values (etypecase object (buffer (with-current-buffer object (point-max))) (string (length object))) t) (values after-end t))) (values point nil)))) (defun* slime-presentation-bounds (point presentation &optional (object (current-buffer))) "Return start index and end index of `presentation' around `point' in `object', and whether the presentation is complete." (multiple-value-bind (start good-start) (slime-presentation-start point presentation object) (multiple-value-bind (end good-end) (slime-presentation-end point presentation object) (values start end (and good-start good-end (slime-presentation-whole-p presentation start end object)))))) (defun slime-presentation-around-point (point &optional object) "Return presentation, start index, end index, and whether the presentation is complete." (let ((object (or object (current-buffer))) (innermost-presentation nil) (innermost-start 0) (innermost-end most-positive-fixnum)) (dolist (presentation (slime-presentations-around-point point object)) (multiple-value-bind (start end whole-p) (slime-presentation-bounds point presentation object) (when whole-p (when (< (- end start) (- innermost-end innermost-start)) (setq innermost-start start innermost-end end innermost-presentation presentation))))) (values innermost-presentation innermost-start innermost-end))) (defun slime-presentation-around-or-before-point (point &optional object) (let ((object (or object (current-buffer)))) (multiple-value-bind (presentation start end whole-p) (slime-presentation-around-point point object) (if presentation (values presentation start end whole-p) (slime-presentation-around-point (1- point) object))))) (defun* slime-for-each-presentation-in-region (from to function &optional (object (current-buffer))) "Call `function' with arguments `presentation', `start', `end', `whole-p' for every presentation in the region `from'--`to' in the string or buffer `object'." (flet ((handle-presentation (presentation point) (multiple-value-bind (start end whole-p) (slime-presentation-bounds point presentation object) (funcall function presentation start end whole-p)))) ;; Handle presentations active at `from'. (dolist (presentation (slime-presentations-around-point from object)) (handle-presentation presentation from)) ;; Use the `slime-repl-presentation' property to search for new presentations. (let ((point from)) (while (< point to) (setq point (next-single-property-change point 'slime-repl-presentation object to)) (let* ((presentation (get-text-property point 'slime-repl-presentation object)) (status (get-text-property point presentation object))) (when (slime-presentation-start-p status) (handle-presentation presentation point))))))) ;; XEmacs compatibility hack, from message by Stephen J. Turnbull on ;; xemacs-beta at xemacs.org of 18 Mar 2002 (unless (boundp 'undo-in-progress) (defvar undo-in-progress nil "Placeholder defvar for XEmacs compatibility from SLIME.") (defadvice undo-more (around slime activate) (let ((undo-in-progress t)) ad-do-it))) (defun slime-after-change-function (start end &rest ignore) "Check all presentations within and adjacent to the change. When a presentation has been altered, change it to plain text." (let ((inhibit-modification-hooks t)) (let ((real-start (max 1 (1- start))) (real-end (min (1+ (buffer-size)) (1+ end))) (any-change nil)) ;; positions around the change (slime-for-each-presentation-in-region real-start real-end (lambda (presentation from to whole-p) (cond (whole-p (slime-ensure-presentation-overlay from to presentation)) ((not undo-in-progress) (slime-remove-presentation-properties from to presentation) (setq any-change t))))) (when any-change (undo-boundary))))) (defun slime-presentation-around-click (event) "Return the presentation around the position of the mouse-click EVENT. If there is no presentation, signal an error. Also return the start position, end position, and buffer of the presentation." (when (and (featurep 'xemacs) (not (button-press-event-p event))) (error "Command must be bound to a button-press-event")) (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) (window (if (featurep 'xemacs) (event-window event) (caadr event)))) (with-current-buffer (window-buffer window) (multiple-value-bind (presentation start end) (slime-presentation-around-point point) (unless presentation (error "No presentation at click")) (values presentation start end (current-buffer)))))) (defun slime-copy-or-inspect-presentation-at-mouse (event) (interactive "e") ; no "@" -- we don't want to select the clicked-at window (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) (if (with-current-buffer buffer (eq major-mode 'slime-repl-mode)) (slime-copy-presentation-at-mouse event) (slime-inspect-presentation-at-mouse event)))) [294 lines skipped] From heller at common-lisp.net Mon Aug 27 12:41:38 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 08:41:38 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827124138.6AB8461052@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10529 Modified Files: slime.el Log Message: (slime-open-stream-to-lisp): Fix typo. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 12:36:10 1.823 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 12:41:38 1.824 @@ -2905,7 +2905,7 @@ (set-process-coding-system stream (car pcs) (cdr pcs))) (when-let (secret (slime-secret)) (slime-net-send secret stream)) - (run-hook-with-args slime-open-stream-hooks stream) + (run-hook-with-args 'slime-open-stream-hooks stream) stream)) (defun slime-io-speed-test (&optional profile) From heller at common-lisp.net Mon Aug 27 12:55:21 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 08:55:21 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827125521.0F440100A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11610 Modified Files: slime.el Log Message: (slime-last-expression): Don't use presentations. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 12:41:38 1.824 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 12:55:20 1.825 @@ -5995,7 +5995,7 @@ window)))))) (defun slime-last-expression () - (slime-buffer-substring-with-reified-output + (buffer-substring-no-properties (save-excursion (backward-sexp) (point)) (point))) From heller at common-lisp.net Mon Aug 27 12:55:51 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 08:55:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827125551.257097200@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11650 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/27 12:36:10 1.1172 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/27 12:55:50 1.1173 @@ -7,8 +7,8 @@ (slime-repl-return-hooks, slime-repl-return): New hook. (slime-repl-current-input-hooks, slime-repl-current-input): New hook. (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook. - (sldb-insert-locals, slime-inspector-insert-ispec): Don't use - presentations. + (sldb-insert-locals, slime-inspector-insert-ispec) + (slime-last-expression): Don't use presentations. 2007-08-26 Tobias C. Rittweiler From heller at common-lisp.net Mon Aug 27 12:58:51 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 08:58:51 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070827125851.CC748111CC@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv11807 Modified Files: ChangeLog slime-scratch.el Log Message: * slime-scratch.el (slime-scratch-buffer): Ignore presentations. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/27 12:36:11 1.10 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/27 12:58:51 1.11 @@ -1,5 +1,9 @@ 2007-08-27 Helmut Eller + * slime-scratch.el (slime-scratch-buffer): Ignore presentations. + +2007-08-27 Helmut Eller + Move presentations to contrib. (ELisp part) * slime-presentations.el: New file. --- /project/slime/cvsroot/slime/contrib/slime-scratch.el 2007/08/24 13:15:45 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-scratch.el 2007/08/27 12:58:51 1.2 @@ -12,6 +12,7 @@ ;; +;;; Code (defvar slime-scratch-mode-map (let ((map (make-sparse-keymap))) @@ -34,9 +35,6 @@ (lisp-mode) (use-local-map slime-scratch-mode-map) (slime-mode t) - (when slime-repl-enable-presentations - ;; Respect the syntax text properties of presentations. - (set (make-local-variable 'parse-sexp-lookup-properties) t)) (current-buffer)))) (slime-define-keys slime-scratch-mode-map From heller at common-lisp.net Mon Aug 27 13:16:49 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 09:16:49 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827131649.5F2C67B49D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15813 Modified Files: test.sh Log Message: * test.sh: Copy contribs to testdir. --- /project/slime/cvsroot/slime/test.sh 2006/10/21 09:27:50 1.8 +++ /project/slime/cvsroot/slime/test.sh 2007/08/27 13:16:49 1.9 @@ -46,7 +46,7 @@ trap "rm -r $testdir" EXIT # remove temporary directory on exit mkdir $testdir -cp $slimedir/*.el $slimedir/*.lisp ChangeLog $testdir +cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib $testdir mkfifo $dribble session=slime-screen.$$ From heller at common-lisp.net Mon Aug 27 14:32:09 2007 From: heller at common-lisp.net (heller) Date: Mon, 27 Aug 2007 10:32:09 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827143209.E96E213026@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv29055 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-eval-feature-conditional): Fix typo. (slime-keywordify): Simplify. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/27 12:55:50 1.1173 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/27 14:32:09 1.1174 @@ -1,5 +1,10 @@ 2007-08-27 Helmut Eller + * slime.el (slime-eval-feature-conditional): Fix typo. + (slime-keywordify): Simplify. + +2007-08-27 Helmut Eller + Move presentations to contrib. Part I. * slime.el (slime-event-hooks, slime-dispatch-event): New hook. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 12:55:20 1.825 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 14:32:09 1.826 @@ -4934,20 +4934,17 @@ ;; skip this sexp (slime-forward-sexp))))) -(defun slime-keywordify (symbol-designator) - "Makes a keyword out of SYMBOL-DESIGNATOR, which may either be -a symbol or a string." - (let ((name (downcase (etypecase symbol-designator - (symbol (symbol-name symbol-designator)) - (string symbol-designator))))) - (intern (if (eq ?: (aref name 0)) - name - (concat ":" name))))) +(defun slime-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) (defun slime-eval-feature-conditional (e) "Interpret a reader conditional expression." (if (symbolp e) - (memq (slime-keywordify rd e) (slime-lisp-features)) + (memq (slime-keywordify e) (slime-lisp-features)) (funcall (ecase (slime-keywordify (car e)) (:and #'every) (:or #'some) From trittweiler at common-lisp.net Mon Aug 27 15:00:35 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 11:00:35 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070827150035.25FF82F047@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv2742/contrib Modified Files: swank-fuzzy.lisp Log Message: * slime.el (slime-sexp-at-point): Fixes a few edge cases were Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, `foo(bar baz)' where point is at the ?\(. (slime-internal-scratch-buffer): New. This variable holds an internal scratch buffer that can be reused instead of having to create a new temporary buffer again and again. (slime-make-extended-operator-parser/look-ahead): Uses `slime-make-form-spec-from-string' to parse nested expressions properly. (slime-nesting-until-point): Added docstring. (slime-make-form-spec-from-string): Added new optional parameter for stripping the operator off the passed string representation of a form. Necessary to work in the context of `slime-make-extended-operator-parser/look-ahead'. Added safety check against a possible endless recursion. * swank.lisp (parse-form-spec): Looses restriction for nesting. --- /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/23 12:58:52 1.2 +++ /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/27 15:00:35 1.3 @@ -108,35 +108,6 @@ symbol-chunks)) (classify-symbol symbol))))) -(defun classify-symbol (symbol) - "Returns a list of classifiers that classify SYMBOL according -to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a -special variable.) The list may contain the following classification -keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO, -:SPECIAL-OPERATOR, and/or :PACKAGE" - (check-type symbol symbol) - (let (result) - (when (boundp symbol) (push :boundp result)) - (when (fboundp symbol) (push :fboundp result)) - (when (find-class symbol nil) (push :class result)) - (when (macro-function symbol) (push :macro result)) - (when (special-operator-p symbol) (push :special-operator result)) - (when (find-package symbol) (push :package result)) - (when (typep (ignore-errors (fdefinition symbol)) - 'generic-function) - (push :generic-function result)) - result)) - -(defun symbol-classification->string (flags) - (format nil "~A~A~A~A~A~A~A" - (if (member :boundp flags) "b" "-") - (if (member :fboundp flags) "f" "-") - (if (member :generic-function flags) "g" "-") - (if (member :class flags) "c" "-") - (if (member :macro flags) "m" "-") - (if (member :special-operator flags) "s" "-") - (if (member :package flags) "p" "-"))) - (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec) "Returns two values: an array of completion objects, sorted by From trittweiler at common-lisp.net Mon Aug 27 15:02:16 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 11:02:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827150216.32B412F048@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2850 Modified Files: swank.lisp Log Message: * slime.el (slime-sexp-at-point): Fixes a few edge cases were Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, `foo(bar baz)' where point is at the ?\(. (slime-internal-scratch-buffer): New. This variable holds an internal scratch buffer that can be reused instead of having to create a new temporary buffer again and again. (slime-make-extended-operator-parser/look-ahead): Uses `slime-make-form-spec-from-string' to parse nested expressions properly. (slime-nesting-until-point): Added docstring. (slime-make-form-spec-from-string): Added new optional parameter for stripping the operator off the passed string representation of a form. Necessary to work in the context of `slime-make-extended-operator-parser/look-ahead'. Added safety check against a possible endless recursion. * swank.lisp (parse-form-spec): Looses restriction for nesting. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/26 23:34:50 1.500 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/27 15:02:15 1.501 @@ -1656,7 +1656,7 @@ ((:type-specifier raw-typespec) (parse-extended-spec raw-typespec :type-specifier)) (t - (when (every #'stringp raw-spec) + (when (every #'(lambda (x) (or (stringp x) (consp x))) raw-spec) (destructuring-bind (raw-operator &rest raw-args) raw-spec (multiple-value-bind (operator found?) (parse-symbol raw-operator) (when (and found? (valid-operator-symbol-p operator)) From trittweiler at common-lisp.net Mon Aug 27 15:02:45 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 11:02:45 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827150245.51C612F048@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2891 Modified Files: slime.el Log Message: * slime.el (slime-sexp-at-point): Fixes a few edge cases were Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, `foo(bar baz)' where point is at the ?\(. (slime-internal-scratch-buffer): New. This variable holds an internal scratch buffer that can be reused instead of having to create a new temporary buffer again and again. (slime-make-extended-operator-parser/look-ahead): Uses `slime-make-form-spec-from-string' to parse nested expressions properly. (slime-nesting-until-point): Added docstring. (slime-make-form-spec-from-string): Added new optional parameter for stripping the operator off the passed string representation of a form. Necessary to work in the context of `slime-make-extended-operator-parser/look-ahead'. Added safety check against a possible endless recursion. * swank.lisp (parse-form-spec): Looses restriction for nesting. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 14:32:09 1.826 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 15:02:44 1.827 @@ -9860,21 +9860,33 @@ (let ((name (slime-symbol-name-at-point))) (and name (intern name)))) -(defun slime-sexp-at-point (&optional n) +(defun slime-sexp-at-point (&optional n skip-blanks-p) "Return the sexp at point as a string, otherwise nil. If N is given and greater than 1, a list of all such sexps following the sexp at point is returned. (If there are not -as many sexps as N, a list with < N sexps is returned.)" +as many sexps as N, a list with < N sexps is returned.) + +If SKIP-BLANKS-P is true, leading whitespaces &c are skipped. +" (interactive "p") (or n (setq n 1)) - (flet ((sexp-at-point () - (let ((string (or (slime-symbol-name-at-point) - (thing-at-point 'sexp)))) + (flet ((sexp-at-point (first-choice) + (let ((string (if (eq first-choice :symbol-first) + (or (slime-symbol-name-at-point) + (thing-at-point 'sexp)) + (or (thing-at-point 'sexp) + (slime-symbol-name-at-point))))) (if string (substring-no-properties string) nil)))) (save-excursion + (when skip-blanks-p ; e.g. `( foo bat)' where point is after ?\(. + (slime-forward-blanks)) (let ((result nil)) (dotimes (i n) - (push (sexp-at-point) result) - (ignore-errors (forward-sexp) (forward-char 1)) + ;; `foo(bar baz)' where point is at ?\(. + (let ((sexp (sexp-at-point :symbol-first))) + (if (equal sexp (first result)) + (push (sexp-at-point :sexp-first) result) + (push sexp result))) + (ignore-errors (forward-sexp) (slime-forward-blanks)) (save-excursion (unless (slime-point-moves-p (ignore-errors (forward-sexp))) (return)))) @@ -9932,51 +9944,64 @@ ("APPLY" . (slime-make-extended-operator-parser/look-ahead 1)) ("DECLARE" . slime-parse-extended-operator/declare))) +;; FIXME: How can this buffer best be hidden from the user? I think there +;; are some ignoration variables; gotta check that. +(defvar slime-internal-scratch-buffer (generate-new-buffer "SLIME-INTERNAL") + "") (defun slime-make-extended-operator-parser/look-ahead (steps) "Returns a parser that parses the current operator at point plus STEPS-many additional sexps on the right side of the operator." (lexical-let ((n steps)) - #'(lambda (name user-point current-forms current-indices current-points) - (let ((old-forms (rest current-forms))) - (let ((args (slime-ensure-list (slime-sexp-at-point n)))) - (setq current-forms - (cons `(,name , at args) old-forms))) - (values current-forms current-indices current-points))))) + (byte-compile + #'(lambda (name user-point current-forms current-indices current-points) + (let ((old-forms (rest current-forms))) + (goto-char user-point) + (let* ((nesting (slime-nesting-until-point (1- (first current-points)))) + (args-str (concat (slime-incomplete-sexp-at-point nesting) + (make-string nesting ?\)))) + (args (slime-make-form-spec-from-string args-str t))) + (setq current-forms (cons `(,name , at args) old-forms)))) + (values current-forms current-indices current-points) + )))) (defun slime-parse-extended-operator/declare (name user-point current-forms current-indices current-points) (when (string= (thing-at-point 'char) "(") (let ((orig-point (point))) - (save-excursion - (goto-char user-point) - (slime-end-of-symbol) - ;; Head of CURRENT-FORMS is "declare" at this point, but we're - ;; interested in what comes next. - (let* ((decl-ops (rest current-forms)) - (decl-indices (rest current-indices)) - (decl-points (rest current-points)) - (decl-pos (1- (first decl-points))) - (nesting (slime-nesting-until-point decl-pos)) - (declspec-str (concat (slime-incomplete-sexp-at-point nesting) - (make-string nesting ?\))))) - ;; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? - (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec-str)) - (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" declspec-str))) - (let* ((typespec-str (match-string 1 declspec-str)) - (typespec (slime-make-form-spec-from-string typespec-str))) - (setq current-forms (list `(:type-specifier ,typespec))) - (setq current-indices (list (second decl-indices))) - (setq current-points (list (second decl-points)))) - (let ((declspec (slime-make-form-spec-from-string declspec-str))) - (setq current-forms (list `(:declaration ,declspec))) - (setq current-indices (list (first decl-indices))) - (setq current-points (list (first decl-points))))))))) + (goto-char user-point) + (slime-end-of-symbol) + ;; Head of CURRENT-FORMS is "declare" at this point, but we're + ;; interested in what comes next. + (let* ((decl-ops (rest current-forms)) + (decl-indices (rest current-indices)) + (decl-points (rest current-points)) + (decl-pos (1- (first decl-points))) + (nesting (slime-nesting-until-point decl-pos)) + (declspec-str (concat (slime-incomplete-sexp-at-point nesting) + (make-string nesting ?\))))) + ;; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? + (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" + declspec-str)) + (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" + declspec-str))) + (let* ((typespec-str (match-string 1 declspec-str)) + (typespec (slime-make-form-spec-from-string typespec-str))) + (setq current-forms (list `(:type-specifier ,typespec))) + (setq current-indices (list (second decl-indices))) + (setq current-points (list (second decl-points)))) + (let ((declspec (slime-make-form-spec-from-string declspec-str))) + (setq current-forms (list `(:declaration ,declspec))) + (setq current-indices (list (first decl-indices))) + (setq current-points (list (first decl-points)))))))) (values current-forms current-indices current-points)) (defun slime-nesting-until-point (target-point) + "Returns the nesting level between current point and TARGET-POINT. +If TARGET-POINT could not be reached, 0 is returned. (As a result +TARGET-POINT should always be placed just before a `?\('.)" (save-excursion (let ((nesting 0)) (while (> (point) target-point) @@ -9986,26 +10011,37 @@ nesting 0)))) -(defun slime-make-form-spec-from-string (string &optional temp-buffer) - (let ((tmpbuf (or temp-buffer (generate-new-buffer "TMP")))) - (if (slime-length= string 0) - "" - (unwind-protect - (with-current-buffer tmpbuf - (erase-buffer) - (insert string) (backward-char 1) - (multiple-value-bind (forms indices points) - (slime-enclosing-form-specs 1) - (if (null forms) - string - (progn - (beginning-of-line) (forward-char 1) - (mapcar #'(lambda (string) - (slime-make-form-spec-from-string string tmpbuf)) - (slime-ensure-list - (slime-sexp-at-point (1+ (first (last indices)))))))))) - (when (not temp-buffer) - (kill-buffer tmpbuf)))))) +(defun slime-make-form-spec-from-string (string &optional strip-operator-p temp-buffer) + "If STRIP-OPERATOR-P is T and STRING is the string +representation of a form, the string representation of this form +is stripped from the form. This can be important to avoid mutual +recursion between this function, `slime-enclosing-form-specs' and +`slime-parse-extended-operator-name'." + (if (slime-length= string 0) + "" + (with-current-buffer (or temp-buffer slime-internal-scratch-buffer) + (erase-buffer) + (insert string) (backward-char 1) + (when strip-operator-p + (save-excursion + (beginning-of-line) + (when (string= (thing-at-point 'char) "(") + (ignore-errors (forward-char 1) + (forward-sexp) + (slime-forward-blanks)) + (delete-region (point-min) (point)) + (insert "(")))) + (multiple-value-bind (forms indices points) + (slime-enclosing-form-specs 1) + (if (null forms) + string + (progn + (beginning-of-line) (forward-char 1) + (mapcar #'(lambda (s) + (assert (not (equal s string))) + (slime-make-form-spec-from-string s temp-buffer)) + (slime-ensure-list + (slime-sexp-at-point (1+ (first (last indices))) t))))))))) (defun slime-enclosing-form-specs (&optional max-levels) @@ -10479,6 +10515,8 @@ slime-enclosing-form-specs slime-make-form-spec-from-string slime-parse-extended-operator/declare + slime-incomplete-form-at-point + slime-sexp-at-point ))) (run-hooks 'slime-load-hook) From trittweiler at common-lisp.net Mon Aug 27 15:03:16 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 11:03:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827150316.1177A3C07A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2927 Modified Files: ChangeLog Log Message: * slime.el (slime-sexp-at-point): Fixes a few edge cases were Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, `foo(bar baz)' where point is at the ?\(. (slime-internal-scratch-buffer): New. This variable holds an internal scratch buffer that can be reused instead of having to create a new temporary buffer again and again. (slime-make-extended-operator-parser/look-ahead): Uses `slime-make-form-spec-from-string' to parse nested expressions properly. (slime-nesting-until-point): Added docstring. (slime-make-form-spec-from-string): Added new optional parameter for stripping the operator off the passed string representation of a form. Necessary to work in the context of `slime-make-extended-operator-parser/look-ahead'. Added safety check against a possible endless recursion. * swank.lisp (parse-form-spec): Looses restriction for nesting. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/27 14:32:09 1.1174 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/27 15:03:15 1.1175 @@ -1,3 +1,23 @@ +2007-08-27 Tobias C. Rittweiler + + * slime.el (slime-sexp-at-point): Fixes a few edge cases were + Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, + `foo(bar baz)' where point is at the ?\(. + (slime-internal-scratch-buffer): New. This variable holds an + internal scratch buffer that can be reused instead of having to + create a new temporary buffer again and again. + (slime-make-extended-operator-parser/look-ahead): Uses + `slime-make-form-spec-from-string' to parse nested expressions + properly. + (slime-nesting-until-point): Added docstring. + (slime-make-form-spec-from-string): Added new optional parameter + for stripping the operator off the passed string representation of + a form. Necessary to work in the context of + `slime-make-extended-operator-parser/look-ahead'. Added safety check + against a possible endless recursion. + + * swank.lisp (parse-form-spec): Looses restriction for nesting. + 2007-08-27 Helmut Eller * slime.el (slime-eval-feature-conditional): Fix typo. From trittweiler at common-lisp.net Mon Aug 27 15:47:26 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 11:47:26 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827154726.132F27A001@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9100 Modified Files: slime.el Log Message: * slime.el (slime-make-extended-operator-parser/look-ahead): Move to end of symbol at point. (slime-make-form-spec-from-string): Fixes unexpected behaviour of `save-excursion'. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 15:02:44 1.827 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 15:47:25 1.828 @@ -9958,6 +9958,7 @@ #'(lambda (name user-point current-forms current-indices current-points) (let ((old-forms (rest current-forms))) (goto-char user-point) + (slime-end-of-symbol) (let* ((nesting (slime-nesting-until-point (1- (first current-points)))) (args-str (concat (slime-incomplete-sexp-at-point nesting) (make-string nesting ?\)))) @@ -10021,20 +10022,20 @@ "" (with-current-buffer (or temp-buffer slime-internal-scratch-buffer) (erase-buffer) - (insert string) (backward-char 1) + (insert string) (when strip-operator-p - (save-excursion - (beginning-of-line) - (when (string= (thing-at-point 'char) "(") - (ignore-errors (forward-char 1) - (forward-sexp) - (slime-forward-blanks)) - (delete-region (point-min) (point)) - (insert "(")))) + (beginning-of-line) + (when (string= (thing-at-point 'char) "(") + (ignore-errors (forward-char 1) + (forward-sexp) + (slime-forward-blanks)) + (delete-region (point-min) (point)) + (insert "("))) + (end-of-line) (backward-char 1) (multiple-value-bind (forms indices points) (slime-enclosing-form-specs 1) (if (null forms) - string + (progn (message "QUUX") string) (progn (beginning-of-line) (forward-char 1) (mapcar #'(lambda (s) From trittweiler at common-lisp.net Mon Aug 27 15:48:25 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 11:48:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827154825.5B7797A011@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9200 Modified Files: slime.el Log Message: * slime.el (slime-make-extended-operator-parser/look-ahead): Move to end of symbol at point. (slime-make-form-spec-from-string): Fixes unexpected behaviour of `save-excursion'. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 15:47:25 1.828 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 15:48:25 1.829 @@ -10035,7 +10035,7 @@ (multiple-value-bind (forms indices points) (slime-enclosing-form-specs 1) (if (null forms) - (progn (message "QUUX") string) + string (progn (beginning-of-line) (forward-char 1) (mapcar #'(lambda (s) From trittweiler at common-lisp.net Mon Aug 27 15:48:58 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 11:48:58 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827154858.D08B4111D1@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9262 Modified Files: ChangeLog Log Message: * slime.el (slime-make-extended-operator-parser/look-ahead): Move to end of symbol at point. (slime-make-form-spec-from-string): Fixes unexpected behaviour of `save-excursion'. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/27 15:03:15 1.1175 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/27 15:48:58 1.1176 @@ -1,5 +1,12 @@ 2007-08-27 Tobias C. Rittweiler + * slime.el (slime-make-extended-operator-parser/look-ahead): Move + to end of symbol at point. + (slime-make-form-spec-from-string): Fixes unexpected behaviour of + `save-excursion'. + +2007-08-27 Tobias C. Rittweiler + * slime.el (slime-sexp-at-point): Fixes a few edge cases were Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, `foo(bar baz)' where point is at the ?\(. From trittweiler at common-lisp.net Mon Aug 27 16:55:31 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 27 Aug 2007 12:55:31 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070827165531.DC76C601A7@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21054 Modified Files: slime.el Log Message: * slime.el (slime-make-extended-operator-parser/look-ahead): Move to end of symbol at point. (slime-make-form-spec-from-string): Fixes unexpected behaviour of `save-excursion'. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 15:48:25 1.829 +++ /project/slime/cvsroot/slime/slime.el 2007/08/27 16:55:31 1.830 @@ -9957,13 +9957,9 @@ (byte-compile #'(lambda (name user-point current-forms current-indices current-points) (let ((old-forms (rest current-forms))) - (goto-char user-point) - (slime-end-of-symbol) - (let* ((nesting (slime-nesting-until-point (1- (first current-points)))) - (args-str (concat (slime-incomplete-sexp-at-point nesting) - (make-string nesting ?\)))) - (args (slime-make-form-spec-from-string args-str t))) - (setq current-forms (cons `(,name , at args) old-forms)))) + (let* ((args (slime-ensure-list (slime-sexp-at-point n))) + (arg-specs (mapcar #'slime-make-form-spec-from-string args))) + (setq current-forms (cons `(,name , at arg-specs) old-forms)))) (values current-forms current-indices current-points) )))) @@ -10021,23 +10017,24 @@ (if (slime-length= string 0) "" (with-current-buffer (or temp-buffer slime-internal-scratch-buffer) + (common-lisp-mode) ; important for `slime-sexp-at-point'. (erase-buffer) (insert string) (when strip-operator-p - (beginning-of-line) + (beginning-of-buffer) (when (string= (thing-at-point 'char) "(") (ignore-errors (forward-char 1) (forward-sexp) (slime-forward-blanks)) (delete-region (point-min) (point)) (insert "("))) - (end-of-line) (backward-char 1) + (end-of-buffer) (backward-char 1) ; for `slime-enclosing-form-specs' (multiple-value-bind (forms indices points) (slime-enclosing-form-specs 1) (if (null forms) string (progn - (beginning-of-line) (forward-char 1) + (beginning-of-buffer) (forward-char 1) (mapcar #'(lambda (s) (assert (not (equal s string))) (slime-make-form-spec-from-string s temp-buffer)) From mkoeppe at common-lisp.net Tue Aug 28 08:23:01 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:23:01 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828082301.15EE03700E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18026 Modified Files: swank-loader.lisp Log Message: (*contribs*): Add swank-presentations. --- /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/25 00:38:19 1.68 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/28 08:22:58 1.69 @@ -199,7 +199,7 @@ "The directory where fasl files should be placed.") (defvar *contribs* '(swank-fuzzy swank-fancy-inspector - swank-presentation-streams) + swank-presentations swank-presentation-streams) "List of names for contrib modules.") (defun append-dir (absolute name) From mkoeppe at common-lisp.net Tue Aug 28 08:24:34 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:24:34 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828082434.C22F043215@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18251 Modified Files: slime.el Log Message: Remove the ID argument from :write-string protocol messages. Everything, except for rigid-indentation tricks, can be achieved by using :write-string in conjunction with :presentation-start and :presentation-end. (slime-dispatch-event): Change it here. (slime-write-string, slime-repl-write-string): And here. --- /project/slime/cvsroot/slime/slime.el 2007/08/27 16:55:31 1.830 +++ /project/slime/cvsroot/slime/slime.el 2007/08/28 08:24:34 1.831 @@ -2620,8 +2620,8 @@ (let ((slime-dispatching-connection (or process (slime-connection)))) (or (run-hook-with-args-until-success 'slime-event-hooks event) (destructure-case event - ((:write-string output &optional id target) - (slime-write-string output id target)) + ((:write-string output &optional target) + (slime-write-string output target)) ((:emacs-rex form package thread continuation) (slime-set-state "|eval...") (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) @@ -2936,16 +2936,15 @@ (defvar slime-write-string-function 'slime-repl-write-string) -(defun slime-write-string (string &optional id target) - "Insert STRING in the REPL buffer. -If ID is non-nil, insert STRING -as a presentation. If TARGET is nil, insert STRING as regular process +(defun slime-write-string (string &optional target) + "Insert STRING in the REPL buffer or some other TARGET. +If TARGET is nil, insert STRING as regular process output. If TARGET is :repl-result, insert STRING as the result of the evaluation. Other values of TARGET map to an Emacs marker via the hashtable `slime-output-target-to-marker'; output is inserted at this marker." - (funcall slime-write-string-function string id target)) + (funcall slime-write-string-function string target)) -(defun slime-repl-write-string (string &optional id target) +(defun slime-repl-write-string (string &optional target) (ecase target ((nil) ; Regular process output (with-current-buffer (slime-output-buffer) From mkoeppe at common-lisp.net Tue Aug 28 08:24:55 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:24:55 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828082455.6A9B654169@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18304 Modified Files: swank.lisp Log Message: Remove the ID argument from :write-string protocol messages. Everything, except for rigid-indentation tricks, can be achieved by using :write-string in conjunction with :presentation-start and :presentation-end. * swank.lisp (present-in-emacs): Unused, removed. * swank.lisp (make-output-function-for-target): Remove id argument from :write-string. (send-repl-results-to-emacs): Don't call save-presented-object. Remove id argument from :write-string. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/27 15:02:15 1.501 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/28 08:24:54 1.502 @@ -604,7 +604,7 @@ (with-connection (connection) (with-simple-restart (abort "Abort sending output to Emacs.") - (send-to-emacs `(:write-string ,string nil ,target)))))) + (send-to-emacs `(:write-string ,string ,target)))))) (defun make-output-stream-for-target (connection target) "Create a stream that sends output to a specific TARGET in Emacs." @@ -1301,25 +1301,6 @@ ((:ok value) value) ((:abort) (abort))))))) -(defun present-in-emacs (value-or-values &key (separated-by " ")) - "Present VALUE in the Emacs repl buffer of the current thread." - (unless (consp value-or-values) - (setf value-or-values (list value-or-values))) - (flet ((present (value) - (if (stringp value) - (send-to-emacs `(:write-string ,value)) - (let ((id (save-presented-object value))) - (send-to-emacs `(:write-string ,(prin1-to-string value) ,id)))))) - (map nil (let ((first-time-p t)) - (lambda (value) - (when (and (not first-time-p) - separated-by) - (present separated-by)) - (present value) - (setf first-time-p nil))) - value-or-values)) - (values)) - (defvar *swank-wire-protocol-version* nil "The version of the swank/slime communication protocol.") @@ -2967,12 +2948,10 @@ (defun send-repl-results-to-emacs (values) (flet ((send (value) - (let ((id (and *record-repl-results* - (save-presented-object value)))) - (send-to-emacs `(:write-string ,(prin1-to-string value) - ,id :repl-result)) - (send-to-emacs `(:write-string ,(string #\Newline) - nil :repl-result))))) + (send-to-emacs `(:write-string ,(prin1-to-string value) + :repl-result)) + (send-to-emacs `(:write-string ,(string #\Newline) + :repl-result)))) (if (null values) (send-to-emacs `(:write-string "; No value" nil :repl-result)) (mapc #'send values)))) From mkoeppe at common-lisp.net Tue Aug 28 08:25:12 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:25:12 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828082512.2D37961061@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18435/contrib Modified Files: slime-presentation-streams.el Log Message: Require slime-presentations contrib. --- /project/slime/cvsroot/slime/contrib/slime-presentation-streams.el 2007/08/24 07:00:05 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-presentation-streams.el 2007/08/28 08:25:12 1.2 @@ -18,6 +18,8 @@ ;;; Initialization +(require 'slime-presentations) + (add-hook 'slime-connected-hook 'slime-install-presentation-streams) (defun slime-install-presentation-streams () From mkoeppe at common-lisp.net Tue Aug 28 08:25:30 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:25:30 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828082530.EFA061122@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18498/contrib Modified Files: slime-presentations.el Log Message: * swank-presentations.lisp: New file. * slime-presentations.el: Load it. * slime-presentations.el (slime-presentation-write): Remove id argument. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/27 12:36:11 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/28 08:25:29 1.2 @@ -591,16 +591,14 @@ (slime-mark-presentation-end id target)) (t nil))) -(defun slime-presentation-write (string &optional id target) +(defun slime-presentation-write (string &optional target) (ecase target ((nil) ; Regular process output (with-current-buffer (slime-output-buffer) (slime-with-output-end-mark - (if id - (slime-insert-presentation string id t) - (slime-propertize-region '(face slime-repl-output-face - rear-nonsticky (face)) - (insert string))) + (slime-propertize-region '(face slime-repl-output-face + rear-nonsticky (face)) + (insert string)) (set-marker slime-output-end (point)) (when (and (= (point) slime-repl-prompt-start-mark) (not (bolp))) @@ -614,11 +612,9 @@ (let ((marker (slime-output-target-marker target))) (goto-char marker) (let ((result-start (point))) - (if id - (slime-insert-presentation string id) - (slime-propertize-region `(face slime-repl-result-face - rear-nonsticky (face)) - (insert string))) + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert string)) ;; Move the input-start marker after the REPL result. (set-marker marker (point)))))) (t @@ -679,4 +675,9 @@ (slime-presentation-init) +(add-hook 'slime-connected-hook 'slime-install-presentations) + +(defun slime-install-presentations () + (slime-eval-async '(swank:swank-require :swank-presentations))) + (provide 'slime-presentations) From mkoeppe at common-lisp.net Tue Aug 28 08:25:54 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:25:54 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828082554.0DC56A14E@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18540/contrib Added Files: swank-presentations.lisp Log Message: * swank-presentations.lisp (send-repl-results-to-emacs): Override core defun to mark up REPL results as presentations. * swank-presentations.lisp: New file. * slime-presentations.el: Load it. --- /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2007/08/28 08:25:53 NONE +++ /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2007/08/28 08:25:53 1.1 ;;; swank-presentation-streams.lisp --- imitate LispM's presentations ;;; ;;; Authors: FIXME -- find all guilty parties ;;; ;;; License: This code has been placed in the Public Domain. All warranties ;;; are disclaimed. (in-package :swank) ;;; More presentation-related code from swank.lisp can go here. --mkoeppe (defun send-repl-results-to-emacs (values) ;; Override a function in swank.lisp, so that ;; presentations are associated with every REPL result. (flet ((send (value) (let ((id (and *record-repl-results* (save-presented-object value)))) (send-to-emacs `(:presentation-start ,id :repl-result)) (send-to-emacs `(:write-string ,(prin1-to-string value) :repl-result)) (send-to-emacs `(:presentation-end ,id :repl-result)) (send-to-emacs `(:write-string ,(string #\Newline) :repl-result))))) (if (null values) (send-to-emacs `(:write-string "; No value" nil :repl-result)) (mapc #'send values)))) (provide :swank-presentations) From mkoeppe at common-lisp.net Tue Aug 28 08:26:03 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:26:03 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828082603.7DB901D120@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18570/contrib Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/27 12:58:51 1.11 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 08:26:03 1.12 @@ -1,3 +1,16 @@ +2007-08-28 Matthias Koeppe + + * swank-presentations.lisp (send-repl-results-to-emacs): + Override core defun to mark up REPL results as presentations. + + * swank-presentations.lisp: New file. + * slime-presentations.el: Load it. + + * slime-presentations.el (slime-presentation-write): Remove id + argument. + + * slime-presentation-streams.el: Require slime-presentations contrib. + 2007-08-27 Helmut Eller * slime-scratch.el (slime-scratch-buffer): Ignore presentations. From mkoeppe at common-lisp.net Tue Aug 28 08:26:23 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 04:26:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828082623.709F37E005@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18592 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2007/08/27 15:48:58 1.1176 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 08:26:16 1.1177 @@ -1,3 +1,24 @@ +2007-08-28 Matthias Koeppe + + Remove the ID argument from :write-string protocol messages. + Everything, except for rigid-indentation tricks, can be achieved + by using :write-string in conjunction with :presentation-start and + :presentation-end. + + * swank.lisp (present-in-emacs): Unused, removed. + + * swank.lisp (make-output-function-for-target): Remove id argument + from :write-string. + (send-repl-results-to-emacs): Don't call + save-presented-object. Remove id argument from :write-string. + + * slime.el (slime-dispatch-event): Change it here. + (slime-write-string, slime-repl-write-string): And here. + +2007-08-28 Matthias Koeppe + + * swank-loader.lisp (*contribs*): Add swank-presentations. + 2007-08-27 Tobias C. Rittweiler * slime.el (slime-make-extended-operator-parser/look-ahead): Move From heller at common-lisp.net Tue Aug 28 13:53:02 2007 From: heller at common-lisp.net (heller) Date: Tue, 28 Aug 2007 09:53:02 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828135302.8E67054162@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv30713 Modified Files: ChangeLog swank.lisp Log Message: Move presentations to contrib. Part II. * swank.lisp (*listener-eval-function*): New variables. (listener-eval): Use it (repl-eval): Used to be listener-eval. (*send-repl-results-function*): New variable. (eval-region): Simplify. (track-package, cat): New functions. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 08:26:16 1.1177 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 13:53:02 1.1178 @@ -1,3 +1,14 @@ +2007-08-28 Helmut Eller + + Move presentations to contrib. Part II. + + * swank.lisp (*listener-eval-function*): New variables. + (listener-eval): Use it + (repl-eval): Used to be listener-eval. + (*send-repl-results-function*): New variable. + (eval-region): Simplify. + (track-package, cat): New functions. + 2007-08-28 Matthias Koeppe Remove the ID argument from :write-string protocol messages. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/28 08:24:54 1.502 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/28 13:53:02 1.503 @@ -2652,88 +2652,6 @@ (test-print-arglist) -;;;; Recording and accessing results of computations - -(defvar *record-repl-results* t - "Non-nil means that REPL results are saved for later lookup.") - -(defvar *object-to-presentation-id* - (make-weak-key-hash-table :test 'eq) - "Store the mapping of objects to numeric identifiers") - -(defvar *presentation-id-to-object* - (make-weak-value-hash-table :test 'eql) - "Store the mapping of numeric identifiers to objects") - -(defun clear-presentation-tables () - (clrhash *object-to-presentation-id*) - (clrhash *presentation-id-to-object*)) - -(defvar *presentation-counter* 0 "identifier counter") - -(defvar *nil-surrogate* (make-symbol "nil-surrogate")) - -;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the -;; rest of slime isn't thread safe either), do we really care? -(defun save-presented-object (object) - "Save OBJECT and return the assigned id. -If OBJECT was saved previously return the old id." - (let ((object (if (null object) *nil-surrogate* object))) - ;; We store *nil-surrogate* instead of nil, to distinguish it from - ;; an object that was garbage collected. - (or (gethash object *object-to-presentation-id*) - (let ((id (incf *presentation-counter*))) - (setf (gethash id *presentation-id-to-object*) object) - (setf (gethash object *object-to-presentation-id*) id) - id)))) - -(defun lookup-presented-object (id) - "Retrieve the object corresponding to ID. -The secondary value indicates the absence of an entry." - (etypecase id - (integer - ;; - (multiple-value-bind (object foundp) - (gethash id *presentation-id-to-object*) - (cond - ((eql object *nil-surrogate*) - ;; A stored nil object - (values nil t)) - ((null object) - ;; Object that was replaced by nil in the weak hash table - ;; when the object was garbage collected. - (values nil nil)) - (t - (values object foundp))))) - (cons - (destructure-case id - ((:frame-var thread-id frame index) - (declare (ignore thread-id)) ; later - (handler-case - (frame-var-value frame index) - (t (condition) - (declare (ignore condition)) - (values nil nil)) - (:no-error (value) - (values value t)))) - ((:inspected-part part-index) - (declare (special *inspectee-parts*)) - (if (< part-index (length *inspectee-parts*)) - (values (inspector-nth-part part-index) t) - (values nil nil))))))) - -(defslimefun get-repl-result (id) - "Get the result of the previous REPL evaluation with ID." - (multiple-value-bind (object foundp) (lookup-presented-object id) - (cond (foundp object) - (t (abort-request "Attempt to access unrecorded object (id ~D)." id))))) - -(defslimefun clear-repl-results () - "Forget the results of all previous REPL evaluations." - (clear-presentation-tables) - t) - - ;;;; Evaluation (defvar *pending-continuations* '() @@ -2807,99 +2725,19 @@ (list (get-output-stream-string s) (format nil "~{~S~^~%~}" values))))) -;;; XXX do we need this stuff? What is it good for? -(defvar *slime-repl-advance-history* nil - "In the dynamic scope of a single form typed at the repl, is set to nil to - prevent the repl from advancing the history - * ** *** etc.") - -(defvar *slime-repl-suppress-output* nil - "In the dynamic scope of a single form typed at the repl, is set to nil to - prevent the repl from printing the result of the evalation.") - -(defvar *slime-repl-eval-hook-pass* (gensym "PASS") - "Token to indicate that a repl hook declines to evaluate the form") - -(defvar *slime-repl-eval-hooks* nil - "A list of functions. When the repl is about to eval a form, first try running each of - these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* - is considered a replacement for calling eval. If there are no hooks, or all - pass, then eval is used.") - -(defslimefun repl-eval-hook-pass () - "call when repl hook declines to evaluate the form" - (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) - -(defslimefun repl-suppress-output () - "In the dynamic scope of a single form typed at the repl, call to - prevent the repl from printing the result of the evalation." - (setq *slime-repl-suppress-output* t)) - -(defslimefun repl-suppress-advance-history () - "In the dynamic scope of a single form typed at the repl, call to - prevent the repl from advancing the history - * ** *** etc." - (setq *slime-repl-advance-history* nil)) - -(defun eval-region (string &optional package-update-p) - "Evaluate STRING and return the result. -If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package -change, then send Emacs an update." - (unwind-protect - (with-input-from-string (stream string) - (let (- values) - (loop - (let ((form (read stream nil stream))) - (when (eq form stream) - (fresh-line) - (finish-output) - (return (values values -))) - (setq - form) - (if *slime-repl-eval-hooks* - (setq values (run-repl-eval-hooks form)) - (setq values (multiple-value-list (eval form)))) - (finish-output))))) - (when (and package-update-p (not (eq *package* *buffer-package*))) - (send-to-emacs - (list :new-package (package-name *package*) - (package-string-for-prompt *package*)))))) - -(defun run-repl-eval-hooks (form) - (loop for hook in *slime-repl-eval-hooks* - for res = (catch *slime-repl-eval-hook-pass* - (multiple-value-list (funcall hook form))) - until (not (eq res *slime-repl-eval-hook-pass*)) - finally (return - (if (eq res *slime-repl-eval-hook-pass*) - (multiple-value-list (eval form)) - res)))) - -(defun package-string-for-prompt (package) - "Return the shortest nickname (or canonical name) of PACKAGE." - (unparse-name - (or (canonical-package-nickname package) - (auto-abbreviated-package-name package) - (shortest-package-nickname package)))) - -(defun canonical-package-nickname (package) - "Return the canonical package nickname, if any, of PACKAGE." - (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* - :test #'string=)))) - (and name (string name)))) - -(defun auto-abbreviated-package-name (package) - "Return an abbreviated 'name' for PACKAGE. - -N.B. this is not an actual package name or nickname." - (when *auto-abbreviate-dotted-packages* - (let ((last-dot (position #\. (package-name package) :from-end t))) - (when last-dot (subseq (package-name package) (1+ last-dot)))))) - -(defun shortest-package-nickname (package) - "Return the shortest nickname (or canonical name) of PACKAGE." - (loop for name in (cons (package-name package) (package-nicknames package)) - for shortest = name then (if (< (length name) (length shortest)) - name - shortest) - finally (return shortest))) +(defun eval-region (string) + "Evaluate STRING. +Return the results of the last form as a list and as secondary value the +last form." + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (eval form))) + (finish-output)))))) (defslimefun interactive-eval-region (string) (with-buffer-syntax () @@ -2946,31 +2784,78 @@ (setq *package* p) (list (package-name p) (package-string-for-prompt p)))) -(defun send-repl-results-to-emacs (values) - (flet ((send (value) - (send-to-emacs `(:write-string ,(prin1-to-string value) - :repl-result)) - (send-to-emacs `(:write-string ,(string #\Newline) - :repl-result)))) - (if (null values) - (send-to-emacs `(:write-string "; No value" nil :repl-result)) - (mapc #'send values)))) +;;;;; Listener eval + +(defvar *listener-eval-function* 'repl-eval) (defslimefun listener-eval (string) + (funcall *listener-eval-function* string)) + +(defvar *send-repl-results-function* 'send-repl-results-to-emacs) + +(defun repl-eval (string) (clear-user-input) (with-buffer-syntax () - (let ((*slime-repl-suppress-output* :unset) - (*slime-repl-advance-history* :unset)) - (multiple-value-bind (values last-form) (eval-region string t) - (unless (or (and (eq values nil) (eq last-form nil)) - (eq *slime-repl-advance-history* nil)) - (setq *** ** ** * * (car values) - /// // // / / values)) - (setq +++ ++ ++ + + last-form) - (unless (eq *slime-repl-suppress-output* t) - (send-repl-results-to-emacs values))))) + (track-package + (lambda () + (multiple-value-bind (values last-form) (eval-region string) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + last-form) + (funcall *send-repl-results-function* values))))) nil) +(defun track-package (fun) + (let ((p *package*)) + (unwind-protect (funcall fun) + (unless (eq *package* p) + (send-to-emacs (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) + +(defun send-repl-results-to-emacs (values) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (dolist (v values) + (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) + :repl-result))))) + +(defun cat (&rest strings) + "Concatenate all arguments and make the result a string." + (with-output-to-string (out) + (dolist (s strings) + (etypecase s + (string (write-string s out)) + (character (write-char s out)))))) + +(defun package-string-for-prompt (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (unparse-name + (or (canonical-package-nickname package) + (auto-abbreviated-package-name package) + (shortest-package-nickname package)))) + +(defun canonical-package-nickname (package) + "Return the canonical package nickname, if any, of PACKAGE." + (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* + :test #'string=)))) + (and name (string name)))) + +(defun auto-abbreviated-package-name (package) + "Return an abbreviated 'name' for PACKAGE. + +N.B. this is not an actual package name or nickname." + (when *auto-abbreviate-dotted-packages* + (let ((last-dot (position #\. (package-name package) :from-end t))) + (when last-dot (subseq (package-name package) (1+ last-dot)))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) + (defslimefun ed-in-emacs (&optional what) "Edit WHAT in Emacs. @@ -4702,125 +4587,4 @@ (add-hook *pre-reply-hook* 'sync-indentation-to-emacs) - -;;;; Presentation menu protocol -;; -;; To define a menu for a type of object, define a method -;; menu-choices-for-presentation on that object type. This function -;; should return a list of two element lists where the first element is -;; the name of the menu action and the second is a function that will be -;; called if the menu is chosen. The function will be called with 3 -;; arguments: -;; -;; choice: The string naming the action from above -;; -;; object: The object -;; -;; id: The presentation id of the object -;; -;; You might want append (when (next-method-p) (call-next-method)) to -;; pick up the Menu actions of superclasses. -;; - -(defvar *presentation-active-menu* nil) - -(defun menu-choices-for-presentation-id (id) - (multiple-value-bind (ob presentp) (lookup-presented-object id) - (cond ((not presentp) 'not-present) - (t - (let ((menu-and-actions (menu-choices-for-presentation ob))) - (setq *presentation-active-menu* (cons id menu-and-actions)) - (mapcar 'car menu-and-actions)))))) - -(defun swank-ioify (thing) - (cond ((keywordp thing) thing) - ((and (symbolp thing)(not (find #\: (symbol-name thing)))) - (intern (symbol-name thing) 'swank-io-package)) - ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing)))) - (t thing))) - -(defun execute-menu-choice-for-presentation-id (id count item) - (let ((ob (lookup-presented-object id))) - (assert (equal id (car *presentation-active-menu*)) () - "Bug: Execute menu call for id ~a but menu has id ~a" - id (car *presentation-active-menu*)) - (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) - (swank-ioify (funcall action item ob id))))) - - -(defgeneric menu-choices-for-presentation (object) - (:method (ob) (declare (ignore ob)) nil)) ; default method - -;; Pathname -(defmethod menu-choices-for-presentation ((ob pathname)) - (let* ((file-exists (ignore-errors (probe-file ob))) - (lisp-type (make-pathname :type "lisp")) - (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) - (let ((source (merge-pathnames lisp-type ob))) - (and (ignore-errors (probe-file source)) - source)))) - (fasl-file (and file-exists - (equal (ignore-errors - (namestring - (truename - (compile-file-pathname - (merge-pathnames lisp-type ob))))) - (namestring (truename ob)))))) - (remove nil - (list* - (and (and file-exists (not fasl-file)) - (list "Edit this file" - (lambda(choice object id) - (declare (ignore choice id)) - (ed-in-emacs (namestring (truename object))) - nil))) - (and file-exists - (list "Dired containing directory" - (lambda (choice object id) - (declare (ignore choice id)) - (ed-in-emacs (namestring - (truename - (merge-pathnames - (make-pathname :name "" :type "") object)))) - nil))) - (and fasl-file - (list "Load this fasl file" - (lambda (choice object id) - (declare (ignore choice id object)) - (load ob) - nil))) - (and fasl-file - (list "Delete this fasl file" - (lambda (choice object id) - (declare (ignore choice id object)) - (let ((nt (namestring (truename ob)))) - (when (y-or-n-p-in-emacs "Delete ~a? " nt) - (delete-file nt))) [28 lines skipped] From heller at common-lisp.net Tue Aug 28 13:53:02 2007 From: heller at common-lisp.net (heller) Date: Tue, 28 Aug 2007 09:53:02 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828135302.BF89A5903E@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv30713/contrib Modified Files: swank-presentations.lisp Added Files: swank-listener-hooks.lisp Log Message: Move presentations to contrib. Part II. * swank.lisp (*listener-eval-function*): New variables. (listener-eval): Use it (repl-eval): Used to be listener-eval. (*send-repl-results-function*): New variable. (eval-region): Simplify. (track-package, cat): New functions. --- /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2007/08/28 08:25:52 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2007/08/28 13:53:02 1.2 @@ -1,16 +1,97 @@ -;;; swank-presentation-streams.lisp --- imitate LispM's presentations -;;; -;;; Authors: FIXME -- find all guilty parties -;;; -;;; License: This code has been placed in the Public Domain. All warranties -;;; are disclaimed. +;;; swank-presentations.lisp --- imitate LispM's presentations +;; +;; Authors: FIXME -- find all guilty parties +;; +;; License: This code has been placed in the Public Domain. All warranties +;; are disclaimed. +;; (in-package :swank) ;;; More presentation-related code from swank.lisp can go here. --mkoeppe +;;;; Recording and accessing results of computations -(defun send-repl-results-to-emacs (values) +(defvar *record-repl-results* t + "Non-nil means that REPL results are saved for later lookup.") + +(defvar *object-to-presentation-id* + (make-weak-key-hash-table :test 'eq) + "Store the mapping of objects to numeric identifiers") + +(defvar *presentation-id-to-object* + (make-weak-value-hash-table :test 'eql) + "Store the mapping of numeric identifiers to objects") + +(defun clear-presentation-tables () + (clrhash *object-to-presentation-id*) + (clrhash *presentation-id-to-object*)) + +(defvar *presentation-counter* 0 "identifier counter") + +(defvar *nil-surrogate* (make-symbol "nil-surrogate")) + +;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the +;; rest of slime isn't thread safe either), do we really care? +(defun save-presented-object (object) + "Save OBJECT and return the assigned id. +If OBJECT was saved previously return the old id." + (let ((object (if (null object) *nil-surrogate* object))) + ;; We store *nil-surrogate* instead of nil, to distinguish it from + ;; an object that was garbage collected. + (or (gethash object *object-to-presentation-id*) + (let ((id (incf *presentation-counter*))) + (setf (gethash id *presentation-id-to-object*) object) + (setf (gethash object *object-to-presentation-id*) id) + id)))) + +(defun lookup-presented-object (id) + "Retrieve the object corresponding to ID. +The secondary value indicates the absence of an entry." + (etypecase id + (integer + ;; + (multiple-value-bind (object foundp) + (gethash id *presentation-id-to-object*) + (cond + ((eql object *nil-surrogate*) + ;; A stored nil object + (values nil t)) + ((null object) + ;; Object that was replaced by nil in the weak hash table + ;; when the object was garbage collected. + (values nil nil)) + (t + (values object foundp))))) + (cons + (destructure-case id + ((:frame-var thread-id frame index) + (declare (ignore thread-id)) ; later + (handler-case + (frame-var-value frame index) + (t (condition) + (declare (ignore condition)) + (values nil nil)) + (:no-error (value) + (values value t)))) + ((:inspected-part part-index) + (declare (special *inspectee-parts*)) + (if (< part-index (length *inspectee-parts*)) + (values (inspector-nth-part part-index) t) + (values nil nil))))))) + +(defslimefun get-repl-result (id) + "Get the result of the previous REPL evaluation with ID." + (multiple-value-bind (object foundp) (lookup-presented-object id) + (cond (foundp object) + (t (abort-request "Attempt to access unrecorded object (id ~D)." id))))) + +(defslimefun clear-repl-results () + "Forget the results of all previous REPL evaluations." + (clear-presentation-tables) + t) + +(defun present-repl-results (values) ;; Override a function in swank.lisp, so that ;; presentations are associated with every REPL result. (flet ((send (value) @@ -23,7 +104,131 @@ (send-to-emacs `(:write-string ,(string #\Newline) :repl-result))))) (if (null values) - (send-to-emacs `(:write-string "; No value" nil :repl-result)) + (send-to-emacs `(:write-string "; No value" :repl-result)) (mapc #'send values)))) + +;;;; Presentation menu protocol +;; +;; To define a menu for a type of object, define a method +;; menu-choices-for-presentation on that object type. This function +;; should return a list of two element lists where the first element is +;; the name of the menu action and the second is a function that will be +;; called if the menu is chosen. The function will be called with 3 +;; arguments: +;; +;; choice: The string naming the action from above +;; +;; object: The object +;; +;; id: The presentation id of the object +;; +;; You might want append (when (next-method-p) (call-next-method)) to +;; pick up the Menu actions of superclasses. +;; + +(defvar *presentation-active-menu* nil) + +(defun menu-choices-for-presentation-id (id) + (multiple-value-bind (ob presentp) (lookup-presented-object id) + (cond ((not presentp) 'not-present) + (t + (let ((menu-and-actions (menu-choices-for-presentation ob))) + (setq *presentation-active-menu* (cons id menu-and-actions)) + (mapcar 'car menu-and-actions)))))) + +(defun swank-ioify (thing) + (cond ((keywordp thing) thing) + ((and (symbolp thing)(not (find #\: (symbol-name thing)))) + (intern (symbol-name thing) 'swank-io-package)) + ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing)))) + (t thing))) + +(defun execute-menu-choice-for-presentation-id (id count item) + (let ((ob (lookup-presented-object id))) + (assert (equal id (car *presentation-active-menu*)) () + "Bug: Execute menu call for id ~a but menu has id ~a" + id (car *presentation-active-menu*)) + (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) + (swank-ioify (funcall action item ob id))))) + + +(defgeneric menu-choices-for-presentation (object) + (:method (ob) (declare (ignore ob)) nil)) ; default method + +;; Pathname +(defmethod menu-choices-for-presentation ((ob pathname)) + (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) + (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) + (let ((source (merge-pathnames lisp-type ob))) + (and (ignore-errors (probe-file source)) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames lisp-type ob))))) + (namestring (truename ob)))))) + (remove nil + (list* + (and (and file-exists (not fasl-file)) + (list "Edit this file" + (lambda(choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring (truename object))) + nil))) + (and file-exists + (list "Dired containing directory" + (lambda (choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") object)))) + nil))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) + (and source-file + (list "Edit lisp source file" + (lambda (choice object id) + (declare (ignore choice id object)) + (ed-in-emacs (namestring (truename source-file))) + nil))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) + (and (next-method-p) (call-next-method)))))) + +(defmethod menu-choices-for-presentation ((ob function)) + (list (list "Disassemble" + (lambda (choice object id) + (declare (ignore choice id)) + (disassemble object))))) + +(defslimefun inspect-presentation (id reset-p) + (let ((what (lookup-presented-object id))) + (when reset-p + (reset-inspector)) + (inspect-object what))) + + +(setq *send-repl-results-function* 'present-repl-results) + (provide :swank-presentations) --- /project/slime/cvsroot/slime/contrib/swank-listener-hooks.lisp 2007/08/28 13:53:02 NONE +++ /project/slime/cvsroot/slime/contrib/swank-listener-hooks.lisp 2007/08/28 13:53:02 1.1 ;;; swank-listener-hooks.lisp --- listener with special hooks ;; ;; Author: Alan Ruttenberg ;; I guess that only Alan Ruttenberg knows how to use this code. It ;; was in swank.lisp for a long time, so here it is. -- Helmut Eller (defvar *slime-repl-advance-history* nil "In the dynamic scope of a single form typed at the repl, is set to nil to prevent the repl from advancing the history - * ** *** etc.") (defvar *slime-repl-suppress-output* nil "In the dynamic scope of a single form typed at the repl, is set to nil to prevent the repl from printing the result of the evalation.") (defvar *slime-repl-eval-hook-pass* (gensym "PASS") "Token to indicate that a repl hook declines to evaluate the form") (defvar *slime-repl-eval-hooks* nil "A list of functions. When the repl is about to eval a form, first try running each of these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* is considered a replacement for calling eval. If there are no hooks, or all pass, then eval is used.") (defslimefun repl-eval-hook-pass () "call when repl hook declines to evaluate the form" (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) (defslimefun repl-suppress-output () "In the dynamic scope of a single form typed at the repl, call to prevent the repl from printing the result of the evalation." (setq *slime-repl-suppress-output* t)) (defslimefun repl-suppress-advance-history () "In the dynamic scope of a single form typed at the repl, call to prevent the repl from advancing the history - * ** *** etc." (setq *slime-repl-advance-history* nil)) (defun %eval-region (string) (with-input-from-string (stream string) (let (- values) (loop (let ((form (read stream nil stream))) (when (eq form stream) (fresh-line) (finish-output) (return (values values -))) (setq - form) (if *slime-repl-eval-hooks* (setq values (run-repl-eval-hooks form)) (setq values (multiple-value-list (eval form)))) (finish-output)))))) (defun run-repl-eval-hooks (form) (loop for hook in *slime-repl-eval-hooks* for res = (catch *slime-repl-eval-hook-pass* (multiple-value-list (funcall hook form))) until (not (eq res *slime-repl-eval-hook-pass*)) finally (return (if (eq res *slime-repl-eval-hook-pass*) (multiple-value-list (eval form)) res)))) (defun %listener-eval (string) (clear-user-input) (with-buffer-syntax () (track-package (lambda () (let ((*slime-repl-suppress-output* :unset) (*slime-repl-advance-history* :unset)) (multiple-value-bind (values last-form) (%eval-region string) (unless (or (and (eq values nil) (eq last-form nil)) (eq *slime-repl-advance-history* nil)) (setq *** ** ** * * (car values) /// // // / / values)) (setq +++ ++ ++ + + last-form) (unless (eq *slime-repl-suppress-output* t) (funcall *send-repl-results-function* values)))))))) (setq *listener-eval-function* '%listener-eval) (provide :swank-listener-hooks) From heller at common-lisp.net Tue Aug 28 14:38:05 2007 From: heller at common-lisp.net (heller) Date: Tue, 28 Aug 2007 10:38:05 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828143805.753AE24004@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7896 Modified Files: slime.el ChangeLog Log Message: * swank.lisp (slime-repl-clear-buffer-hook): New hook. (slime-repl-clear-buffer): Use it. * slime-presentations.el (slime-clear-presentations): New function. Add it to slime-repl-clear-buffer-hook. --- /project/slime/cvsroot/slime/slime.el 2007/08/28 08:24:34 1.831 +++ /project/slime/cvsroot/slime/slime.el 2007/08/28 14:38:05 1.832 @@ -3492,31 +3492,16 @@ (goto-char slime-repl-input-start-mark) (line-beginning-position))) -(defun slime-repl-clear-buffer (&optional num-lines) - "Delete the output generated by the Lisp process. +(defvar slime-repl-clear-buffer-hook) -NUM-LINES, if provided, specifies the number of lines before the -repl's input line to leave. Specifying NUM-LINES causes swank to -remember the repl results so some memory leaking is possible." - (interactive "P") - (let ((effective-num-lines (cond - ((null num-lines) nil) - ((consp num-lines) (first num-lines)) - ((integerp num-lines) num-lines) - ((eql '- num-lines) -1)))) - (unless effective-num-lines - (slime-eval-async `(swank:clear-repl-results))) - (set-marker slime-repl-last-input-start-mark nil) - (let ((inhibit-read-only t)) - (delete-region (point-min) - (if num-lines - (save-excursion - (goto-char slime-repl-input-start-mark) - (forward-line (- effective-num-lines)) - (beginning-of-line) - (point)) - (slime-repl-input-line-beginning-position))) - (goto-char slime-repl-input-start-mark)))) +(defun slime-repl-clear-buffer () + "Delete the output generated by the Lisp process." + (interactive) + (set-marker slime-repl-last-input-start-mark nil) + (let ((inhibit-read-only t)) + (delete-region (point-min) (slime-repl-input-line-beginning-position)) + (goto-char slime-repl-input-start-mark)) + (run-hooks 'slime-repl-clear-buffer-hook)) (defun slime-repl-clear-output () "Delete the output inserted since the last input." --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 13:53:02 1.1178 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 14:38:05 1.1179 @@ -8,6 +8,8 @@ (*send-repl-results-function*): New variable. (eval-region): Simplify. (track-package, cat): New functions. + (slime-repl-clear-buffer-hook): New hook. + (slime-repl-clear-buffer): Use it. 2007-08-28 Matthias Koeppe From heller at common-lisp.net Tue Aug 28 14:38:05 2007 From: heller at common-lisp.net (heller) Date: Tue, 28 Aug 2007 10:38:05 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828143805.B26017B4A6@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv7896/contrib Modified Files: slime-presentations.el ChangeLog Log Message: * swank.lisp (slime-repl-clear-buffer-hook): New hook. (slime-repl-clear-buffer): Use it. * slime-presentations.el (slime-clear-presentations): New function. Add it to slime-repl-clear-buffer-hook. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/28 08:25:29 1.2 +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/28 14:38:05 1.3 @@ -657,7 +657,10 @@ (list* '("<" . slime-mark-presentation-start-handler) '(">" . slime-mark-presentation-end-handler) bridge-handlers))) - + +(defun slime-clear-presentations () + (slime-eval-async `(swank:clear-repl-results))) + ;;; Initialization (defun slime-presentation-init () @@ -671,7 +674,8 @@ (setq slime-write-string-function 'slime-presentation-write) (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed) (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input) - (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)) + (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open) + (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)) (slime-presentation-init) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 08:26:03 1.12 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 14:38:05 1.13 @@ -1,3 +1,19 @@ +2007-08-28 Helmut Eller + + * slime-presentations.el (slime-clear-presentations): New + function. Add it to slime-repl-clear-buffer-hook. + +2007-08-28 Helmut Eller + + * swank-listener-hooks.lisp: New file + +2007-08-28 Helmut Eller + + Move the rest of the presentation related code. + + * swank-presentations.lisp (present-repl-results): Renamed from + send-repl-results-to-emacs. + 2007-08-28 Matthias Koeppe * swank-presentations.lisp (send-repl-results-to-emacs): @@ -13,13 +29,10 @@ 2007-08-27 Helmut Eller - * slime-scratch.el (slime-scratch-buffer): Ignore presentations. - -2007-08-27 Helmut Eller - Move presentations to contrib. (ELisp part) * slime-presentations.el: New file. + * slime-scratch.el (slime-scratch-buffer): Ignore presentations. 2007-08-24 Matthias Koeppe From mkoeppe at common-lisp.net Tue Aug 28 16:26:32 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 12:26:32 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828162632.799A83C018@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv32554/contrib Modified Files: swank-presentation-streams.lisp Log Message: Require swank-presentations. (present-repl-results-via-presentation-streams): New. (*send-repl-results-function*): Set this variable rather than overriding send-repl-results-to-emacs. --- /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 03:59:56 1.3 +++ /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/28 16:26:32 1.4 @@ -10,6 +10,8 @@ (in-package :swank) +(swank-require :swank-presentations) + ;; This file contains a mechanism for printing to the slime repl so ;; that the printed result remembers what object it is associated ;; with. This extends the recording of REPL results. @@ -222,7 +224,7 @@ (write-annotation stream #'presentation-end record))) (funcall continue)))) -(defun send-repl-results-to-emacs (values) +(defun present-repl-results-via-presentation-streams (values) ;; Override a function in swank.lisp, so that ;; nested presentations work in the REPL result. (let ((repl-results (connection.repl-results *emacs-connection*))) @@ -310,4 +312,8 @@ (excl:fwrap 'excl::pathname-printer 'print-pathname-present 'presenting-pathname-wrapper)) +;; Hook into SWANK. + +(setq *send-repl-results-function* 'present-repl-results-via-presentation-streams) + (provide :swank-presentation-streams) From mkoeppe at common-lisp.net Tue Aug 28 16:26:54 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 12:26:54 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828162654.DE52B5003A@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv32601/contrib Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 14:38:05 1.13 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 16:26:54 1.14 @@ -1,3 +1,10 @@ +2007-08-28 Matthias Koeppe + + * swank-presentation-streams.lisp: Require swank-presentations. + (present-repl-results-via-presentation-streams): New. + (*send-repl-results-function*): Set this variable rather than + overriding send-repl-results-to-emacs. + 2007-08-28 Helmut Eller * slime-presentations.el (slime-clear-presentations): New From trittweiler at common-lisp.net Tue Aug 28 20:44:48 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Tue, 28 Aug 2007 16:44:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828204448.6C5576410D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22252 Modified Files: swank.lisp slime.el ChangeLog Log Message: * slime.el (slime-make-form-spec-from-string): Elisp Hacking 101: Don't use `beginning-of-buffer' and `end-of-buffer' in Elisp code. * swank.lisp (read-form-spec): Unintern just newly interned symbols when an reader error occurs. --- /project/slime/cvsroot/slime/swank.lisp 2007/08/28 13:53:02 1.503 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/28 20:44:41 1.504 @@ -1678,28 +1678,32 @@ (with-buffer-syntax () (call-with-ignored-reader-errors #'(lambda () - (let ((result) (newly-interned-symbols)) - (dolist (element spec) - (etypecase element - (string - (multiple-value-bind (symbol found? symbol-name package) - (parse-symbol element) - (if found? - (push symbol result) - (let ((sexp (read-from-string element))) - (when (symbolp sexp) - (push sexp newly-interned-symbols) - ;; assert that PARSE-SYMBOL didn't parse incorrectly. - (assert (and (equal symbol-name (symbol-name sexp)) - (eq package (symbol-package sexp))))) - (push sexp result))))) - (cons - (multiple-value-bind (read-spec interned-symbols) - (read-form-spec element) - (push read-spec result) - (setf newly-interned-symbols - (append interned-symbols - newly-interned-symbols)))))) + (let ((result) (newly-interned-symbols) (ok)) + (unwind-protect + (progn + (dolist (element spec) + (etypecase element + (string + (multiple-value-bind (symbol found? symbol-name package) + (parse-symbol element) + (if found? + (push symbol result) + (let ((sexp (read-from-string element))) + (when (symbolp sexp) + (push sexp newly-interned-symbols) + ;; assert that PARSE-SYMBOL didn't parse incorrectly. + (assert (and (equal symbol-name (symbol-name sexp)) + (eq package (symbol-package sexp))))) + (push sexp result))))) + (cons + (multiple-value-bind (read-spec interned-symbols) + (read-form-spec element) + (push read-spec result) + (setf newly-interned-symbols + (append interned-symbols + newly-interned-symbols)))))) + (setq ok t)) + (mapc #'unintern newly-interned-symbols)) (values (nreverse result) (nreverse newly-interned-symbols)))))))) --- /project/slime/cvsroot/slime/slime.el 2007/08/28 14:38:05 1.832 +++ /project/slime/cvsroot/slime/slime.el 2007/08/28 20:44:42 1.833 @@ -9896,7 +9896,7 @@ parsing, and are then returned back as multiple values." ;; OPS, INDICES and POINTS are like the finally returned values of ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order, - ;; i.e. the leftmost operator (that is the latest) operator comes + ;; i.e. the leftmost (that is the latest) operator comes ;; first. (save-excursion (ignore-errors @@ -10005,20 +10005,20 @@ (erase-buffer) (insert string) (when strip-operator-p - (beginning-of-buffer) + (goto-char (point-min)) (when (string= (thing-at-point 'char) "(") (ignore-errors (forward-char 1) (forward-sexp) (slime-forward-blanks)) (delete-region (point-min) (point)) (insert "("))) - (end-of-buffer) (backward-char 1) ; for `slime-enclosing-form-specs' + (goto-char (1- (point-max))) ; for `slime-enclosing-form-specs' (multiple-value-bind (forms indices points) (slime-enclosing-form-specs 1) (if (null forms) string (progn - (beginning-of-buffer) (forward-char 1) + (goto-char (1+ (point-min))) (mapcar #'(lambda (s) (assert (not (equal s string))) (slime-make-form-spec-from-string s temp-buffer)) @@ -10072,54 +10072,54 @@ ;; do not need them in navigating through the nested lists. ;; This speeds up this function significantly. (ignore-errors - (save-excursion - ;; Make sure we get the whole operator name. - (slime-end-of-symbol) - (save-restriction - ;; Don't parse more than 20000 characters before point, so we don't spend - ;; too much time. - (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) - (narrow-to-region (save-excursion (beginning-of-defun) (point)) - (min (1+ (point)) (point-max))) - (while (or (not max-levels) - (<= level max-levels)) - (let ((arg-index 0)) - ;; Move to the beginning of the current sexp if not already there. - (if (or (and (char-after) - (member (char-syntax (char-after)) '(?\( ?'))) - (member (char-syntax (char-before)) '(?\ ?>))) - (incf arg-index)) - (ignore-errors (backward-sexp 1)) - (while (and (< arg-index 64) - (ignore-errors (backward-sexp 1) - (> (point) (point-min)))) + (save-excursion + ;; Make sure we get the whole operator name. + (slime-end-of-symbol) + (save-restriction + ;; Don't parse more than 20000 characters before point, so we don't spend + ;; too much time. + (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) + (narrow-to-region (save-excursion (beginning-of-defun) (point)) + (min (1+ (point)) (point-max))) + (while (or (not max-levels) + (<= level max-levels)) + (let ((arg-index 0)) + ;; Move to the beginning of the current sexp if not already there. + (if (or (and (char-after) + (member (char-syntax (char-after)) '(?\( ?'))) + (member (char-syntax (char-before)) '(?\ ?>))) (incf arg-index)) - (backward-up-list 1) - (when (member (char-syntax (char-after)) '(?\( ?')) - (incf level) - (forward-char 1) - (let ((name (slime-symbol-name-at-point))) - (cond - (name - (save-restriction - (widen) ; to allow looking-ahead/back in extended parsing. - (multiple-value-bind (new-result new-indices new-points) - (slime-parse-extended-operator-name initial-point - (cons `(,name) result) ; minimal form spec - (cons arg-index arg-indices) - (cons (point) points)) - (setq result new-result) - (setq arg-indices new-indices) - (setq points new-points)))) - (t - (push nil result) - (push arg-index arg-indices) - (push (point) points)))) - (backward-up-list 1))))))) - (values - (nreverse result) - (nreverse arg-indices) - (nreverse points)))) + (ignore-errors (backward-sexp 1)) + (while (and (< arg-index 64) + (ignore-errors (backward-sexp 1) + (> (point) (point-min)))) + (incf arg-index)) + (backward-up-list 1) + (when (member (char-syntax (char-after)) '(?\( ?')) + (incf level) + (forward-char 1) + (let ((name (slime-symbol-name-at-point))) + (cond + (name + (save-restriction + (widen) ; to allow looking-ahead/back in extended parsing. + (multiple-value-bind (new-result new-indices new-points) + (slime-parse-extended-operator-name initial-point + (cons `(,name) result) ; minimal form spec + (cons arg-index arg-indices) + (cons (point) points)) + (setq result new-result) + (setq arg-indices new-indices) + (setq points new-points)))) + (t + (push nil result) + (push arg-index arg-indices) + (push (point) points)))) + (backward-up-list 1))))))) + (values + (nreverse result) + (nreverse arg-indices) + (nreverse points)))) ;;;; Portability library --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 14:38:05 1.1179 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 20:44:43 1.1180 @@ -1,3 +1,11 @@ +2007-08-28 Tobias C. Rittweiler + + * slime.el (slime-make-form-spec-from-string): Elisp Hacking 101: + Don't use `beginning-of-buffer' and `end-of-buffer' in Elisp code. + + * swank.lisp (read-form-spec): Unintern just newly interned + symbols when an reader error occurs. + 2007-08-28 Helmut Eller Move presentations to contrib. Part II. From trittweiler at common-lisp.net Tue Aug 28 21:13:57 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Tue, 28 Aug 2007 17:13:57 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828211357.B4B302400A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28259 Modified Files: swank.lisp Log Message: * swank.lisp (classify-symbol, symbol-classification->string): Resurrected in swank.lisp. (I was bitten by cvs-pcl which committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp' where I already removed these functions from.) --- /project/slime/cvsroot/slime/swank.lisp 2007/08/28 20:44:41 1.504 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/28 21:13:57 1.505 @@ -282,7 +282,9 @@ (emacs-connected)) -;;;; Helper macros +;;;; Utilities + +;;;;; Helper macros (defmacro with-io-redirection ((connection) &body body) "Execute BODY I/O redirection to CONNECTION. @@ -338,6 +340,18 @@ (unwind-protect (progn , at body) (delete-package ,var)))) +(defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body) + "Just like do-symbols, but makes sure a symbol is visited only once." + (let ((seen-ht (gensym "SEEN-HT"))) + `(let ((,seen-ht (make-hash-table :test #'eq))) + (do-symbols (,var ,package ,result-form) + (unless (gethash ,var ,seen-ht) + (setf (gethash ,var ,seen-ht) t) + , at body))))) + + +;;;;; Logging + (defvar *log-events* nil) (defvar *log-output* *error-output*) (defvar *event-history* (make-array 40 :initial-element nil) @@ -392,6 +406,9 @@ (defun ascii-char-p (c) (<= (char-code c) 127)) + +;;;;; Misc + (defun length= (seq n) "Test for whether SEQ contains N number of elements. I.e. it's equivalent to (= (LENGTH SEQ) N), but besides being more concise, it may also be more @@ -426,14 +443,116 @@ (setq found v)))) found)) -(defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body) - "Just like do-symbols, but makes sure a symbol is visited only once." - (let ((seen-ht (gensym "SEEN-HT"))) - `(let ((,seen-ht (make-hash-table :test #'eq))) - (do-symbols (,var ,package ,result-form) - (unless (gethash ,var ,seen-ht) - (setf (gethash ,var ,seen-ht) t) - , at body))))) + +;;;;; Symbols + +(defun symbol-status (symbol &optional (package (symbol-package symbol))) + "Returns one of + + :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, + + :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, + + :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, + but is not _present_ in PACKAGE, + + or NIL if SYMBOL is not _accessible_ in PACKAGE. + + +Be aware not to get confused with :INTERNAL and how \"internal +symbols\" are defined in the spec; there is a slight mismatch of +definition with the Spec and what's commonly meant when talking +about internal symbols most times. As the spec says: + + In a package P, a symbol S is + + _accessible_ if S is either _present_ in P itself or was + inherited from another package Q (which implies + that S is _external_ in Q.) + + You can check that with: (AND (SYMBOL-STATUS S P) T) + + + _present_ if either P is the /home package/ of S or S has been + imported into P or exported from P by IMPORT, or + EXPORT respectively. + + Or more simply, if S is not _inherited_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :INHERITED)))) + + + _external_ if S is going to be inherited into any package that + /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or + DEFPACKAGE. + + Note that _external_ implies _present_, since to + make a symbol _external_, you'd have to use EXPORT + which will automatically make the symbol _present_. + + You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) + + + _internal_ if S is _accessible_ but not _external_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :EXTERNAL)))) + + + Notice that this is *different* to + (EQ (SYMBOL-STATUS S P) :INTERNAL) + because what the spec considers _internal_ is split up into two + explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, + CL:FIND-SYMBOL does. + + The rationale is that most times when you speak about \"internal\" + symbols, you're actually not including the symbols inherited + from other packages, but only about the symbols directly specific + to the package in question. +" + (when package ; may be NIL when symbol is completely uninterned. + (check-type symbol symbol) (check-type package package) + (multiple-value-bind (present-symbol status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol present-symbol) status)))) + +(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) + "True if SYMBOL is external in PACKAGE. +If PACKAGE is not specified, the home package of SYMBOL is used." + (eq (symbol-status symbol package) :external)) + + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according +to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a +special variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO, +:SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (let (result) + (when (boundp symbol) (push :boundp result)) + (when (fboundp symbol) (push :fboundp result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (push :generic-function result)) + result)) + +(defun symbol-classification->string (flags) + (format nil "~A~A~A~A~A~A~A" + (if (member :boundp flags) "b" "-") + (if (member :fboundp flags) "f" "-") + (if (member :generic-function flags) "g" "-") + (if (member :class flags) "c" "-") + (if (member :macro flags) "m" "-") + (if (member :special-operator flags) "s" "-") + (if (member :package flags) "p" "-"))) ;;;; TCP Server @@ -3497,85 +3616,6 @@ append (package-nicknames package)))))) -(defun symbol-status (symbol &optional (package (symbol-package symbol))) - "Returns one of - - :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, - - :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, - - :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, - but is not _present_ in PACKAGE, - - or NIL if SYMBOL is not _accessible_ in PACKAGE. - - -Be aware not to get confused with :INTERNAL and how \"internal -symbols\" are defined in the spec; there is a slight mismatch of -definition with the Spec and what's commonly meant when talking -about internal symbols most times. As the spec says: - - In a package P, a symbol S is - - _accessible_ if S is either _present_ in P itself or was - inherited from another package Q (which implies - that S is _external_ in Q.) - - You can check that with: (AND (SYMBOL-STATUS S P) T) - - - _present_ if either P is the /home package/ of S or S has been - imported into P or exported from P by IMPORT, or - EXPORT respectively. - - Or more simply, if S is not _inherited_. - - You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) - (AND STATUS - (NOT (EQ STATUS :INHERITED)))) - - - _external_ if S is going to be inherited into any package that - /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or - DEFPACKAGE. - - Note that _external_ implies _present_, since to - make a symbol _external_, you'd have to use EXPORT - which will automatically make the symbol _present_. - - You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) - - - _internal_ if S is _accessible_ but not _external_. - - You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) - (AND STATUS - (NOT (EQ STATUS :EXTERNAL)))) - - - Notice that this is *different* to - (EQ (SYMBOL-STATUS S P) :INTERNAL) - because what the spec considers _internal_ is split up into two - explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, - CL:FIND-SYMBOL does. - - The rationale is that most times when you speak about \"internal\" - symbols, you're actually not including the symbols inherited - from other packages, but only about the symbols directly specific - to the package in question. -" - (when package ; may be NIL when symbol is completely uninterned. - (check-type symbol symbol) (check-type package package) - (multiple-value-bind (present-symbol status) - (find-symbol (symbol-name symbol) package) - (and (eq symbol present-symbol) status)))) - -(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) - "True if SYMBOL is external in PACKAGE. -If PACKAGE is not specified, the home package of SYMBOL is used." - (eq (symbol-status symbol package) :external)) - - ;; PARSE-COMPLETION-ARGUMENTS return table: ;; ;; user behaviour | NAME | PACKAGE-NAME | PACKAGE From trittweiler at common-lisp.net Tue Aug 28 21:14:38 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Tue, 28 Aug 2007 17:14:38 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828211438.56F722F047@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28346 Modified Files: ChangeLog Log Message: * swank.lisp (classify-symbol, symbol-classification->string): Resurrected in swank.lisp. (I was bitten by cvs-pcl which committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp' where I already removed these functions from.) --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 20:44:43 1.1180 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 21:14:38 1.1181 @@ -1,5 +1,12 @@ 2007-08-28 Tobias C. Rittweiler + * swank.lisp (classify-symbol, symbol-classification->string): + Resurrected in swank.lisp. (I was bitten by cvs-pcl which + committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp' + where I already removed these functions from.) + +2007-08-28 Tobias C. Rittweiler + * slime.el (slime-make-form-spec-from-string): Elisp Hacking 101: Don't use `beginning-of-buffer' and `end-of-buffer' in Elisp code. From mkoeppe at common-lisp.net Tue Aug 28 21:59:48 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 17:59:48 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828215948.DCE048307F@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv4232 Modified Files: slime-presentations.el Log Message: (slime-last-output-target-id) (slime-output-target-to-marker, slime-output-target-marker) (slime-redirect-trace-output): Moved back into SLIME core. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/28 14:38:05 1.3 +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/28 21:59:48 1.4 @@ -165,45 +165,6 @@ (insert-it) (slime-add-presentation-properties start (point) output-id t)))) -(defvar slime-last-output-target-id 0 - "The last integer we used as a TARGET id.") - -(defvar slime-output-target-to-marker - (make-hash-table) - "Map from TARGET ids to Emacs markers that indicate where -output should be inserted.") -;; Note: We would like the entries to disappear when the buffers are -;; killed. We cannot just make the hash-table ":weakness 'value" -- -;; there is no reference from the buffers to the markers in the -;; buffer, so entries would disappear even though the buffers are -;; alive. Best solution might be to make buffer-local variables that -;; keep the markers. --mkoeppe - -(defun slime-output-target-marker (target) - "Return a marker that indicates where output for TARGET should -be inserted." - (case target - ((nil) - (with-current-buffer (slime-output-buffer) - slime-output-end)) - (:repl-result - (with-current-buffer (slime-output-buffer) - slime-repl-input-start-mark)) - (t - (gethash target slime-output-target-to-marker)))) - -(defun slime-redirect-trace-output () - "Redirect the trace output to a separate Emacs buffer." - (interactive) - (let ((buffer (get-buffer-create "*SLIME Trace Output*"))) - (with-current-buffer buffer - (let ((marker (copy-marker (buffer-size))) - (target (incf slime-last-output-target-id))) - (puthash target marker slime-output-target-to-marker) - (slime-eval `(swank:redirect-trace-output ,target)))) - (pop-to-buffer buffer))) - - (defun slime-presentation-whole-p (presentation start end &optional object) (let ((object (or object (current-buffer)))) (string= (etypecase object From mkoeppe at common-lisp.net Tue Aug 28 22:00:20 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 18:00:20 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828220020.00FBC601B0@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5312 Modified Files: slime.el Log Message: (slime-repl-write-string): Handle arbitrary targets using slime-output-target-marker. (slime-last-output-target-id, slime-output-target-to-marker) (slime-output-target-marker) (slime-redirect-trace-output): Move back here from slime-presentations.el. --- /project/slime/cvsroot/slime/slime.el 2007/08/28 20:44:42 1.833 +++ /project/slime/cvsroot/slime/slime.el 2007/08/28 22:00:20 1.834 @@ -2970,7 +2970,39 @@ (if (>= (marker-position slime-output-end) (point)) ;; If the output-end marker was moved by our insertion, ;; set it back to the beginning of the REPL result. - (set-marker slime-output-end result-start))))))) + (set-marker slime-output-end result-start))))) + (t + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))))) + +(defvar slime-last-output-target-id 0 + "The last integer we used as a TARGET id.") + +(defvar slime-output-target-to-marker + (make-hash-table) + "Map from TARGET ids to Emacs markers that indicate where +output should be inserted.") + +(defun slime-output-target-marker (target) + "Return a marker that indicates where output for TARGET should +be inserted." + (case target + ((nil) + (with-current-buffer (slime-output-buffer) + slime-output-end)) + (:repl-result + (with-current-buffer (slime-output-buffer) + slime-repl-input-start-mark)) + (t + (gethash target slime-output-target-to-marker)))) (defun slime-switch-to-output-buffer (&optional connection) "Select the output buffer, preferably in a different window." @@ -6102,6 +6134,24 @@ ;;;; Tracing +(defun slime-redirect-trace-output () + "Redirect the trace output to a separate Emacs buffer." + (interactive) + (let ((buffer (get-buffer-create "*SLIME Trace Output*"))) + (with-current-buffer buffer + (let ((marker (copy-marker (buffer-size))) + (target (incf slime-last-output-target-id))) + (puthash target marker slime-output-target-to-marker) + (slime-eval `(swank:redirect-trace-output ,target)))) + ;; Note: We would like the entries in + ;; slime-output-target-to-marker to disappear when the buffers are + ;; killed. We cannot just make the hash-table ":weakness 'value" + ;; -- there is no reference from the buffers to the markers in the + ;; buffer, so entries would disappear even though the buffers are + ;; alive. Best solution might be to make buffer-local variables + ;; that keep the markers. --mkoeppe + (pop-to-buffer buffer))) + (defun slime-untrace-all () "Untrace all functions." (interactive) From mkoeppe at common-lisp.net Tue Aug 28 22:00:48 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 18:00:48 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070828220048.459F16A031@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv6295/contrib Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 16:26:54 1.14 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 22:00:48 1.15 @@ -1,5 +1,9 @@ 2007-08-28 Matthias Koeppe + * slime-presentations.el (slime-last-output-target-id) + (slime-output-target-to-marker, slime-output-target-marker) + (slime-redirect-trace-output): Moved back into SLIME core. + * swank-presentation-streams.lisp: Require swank-presentations. (present-repl-results-via-presentation-streams): New. (*send-repl-results-function*): Set this variable rather than From mkoeppe at common-lisp.net Tue Aug 28 22:00:50 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 18:00:50 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828220050.A6B8B7080@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6295 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 21:14:38 1.1181 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:00:48 1.1182 @@ -1,3 +1,11 @@ +2007-08-28 Matthias Koeppe + + * slime.el (slime-repl-write-string): Handle arbitrary targets + using slime-output-target-marker. + (slime-last-output-target-id, slime-output-target-to-marker) + (slime-output-target-marker) + (slime-redirect-trace-output): Move back here from slime-presentations.el. + 2007-08-28 Tobias C. Rittweiler * swank.lisp (classify-symbol, symbol-classification->string): From heller at common-lisp.net Tue Aug 28 22:03:26 2007 From: heller at common-lisp.net (heller) Date: Tue, 28 Aug 2007 18:03:26 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828220326.E129F5F058@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7063 Modified Files: ChangeLog slime.el swank.lisp Log Message: Fix some output related bugs. * swank.lisp (send-repl-results-to-emacs): Emit a fresh line. * slime.el (slime-insert-transcript-delimiter): Use insert-before-markers since slime-output-end is no longer left inserting. Reported by Austin Haas . --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:00:48 1.1182 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:03:26 1.1183 @@ -1,3 +1,19 @@ +2007-08-28 Helmut Eller + + Fix some output related bugs. + + * swank.lisp (send-repl-results-to-emacs): Emit a fresh line. + + * slime.el (slime-insert-transcript-delimiter): Use + insert-before-markers since slime-output-end is no longer left + inserting. Reported by Austin Haas . + +2007-08-28 Helmut Eller + + * slime.el (slime-display-or-scroll-completions, + slime-scroll-completions): New functions. Factored out of + slime-expand-abbreviations-and-complete. + 2007-08-28 Matthias Koeppe * slime.el (slime-repl-write-string): Handle arbitrary targets @@ -11,7 +27,7 @@ * swank.lisp (classify-symbol, symbol-classification->string): Resurrected in swank.lisp. (I was bitten by cvs-pcl which committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp' - where I already removed these functions from.) + where I already removed these functions from.) 2007-08-28 Tobias C. Rittweiler @@ -20,7 +36,7 @@ * swank.lisp (read-form-spec): Unintern just newly interned symbols when an reader error occurs. - + 2007-08-28 Helmut Eller Move presentations to contrib. Part II. --- /project/slime/cvsroot/slime/slime.el 2007/08/28 22:00:20 1.834 +++ /project/slime/cvsroot/slime/slime.el 2007/08/28 22:03:26 1.835 @@ -5491,6 +5491,23 @@ (setq slime-completions-window (get-buffer-window slime-completions-buffer-name))))) +(defun slime-display-or-scroll-completions (completions base) + (cond ((and (eq last-command this-command) + (slime-completion-window-active-p)) + (slime-scroll-completions)) + (t + (slime-display-completion-list completions base))) + (slime-complete-delay-restoration)) + +(defun slime-scroll-completions () + (let ((window slime-completions-window)) + (with-current-buffer (window-buffer window) + (if (pos-visible-in-window-p (point-max) window) + (set-window-start window (point-min)) + (save-selected-window + (select-window window) + (scroll-up)))))) + (defun slime-complete-symbol () "Complete the symbol at point. @@ -5532,19 +5549,8 @@ (when (member completed-prefix completion-set) (slime-minibuffer-respecting-message "Complete but not unique")) - (if (and (eq last-command this-command) - (slime-completion-window-active-p)) - ;; Scroll the completions window only - (let ((window slime-completions-window)) - (with-current-buffer (window-buffer window) - (if (pos-visible-in-window-p (point-max) window) - (set-window-start window (point-min) nil) - (let ((other-window-scroll-buffer - (window-buffer window))) - (scroll-other-window))))) ; madhu - (slime-display-completion-list completion-set - completed-prefix) - (slime-complete-delay-restoration))))))) + (slime-display-or-scroll-completions completion-set + completed-prefix)))))) (defun slime-complete-symbol*-fancy-bit () "Do fancy tricks after completing a symbol. @@ -5588,10 +5594,10 @@ (slime-complete-restore-window-configuration)) ;; Incomplete (t - (slime-minibuffer-respecting-message + (slime-minibuffer-respecting-message "Complete but not unique") - (slime-display-completion-list completions partial) - (slime-complete-delay-restoration)))))))) + (slime-display-or-scroll-completions completions + partial)))))))) (defun slime-maybe-complete-as-filename () "If point is at a string starting with \", complete it as filename. @@ -5982,13 +5988,13 @@ (defun slime-insert-transcript-delimiter (string) (with-current-buffer (slime-output-buffer) (slime-with-output-end-mark - (unless (bolp) (insert "\n")) - (slime-insert-propertized - '(slime-transcript-delimiter t) - ";;;; " (subst-char-in-string ?\n ?\ - (substring string 0 - (min 60 (length string)))) - " ...\n")))) + (unless (bolp) (insert-before-markers "\n")) + (slime-propertize-region '(slime-transcript-delimiter t) + (insert-before-markers + ";;;; " (subst-char-in-string ?\n ?\ + (substring string 0 + (min 60 (length string)))) + " ...\n"))))) (defun slime-display-buffer-region (buffer start end &optional other-window) "Like `display-buffer', but only display the specified region." --- /project/slime/cvsroot/slime/swank.lisp 2007/08/28 21:13:57 1.505 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/28 22:03:26 1.506 @@ -2936,6 +2936,8 @@ (package-string-for-prompt *package*))))))) (defun send-repl-results-to-emacs (values) + (fresh-line) + (finish-output) (if (null values) (send-to-emacs `(:write-string "; No value" :repl-result)) (dolist (v values) From mkoeppe at common-lisp.net Tue Aug 28 22:23:40 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 18:23:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828222340.D704D5416A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12461 Modified Files: slime.el Log Message: (slime-repl-insert-prompt): Don't go to point-max but to slime-repl-input-start-mark if there is one. This fixes user input type-ahead again (this change from 2007-08-25 got lost). Testcase: Type (dotimes (i 5) (format t "Number ~A~%" i) (sleep 1)) and then type ahead while the command is executing and output arrives. --- /project/slime/cvsroot/slime/slime.el 2007/08/28 22:03:26 1.835 +++ /project/slime/cvsroot/slime/slime.el 2007/08/28 22:23:40 1.836 @@ -3220,7 +3220,7 @@ (defun slime-repl-insert-prompt () "Goto to point max, and insert the prompt." - (goto-char (point-max)) + (goto-char (if slime-repl-input-start-mark slime-repl-input-start-mark (point-max))) (unless (bolp) (insert "\n")) (let ((prompt-start (point)) (prompt (format "%s> " (slime-lisp-package-prompt-string)))) From heller at common-lisp.net Tue Aug 28 22:23:53 2007 From: heller at common-lisp.net (heller) Date: Tue, 28 Aug 2007 18:23:53 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828222353.8ADD559092@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12396 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (safe-definition-finding): Remove whitespace around error messages. (trim-whitespace): New function. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:03:26 1.1183 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:23:53 1.1184 @@ -1,3 +1,9 @@ +2007-08-29 Helmut Eller + + * swank-cmucl.lisp (safe-definition-finding): Remove whitespace + around error messages. + (trim-whitespace): New function. + 2007-08-28 Helmut Eller Fix some output related bugs. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2007/08/23 19:03:37 1.171 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2007/08/28 22:23:53 1.172 @@ -697,7 +697,11 @@ (if *debug-definition-finding* (body) (handler-case (values (progn , at body) nil) - (error (c) (values (list :error (princ-to-string c)) c)))))) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) (defun code-location-source-location (code-location) "Safe wrapper around `code-location-from-source-location'." From mkoeppe at common-lisp.net Tue Aug 28 22:26:26 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 18:26:26 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070828222626.2B346640B8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13071 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:23:53 1.1184 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:26:25 1.1185 @@ -1,3 +1,12 @@ +2007-08-28 Matthias Koeppe + + * slime.el (slime-repl-insert-prompt): Don't go to point-max but + to slime-repl-input-start-mark if there is one. This fixes user + input type-ahead again (this change from 2007-08-25 got lost). + Testcase: Type (dotimes (i 5) (format t "Number ~A~%" i) (sleep + 1)) and then type ahead while the command is executing and output + arrives. + 2007-08-29 Helmut Eller * swank-cmucl.lisp (safe-definition-finding): Remove whitespace From mkoeppe at common-lisp.net Wed Aug 29 01:08:25 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 21:08:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070829010825.EA141481AD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10730 Modified Files: slime.el Log Message: (slime-repl-write-string): Insert a :repl-result before the prompt, not at point-max. Update markers properly. --- /project/slime/cvsroot/slime/slime.el 2007/08/28 22:23:40 1.836 +++ /project/slime/cvsroot/slime/slime.el 2007/08/29 01:08:25 1.837 @@ -2962,15 +2962,14 @@ (point)))))) (:repl-result (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (let ((result-start (point))) - (slime-insert-propertized `(face slime-repl-result-face + (let ((marker (slime-output-target-marker target))) + (goto-char marker) + (let ((result-start (point))) + (slime-insert-propertized `(face slime-repl-result-face rear-nonsticky (face)) string) - (if (>= (marker-position slime-output-end) (point)) - ;; If the output-end marker was moved by our insertion, - ;; set it back to the beginning of the REPL result. - (set-marker slime-output-end result-start))))) + ;; Move the input-start marker after the REPL result. + (set-marker marker (point)))))) (t (let* ((marker (slime-output-target-marker target)) (buffer (and marker (marker-buffer marker)))) From mkoeppe at common-lisp.net Wed Aug 29 01:08:43 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 28 Aug 2007 21:08:43 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070829010843.1826D4B02F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10768 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/28 22:26:25 1.1185 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/29 01:08:39 1.1186 @@ -1,11 +1,14 @@ 2007-08-28 Matthias Koeppe + Fix user input type-ahead again (this change from 2007-08-25 got + lost). Testcase: Type (dotimes (i 5) (format t "Number ~A~%" + i) (sleep 1)) and then type ahead while the command is executing + and output arrives. + * slime.el (slime-repl-insert-prompt): Don't go to point-max but - to slime-repl-input-start-mark if there is one. This fixes user - input type-ahead again (this change from 2007-08-25 got lost). - Testcase: Type (dotimes (i 5) (format t "Number ~A~%" i) (sleep - 1)) and then type ahead while the command is executing and output - arrives. + to slime-repl-input-start-mark if there is one. + (slime-repl-write-string): Insert a :repl-result before the + prompt, not at point-max. Update markers properly. 2007-08-29 Helmut Eller From mkoeppe at common-lisp.net Wed Aug 29 04:50:34 2007 From: mkoeppe at common-lisp.net (mkoeppe) Date: Wed, 29 Aug 2007 00:50:34 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070829045034.DABB624004@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv21137 Modified Files: swank-presentations.lisp Log Message: Add guilty parties --- /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2007/08/28 13:53:02 1.2 +++ /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2007/08/29 04:50:34 1.3 @@ -1,6 +1,9 @@ ;;; swank-presentations.lisp --- imitate LispM's presentations ;; -;; Authors: FIXME -- find all guilty parties +;; Authors: Alan Ruttenberg +;; Luke Gorrie +;; Helmut Eller +;; Matthias Koeppe ;; ;; License: This code has been placed in the Public Domain. All warranties ;; are disclaimed. @@ -8,8 +11,6 @@ (in-package :swank) -;;; More presentation-related code from swank.lisp can go here. --mkoeppe - ;;;; Recording and accessing results of computations (defvar *record-repl-results* t From trittweiler at common-lisp.net Thu Aug 30 23:09:33 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 30 Aug 2007 19:09:33 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070830230933.6A1FE50029@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5412 Modified Files: slime.el Log Message: * slime.el (slime-sexp-at-point): Explicitely set current syntax table to operate in `lisp-mode-syntax-table' because `thing-at-point' is used which depends on the syntax table. (E.h. keywords like `:foo' aren't recognized as sexp otherwise.) * slime.el (slime-parse-extended-operator/declare): Wrap regexp stuff in `save-match-data' (slime-internal-scratch-buffer): Removed again. (Was only introduced as a performance hack; but it turned out that the bad performance was because of unneccessary recursive calls of `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 already.) (slime-make-form-spec-from-string): Use `with-temp-buffer' instead of `slime-internal-scratch-buffer'. Removed activation of `lisp-mode' in the temporary buffer, because this made `lisp-mode-hooks' run. This activated autodoc in the temp buffer, although the temp buffer is used to compute an autodoc itself (which resulted in some very mutual recursion which caused the current arglist to be displayed again and again---as could have been witnessed in `*Messages*'.) `Lisp-mode' was activated to get the right syntax-table for `slime-sexp-at-point', but this one sets the correct syntax-table itself now. --- /project/slime/cvsroot/slime/slime.el 2007/08/29 01:08:25 1.837 +++ /project/slime/cvsroot/slime/slime.el 2007/08/30 23:09:33 1.838 @@ -9915,23 +9915,26 @@ (or (thing-at-point 'sexp) (slime-symbol-name-at-point))))) (if string (substring-no-properties string) nil)))) - (save-excursion - (when skip-blanks-p ; e.g. `( foo bat)' where point is after ?\(. - (slime-forward-blanks)) - (let ((result nil)) - (dotimes (i n) - ;; `foo(bar baz)' where point is at ?\(. - (let ((sexp (sexp-at-point :symbol-first))) - (if (equal sexp (first result)) + ;; `thing-at-point' depends upon the current syntax table; otherwise + ;; keywords like `:foo' are not recognized as sexps. (This function + ;; may be called from temporary buffers etc.) + (with-syntax-table lisp-mode-syntax-table + (save-excursion + (when skip-blanks-p ; e.g. `( foo bat)' where point is after ?\(. + (slime-forward-blanks)) + (let ((result nil)) + (dotimes (i n) + ;; `foo(bar baz)' where point is at ?\( or ?\). + (if (member (char-syntax (char-after)) '(?\( ?\) ?\')) (push (sexp-at-point :sexp-first) result) - (push sexp result))) - (ignore-errors (forward-sexp) (slime-forward-blanks)) - (save-excursion - (unless (slime-point-moves-p (ignore-errors (forward-sexp))) - (return)))) - (if (slime-length= result 1) - (first result) - (nreverse result)))))) + (push (sexp-at-point :symbol-first) result)) + (ignore-errors (forward-sexp) (slime-forward-blanks)) + (save-excursion + (unless (slime-point-moves-p (ignore-errors (forward-sexp))) + (return)))) + (if (slime-length= result 1) + (first result) + (nreverse result))))))) (defun slime-sexp-at-point-or-error () "Return the sexp at point as a string, othwise signal an error." @@ -9970,7 +9973,6 @@ (funcall parser op-name user-point forms indices points)))))) (values forms indices points)) - (defvar slime-extended-operator-name-parser-alist '(("MAKE-INSTANCE" . (slime-make-extended-operator-parser/look-ahead 1)) ("MAKE-CONDITION" . (slime-make-extended-operator-parser/look-ahead 1)) @@ -9983,25 +9985,19 @@ ("APPLY" . (slime-make-extended-operator-parser/look-ahead 1)) ("DECLARE" . slime-parse-extended-operator/declare))) -;; FIXME: How can this buffer best be hidden from the user? I think there -;; are some ignoration variables; gotta check that. -(defvar slime-internal-scratch-buffer (generate-new-buffer "SLIME-INTERNAL") - "") (defun slime-make-extended-operator-parser/look-ahead (steps) "Returns a parser that parses the current operator at point plus STEPS-many additional sexps on the right side of the operator." (lexical-let ((n steps)) - (byte-compile - #'(lambda (name user-point current-forms current-indices current-points) - (let ((old-forms (rest current-forms))) - (let* ((args (slime-ensure-list (slime-sexp-at-point n))) - (arg-specs (mapcar #'slime-make-form-spec-from-string args))) - (setq current-forms (cons `(,name , at arg-specs) old-forms)))) - (values current-forms current-indices current-points) - )))) - + #'(lambda (name user-point current-forms current-indices current-points) + (let ((old-forms (rest current-forms))) + (let* ((args (slime-ensure-list (slime-sexp-at-point n))) + (arg-specs (mapcar #'slime-make-form-spec-from-string args))) + (setq current-forms (cons `(,name , at arg-specs) old-forms)))) + (values current-forms current-indices current-points) + ))) (defun slime-parse-extended-operator/declare (name user-point current-forms current-indices current-points) @@ -10018,20 +10014,20 @@ (nesting (slime-nesting-until-point decl-pos)) (declspec-str (concat (slime-incomplete-sexp-at-point nesting) (make-string nesting ?\))))) - ;; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? - (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" - declspec-str)) - (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" - declspec-str))) - (let* ((typespec-str (match-string 1 declspec-str)) - (typespec (slime-make-form-spec-from-string typespec-str))) - (setq current-forms (list `(:type-specifier ,typespec))) - (setq current-indices (list (second decl-indices))) - (setq current-points (list (second decl-points)))) - (let ((declspec (slime-make-form-spec-from-string declspec-str))) - (setq current-forms (list `(:declaration ,declspec))) - (setq current-indices (list (first decl-indices))) - (setq current-points (list (first decl-points)))))))) + (save-match-data ; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? + (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" + declspec-str)) + (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$" + declspec-str))) + (let* ((typespec-str (match-string 1 declspec-str)) + (typespec (slime-make-form-spec-from-string typespec-str))) + (setq current-forms (list `(:type-specifier ,typespec))) + (setq current-indices (list (second decl-indices))) + (setq current-points (list (second decl-points)))) + (let ((declspec (slime-make-form-spec-from-string declspec-str))) + (setq current-forms (list `(:declaration ,declspec))) + (setq current-indices (list (first decl-indices))) + (setq current-points (list (first decl-points))))))))) (values current-forms current-indices current-points)) (defun slime-nesting-until-point (target-point) @@ -10047,7 +10043,8 @@ nesting 0)))) -(defun slime-make-form-spec-from-string (string &optional strip-operator-p temp-buffer) + +(defun slime-make-form-spec-from-string (string &optional strip-operator-p) "If STRIP-OPERATOR-P is T and STRING is the string representation of a form, the string representation of this form is stripped from the form. This can be important to avoid mutual @@ -10055,11 +10052,13 @@ `slime-parse-extended-operator-name'." (if (slime-length= string 0) "" - (with-current-buffer (or temp-buffer slime-internal-scratch-buffer) - (common-lisp-mode) ; important for `slime-sexp-at-point'. + (with-temp-buffer + ;; Do NEVER ever try to activate `lisp-mode' here with + ;; `slime-use-autodoc-mode' enabled, as this function is used + ;; to compute the current autodoc itself. (erase-buffer) (insert string) - (when strip-operator-p + (when strip-operator-p ; `(OP arg1 arg2 ...)' ==> `(arg1 arg2 ...)' (goto-char (point-min)) (when (string= (thing-at-point 'char) "(") (ignore-errors (forward-char 1) @@ -10067,18 +10066,18 @@ (slime-forward-blanks)) (delete-region (point-min) (point)) (insert "("))) - (goto-char (1- (point-max))) ; for `slime-enclosing-form-specs' + (goto-char (1- (point-max))) ; `(OP arg1 ... argN|)' (multiple-value-bind (forms indices points) (slime-enclosing-form-specs 1) (if (null forms) string - (progn - (goto-char (1+ (point-min))) + (let ((n (first (last indices)))) + (goto-char (1+ (point-min))) ; `(|OP arg1 ... argN)' (mapcar #'(lambda (s) - (assert (not (equal s string))) - (slime-make-form-spec-from-string s temp-buffer)) + (assert (not (equal s string))) ; trap against + (slime-make-form-spec-from-string s)) ; endless recursion. (slime-ensure-list - (slime-sexp-at-point (1+ (first (last indices))) t))))))))) + (slime-sexp-at-point (1+ n) t))))))))) (defun slime-enclosing-form-specs (&optional max-levels) From trittweiler at common-lisp.net Thu Aug 30 23:11:24 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 30 Aug 2007 19:11:24 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070830231124.50DE750049@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5588 Modified Files: ChangeLog Log Message: * slime.el (slime-sexp-at-point): Explicitely set current syntax table to operate in `lisp-mode-syntax-table' because `thing-at-point' is used which depends on the syntax table. (E.h. keywords like `:foo' aren't recognized as sexp otherwise.) * slime.el (slime-parse-extended-operator/declare): Wrap regexp stuff in `save-match-data' (slime-internal-scratch-buffer): Removed again. (Was only introduced as a performance hack; but it turned out that the bad performance was because of unneccessary recursive calls of `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 already.) (slime-make-form-spec-from-string): Use `with-temp-buffer' instead of `slime-internal-scratch-buffer'. Removed activation of `lisp-mode' in the temporary buffer, because this made `lisp-mode-hooks' run. This activated autodoc in the temp buffer, although the temp buffer is used to compute an autodoc itself (which resulted in some very mutual recursion which caused the current arglist to be displayed again and again---as could have been witnessed in `*Messages*'.) `Lisp-mode' was activated to get the right syntax-table for `slime-sexp-at-point', but this one sets the correct syntax-table itself now. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/29 01:08:39 1.1186 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:11:24 1.1187 @@ -1,3 +1,28 @@ +2007-08-31 Tobias C. Rittweiler + + * slime.el (slime-sexp-at-point): Explicitely set current syntax + table to operate in `lisp-mode-syntax-table' because + `thing-at-point' is used which depends on the syntax table. (E.h. + keywords like `:foo' aren't recognized as sexp otherwise.) + + * slime.el (slime-parse-extended-operator/declare): Wrap regexp + stuff in `save-match-data' + (slime-internal-scratch-buffer): Removed again. (Was only + introduced as a performance hack; but it turned out that the bad + performance was because of unneccessary recursive calls of + `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 + already.) + (slime-make-form-spec-from-string): Use `with-temp-buffer' instead + of `slime-internal-scratch-buffer'. Removed activation of + `lisp-mode' in the temporary buffer, because this made + `lisp-mode-hooks' run. This activated autodoc in the temp buffer, + although the temp buffer is used to compute an autodoc + itself (which resulted in some very mutual recursion which caused + the current arglist to be displayed again and again---as could + have been witnessed in `*Messages*'.) `Lisp-mode' was activated to + get the right syntax-table for `slime-sexp-at-point', but this one + sets the correct syntax-table itself now. + 2007-08-28 Matthias Koeppe Fix user input type-ahead again (this change from 2007-08-25 got From trittweiler at common-lisp.net Thu Aug 30 23:12:19 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 30 Aug 2007 19:12:19 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070830231219.797F98307E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5630 Modified Files: ChangeLog Log Message: * slime.el (slime-sexp-at-point): Explicitely set current syntax table to operate in `lisp-mode-syntax-table' because `thing-at-point' is used which depends on the syntax table. (E.h. keywords like `:foo' aren't recognized as sexp otherwise.) * slime.el (slime-parse-extended-operator/declare): Wrap regexp stuff in `save-match-data' (slime-internal-scratch-buffer): Removed again. (Was only introduced as a performance hack; but it turned out that the bad performance was because of unneccessary recursive calls of `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 already.) (slime-make-form-spec-from-string): Use `with-temp-buffer' instead of `slime-internal-scratch-buffer'. Removed activation of `lisp-mode' in the temporary buffer, because this made `lisp-mode-hooks' run. This activated autodoc in the temp buffer, although the temp buffer is used to compute an autodoc itself (which resulted in some very mutual recursion which caused the current arglist to be displayed again and again---as could have been witnessed in `*Messages*'.) `Lisp-mode' was activated to get the right syntax-table for `slime-sexp-at-point', but this one sets the correct syntax-table itself now. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:11:24 1.1187 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:12:19 1.1188 @@ -2,12 +2,12 @@ * slime.el (slime-sexp-at-point): Explicitely set current syntax table to operate in `lisp-mode-syntax-table' because - `thing-at-point' is used which depends on the syntax table. (E.h. + `thing-at-point' is used which depends on the syntax table. (E.g. keywords like `:foo' aren't recognized as sexp otherwise.) * slime.el (slime-parse-extended-operator/declare): Wrap regexp stuff in `save-match-data' - (slime-internal-scratch-buffer): Removed again. (Was only + (slime-internal-scratch-buffer): Removed again. Was only introduced as a performance hack; but it turned out that the bad performance was because of unneccessary recursive calls of `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 From trittweiler at common-lisp.net Thu Aug 30 23:20:32 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 30 Aug 2007 19:20:32 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070830232032.64A20610A8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7794 Modified Files: swank-cmucl.lisp Log Message: * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as the PPC-Darwin version. Changed to conditionalize on the presence of darwin instead of ppc so that slime works with both Darwin versions of CMUCL. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2007/08/28 22:23:53 1.172 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2007/08/30 23:20:31 1.173 @@ -76,7 +76,7 @@ (defimplementation preferred-communication-style () :sigio) -#-(or ppc mips) +#-(or darwin mips) (defimplementation create-socket (host port) (let* ((addr (resolve-hostname host)) (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) @@ -85,7 +85,7 @@ (ext:create-inet-listener port :stream :reuse-address t :host addr))) ;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. -#+(or ppc mips) +#+(or darwin mips) (defimplementation create-socket (host port) (declare (ignore host)) (ext:create-inet-listener port :stream :reuse-address t)) From trittweiler at common-lisp.net Thu Aug 30 23:21:02 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 30 Aug 2007 19:21:02 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070830232102.06DFE640D9@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7829 Modified Files: ChangeLog Log Message: * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as the PPC-Darwin version. Changed to conditionalize on the presence of darwin instead of ppc so that slime works with both Darwin versions of CMUCL. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:12:19 1.1188 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:21:01 1.1189 @@ -1,3 +1,10 @@ +2007-08-31 Jon Allen Boone + + * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as + the PPC-Darwin version. Changed to conditionalize on the + presence of darwin instead of ppc so that slime works with both + Darwin versions of CMUCL. + 2007-08-31 Tobias C. Rittweiler * slime.el (slime-sexp-at-point): Explicitely set current syntax From trittweiler at common-lisp.net Thu Aug 30 23:43:41 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 30 Aug 2007 19:43:41 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070830234341.910D86A02E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12950 Modified Files: slime.el Log Message: * slime.el (slime-reindent-defun): Fixed when used in lisp file buffers. (Similiar patch also provided by G??bor Melis; problem also reported by Jeff Cunningham.) --- /project/slime/cvsroot/slime/slime.el 2007/08/30 23:09:33 1.838 +++ /project/slime/cvsroot/slime/slime.el 2007/08/30 23:43:41 1.839 @@ -8737,13 +8737,14 @@ (fill-paragraph nil) (let ((start (progn (unless (or (and (zerop (current-column)) (eq ?\( (char-after))) - (slime-repl-at-prompt-start-p)) + (and slime-repl-input-start-mark + (slime-repl-at-prompt-start-p))) (slime-beginning-of-defun)) (point))) (end (ignore-errors (slime-end-of-defun) (point)))) (unless end (forward-paragraph) - (slime-close-all-sexp) + (slime-close-all-parens-in-sexp) (slime-end-of-defun) (setf end (point))) (indent-region start end nil))))) From trittweiler at common-lisp.net Thu Aug 30 23:44:11 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 30 Aug 2007 19:44:11 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070830234411.21A176A02E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12983 Modified Files: ChangeLog Log Message: * slime.el (slime-reindent-defun): Fixed when used in lisp file buffers. (Similiar patch also provided by G??bor Melis; problem also reported by Jeff Cunningham.) --- /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:21:01 1.1189 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:44:10 1.1190 @@ -1,3 +1,9 @@ +2007-08-31 Andreas Fuchs + + * slime.el (slime-reindent-defun): Fixed when used in lisp file + buffers. (Similiar patch also provided by G?bor Melis; problem + also reported by Jeff Cunningham.) + 2007-08-31 Jon Allen Boone * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as From heller at common-lisp.net Fri Aug 31 11:48:23 2007 From: heller at common-lisp.net (heller) Date: Fri, 31 Aug 2007 07:48:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070831114823.CA55B33083@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22347 Modified Files: ChangeLog swank-loader.lisp swank.lisp slime.el Log Message: Move compound prefix completion and autodoc to contrib. * swank.lisp (simple-completions): Rewritten for simplicity. (operator-arglist): Rewritten for simplicity. * slime.el (slime-complete-symbol-function): Make simple completion the default. (slime-echo-arglist-function, slime-echo-arglist): New hook. --- /project/slime/cvsroot/slime/ChangeLog 2007/08/30 23:44:10 1.1190 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/31 11:48:22 1.1191 @@ -1,3 +1,14 @@ +2007-08-31 Helmut Eller + + Move compound prefix completion and autodoc to contrib. + + * swank.lisp (simple-completions): Rewritten for simplicity. + (operator-arglist): Rewritten for simplicity. + + * slime.el (slime-complete-symbol-function): Make simple + completion the default. + (slime-echo-arglist-function, slime-echo-arglist): New hook. + 2007-08-31 Andreas Fuchs * slime.el (slime-reindent-defun): Fixed when used in lisp file @@ -35,7 +46,7 @@ have been witnessed in `*Messages*'.) `Lisp-mode' was activated to get the right syntax-table for `slime-sexp-at-point', but this one sets the correct syntax-table itself now. - + 2007-08-28 Matthias Koeppe Fix user input type-ahead again (this change from 2007-08-25 got @@ -48,7 +59,7 @@ (slime-repl-write-string): Insert a :repl-result before the prompt, not at point-max. Update markers properly. -2007-08-29 Helmut Eller +2007-08-28 Helmut Eller * swank-cmucl.lisp (safe-definition-finding): Remove whitespace around error messages. --- /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/28 08:22:58 1.69 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2007/08/31 11:48:23 1.70 @@ -198,7 +198,8 @@ (defvar *fasl-directory* (default-fasl-directory) "The directory where fasl files should be placed.") -(defvar *contribs* '(swank-fuzzy swank-fancy-inspector +(defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy + swank-fancy-inspector swank-presentations swank-presentation-streams) "List of names for contrib modules.") --- /project/slime/cvsroot/slime/swank.lisp 2007/08/28 22:03:26 1.506 +++ /project/slime/cvsroot/slime/swank.lisp 2007/08/31 11:48:23 1.507 @@ -1568,10 +1568,9 @@ (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" (untokenize-symbol nil nil \"foo\") ==> \"foo\" " - (let ((prefix (cond ((not package-name) "") - (internal-p (format nil "~A::" package-name)) - (t (format nil "~A:" package-name))))) - (concatenate 'string prefix symbol-name))) + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) (defun casify-char (char) "Convert CHAR accoring to readtable-case." @@ -1639,1141 +1638,6 @@ :test #'string=))) *readtable*))) -(defun valid-operator-symbol-p (symbol) - "Is SYMBOL the name of a function, a macro, or a special-operator?" - (or (fboundp symbol) - (macro-function symbol) - (special-operator-p symbol))) - -(defun valid-operator-name-p (string) - "Is STRING the name of a function, macro, or special-operator?" - (let ((symbol (parse-symbol string))) - (valid-operator-symbol-p symbol))) - - -;;;; Arglists - -(defslimefun arglist-for-echo-area (raw-specs &key arg-indices - print-right-margin print-lines) - "Return the arglist for the first valid ``form spec'' in -RAW-SPECS. A ``form spec'' is a superset of functions, macros, -special-ops, declarations and type specifiers. - -For more information about the format of ``raw form specs'' and -``form specs'', please see PARSE-FORM-SPEC." - (handler-case - (with-buffer-syntax () - (multiple-value-bind (form-spec arg-index newly-interned-symbols) - (parse-first-valid-form-spec raw-specs arg-indices) - (unwind-protect - (when form-spec - (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) - (unless (eql arglist :not-available) - (multiple-value-bind (type operator arguments) - (split-form-spec form-spec) - (declare (ignore arguments)) - (multiple-value-bind (stringified-arglist) - (decoded-arglist-to-string - arglist - :operator operator - :print-right-margin print-right-margin - :print-lines print-lines - :highlight (and arg-index - (not (zerop arg-index)) - ;; don't highlight the operator - arg-index)) - (case type - (:declaration (format nil "(declare ~A)" stringified-arglist)) - (:type-specifier (format nil "[Typespec] ~A" stringified-arglist)) - (t stringified-arglist))))))) - (mapc #'unintern newly-interned-symbols)))) - (error (cond) - (format nil "ARGLIST (error): ~A" cond)) - )) - -(defun parse-form-spec (raw-spec) - "Takes a raw (i.e. unparsed) form spec from SLIME and returns a -proper form spec for further processing within SWANK. Returns NIL -if RAW-SPEC could not be parsed. Symbols that had to be interned -in course of the conversion, are returned as secondary return value. - -A ``raw form spec'' can be either: - - i) a list of strings representing a Common Lisp form - - ii) a list of strings as of i), but which additionally - contains other raw form specs - - iii) one of: - - a) (:declaration declspec) - - where DECLSPEC is a raw form spec. - - b) (:type-specifier typespec) - - where TYPESPEC is a raw form spec. - - -A ``form spec'' is either - - 1) a normal Common Lisp form - - 2) a Common Lisp form with a list as its CAR specifying what namespace - the operator is supposed to be interpreted in: - - a) ((:declaration decl-identifier) declarg1 declarg2 ...) - - b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...) - - -Examples: - - (\"defmethod\") => (defmethod) - (\"cl:defmethod\") => (cl:defmethod) - (\"defmethod\" \"print-object\") => (defmethod print-object) - - (\"foo\" (\"bar\" (\"quux\")) \"baz\" => (foo (bar (quux)) baz) - - (:declaration \"optimize\" \"(optimize)\") => ((:declaration optimize)) - (:declaration \"type\" \"(type string)\") => ((:declaration type) string) - (:type-specifier \"float\" \"(float)\") => ((:type-specifier float)) - (:type-specifier \"float\" \"(float 0 100)\") => ((:type-specifier float) 0 100) -" - (flet ((parse-extended-spec (raw-extension extension-flag) - (when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d")) - (nth-value 1 (parse-symbol (first raw-extension)))) - (multiple-value-bind (extension introduced-symbols) - (read-form-spec raw-extension) - (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c. - (destructuring-bind (identifier &rest args) extension - (values `((,extension-flag ,identifier) , at args) - introduced-symbols))))))) - (when (consp raw-spec) - (destructure-case raw-spec - ((:declaration raw-declspec) - (parse-extended-spec raw-declspec :declaration)) - ((:type-specifier raw-typespec) - (parse-extended-spec raw-typespec :type-specifier)) - (t - (when (every #'(lambda (x) (or (stringp x) (consp x))) raw-spec) - (destructuring-bind (raw-operator &rest raw-args) raw-spec - (multiple-value-bind (operator found?) (parse-symbol raw-operator) - (when (and found? (valid-operator-symbol-p operator)) - (multiple-value-bind (parsed-args introduced-symbols) - (read-form-spec raw-args) - (values `(,operator , at parsed-args) introduced-symbols))))))))))) - -(defun split-form-spec (spec) - "Returns all three relevant information a ``form spec'' -contains: the operator type, the operator, and the operands." - (destructuring-bind (operator-designator &rest arguments) spec - (multiple-value-bind (type operator) - (if (listp operator-designator) - (values (first operator-designator) (second operator-designator)) - (values :function operator-designator)) ; functions, macros, special ops - (values type operator arguments)))) ; are all fbound. - -(defun parse-first-valid-form-spec (raw-specs &optional arg-indices) - "Returns the first parsed form spec in RAW-SPECS that can -successfully be parsed. Additionally returns its respective index -in ARG-INDICES (or NIL.), and all newly interned symbols as tertiary -return value." - (block traversal - (mapc #'(lambda (raw-spec index) - (multiple-value-bind (spec symbols) (parse-form-spec raw-spec) - (when spec (return-from traversal - (values spec index symbols))))) - raw-specs - (append arg-indices '#1=(nil . #1#))) - nil)) ; found nothing - -(defun read-form-spec (spec) - "Turns the ``raw form spec'' SPEC into a proper Common Lisp form. - -It returns symbols that had to interned for the conversion as -secondary return value." - (when spec - (with-buffer-syntax () - (call-with-ignored-reader-errors - #'(lambda () - (let ((result) (newly-interned-symbols) (ok)) - (unwind-protect - (progn - (dolist (element spec) - (etypecase element - (string - (multiple-value-bind (symbol found? symbol-name package) - (parse-symbol element) - (if found? - (push symbol result) - (let ((sexp (read-from-string element))) - (when (symbolp sexp) - (push sexp newly-interned-symbols) - ;; assert that PARSE-SYMBOL didn't parse incorrectly. - (assert (and (equal symbol-name (symbol-name sexp)) - (eq package (symbol-package sexp))))) - (push sexp result))))) - (cons - (multiple-value-bind (read-spec interned-symbols) - (read-form-spec element) - (push read-spec result) - (setf newly-interned-symbols - (append interned-symbols - newly-interned-symbols)))))) - (setq ok t)) - (mapc #'unintern newly-interned-symbols)) - (values (nreverse result) - (nreverse newly-interned-symbols)))))))) - - - -(defun clean-arglist (arglist) - "Remove &whole, &enviroment, and &aux elements from ARGLIST." - (cond ((null arglist) '()) - ((member (car arglist) '(&whole &environment)) - (clean-arglist (cddr arglist))) - ((eq (car arglist) '&aux) - '()) - (t (cons (car arglist) (clean-arglist (cdr arglist)))))) - - -(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) - provided-args ; list of the provided actual arguments - required-args ; list of the required arguments - optional-args ; list of the optional arguments - key-p ; whether &key appeared - keyword-args ; list of the keywords - rest ; name of the &rest or &body argument (if any) - body-p ; whether the rest argument is a &body - allow-other-keys-p ; whether &allow-other-keys appeared - aux-args ; list of &aux variables - any-p ; whether &any appeared - any-args ; list of &any arguments [*] - known-junk ; &whole, &environment - unknown-junk) ; unparsed stuff - -;;; -;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, -;;; and is only used to describe certain arglists that cannot be -;;; described in another way. -;;; -;;; &ANY is very similiar to &KEY but while &KEY is based upon -;;; the idea of a plist (key1 value1 key2 value2), &ANY is a -;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: -;;; -;;; a) (&ANY :A :B :C) means that you can provide any (non-null) -;;; set consisting of the keywords `:A', `:B', or `:C' in -;;; the arglist. E.g. (:A) or (:C :B :A). -;;; -;;; (This is not restricted to keywords only, but any self-evaluating -;;; expression is allowed.) -;;; -;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can -;;; provide any (non-null) set consisting of lists where -;;; the CAR of the list is one of `key1', `key2', or `key3'. -;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) -;;; -;;; -;;; For example, a) let us describe the situations of EVAL-WHEN as -;;; -;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) -;;; -;;; and b) let us describe the optimization qualifiers that are valid -;;; in the declaration specifier `OPTIMIZE': -;;; -;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) -;;; - -(defun print-arglist (arglist &key operator highlight) - (let ((index 0) - (need-space nil)) - (labels ((print-arg (arg) - (typecase arg - (arglist ; destructuring pattern - (print-arglist arg)) - (optional-arg - (princ (encode-optional-arg arg))) - (keyword-arg - (let ((enc-arg (encode-keyword-arg arg))) - (etypecase enc-arg - (symbol (princ enc-arg)) - ((cons symbol) - (pprint-logical-block (nil nil :prefix "(" :suffix ")") - (princ (car enc-arg)) - (write-char #\space) - (pprint-fill *standard-output* (cdr enc-arg) nil))) - ((cons cons) - (pprint-logical-block (nil nil :prefix "(" :suffix ")") - (pprint-logical-block (nil nil :prefix "(" :suffix ")") - (prin1 (caar enc-arg)) - (write-char #\space) - (print-arg (keyword-arg.arg-name arg))) - (unless (null (cdr enc-arg)) - (write-char #\space)) - (pprint-fill *standard-output* (cdr enc-arg) nil)))))) - (t ; required formal or provided actual arg - (princ arg)))) - (print-space () - (ecase need-space - ((nil)) - ((:miser) - (write-char #\space) - (pprint-newline :miser)) - ((t) - (write-char #\space) - (pprint-newline :fill))) - (setq need-space t)) - (print-with-space (obj) - (print-space) - (print-arg obj)) - (print-with-highlight (arg &optional (index-ok-p #'=)) - (print-space) - (cond - ((and highlight (funcall index-ok-p index highlight)) - (princ "===> ") - (print-arg arg) - (princ " <===")) - (t - (print-arg arg))) - (incf index))) - (pprint-logical-block (nil nil :prefix "(" :suffix ")") - (when operator - (print-with-highlight operator) - (setq need-space :miser)) - (mapc #'print-with-highlight - (arglist.provided-args arglist)) - (mapc #'print-with-highlight - (arglist.required-args arglist)) - (when (arglist.optional-args arglist) - (print-with-space '&optional) - (mapc #'print-with-highlight - (arglist.optional-args arglist))) - (when (arglist.key-p arglist) - (print-with-space '&key) - (mapc #'print-with-space - (arglist.keyword-args arglist))) - (when (arglist.allow-other-keys-p arglist) - (print-with-space '&allow-other-keys)) - (when (arglist.any-args arglist) - (print-with-space '&any) - (mapc #'print-with-space - (arglist.any-args arglist))) - (cond ((not (arglist.rest arglist))) - ((arglist.body-p arglist) - (print-with-space '&body) - (print-with-highlight (arglist.rest arglist) #'<=)) - (t - (print-with-space '&rest) - (print-with-highlight (arglist.rest arglist) #'<=))) - (mapc #'print-with-space - (arglist.unknown-junk arglist)))))) - -(defun decoded-arglist-to-string (arglist - &key operator highlight (package *package*) - print-right-margin print-lines) - "Print the decoded ARGLIST for display in the echo area. The -argument name are printed without package qualifiers and pretty -printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is -non-nil, it must be the index of an argument; highlight this argument. -If OPERATOR is non-nil, put it in front of the arglist." - (with-output-to-string (*standard-output*) - (with-standard-io-syntax - (let ((*package* package) (*print-case* :downcase) - (*print-pretty* t) (*print-circle* nil) (*print-readably* nil) - (*print-level* 10) (*print-length* 20) - (*print-right-margin* print-right-margin) - (*print-lines* print-lines) - (*print-escape* nil)) ; no package qualifies. - (print-arglist arglist :operator operator :highlight highlight))))) - -(defslimefun variable-desc-for-echo-area (variable-name) - "Return a short description of VARIABLE-NAME, or NIL." - (with-buffer-syntax () - (let ((sym (parse-symbol variable-name))) - (if (and sym (boundp sym)) - (let ((*print-pretty* nil) (*print-level* 4) - (*print-length* 10) (*print-circle* t)) - (format nil "~A => ~A" sym (symbol-value sym))))))) - -(defun decode-required-arg (arg) - "ARG can be a symbol or a destructuring pattern." - (etypecase arg - (symbol arg) - (list (decode-arglist arg)))) - -(defun encode-required-arg (arg) - (etypecase arg - (symbol arg) - (arglist (encode-arglist arg)))) - -(defstruct (keyword-arg - (:conc-name keyword-arg.) - (:constructor make-keyword-arg (keyword arg-name default-arg))) - keyword - arg-name - default-arg) - -(defun decode-keyword-arg (arg) - "Decode a keyword item of formal argument list. -Return three values: keyword, argument name, default arg." - (cond ((symbolp arg) - (make-keyword-arg (intern (symbol-name arg) keyword-package) [1157 lines skipped] --- /project/slime/cvsroot/slime/slime.el 2007/08/30 23:43:41 1.839 +++ /project/slime/cvsroot/slime/slime.el 2007/08/31 11:48:23 1.840 @@ -65,9 +65,6 @@ (require 'overlay)) (require 'easymenu) -(defvar slime-use-autodoc-mode nil - "When non-nil always enable slime-autodoc-mode in slime-mode.") - (defvar slime-highlight-compiler-notes t "When non-nil highlight buffers with compilation notes, warnings and errors." ) @@ -84,9 +81,7 @@ (setq slime-use-highlight-edits-mode highlight-edits)) (defun slime-shared-lisp-mode-hook () - (slime-mode 1) - (when slime-use-autodoc-mode - (slime-autodoc-mode 1))) + (slime-mode 1)) (defun slime-lisp-mode-hook () (slime-shared-lisp-mode-hook) @@ -259,7 +254,7 @@ :group 'slime-mode :type 'boolean) -(defcustom slime-complete-symbol-function 'slime-complete-symbol* +(defcustom slime-complete-symbol-function 'slime-simple-complete-symbol "*Function to perform symbol completion." :group 'slime-mode :type '(choice (const :tag "Simple" slime-simple-complete-symbol) @@ -3151,8 +3146,6 @@ (add-local-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history) (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories) (slime-setup-command-hooks) - (when slime-use-autodoc-mode - (slime-autodoc-mode 1)) ;; At the REPL, we define beginning-of-defun and end-of-defun to be ;; the start of the previous prompt or next prompt respectively. ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN. @@ -5127,278 +5120,26 @@ (slime-background-activities-enabled-p)) (slime-echo-arglist))) -(defun slime-fontify-string (string) - "Fontify STRING as `font-lock-mode' does in Lisp mode." - (with-current-buffer (get-buffer-create " *slime-fontify*") - (erase-buffer) - (if (not (eq major-mode 'lisp-mode)) - (lisp-mode)) - (insert string) - (let ((font-lock-verbose nil)) - (font-lock-fontify-buffer)) - (goto-char (point-min)) - (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t) - (let ((highlight (match-string 1))) - ;; Can't use (replace-match highlight) here -- broken in Emacs 21 - (delete-region (match-beginning 0) (match-end 0)) - (slime-insert-propertized '(face highlight) highlight))) - (buffer-substring (point-min) (point-max)))) +(defvar slime-echo-arglist-function 'slime-show-arglist) (defun slime-echo-arglist () "Display the arglist of the current form in the echo area." - (slime-autodoc)) - -(defun slime-arglist (name) - "Show the argument list for NAME." - (interactive (list (slime-read-symbol-name "Arglist of: "))) - (slime-eval-async - `(swank:arglist-for-echo-area (quote (,name))) - (lambda (arglist) - (if arglist - (message "%s" (slime-fontify-string arglist)) - (error "Arglist not available"))))) - -(defun slime-incomplete-form-at-point () - "Looks for a ``raw form spec'' around point to be processed by -SWANK::PARSE-FORM-SPEC. It is similiar to -SLIME-INCOMPLETE-SEXP-AT-POINT but looks further back than just -one sexp to find out the context." - (multiple-value-bind (operators arg-indices points) - (slime-enclosing-form-specs) - (if (null operators) - "" - (let ((op (first operators))) - (destructure-case (slime-ensure-list op) - ((:declaration declspec) op) - ((:type-specifier typespec) op) - (t (slime-ensure-list - (save-excursion (goto-char (first points)) - (slime-sexp-at-point (1+ (first arg-indices))))))))))) - -(defun slime-complete-form () - "Complete the form at point. -This is a superset of the functionality of `slime-insert-arglist'." - (interactive) - ;; Find the (possibly incomplete) form around point. - (let ((form-string (slime-incomplete-form-at-point))) - (let ((result (slime-eval `(swank:complete-form ',form-string)))) - (if (eq result :not-available) - (error "Could not generate completion for the form `%s'" form-string) - (progn - (just-one-space) - (save-excursion - ;; SWANK:COMPLETE-FORM always returns a closing - ;; parenthesis; but we only want to insert one if it's - ;; really necessary (thinking especially of paredit.el.) - (insert (substring result 0 -1)) - (let ((slime-close-parens-limit 1)) - (slime-close-all-parens-in-sexp))) - (save-excursion - (backward-up-list 1) - (indent-sexp))))))) - - -(defun slime-get-arglist (symbol-name) - "Return the argument list for SYMBOL-NAME." - (slime-eval `(swank:arglist-for-echo-area (quote (,symbol-name))))) - - -;;;; Autodocs (automatic context-sensitive help) - -(defvar slime-autodoc-mode nil - "*When non-nil, print documentation about symbols as the point moves.") - -(defvar slime-autodoc-cache-type 'last - "*Cache policy for automatically fetched documentation. -Possible values are: - nil - none. - last - cache only the most recently-looked-at symbol's documentation. - The values are stored in the variable `slime-autodoc-cache'. - -More caching means fewer calls to the Lisp process, but at the risk of -using outdated information.") - -(defvar slime-autodoc-cache nil - "Cache variable for when `slime-autodoc-cache-type' is 'last'. -The value is (SYMBOL-NAME . DOCUMENTATION).") - -(defun slime-autodoc-mode (&optional arg) - "Enable `slime-autodoc'." - (interactive "P") - (cond ((< (prefix-numeric-value arg) 0) (setq slime-autodoc-mode nil)) - (arg (setq slime-autodoc-mode t)) - (t (setq slime-autodoc-mode (not slime-autodoc-mode)))) - (if slime-autodoc-mode - (progn - (slime-autodoc-start-timer) - (add-hook 'pre-command-hook - 'slime-autodoc-pre-command-refresh-echo-area t)) - (slime-autodoc-stop-timer))) - -(defvar slime-autodoc-last-message "") - -(defun slime-autodoc () - "Print some apropos information about the code at point, if applicable." - (destructuring-bind (cache-key retrieve-form) (slime-autodoc-thing-at-point) - (let ((cached (slime-get-cached-autodoc cache-key))) - (if cached - (slime-autodoc-message cached) - ;; Asynchronously fetch, cache, and display documentation - (slime-eval-async - retrieve-form - (with-lexical-bindings (cache-key) - (lambda (doc) - (let ((doc (if doc (slime-fontify-string doc) ""))) - (slime-update-autodoc-cache cache-key doc) - (slime-autodoc-message doc))))))))) - -(defcustom slime-autodoc-use-multiline-p nil - "If non-nil, allow long autodoc messages to resize echo area display." - :type 'boolean - :group 'slime-ui) - -(defvar slime-autodoc-message-function 'slime-autodoc-show-message) + (funcall slime-echo-arglist-function)) -(defun slime-autodoc-message (doc) - "Display the autodoc documentation string DOC." - (funcall slime-autodoc-message-function doc)) - -(defun slime-autodoc-show-message (doc) - (unless slime-autodoc-use-multiline-p - (setq doc (slime-oneliner doc))) - (setq slime-autodoc-last-message doc) - (message "%s" doc)) - -(defun slime-autodoc-message-dimensions () - "Return the available width and height for pretty printing autodoc -messages." - (cond - (slime-autodoc-use-multiline-p - ;; Use the full width of the minibuffer; - ;; minibuffer will grow vertically if necessary - (values (window-width (minibuffer-window)) - nil)) - (t - ;; Try to fit everything in one line; we cut off when displaying - (values 1000 1)))) - -(defun slime-autodoc-pre-command-refresh-echo-area () - (unless (string= slime-autodoc-last-message "") - (if (slime-autodoc-message-ok-p) - (message "%s" slime-autodoc-last-message) - (setq slime-autodoc-last-message "")))) - -(defun slime-autodoc-thing-at-point () - "Return a cache key and a swank form." - (let ((global (slime-autodoc-global-at-point))) - (if global - (values (slime-qualify-cl-symbol-name global) - `(swank:variable-desc-for-echo-area ,global)) - (multiple-value-bind (operators arg-indices points) - (slime-enclosing-form-specs) - (values (mapcar* (lambda (designator arg-index) - (cons - (if (symbolp designator) - (slime-qualify-cl-symbol-name designator) - designator) - arg-index)) - operators arg-indices) - (multiple-value-bind (width height) - (slime-autodoc-message-dimensions) - `(swank:arglist-for-echo-area ',operators - :arg-indices ',arg-indices - :print-right-margin ,width - :print-lines ,height))))))) - -(defun slime-autodoc-global-at-point () - "Return the global variable name at point, if any." - (when-let (name (slime-symbol-name-at-point)) - (if (slime-global-variable-name-p name) name))) +(defun slime-show-arglist () + (let ((op (slime-operator-before-point))) + (when op + (slime-eval-async `(swank:operator-arglist ,op ,(slime-current-package)) + (lambda (arglist) + (when arglist + (slime-message "%s" arglist))))))) -(defcustom slime-global-variable-name-regexp "^\\(.*:\\)?\\([*+]\\).+\\2$" - "Regexp used to check if a symbol name is a global variable. - -Default value assumes +this+ or *that* naming conventions." - :type 'regexp - :group 'slime) - -(defun slime-global-variable-name-p (name) - "Is NAME a global variable? -Globals are recognised purely by *this-naming-convention*." - (and (< (length name) 80) ; avoid overflows in regexp matcher - (string-match slime-global-variable-name-regexp name))) - -(defun slime-get-cached-autodoc (symbol-name) - "Return the cached autodoc documentation for SYMBOL-NAME, or nil." - (ecase slime-autodoc-cache-type - ((nil) nil) - ((last) - (when (equal (car slime-autodoc-cache) symbol-name) - (cdr slime-autodoc-cache))) - ((all) - (when-let (symbol (intern-soft symbol-name)) - (get symbol 'slime-autodoc-cache))))) - -(defun slime-update-autodoc-cache (symbol-name documentation) - "Update the autodoc cache for SYMBOL with DOCUMENTATION. -Return DOCUMENTATION." - (ecase slime-autodoc-cache-type - ((nil) nil) - ((last) - (setq slime-autodoc-cache (cons symbol-name documentation))) - ((all) - (put (intern symbol-name) 'slime-autodoc-cache documentation))) - documentation) - - -;;;;; Asynchronous message idle timer - -(defvar slime-autodoc-idle-timer nil - "Idle timer for the next autodoc message.") - -(defvar slime-autodoc-delay 0.2 - "*Delay before autodoc messages are fetched and displayed, in seconds.") - -(defun slime-autodoc-start-timer () - "(Re)start the timer that prints autodocs every `slime-autodoc-delay' seconds." - (interactive) - (when slime-autodoc-idle-timer - (cancel-timer slime-autodoc-idle-timer)) - (setq slime-autodoc-idle-timer - (run-with-idle-timer slime-autodoc-delay slime-autodoc-delay - 'slime-autodoc-timer-hook))) - -(defun slime-autodoc-stop-timer () - "Stop the timer that prints autodocs. -See also `slime-autodoc-start-timer'." - (when slime-autodoc-idle-timer - (cancel-timer slime-autodoc-idle-timer) - (setq slime-autodoc-idle-timer nil))) - -(defun slime-autodoc-timer-hook () - "Function to be called after each Emacs becomes idle. -When `slime-autodoc-mode' is non-nil, print apropos information about -the symbol at point if applicable." - (when (slime-autodoc-message-ok-p) - (condition-case err - (slime-autodoc) - (error - (setq slime-autodoc-mode nil) - (message "Error: %S; slime-autodoc-mode now disabled." err))))) - -(defun slime-autodoc-message-ok-p () - "Return true if printing a message is currently okay (shouldn't -annoy the user)." - (and (or slime-mode (eq major-mode 'slime-repl-mode) - (eq major-mode 'sldb-mode)) - slime-autodoc-mode - (or (null (current-message)) - (string= (current-message) slime-autodoc-last-message)) - (not executing-kbd-macro) - (not (and (boundp 'edebug-active) (symbol-value 'edebug-active))) - (not cursor-in-echo-area) - (not (eq (selected-window) (minibuffer-window))) - (slime-background-activities-enabled-p))) +(defun slime-operator-before-point () + (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (slime-symbol-name-at-point)))) ;;;; Completion @@ -5514,65 +5255,6 @@ (interactive) (funcall slime-complete-symbol-function)) -(defun slime-complete-symbol* () - "Expand abbreviations and complete the symbol at point." - ;; NB: It is only the name part of the symbol that we actually want - ;; to complete -- the package prefix, if given, is just context. - (or (slime-maybe-complete-as-filename) - (slime-expand-abbreviations-and-complete))) - -(defun slime-expand-abbreviations-and-complete () - (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) - (beg (move-marker (make-marker) (slime-symbol-start-pos))) - (prefix (buffer-substring-no-properties beg end)) - (completion-result (slime-contextual-completions beg end)) - (completion-set (first completion-result)) - (completed-prefix (second completion-result))) - (if (null completion-set) - (progn (slime-minibuffer-respecting-message - "Can't find completion for \"%s\"" prefix) - (ding) - (slime-complete-restore-window-configuration)) - (goto-char end) - (insert-and-inherit completed-prefix) - (delete-region beg end) - (goto-char (+ beg (length completed-prefix))) - (cond ((and (member completed-prefix completion-set) - (slime-length= completion-set 1)) - (slime-minibuffer-respecting-message "Sole completion") - (when slime-complete-symbol*-fancy - (slime-complete-symbol*-fancy-bit)) - (slime-complete-restore-window-configuration)) - ;; Incomplete - (t - (when (member completed-prefix completion-set) - (slime-minibuffer-respecting-message - "Complete but not unique")) - (slime-display-or-scroll-completions completion-set - completed-prefix)))))) - -(defun slime-complete-symbol*-fancy-bit () - "Do fancy tricks after completing a symbol. -\(Insert a space or close-paren based on arglist information.)" - (let ((arglist (slime-get-arglist (slime-symbol-name-at-point)))) - (when arglist - (let ((args - ;; Don't intern these symbols - (let ((obarray (make-vector 10 0))) - (cdr (read arglist)))) - (function-call-position-p - (save-excursion - (backward-sexp) - (equal (char-before) ?\()))) - (when function-call-position-p - (if (null args) - (insert-and-inherit ")") - (insert-and-inherit " ") - (when (and slime-space-information-p - (slime-background-activities-enabled-p) - (not (minibuffer-window-active-p (minibuffer-window)))) - (slime-echo-arglist)))))))) - (defun slime-simple-complete-symbol () "Complete the symbol at point. [608 lines skipped] From heller at common-lisp.net Fri Aug 31 11:48:24 2007 From: heller at common-lisp.net (heller) Date: Fri, 31 Aug 2007 07:48:24 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831114824.2E6443700E@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv22347/contrib Modified Files: ChangeLog swank-fuzzy.lisp Added Files: slime-autodoc.el slime-c-p-c.el slime-editing-commands.el slime-parse.el swank-arglists.lisp swank-c-p-c.lisp Log Message: Move compound prefix completion and autodoc to contrib. * swank.lisp (simple-completions): Rewritten for simplicity. (operator-arglist): Rewritten for simplicity. * slime.el (slime-complete-symbol-function): Make simple completion the default. (slime-echo-arglist-function, slime-echo-arglist): New hook. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/28 22:00:48 1.15 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 11:48:23 1.16 @@ -1,3 +1,16 @@ +2007-08-31 Helmut Eller + + Move compound prefix completion and autodoc to contrib. + Interdependencies made it almost necessary to move parsing code + and editing commands in the same patch. + + * slime-c-p-c.el: New file. + * swank-c-p-c.el: New file. + * slime-parse.el: New file. + * swank-arglists.el: New file. + * slime-editing-commands.el: New file. + * slime-autodoc.el: New file. + 2007-08-28 Matthias Koeppe * slime-presentations.el (slime-last-output-target-id) --- /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/27 15:00:35 1.3 +++ /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/31 11:48:23 1.4 @@ -7,6 +7,9 @@ (in-package :swank) +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + ;;; For nomenclature of the fuzzy completion section, please read ;;; through the following docstring. @@ -108,6 +111,10 @@ symbol-chunks)) (classify-symbol symbol))))) +(defun format-completion-result (string internal-p package-name) + (let ((result (untokenize-symbol package-name internal-p string))) + ;; We return the length of the possibly added prefix as second value. + (values result (search string result)))) (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec) "Returns two values: an array of completion objects, sorted by --- /project/slime/cvsroot/slime/contrib/slime-autodoc.el 2007/08/31 11:48:24 NONE +++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el 2007/08/31 11:48:24 1.1 ;;; slime-autodoc.el --- show fancy arglist in echo area ;; ;; Authors: Luke Gorrie ;; Lawrence Mitchell ;; Matthias Koeppe ;; Tobias C. Rittweiler ;; and others ;; ;; License: GNU GPL (same license as Emacs) ;; (require 'slime-parse) (defvar slime-use-autodoc-mode nil "When non-nil always enable slime-autodoc-mode in slime-mode.") (defun slime-fontify-string (string) "Fontify STRING as `font-lock-mode' does in Lisp mode." (with-current-buffer (get-buffer-create " *slime-fontify*") (erase-buffer) (if (not (eq major-mode 'lisp-mode)) (lisp-mode)) (insert string) (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) (goto-char (point-min)) (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t) (let ((highlight (match-string 1))) ;; Can't use (replace-match highlight) here -- broken in Emacs 21 (delete-region (match-beginning 0) (match-end 0)) (slime-insert-propertized '(face highlight) highlight))) (buffer-substring (point-min) (point-max)))) (defun slime-arglist (name) "Show the argument list for NAME." (interactive (list (slime-read-symbol-name "Arglist of: "))) (slime-eval-async `(swank:arglist-for-echo-area (quote (,name))) (lambda (arglist) (if arglist (message "%s" (slime-fontify-string arglist)) (error "Arglist not available"))))) ;;;; Autodocs (automatic context-sensitive help) (defvar slime-autodoc-mode nil "*When non-nil, print documentation about symbols as the point moves.") (defvar slime-autodoc-cache-type 'last "*Cache policy for automatically fetched documentation. Possible values are: nil - none. last - cache only the most recently-looked-at symbol's documentation. The values are stored in the variable `slime-autodoc-cache'. More caching means fewer calls to the Lisp process, but at the risk of using outdated information.") (defvar slime-autodoc-cache nil "Cache variable for when `slime-autodoc-cache-type' is 'last'. The value is (SYMBOL-NAME . DOCUMENTATION).") (defun slime-autodoc-mode (&optional arg) "Enable `slime-autodoc'." (interactive "P") (cond ((< (prefix-numeric-value arg) 0) (setq slime-autodoc-mode nil)) (arg (setq slime-autodoc-mode t)) (t (setq slime-autodoc-mode (not slime-autodoc-mode)))) (if slime-autodoc-mode (progn (slime-autodoc-start-timer) (add-hook 'pre-command-hook 'slime-autodoc-pre-command-refresh-echo-area t)) (slime-autodoc-stop-timer))) (defvar slime-autodoc-last-message "") (defun slime-autodoc () "Print some apropos information about the code at point, if applicable." (destructuring-bind (cache-key retrieve-form) (slime-autodoc-thing-at-point) (let ((cached (slime-get-cached-autodoc cache-key))) (if cached (slime-autodoc-message cached) ;; Asynchronously fetch, cache, and display documentation (slime-eval-async retrieve-form (with-lexical-bindings (cache-key) (lambda (doc) (let ((doc (if doc (slime-fontify-string doc) ""))) (slime-update-autodoc-cache cache-key doc) (slime-autodoc-message doc))))))))) (defcustom slime-autodoc-use-multiline-p nil "If non-nil, allow long autodoc messages to resize echo area display." :type 'boolean :group 'slime-ui) (defvar slime-autodoc-message-function 'slime-autodoc-show-message) (defun slime-autodoc-message (doc) "Display the autodoc documentation string DOC." (funcall slime-autodoc-message-function doc)) (defun slime-autodoc-show-message (doc) (unless slime-autodoc-use-multiline-p (setq doc (slime-oneliner doc))) (setq slime-autodoc-last-message doc) (message "%s" doc)) (defun slime-autodoc-message-dimensions () "Return the available width and height for pretty printing autodoc messages." (cond (slime-autodoc-use-multiline-p ;; Use the full width of the minibuffer; ;; minibuffer will grow vertically if necessary (values (window-width (minibuffer-window)) nil)) (t ;; Try to fit everything in one line; we cut off when displaying (values 1000 1)))) (defun slime-autodoc-pre-command-refresh-echo-area () (unless (string= slime-autodoc-last-message "") (if (slime-autodoc-message-ok-p) (message "%s" slime-autodoc-last-message) (setq slime-autodoc-last-message "")))) (defun slime-autodoc-thing-at-point () "Return a cache key and a swank form." (let ((global (slime-autodoc-global-at-point))) (if global (values (slime-qualify-cl-symbol-name global) `(swank:variable-desc-for-echo-area ,global)) (multiple-value-bind (operators arg-indices points) (slime-enclosing-form-specs) (values (mapcar* (lambda (designator arg-index) (cons (if (symbolp designator) (slime-qualify-cl-symbol-name designator) designator) arg-index)) operators arg-indices) (multiple-value-bind (width height) (slime-autodoc-message-dimensions) `(swank:arglist-for-echo-area ',operators :arg-indices ',arg-indices :print-right-margin ,width :print-lines ,height))))))) (defun slime-autodoc-global-at-point () "Return the global variable name at point, if any." (when-let (name (slime-symbol-name-at-point)) (if (slime-global-variable-name-p name) name))) (defcustom slime-global-variable-name-regexp "^\\(.*:\\)?\\([*+]\\).+\\2$" "Regexp used to check if a symbol name is a global variable. Default value assumes +this+ or *that* naming conventions." :type 'regexp :group 'slime) (defun slime-global-variable-name-p (name) "Is NAME a global variable? Globals are recognised purely by *this-naming-convention*." (and (< (length name) 80) ; avoid overflows in regexp matcher (string-match slime-global-variable-name-regexp name))) (defun slime-get-cached-autodoc (symbol-name) "Return the cached autodoc documentation for SYMBOL-NAME, or nil." (ecase slime-autodoc-cache-type ((nil) nil) ((last) (when (equal (car slime-autodoc-cache) symbol-name) (cdr slime-autodoc-cache))) ((all) (when-let (symbol (intern-soft symbol-name)) (get symbol 'slime-autodoc-cache))))) (defun slime-update-autodoc-cache (symbol-name documentation) "Update the autodoc cache for SYMBOL with DOCUMENTATION. Return DOCUMENTATION." (ecase slime-autodoc-cache-type ((nil) nil) ((last) (setq slime-autodoc-cache (cons symbol-name documentation))) ((all) (put (intern symbol-name) 'slime-autodoc-cache documentation))) documentation) ;;;;; Asynchronous message idle timer (defvar slime-autodoc-idle-timer nil "Idle timer for the next autodoc message.") (defvar slime-autodoc-delay 0.2 "*Delay before autodoc messages are fetched and displayed, in seconds.") (defun slime-autodoc-start-timer () "(Re)start the timer that prints autodocs every `slime-autodoc-delay' seconds." (interactive) (when slime-autodoc-idle-timer (cancel-timer slime-autodoc-idle-timer)) (setq slime-autodoc-idle-timer (run-with-idle-timer slime-autodoc-delay slime-autodoc-delay 'slime-autodoc-timer-hook))) (defun slime-autodoc-stop-timer () "Stop the timer that prints autodocs. See also `slime-autodoc-start-timer'." (when slime-autodoc-idle-timer (cancel-timer slime-autodoc-idle-timer) (setq slime-autodoc-idle-timer nil))) (defun slime-autodoc-timer-hook () "Function to be called after each Emacs becomes idle. When `slime-autodoc-mode' is non-nil, print apropos information about the symbol at point if applicable." (when (slime-autodoc-message-ok-p) (condition-case err (slime-autodoc) (error (setq slime-autodoc-mode nil) (message "Error: %S; slime-autodoc-mode now disabled." err))))) (defun slime-autodoc-message-ok-p () "Return true if printing a message is currently okay (shouldn't annoy the user)." (and (or slime-mode (eq major-mode 'slime-repl-mode) (eq major-mode 'sldb-mode)) slime-autodoc-mode (or (null (current-message)) (string= (current-message) slime-autodoc-last-message)) (not executing-kbd-macro) (not (and (boundp 'edebug-active) (symbol-value 'edebug-active))) (not cursor-in-echo-area) (not (eq (selected-window) (minibuffer-window))) (slime-background-activities-enabled-p))) ;;; Initialization (defun slime-autodoc-init () (setq slime-echo-arglist-function 'slime-autodoc) (add-hook 'slime-connected-hook 'slime-autodoc-on-connect) (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) (add-hook h 'slime-autodoc-maybe-enable))) (defun slime-autodoc-on-connect () (slime-eval-async '(swank:swank-require :swank-arglists))) (defun slime-autodoc-maybe-enable () (when slime-use-autodoc-mode (slime-autodoc-mode 1))) (slime-autodoc-init) (provide 'slime-autodoc) --- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 11:48:24 NONE +++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 11:48:24 1.1 ;;; slime-c-p-c.el --- ILISP style Compound Prefix Completion ;; ;; Authors: Luke Gorrie ;; Edi Weitz ;; Matthias Koeppe ;; Tobias C. Rittweiler ;; and others ;; ;; License: GNU GPL (same license as Emacs) ;; ;;; ;; ;; (require 'slime-parse) (require 'slime-editing-commands) (defun slime-complete-symbol* () "Expand abbreviations and complete the symbol at point." ;; NB: It is only the name part of the symbol that we actually want ;; to complete -- the package prefix, if given, is just context. (or (slime-maybe-complete-as-filename) (slime-expand-abbreviations-and-complete))) ;; FIXME: there is no consesus where point should end up after ;; completion. Some want it after the first non-completed prefix, ;; others at the end of the inserted text. (defun slime-expand-abbreviations-and-complete () (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) (beg (move-marker (make-marker) (slime-symbol-start-pos))) (prefix (buffer-substring-no-properties beg end)) (completion-result (slime-contextual-completions beg end)) (completion-set (first completion-result)) (completed-prefix (second completion-result))) (if (null completion-set) (progn (slime-minibuffer-respecting-message "Can't find completion for \"%s\"" prefix) (ding) (slime-complete-restore-window-configuration)) (goto-char end) (insert-and-inherit completed-prefix) (delete-region beg end) (goto-char (+ beg (length completed-prefix))) (cond ((and (member completed-prefix completion-set) (slime-length= completion-set 1)) (slime-minibuffer-respecting-message "Sole completion") (when slime-complete-symbol*-fancy (slime-complete-symbol*-fancy-bit)) (slime-complete-restore-window-configuration)) ;; Incomplete (t (when (member completed-prefix completion-set) (slime-minibuffer-respecting-message "Complete but not unique")) (slime-display-or-scroll-completions completion-set completed-prefix)))))) (defun slime-complete-symbol*-fancy-bit () "Do fancy tricks after completing a symbol. \(Insert a space or close-paren based on arglist information.)" (let ((arglist (slime-get-arglist (slime-symbol-name-at-point)))) (when arglist (let ((args ;; Don't intern these symbols (let ((obarray (make-vector 10 0))) (cdr (read arglist)))) (function-call-position-p (save-excursion (backward-sexp) (equal (char-before) ?\()))) (when function-call-position-p (if (null args) (insert-and-inherit ")") (insert-and-inherit " ") (when (and slime-space-information-p (slime-background-activities-enabled-p) (not (minibuffer-window-active-p (minibuffer-window)))) (slime-echo-arglist)))))))) (defun slime-get-arglist (symbol-name) "Return the argument list for SYMBOL-NAME." (slime-eval `(swank:arglist-for-echo-area (quote (,symbol-name))))) (defun* slime-contextual-completions (beg end) "Return a list of completions of the token from BEG to END in the current buffer." (let ((token (buffer-substring-no-properties beg end))) (cond ((and (< beg (point-max)) (string= (buffer-substring-no-properties beg (1+ beg)) ":")) ;; Contextual keyword completion (multiple-value-bind (operator-names arg-indices points) (save-excursion (goto-char beg) (slime-enclosing-form-specs)) (when operator-names (let ((completions (slime-completions-for-keyword operator-names token arg-indices))) (when (first completions) (return-from slime-contextual-completions completions)) ;; If no matching keyword was found, do regular symbol ;; completion. )))) ((and (> beg 2) (string= (buffer-substring-no-properties (- beg 2) beg) "#\\")) ;; Character name completion (return-from slime-contextual-completions (slime-completions-for-character token)))) ;; Regular symbol completion (slime-completions token))) (defun slime-completions (prefix) (slime-eval `(swank:completions ,prefix ',(slime-current-package)))) [45 lines skipped] --- /project/slime/cvsroot/slime/contrib/slime-editing-commands.el 2007/08/31 11:48:24 NONE +++ /project/slime/cvsroot/slime/contrib/slime-editing-commands.el 2007/08/31 11:48:24 1.1 [225 lines skipped] --- /project/slime/cvsroot/slime/contrib/slime-parse.el 2007/08/31 11:48:24 NONE +++ /project/slime/cvsroot/slime/contrib/slime-parse.el 2007/08/31 11:48:24 1.1 [575 lines skipped] --- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/08/31 11:48:24 NONE +++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/08/31 11:48:24 1.1 [1711 lines skipped] --- /project/slime/cvsroot/slime/contrib/swank-c-p-c.lisp 2007/08/31 11:48:24 NONE +++ /project/slime/cvsroot/slime/contrib/swank-c-p-c.lisp 2007/08/31 11:48:24 1.1 [1990 lines skipped] From heller at common-lisp.net Fri Aug 31 12:23:13 2007 From: heller at common-lisp.net (heller) Date: Fri, 31 Aug 2007 08:23:13 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831122313.0D8195411F@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv625 Modified Files: slime-c-p-c.el Log Message: * slime-c-p-c.el (slime-c-p-c-init): Fix typos. --- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 11:48:23 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 12:23:12 1.2 @@ -8,9 +8,14 @@ ;; ;; License: GNU GPL (same license as Emacs) ;; -;;; +;;; Installation ;; +;; Add this to your .emacs: ;; +;; (add-to-list 'load-path "") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-c-p-c))) +;; + (require 'slime-parse) @@ -151,10 +156,12 @@ ;;; Initialization (defun slime-c-p-c-init () - (setq 'slime-complete-symbol-function 'slime-complete-symbol*) + (setq slime-complete-symbol-function 'slime-complete-symbol*) (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect)) (defun slime-c-p-c-on-connect () - (slime-eval-async '(swank:swank-require :arglists))) + (slime-eval-async '(swank:swank-require :swank-arglists))) + +(slime-c-p-c-init) (provide 'slime-c-p-c) From heller at common-lisp.net Fri Aug 31 12:23:19 2007 From: heller at common-lisp.net (heller) Date: Fri, 31 Aug 2007 08:23:19 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831122319.16FD856200@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv661 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 11:48:23 1.16 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 12:23:19 1.17 @@ -1,5 +1,9 @@ 2007-08-31 Helmut Eller + * slime-c-p-c.el (slime-c-p-c-init): Fix typos. + +2007-08-31 Helmut Eller + Move compound prefix completion and autodoc to contrib. Interdependencies made it almost necessary to move parsing code and editing commands in the same patch. From heller at common-lisp.net Fri Aug 31 13:10:47 2007 From: heller at common-lisp.net (heller) Date: Fri, 31 Aug 2007 09:10:47 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070831131047.BD09521059@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9743 Modified Files: slime.el Log Message: * slime.el (slime-obsolete-commands): New table. Use it to bind a command with an upgrade notice. --- /project/slime/cvsroot/slime/slime.el 2007/08/31 11:48:23 1.840 +++ /project/slime/cvsroot/slime/slime.el 2007/08/31 13:10:47 1.841 @@ -1,4 +1,3 @@ - ;;; slime.el -- Superior Lisp Interaction Mode for Emacs ;; ;;;; License @@ -638,17 +637,12 @@ ("\C-c" slime-compile-defun :prefixed t) ("\C-l" slime-load-file :prefixed t) ;; Editing/navigating - ("\M-\C-a" slime-beginning-of-defun :inferior t) - ("\M-\C-e" slime-end-of-defun :inferior t) ("\M-\C-i" slime-complete-symbol :inferior t) ("\C-i" slime-complete-symbol :prefixed t :inferior t) ("\M-." slime-edit-definition :inferior t :sldb t) ("\C-x4." slime-edit-definition-other-window :inferior t :sldb t) ("\C-x5." slime-edit-definition-other-frame :inferior t :sldb t) ("\M-," slime-pop-find-definition-stack :inferior t :sldb t) - ; Obsolete; see comment at SLIME-CLOSE-PARENS-AT-POINT. - ;("\C-q" slime-close-parens-at-point :prefixed t :inferior t) - ("\C-c\M-q" slime-reindent-defun :inferior t) ;; Evaluating ("\C-x\C-e" slime-eval-last-expression :inferior t) ("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) @@ -664,7 +658,6 @@ ("\M-g" slime-quit :prefixed t :inferior t :sldb t) ;; Documentation (" " slime-space :inferior t) - ("\C-s" slime-complete-form :prefixed t :inferior t) ("\C-f" slime-describe-function :prefixed t :inferior t :sldb t) ("\M-d" slime-disassemble-symbol :prefixed t :inferior t :sldb t) ("\C-t" slime-toggle-trace-fdefinition :prefixed t :sldb t) @@ -783,7 +776,6 @@ [ "Edit Definition..." slime-edit-definition ,C ] [ "Return From Definition" slime-pop-find-definition-stack ,C ] [ "Complete Symbol" slime-complete-symbol ,C ] - [ "Complete Form" slime-complete-form ,C ] [ "Show REPL" slime-switch-to-output-buffer ,C ] "--" ("Evaluation" @@ -824,7 +816,6 @@ [ "List Callees..." slime-list-callees ,C ] [ "Next Location" slime-next-location t ]) ("Editing" - [ "Close All Parens" slime-close-all-parens-in-sexp t] [ "Check Parens" check-parens t] [ "Update Indentation" slime-update-indentation ,C] [ "Select Buffer" slime-selector t]) @@ -9640,18 +9631,36 @@ ;;; Some "nice" backward compatiblity bindings for lusers. -(unless (lookup-key slime-mode-map "\C-c\M-i") - (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-upgrade-notice) - (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-upgrade-notice)) +(defvar slime-obsolete-commands + '(("\C-c\M-i" (slime repl) slime-fuzzy-complete-symbol) + ("\M-\C-a" (slime) slime-beginning-of-defun) + ("\M-\C-e" (slime) slime-end-of-defun) + ("\C-c\M-q" (slime) slime-reindent-defun) + ("\C-c\C-s" (slime) slime-complete-form) + ;; (nil nil slime-close-all-parens-in-sexp) + )) + +(defun slime-bind-obsolete-commands () + (loop for (key maps command) in slime-obsolete-commands do + (dolist (m maps) (slime-bind-obsolete-command m key command)))) + +(defun slime-bind-obsolete-command (map key command) + (let ((map (ecase map + (slime slime-mode-map) + (repl slime-repl-mode-map)))) + (unless (lookup-key map key) + (define-key map key `(lambda (&rest _) + (interactive) + (slime-upgrade-notice ',command)))))) -(defun slime-fuzzy-upgrade-notice () - (interactive) - (slime-timebomb "slime-fuzzy-complete-symbol is not loaded. +(slime-bind-obsolete-commands) -Fuzzy completion has been moved to contrib. +(defun slime-upgrade-notice (command) + (slime-timebomb (format "The command `%s' has been moved to contrib. Please consult the README file in the contrib directory for details. -To fetch the contrib directoy use: cvs update -d contrib" +To fetch the contrib directoy use: cvs update -d" + command) 15)) ;;;; ... with gratuitous bloat From heller at common-lisp.net Fri Aug 31 13:11:03 2007 From: heller at common-lisp.net (heller) Date: Fri, 31 Aug 2007 09:11:03 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20070831131103.B8F222105A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9774 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2007/08/31 11:48:22 1.1191 +++ /project/slime/cvsroot/slime/ChangeLog 2007/08/31 13:11:03 1.1192 @@ -9,6 +9,11 @@ completion the default. (slime-echo-arglist-function, slime-echo-arglist): New hook. + Remove corresponding key bindigs. + + * slime.el (slime-obsolete-commands): New table. Use it to bind + a command with an upgrade notice. + 2007-08-31 Andreas Fuchs * slime.el (slime-reindent-defun): Fixed when used in lisp file From heller at common-lisp.net Fri Aug 31 14:07:54 2007 From: heller at common-lisp.net (heller) Date: Fri, 31 Aug 2007 10:07:54 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831140754.780B9601A9@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv17575 Modified Files: ChangeLog slime-autodoc.el slime-c-p-c.el slime-editing-commands.el Log Message: * slime-autodoc.el: Add installation notes. * slime-editing-commands.el: Add installation notes. * slime-c-p-c.el (slime-c-p-c-init): Fix typos. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 12:23:19 1.17 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 14:07:54 1.18 @@ -1,5 +1,7 @@ 2007-08-31 Helmut Eller + * slime-autodoc.el: Add installation notes. + * slime-editing-commands.el: Add installation notes. * slime-c-p-c.el (slime-c-p-c-init): Fix typos. 2007-08-31 Helmut Eller --- /project/slime/cvsroot/slime/contrib/slime-autodoc.el 2007/08/31 11:48:23 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el 2007/08/31 14:07:54 1.2 @@ -8,6 +8,13 @@ ;; ;; License: GNU GPL (same license as Emacs) ;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-autodoc))) +;; (require 'slime-parse) --- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 12:23:12 1.2 +++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 14:07:54 1.3 @@ -157,7 +157,9 @@ (defun slime-c-p-c-init () (setq slime-complete-symbol-function 'slime-complete-symbol*) - (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect)) + (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect) + (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form) + ) (defun slime-c-p-c-on-connect () (slime-eval-async '(swank:swank-require :swank-arglists))) --- /project/slime/cvsroot/slime/contrib/slime-editing-commands.el 2007/08/31 11:48:23 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-editing-commands.el 2007/08/31 14:07:54 1.2 @@ -8,8 +8,13 @@ ;; ;; License: GNU GPL (same license as Emacs) ;; -;;; +;;; Installation ;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-editing-commands))) +;; (add-hook 'slime-mode-hook 'slime-bind-editing-commands) ;; (defun slime-beginning-of-defun () @@ -177,4 +182,9 @@ (setf end (point))) (indent-region start end nil))))) +(defun slime-bind-editing-commands () + (define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun) + (define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun) + (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun)) + (provide 'slime-editing-commands) From trittweiler at common-lisp.net Fri Aug 31 15:35:51 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 31 Aug 2007 11:35:51 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831153551.AD64628262@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv31717/contrib Modified Files: swank-arglists.lisp Log Message: * swank-arglist.lisp: Do not fall back to READ when interpreting the ``raw form specs'' comming from Slime's autodoc stuff. But still do so for those comming from `slime-complete-form'. (unintern-in-home-package): New. (*arglist-dummy*): New. (read-conversatively-for-autodoc): New function. Doesn't READ anything that comes from Slime's autodoc. Just tries to parse symbols. If that's not successfull, returns the dummy placeholder datum stored in `*arglist-dummy*'. (arglist-for-echo-area): Parse form-specs using `read-conversatively-for-autodoc'. Use `unintern-in-home-package'. (read-softly): New. Splitted out from `read-form-spec'. This function tries to keep track of newly interned functions before READing. (read-form-spec): Parametrized to take a function to read the elements of the passed ``raw form spec''. Uses `read-softly' as default reader. (complete-form, completions-for-keywords): Use `unintern-in-home-package'. --- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/08/31 11:48:23 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/08/31 15:35:51 1.2 @@ -23,7 +23,6 @@ (let ((symbol (parse-symbol string))) (valid-operator-symbol-p symbol))) - (defslimefun arglist-for-echo-area (raw-specs &key arg-indices print-right-margin print-lines) "Return the arglist for the first valid ``form spec'' in @@ -35,7 +34,8 @@ (handler-case (with-buffer-syntax () (multiple-value-bind (form-spec arg-index newly-interned-symbols) - (parse-first-valid-form-spec raw-specs arg-indices) + (parse-first-valid-form-spec raw-specs arg-indices + #'read-conversatively-for-autodoc) (unwind-protect (when form-spec (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) @@ -57,12 +57,30 @@ (:declaration (format nil "(declare ~A)" stringified-arglist)) (:type-specifier (format nil "[Typespec] ~A" stringified-arglist)) (t stringified-arglist))))))) - (mapc #'unintern newly-interned-symbols)))) + (mapc #'unintern-in-home-package newly-interned-symbols)))) (error (cond) (format nil "ARGLIST (error): ~A" cond)) )) -(defun parse-form-spec (raw-spec) +(defvar *arglist-dummy* (cons :dummy nil)) + +(defun read-conversatively-for-autodoc (string) + "Tries to find the symbol that's represented by STRING. + +If it can't, this either means that STRING does not represent a +symbol, or that the symbol behind STRING would have to be freshly +interned. Because this function is supposed to be called from the +automatic arglist display stuff from Slime, interning freshly +symbols is a big no-no. + +In such a case (that no symbol could be found), the object +*ARGLIST-DUMMY* is returned instead, which works as a placeholder +datum for subsequent logics to rely on." + (multiple-value-bind (symbol found?) (parse-symbol string) + (if found? symbol *arglist-dummy*))) + + +(defun parse-form-spec (raw-spec &optional reader) "Takes a raw (i.e. unparsed) form spec from SLIME and returns a proper form spec for further processing within SWANK. Returns NIL if RAW-SPEC could not be parsed. Symbols that had to be interned @@ -115,7 +133,7 @@ (when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d")) (nth-value 1 (parse-symbol (first raw-extension)))) (multiple-value-bind (extension introduced-symbols) - (read-form-spec raw-extension) + (read-form-spec raw-extension reader) (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c. (destructuring-bind (identifier &rest args) extension (values `((,extension-flag ,identifier) , at args) @@ -132,9 +150,10 @@ (multiple-value-bind (operator found?) (parse-symbol raw-operator) (when (and found? (valid-operator-symbol-p operator)) (multiple-value-bind (parsed-args introduced-symbols) - (read-form-spec raw-args) + (read-form-spec raw-args reader) (values `(,operator , at parsed-args) introduced-symbols))))))))))) + (defun split-form-spec (spec) "Returns all three relevant information a ``form spec'' contains: the operator type, the operator, and the operands." @@ -145,58 +164,83 @@ (values :function operator-designator)) ; functions, macros, special ops (values type operator arguments)))) ; are all fbound. -(defun parse-first-valid-form-spec (raw-specs &optional arg-indices) + +(defun parse-first-valid-form-spec (raw-specs &optional arg-indices reader) "Returns the first parsed form spec in RAW-SPECS that can successfully be parsed. Additionally returns its respective index in ARG-INDICES (or NIL.), and all newly interned symbols as tertiary return value." (block traversal (mapc #'(lambda (raw-spec index) - (multiple-value-bind (spec symbols) (parse-form-spec raw-spec) + (multiple-value-bind (spec symbols) (parse-form-spec raw-spec reader) (when spec (return-from traversal (values spec index symbols))))) raw-specs (append arg-indices '#1=(nil . #1#))) nil)) ; found nothing -(defun read-form-spec (spec) - "Turns the ``raw form spec'' SPEC into a proper Common Lisp form. -It returns symbols that had to interned for the conversion as -secondary return value." +(defun read-form-spec (spec &optional reader) + "Turns the ``raw form spec'' SPEC into a proper Common Lisp +form. As secondary return value, it returns all the symbols that +had to be newly interned during the conversion. + +READER is a function that takes a string, and returns two values: +the Common Lisp datum that the string represents, a flag whether +the returned datum is a symbol and has been newly interned in +some package. + +If READER is not explicitly given, the function READ-SOFTLY is +used instead." (when spec (with-buffer-syntax () (call-with-ignored-reader-errors #'(lambda () (let ((result) (newly-interned-symbols) (ok)) (unwind-protect - (progn - (dolist (element spec) - (etypecase element - (string - (multiple-value-bind (symbol found? symbol-name package) - (parse-symbol element) - (if found? - (push symbol result) - (let ((sexp (read-from-string element))) - (when (symbolp sexp) - (push sexp newly-interned-symbols) - ;; assert that PARSE-SYMBOL didn't parse incorrectly. - (assert (and (equal symbol-name (symbol-name sexp)) - (eq package (symbol-package sexp))))) - (push sexp result))))) - (cons - (multiple-value-bind (read-spec interned-symbols) - (read-form-spec element) - (push read-spec result) - (setf newly-interned-symbols - (append interned-symbols - newly-interned-symbols)))))) - (setq ok t)) - (mapc #'unintern newly-interned-symbols)) + (dolist (element spec (setq ok t)) + (etypecase element + (string + (multiple-value-bind (sexp newly-interned?) + (funcall (or reader 'read-softly) element) + (push sexp result) + (when newly-interned? + (push sexp newly-interned-symbols)))) + (cons + (multiple-value-bind (read-spec interned-symbols) + (read-form-spec element) + (push read-spec result) + (setf newly-interned-symbols + (append interned-symbols + newly-interned-symbols)))))) + (unless ok + (mapc #'unintern-in-home-package newly-interned-symbols))) (values (nreverse result) (nreverse newly-interned-symbols)))))))) +(defun unintern-in-home-package (symbol) + (unintern symbol (symbol-package symbol))) + +(defun read-softly (string) + "Returns two values: + + 1. the object resulting from READing STRING. + + 2. T if the object is a symbol that had to be newly interned + in some package. (This does not work for symbols in + compound forms like lists or vectors.)" + (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) + (if found? + (values symbol nil) + (let ((sexp (read-from-string string))) + (values sexp + (when (symbolp sexp) + (prog1 t + ;; assert that PARSE-SYMBOL didn't parse incorrectly. + (assert (and (equal symbol-name (symbol-name sexp)) + (eq package (symbol-package sexp))))))))))) + + (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) provided-args ; list of the provided actual arguments required-args ; list of the required arguments @@ -1057,7 +1101,7 @@ (decoded-arglist-to-template-string form-completion *buffer-package* :prefix ""))))) - (mapc #'unintern newly-interned-symbols)) + (mapc #'unintern-in-home-package newly-interned-symbols)) :not-available)) @@ -1107,7 +1151,7 @@ (format-completion-set strings nil ""))) (list completion-set (longest-compound-prefix completion-set))))))))) - (mapc #'unintern newly-interned-symbols))))) + (mapc #'unintern-in-home-package newly-interned-symbols))))) (defun arglist-to-string (arglist package &key print-right-margin highlight) From trittweiler at common-lisp.net Fri Aug 31 15:36:11 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 31 Aug 2007 11:36:11 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831153611.2BD7B2F048@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv31762/contrib Modified Files: ChangeLog Log Message: * swank-arglist.lisp: Do not fall back to READ when interpreting the ``raw form specs'' comming from Slime's autodoc stuff. But still do so for those comming from `slime-complete-form'. (unintern-in-home-package): New. (*arglist-dummy*): New. (read-conversatively-for-autodoc): New function. Doesn't READ anything that comes from Slime's autodoc. Just tries to parse symbols. If that's not successfull, returns the dummy placeholder datum stored in `*arglist-dummy*'. (arglist-for-echo-area): Parse form-specs using `read-conversatively-for-autodoc'. Use `unintern-in-home-package'. (read-softly): New. Splitted out from `read-form-spec'. This function tries to keep track of newly interned functions before READing. (read-form-spec): Parametrized to take a function to read the elements of the passed ``raw form spec''. Uses `read-softly' as default reader. (complete-form, completions-for-keywords): Use `unintern-in-home-package'. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 14:07:54 1.18 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 15:36:11 1.19 @@ -1,3 +1,29 @@ +2007-08-31 Tobias C. Rittweiler + + * swank-arglist.lisp: Do not fall back to READ when interpreting + the ``raw form specs'' comming from Slime's autodoc stuff. But + still do so for those comming from `slime-complete-form'. + + (unintern-in-home-package): New. + + (*arglist-dummy*): New. + (read-conversatively-for-autodoc): New function. Doesn't READ + anything that comes from Slime's autodoc. Just tries to parse + symbols. If that's not successfull, returns the dummy placeholder + datum stored in `*arglist-dummy*'. + (arglist-for-echo-area): Parse form-specs using + `read-conversatively-for-autodoc'. Use `unintern-in-home-package'. + + (read-softly): New. Splitted out from `read-form-spec'. This + function tries to keep track of newly interned functions before + READing. + (read-form-spec): Parametrized to take a function to read the + elements of the passed ``raw form spec''. Uses `read-softly' as + default reader. + + (complete-form, completions-for-keywords): + Use `unintern-in-home-package'. + 2007-08-31 Helmut Eller * slime-autodoc.el: Add installation notes. From trittweiler at common-lisp.net Fri Aug 31 22:16:11 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 31 Aug 2007 18:16:11 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831221611.01FDE4B026@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv27382/contrib Modified Files: slime-c-p-c.el Log Message: Added extended arglist display for EVAL-WHEN, viz: (eval-when (:compile-toplevel :load-toplevel :execute) &body body) Notice that completion works as expected on these keywords. * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. (print-arglist): Print keywords with PRIN1 rather than PRINC, to get a result as shown above for the EVAL-WHEN case. (completions-for-keyword): Add support for &ANY args. --- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 14:07:54 1.3 +++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/08/31 22:16:11 1.4 @@ -122,8 +122,8 @@ (defun slime-completions-for-keyword (operator-designator prefix arg-indices) (slime-eval `(swank:completions-for-keyword ',operator-designator - ,prefix - ',arg-indices))) + ,prefix + ',arg-indices))) (defun slime-completions-for-character (prefix) (slime-eval `(swank:completions-for-character ,prefix))) From trittweiler at common-lisp.net Fri Aug 31 22:17:09 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 31 Aug 2007 18:17:09 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831221709.9C31154162@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv27682/contrib Modified Files: swank-arglists.lisp Log Message: Added extended arglist display for EVAL-WHEN, viz: (eval-when (:compile-toplevel :load-toplevel :execute) &body body) Notice that completion works as expected on these keywords. * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. (print-arglist): Print keywords with PRIN1 rather than PRINC, to get a result as shown above for the EVAL-WHEN case. (completions-for-keyword): Add support for &ANY args. --- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/08/31 15:35:51 1.2 +++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2007/08/31 22:17:09 1.3 @@ -316,7 +316,9 @@ (write-char #\space)) (pprint-fill *standard-output* (cdr enc-arg) nil)))))) (t ; required formal or provided actual arg - (princ arg)))) + (if (keywordp arg) + (prin1 arg) ; for &ANY args. + (princ arg))))) (print-space () (ecase need-space ((nil)) @@ -1051,6 +1053,13 @@ t)))))) (call-next-method)) +(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'eval-when)) + arguments &key (remove-args t)) + (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) + (maybecall remove-args #'remove-actual-args + (make-arglist :required-args (list (make-arglist :any-args eval-when-args)) + :rest '#:body :body-p t)))) + (defmethod arglist-dispatch ((operator-type (eql :declaration)) decl-identifier decl-args &key (remove-args t)) (with-availability (arglist) @@ -1124,33 +1133,34 @@ (multiple-value-bind (form-spec index newly-interned-symbols) (parse-first-valid-form-spec raw-specs arg-indices) (unwind-protect - (when form-spec - (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) - (unless (eql arglist :not-available) - (multiple-value-bind (type operator arguments) (split-form-spec form-spec) - (declare (ignore type arguments)) - (let* ((indices (butlast (reverse (last arg-indices (1+ index))))) - (arglist (apply #'arglist-ref arglist operator indices))) - (when (and arglist (arglist-p arglist)) - ;; It would be possible to complete keywords only if we - ;; are in a keyword position, but it is not clear if we - ;; want that. - (let* ((keywords - (mapcar #'keyword-arg.keyword - (arglist.keyword-args arglist))) - (keyword-name - (tokenize-symbol keyword-string)) - (matching-keywords - (find-matching-symbols-in-list keyword-name keywords - #'compound-prefix-match)) - (converter (completion-output-symbol-converter keyword-string)) - (strings - (mapcar converter - (mapcar #'symbol-name matching-keywords))) - (completion-set - (format-completion-set strings nil ""))) - (list completion-set - (longest-compound-prefix completion-set))))))))) + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (multiple-value-bind (type operator arguments) (split-form-spec form-spec) + (declare (ignore type arguments)) + (let* ((indices (butlast (reverse (last arg-indices (1+ index))))) + (arglist (apply #'arglist-ref arglist operator indices))) + (when (and arglist (arglist-p arglist)) + ;; It would be possible to complete keywords only if we + ;; are in a keyword position, but it is not clear if we + ;; want that. + (let* ((keywords + (append (mapcar #'keyword-arg.keyword + (arglist.keyword-args arglist)) + (remove-if-not #'keywordp (arglist.any-args arglist)))) + (keyword-name + (tokenize-symbol keyword-string)) + (matching-keywords + (find-matching-symbols-in-list keyword-name keywords + #'compound-prefix-match)) + (converter (completion-output-symbol-converter keyword-string)) + (strings + (mapcar converter + (mapcar #'symbol-name matching-keywords))) + (completion-set + (format-completion-set strings nil ""))) + (list completion-set + (longest-compound-prefix completion-set))))))))) (mapc #'unintern-in-home-package newly-interned-symbols))))) @@ -1173,7 +1183,12 @@ (test '(&whole x y z) "(y z)") (test '(x &aux y z) "(x)") (test '(x &environment env y) "(x y)") - (test '(&key ((function f))) "(&key ((function f)))"))) + (test '(&key ((function f))) "(&key ((function f)))") + (test '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)") + (test '(declare (optimize &any (speed 1) (safety 1))) + "(declare (optimize &any (speed 1) (safety 1)))") + )) (test-print-arglist) From trittweiler at common-lisp.net Fri Aug 31 22:17:52 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 31 Aug 2007 18:17:52 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831221752.C67D8560A3@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv27934/contrib Modified Files: ChangeLog Log Message: Added extended arglist display for EVAL-WHEN, viz: (eval-when (:compile-toplevel :load-toplevel :execute) &body body) Notice that completion works as expected on these keywords. * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. (print-arglist): Print keywords with PRIN1 rather than PRINC, to get a result as shown above for the EVAL-WHEN case. (completions-for-keyword): Add support for &ANY args. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 15:36:11 1.19 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 22:17:52 1.20 @@ -1,5 +1,18 @@ 2007-08-31 Tobias C. Rittweiler + Added extended arglist display for EVAL-WHEN, viz: + + (eval-when (:compile-toplevel :load-toplevel :execute) &body body) + + Notice that completion works as expected on these keywords. + + * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. + (print-arglist): Print keywords with PRIN1 rather than PRINC, + to get a result as shown above for the EVAL-WHEN case. + (completions-for-keyword): Add support for &ANY args. + +2007-08-31 Tobias C. Rittweiler + * swank-arglist.lisp: Do not fall back to READ when interpreting the ``raw form specs'' comming from Slime's autodoc stuff. But still do so for those comming from `slime-complete-form'. From trittweiler at common-lisp.net Fri Aug 31 22:40:31 2007 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 31 Aug 2007 18:40:31 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20070831224031.E5EB24507D@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv1031/contrib Modified Files: ChangeLog Log Message: Added extended arglist display for EVAL-WHEN, viz: (eval-when (:compile-toplevel :load-toplevel :execute) &body body) Notice that completion works as expected on these keywords. * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. (print-arglist): Print keywords with PRIN1 rather than PRINC, to get a result as shown above for the EVAL-WHEN case. (completions-for-keyword): Add support for &ANY args. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 22:17:52 1.20 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/31 22:40:31 1.21 @@ -2,10 +2,12 @@ Added extended arglist display for EVAL-WHEN, viz: - (eval-when (:compile-toplevel :load-toplevel :execute) &body body) + (eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) Notice that completion works as expected on these keywords. + Die, EVAL-ALWAYS, die! + * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. (print-arglist): Print keywords with PRIN1 rather than PRINC, to get a result as shown above for the EVAL-WHEN case.