R7DPYUNF6AQCVYWM4XA7KTXLCQHJTERTAXOM5ANZWK7ZZIE7CZWQC
(locked nil discoverable nil display_name "Jared Jennings" bot nil privacy "public" sensitive nil language "" max_toot_chars 5000)
'("63d5b85a4a8840df8c0a321dd8769381095bc0a0b7ef03a3aa1aa50aa23ea662" "f0743a238e80c38ca3d73bc03327ae3e529f2bc33d67efb41616ea1caffaebd6" "3ebef83a2705540325b0223388796b392f9e1e54a3063e6ba4827a380ed5477c" "a5a788e89884387d68c6e5c4e84e9d3b1a5723500a5fcf56a112d87deb6362cf" "6e6982c9bbe999b057486b0cfd7ee1884ceccac1602206cb7d4ed18cdd98abad" "37768a79b479684b0756dec7c0fc7652082910c37d8863c35b702db3f16000f8" "7c0830e1aea024fc0d4e76ba3db9f78cb37c09da2290f38af1a8fe87881007f7" "cfe4d36ed4cf00a541f7ba0deb38c94808c13a3e4c717f07bc3b9c866670e8d1" "474513bacf33a439da7b9a5df1dd11a277929d8480752675fc7d5f3816d8fdef" "b07a04cf42fe1001b2119b45f40cbc368783b5b8e1721ce3728a5f2823d97a66" "72ed8b6bffe0bfa8d097810649fd57d2b598deef47c992920aef8b5d9599eefe" "2ff9ac386eac4dffd77a33e93b0c8236bb376c5a5df62e36d4bfa821d56e4e20" "09c7e6bedcc4724a003e0ff36e045822b0385582b11a52758ed77973df04f3ee" "930243b929e5886e97390710218558ab346b31f6d04c6320d5182a81761ce9ed" "1d609285d297920b97b0d230360a8d7c3f930edcf1abe96a1d82356f9a5e228d" "abe5ee8858cd1fbe36304a8c3b2315d3e0a4ef7c8588fcc45d1c23eafb725bb6" "d600c677f1777c1e4bfb066529b5b73c0179d0499dd4ffa3f599a0fb0cfbd501" "30289fa8d502f71a392f40a0941a83842152a68c54ad69e0638ef52f04777a4c" "c7f10959cb1bc7a36ee355c765a1768d48929ec55dde137da51077ac7f899521" "773e0bfa5450c75d613cbf29734cdc876c3d59dbf85b93cff3015a8687dea158" "bf798e9e8ff00d4bf2512597f36e5a135ce48e477ce88a0764cfb5d8104e8163" "1436d643b98844555d56c59c74004eb158dc85fc55d2e7205f8d9b8c860e177f" "1e9001d2f6ffb095eafd9514b4d5974b720b275143fbc89ea046495a99c940b0" "f11e219c9d043cbd5f4b2e01713c2c24a948a98bed48828dc670bd64ae771aa1" "8f97d5ec8a774485296e366fdde6ff5589cf9e319a584b845b6f7fa788c9fa9a" "2642a1b7f53b9bb34c7f1e032d2098c852811ec2881eec2dc8cc07be004e45a0" "5111a41453244802afd93eed1a434e612a8afbdf19c52384dffab129258bab6e" "0329c772ed96053a73b9ddddf96c1183e23c267955bbdf78e7933057ce9da04b" "36ca8f60565af20ef4f30783aa16a26d96c02df7b4e54e9900a5138fb33808da" "23b564cfb74d784c73167d7de1b9a067bcca00719f81e46d09ee71a12ef7ee82" "f7ef6451d988d6e2fc86deea398eee02b3371703d88f265d31a011bd240dcf99" "3d4df186126c347e002c8366d32016948068d2e9198c496093a96775cc3b3eaa" "c560237b7505f67a271def31c706151afd7aa6eba9f69af77ec05bde5408dbcd" "24cb0b5666e1e17fb6a378c413682f57fe176775eda015eb0a98d65fbb64b127" "b0eb9e6e6dcb29c6ec4bcd72605188f482d52ee019cb0ccc73b5404be4f3a6e7" "08a89acffece58825e75479333109e01438650d27661b29212e6560070b156cf" "c9ddf33b383e74dac7690255dd2c3dfa1961a8e8a1d20e401c6572febef61045" "a22f40b63f9bc0a69ebc8ba4fbc6b452a4e3f84b80590ba0a92b4ff599e53ad0" "585942bb24cab2d4b2f74977ac3ba6ddbd888e3776b9d2f993c5704aa8bb4739" "fa2af0c40576f3bde32290d7f4e7aa865eb6bf7ebe31eb9e37c32aa6f4ae8d10" "85d1dbf2fc0e5d30f236712b831fb24faf6052f3114964fdeadede8e1b329832" "bffb799032a7404b33e431e6a1c46dc0ca62f54fdd20744a35a57c3f78586646" "779df25c6240f183dd378811465566082eacc3c86ed260835382cb5c1dc54de3" "eee70baee3a2d093a98fa344480d2330eb3a17f8dfa883cc41d8008cd46fa669" "b70474b8a631f73868f01fdb047f102dd36325ecbf6789962e613e9195e165d7" "ccdd152be99a9250f5c24e09860911ff4b1519a8c4c73e4d67364514a3359f71" "ba913d12adb68e9dadf1f43e6afa8e46c4822bb96a289d5bf1204344064f041e" "146614f131e5029df850a268aff1f0e3ae16734a119904eab133755b574da37d" "c8935cb969e24ff30a6ee1da011eadc156b9f128a3b0a39cc664628838a644ad" "767a6105de48707dd6a593b62c05a7bf4ee9930c86e3225410110d95906772d6" "39546362fed4d5201b2b386dc21f21439497c9eec5fee323d953b3e230e4083e" "2f4f50d98073c01038b518066840638455657dc91dd1a225286d573926f36914" "80ae3a89f1eca6fb94a525004f66b544e347c6f756aaafb728c7cdaef85ea1f5" "7b1a2c8ec90a30cc5d039db0e52f192a291f4c3655103cf669721f94028eac27" "bcd0237b2a5b7897e482458cc62c4f3fa3d9d7f9a9667338e67d4c7a8e009819" "8e79884e89740cf6b7e0210f52e4ac995dc1f1a9a17151bfcfb4d660757a011b" "454c1c9ce70f7d807c51c890910365fd3c64a9e63f596511e9ff57dd97bbeea8" "387b487737860e18cbb92d83a42616a67c1edfd0664d521940e7fbf049c315ae" "6231254e74298a1cf8a5fee7ca64352943de4b495e615c449e9bb27e2ccae709" "3577ee091e1d318c49889574a31175970472f6f182a9789f1a3e9e4513641d86" "cbd85ab34afb47003fa7f814a462c24affb1de81ebf172b78cb4e65186ba59d2" "8f5b54bf6a36fe1c138219960dd324aad8ab1f62f543bed73ef5ad60956e36ae" "9d8ad1c413fccc14d992f6bed0ead11f1798a05ee8913daaa24a24604c212b61" "e246ff6951678c835ab95aedb99a48fdd665656eadf8b8bc0a4f60e17fbc6b7e" "e57eec7e0399272aaca7985a5cc94f3a2675db4cd2dbd79a99c72786e489e43c" "d0fd069415ef23ccc21ccb0e54d93bdbb996a6cce48ffce7f810826bb243502c" "ffba0482d3548c9494e84c1324d527f73ea4e43fff8dfd0e48faa8fc6d5c2bc7" "9e816bc85b64963710efdbc57db8545b53f7f359b0736e0b36fbc9efe07f12f4" "6ac7c0f959f0d7853915012e78ff70150bfbe2a69a1b703c3ac4184f9ae3ae02" "845103fcb9b091b0958171653a4413ccfad35552bc39697d448941bcbe5a660d" "bc836bf29eab22d7e5b4c142d201bcce351806b7c1f94955ccafab8ce5b20208" "7f6d4aebcc44c264a64e714c3d9d1e903284305fd7e319e7cb73345a9994f5ef" "10a31b6c251640d04b2fa74bd2c05aaaee915cbca6501bcc82820cdc177f5a93" "6e933f1668e124ec17fc7b6547f65ba760e06efb568a6c8091c600c67827e592" "02199888a97767d7779269a39ba2e641d77661b31b3b8dd494b1a7250d1c8dc1" "2a49f95b19d5926d940db11057077df2d01faaf33e66c5a8d4ee8043a904695f" "bdb4509c123230a059d89fc837c40defdecee8279c741b7f060196b343b2d18d" "ed17fef69db375ae1ced71fdc12e543448827aac5eb7166d2fd05f4c95a7be71" "6515fcc302292f29a94f6ac0c5795c57a396127d5ea31f37fc5f9f0308bbe19f" "5a45c8bf60607dfa077b3e23edfb8df0f37c4759356682adf7ab762ba6b10600" "6c5a5c47749e7992b4da3011595f5470f33e19f29b10564cd4f62faebbe36b91" "8a379e7ac3a57e64de672dd744d4730b3bdb88ae328e8106f95cd81cbd44e0b6" "2035a16494e06636134de6d572ec47c30e26c3447eafeb6d3a9e8aee73732396" "ed0b4fc082715fc1d6a547650752cd8ec76c400ef72eb159543db1770a27caa7" "42b9d85321f5a152a6aef0cc8173e701f572175d6711361955ecfb4943fe93af" "021720af46e6e78e2be7875b2b5b05344f4e21fad70d17af7acfd6922386b61e" "9fcac3986e3550baac55dc6175195a4c7537e8aa082043dcbe3f93f548a3a1e0" "242527ce24b140d304381952aa7a081179a9848d734446d913ca8ef0af3cef21" "8cb818e0658f6cc59928a8f2b2917adc36d882267bf816994e00c5b8fcbf6933" "3fa81193ab414a4d54cde427c2662337c2cab5dd4eb17ffff0d90bca97581eb6" "44247f2a14c661d96d2bff302f1dbf37ebe7616935e4682102b68c0b6cc80095" "73bff6f2ef60f8a1238a9ca666235d258e3acdeeed85d092ca532788dd7a33c4" "05eeb814f74b2fd4f2e6e37b4d604eb9b1daaaedfa5e692f1d485250c6b553eb" "0055e55e6a357a941027139152a67f93376616d3501055d06852f10fdc16bac0" "1f3113447a652b8436a9938bbac71ecaf022cc73ecd0d76182eb9713aa781f17" "b755c709cb46ba4599ab3a3c189a056e9736cbbb39ed9ecfc1ab1aa3d6f79021" "75c5c39809c52d48cb9dcbf1694bf2d27d5f6fd053777c194e0b69d8e49031c0" "54e08527b4f4b127ebf7359acbbbecfab55152da01716c4809682eb71937fd33" "81db42d019a738d388596533bd1b5d66aef3663842172f3696733c0aab05a150" "ef1e992ef341e86397b39ee6b41c1368e1b33d45b0848feac6a8e8d5753daa67" "ad109c1ad8115573f40e22ac2b996693b5d48052fa37b5919f70ea37c62a965e" "b143ad150e25f9b6d09ae313718f85cc785c89445f3369f74bd0d836d5881c56" "dc9a8d70c4f94a28aafc7833f8d05667601968e6c9bf998791c39fcb3e4679c9" "125fd2180e880802ae98b85f282b17f0aa8fa6cb9fc4f33d7fb19a38c40acef0" "4d80487632a0a5a72737a7fc690f1f30266668211b17ba836602a8da890c2118" "9a155066ec746201156bb39f7518c1828a73d67742e11271e4f24b7b178c4710" "4bfced46dcfc40c45b076a1758ca106a947b1b6a6ff79a3281f3accacfb3243c" "31992d4488dba5b28ddb0c16914bf5726dc41588c2b1c1a2fd16516ea92c1d8e" "0e33022384e4db1374827f51e3d9e9a2d56282c2e3568c22f1c12ad80e20cf0c" "83db918b06f0b1df1153f21c0d47250556c7ffb5b5e6906d21749f41737babb7" "47744f6c8133824bdd104acc4280dbed4b34b85faa05ac2600f716b0226fb3f6" "8b313e1793da427e90c034dbe74f3ad9092ac291846c0f855908c42a6bda1ff4" "43c1a8090ed19ab3c0b1490ce412f78f157d69a29828aa977dae941b994b4147" "bc4b650c41b16b98166b35da94b366c6a9e1e7883bbf4937c897fb7bd05aa619" "e9460a84d876da407d9e6accf9ceba453e2f86f8b86076f37c08ad155de8223c" "8ec2e01474ad56ee33bc0534bdbe7842eea74dccfb576e09f99ef89a705f5501" "d606ac41cdd7054841941455c0151c54f8bff7e4e050255dbd4ae4d60ab640c1" "4f2ede02b3324c2f788f4e0bad77f7ebc1874eff7971d2a2c9b9724a50fb3f65" "2b6bd2ebad907ee42b3ffefa4831f348e3652ea8245570cdda67f0034f07db93" "7f3ef7724515515443f961ef87fee655750512473b1f5bf890e2dc7e065f240c" "65d9573b64ec94844f95e6055fe7a82451215f551c45275ca5b78653d505bc42" "39dffaee0e575731c909bb3e4b411f1c4759c3d7510bf02aa5aef322a596dd57" "2cf7f9d1d8e4d735ba53facdc3c6f3271086b6906c4165b12e4fd8e3865469a6" default))
'("cec8e841d2736d48fbf6578230fdee035a7be26c624ca5a266835b040e9caed2" "9b4ae6aa7581d529e20e5e503208316c5ef4c7005be49fdb06e5d07160b67adc" "0851a8045231c27d5274da06aae06c81f9be75d04ba4c3ee43997708d3cf30d1" "1524ee33541a025ea700dfcd9e275646488d210b374783425f1664454f266183" "a04676d7b664d62cf8cd68eaddca902899f98985fff042d8d474a0d51e8c9236" "63d5b85a4a8840df8c0a321dd8769381095bc0a0b7ef03a3aa1aa50aa23ea662" "f0743a238e80c38ca3d73bc03327ae3e529f2bc33d67efb41616ea1caffaebd6" "3ebef83a2705540325b0223388796b392f9e1e54a3063e6ba4827a380ed5477c" "a5a788e89884387d68c6e5c4e84e9d3b1a5723500a5fcf56a112d87deb6362cf" "6e6982c9bbe999b057486b0cfd7ee1884ceccac1602206cb7d4ed18cdd98abad" "37768a79b479684b0756dec7c0fc7652082910c37d8863c35b702db3f16000f8" "7c0830e1aea024fc0d4e76ba3db9f78cb37c09da2290f38af1a8fe87881007f7" "cfe4d36ed4cf00a541f7ba0deb38c94808c13a3e4c717f07bc3b9c866670e8d1" "474513bacf33a439da7b9a5df1dd11a277929d8480752675fc7d5f3816d8fdef" "b07a04cf42fe1001b2119b45f40cbc368783b5b8e1721ce3728a5f2823d97a66" "72ed8b6bffe0bfa8d097810649fd57d2b598deef47c992920aef8b5d9599eefe" "2ff9ac386eac4dffd77a33e93b0c8236bb376c5a5df62e36d4bfa821d56e4e20" "09c7e6bedcc4724a003e0ff36e045822b0385582b11a52758ed77973df04f3ee" "930243b929e5886e97390710218558ab346b31f6d04c6320d5182a81761ce9ed" "1d609285d297920b97b0d230360a8d7c3f930edcf1abe96a1d82356f9a5e228d" "abe5ee8858cd1fbe36304a8c3b2315d3e0a4ef7c8588fcc45d1c23eafb725bb6" "d600c677f1777c1e4bfb066529b5b73c0179d0499dd4ffa3f599a0fb0cfbd501" "30289fa8d502f71a392f40a0941a83842152a68c54ad69e0638ef52f04777a4c" "c7f10959cb1bc7a36ee355c765a1768d48929ec55dde137da51077ac7f899521" "773e0bfa5450c75d613cbf29734cdc876c3d59dbf85b93cff3015a8687dea158" "bf798e9e8ff00d4bf2512597f36e5a135ce48e477ce88a0764cfb5d8104e8163" "1436d643b98844555d56c59c74004eb158dc85fc55d2e7205f8d9b8c860e177f" "1e9001d2f6ffb095eafd9514b4d5974b720b275143fbc89ea046495a99c940b0" "f11e219c9d043cbd5f4b2e01713c2c24a948a98bed48828dc670bd64ae771aa1" "8f97d5ec8a774485296e366fdde6ff5589cf9e319a584b845b6f7fa788c9fa9a" "2642a1b7f53b9bb34c7f1e032d2098c852811ec2881eec2dc8cc07be004e45a0" "5111a41453244802afd93eed1a434e612a8afbdf19c52384dffab129258bab6e" "0329c772ed96053a73b9ddddf96c1183e23c267955bbdf78e7933057ce9da04b" "36ca8f60565af20ef4f30783aa16a26d96c02df7b4e54e9900a5138fb33808da" "23b564cfb74d784c73167d7de1b9a067bcca00719f81e46d09ee71a12ef7ee82" "f7ef6451d988d6e2fc86deea398eee02b3371703d88f265d31a011bd240dcf99" "3d4df186126c347e002c8366d32016948068d2e9198c496093a96775cc3b3eaa" "c560237b7505f67a271def31c706151afd7aa6eba9f69af77ec05bde5408dbcd" "24cb0b5666e1e17fb6a378c413682f57fe176775eda015eb0a98d65fbb64b127" "b0eb9e6e6dcb29c6ec4bcd72605188f482d52ee019cb0ccc73b5404be4f3a6e7" "08a89acffece58825e75479333109e01438650d27661b29212e6560070b156cf" "c9ddf33b383e74dac7690255dd2c3dfa1961a8e8a1d20e401c6572febef61045" "a22f40b63f9bc0a69ebc8ba4fbc6b452a4e3f84b80590ba0a92b4ff599e53ad0" "585942bb24cab2d4b2f74977ac3ba6ddbd888e3776b9d2f993c5704aa8bb4739" "fa2af0c40576f3bde32290d7f4e7aa865eb6bf7ebe31eb9e37c32aa6f4ae8d10" "85d1dbf2fc0e5d30f236712b831fb24faf6052f3114964fdeadede8e1b329832" "bffb799032a7404b33e431e6a1c46dc0ca62f54fdd20744a35a57c3f78586646" "779df25c6240f183dd378811465566082eacc3c86ed260835382cb5c1dc54de3" "eee70baee3a2d093a98fa344480d2330eb3a17f8dfa883cc41d8008cd46fa669" "b70474b8a631f73868f01fdb047f102dd36325ecbf6789962e613e9195e165d7" "ccdd152be99a9250f5c24e09860911ff4b1519a8c4c73e4d67364514a3359f71" "ba913d12adb68e9dadf1f43e6afa8e46c4822bb96a289d5bf1204344064f041e" "146614f131e5029df850a268aff1f0e3ae16734a119904eab133755b574da37d" "c8935cb969e24ff30a6ee1da011eadc156b9f128a3b0a39cc664628838a644ad" "767a6105de48707dd6a593b62c05a7bf4ee9930c86e3225410110d95906772d6" "39546362fed4d5201b2b386dc21f21439497c9eec5fee323d953b3e230e4083e" "2f4f50d98073c01038b518066840638455657dc91dd1a225286d573926f36914" "80ae3a89f1eca6fb94a525004f66b544e347c6f756aaafb728c7cdaef85ea1f5" "7b1a2c8ec90a30cc5d039db0e52f192a291f4c3655103cf669721f94028eac27" "bcd0237b2a5b7897e482458cc62c4f3fa3d9d7f9a9667338e67d4c7a8e009819" "8e79884e89740cf6b7e0210f52e4ac995dc1f1a9a17151bfcfb4d660757a011b" "454c1c9ce70f7d807c51c890910365fd3c64a9e63f596511e9ff57dd97bbeea8" "387b487737860e18cbb92d83a42616a67c1edfd0664d521940e7fbf049c315ae" "6231254e74298a1cf8a5fee7ca64352943de4b495e615c449e9bb27e2ccae709" "3577ee091e1d318c49889574a31175970472f6f182a9789f1a3e9e4513641d86" "cbd85ab34afb47003fa7f814a462c24affb1de81ebf172b78cb4e65186ba59d2" "8f5b54bf6a36fe1c138219960dd324aad8ab1f62f543bed73ef5ad60956e36ae" "9d8ad1c413fccc14d992f6bed0ead11f1798a05ee8913daaa24a24604c212b61" "e246ff6951678c835ab95aedb99a48fdd665656eadf8b8bc0a4f60e17fbc6b7e" "e57eec7e0399272aaca7985a5cc94f3a2675db4cd2dbd79a99c72786e489e43c" "d0fd069415ef23ccc21ccb0e54d93bdbb996a6cce48ffce7f810826bb243502c" "ffba0482d3548c9494e84c1324d527f73ea4e43fff8dfd0e48faa8fc6d5c2bc7" "9e816bc85b64963710efdbc57db8545b53f7f359b0736e0b36fbc9efe07f12f4" "6ac7c0f959f0d7853915012e78ff70150bfbe2a69a1b703c3ac4184f9ae3ae02" "845103fcb9b091b0958171653a4413ccfad35552bc39697d448941bcbe5a660d" "bc836bf29eab22d7e5b4c142d201bcce351806b7c1f94955ccafab8ce5b20208" "7f6d4aebcc44c264a64e714c3d9d1e903284305fd7e319e7cb73345a9994f5ef" "10a31b6c251640d04b2fa74bd2c05aaaee915cbca6501bcc82820cdc177f5a93" "6e933f1668e124ec17fc7b6547f65ba760e06efb568a6c8091c600c67827e592" "02199888a97767d7779269a39ba2e641d77661b31b3b8dd494b1a7250d1c8dc1" "2a49f95b19d5926d940db11057077df2d01faaf33e66c5a8d4ee8043a904695f" "bdb4509c123230a059d89fc837c40defdecee8279c741b7f060196b343b2d18d" "ed17fef69db375ae1ced71fdc12e543448827aac5eb7166d2fd05f4c95a7be71" "6515fcc302292f29a94f6ac0c5795c57a396127d5ea31f37fc5f9f0308bbe19f" "5a45c8bf60607dfa077b3e23edfb8df0f37c4759356682adf7ab762ba6b10600" "6c5a5c47749e7992b4da3011595f5470f33e19f29b10564cd4f62faebbe36b91" "8a379e7ac3a57e64de672dd744d4730b3bdb88ae328e8106f95cd81cbd44e0b6" "2035a16494e06636134de6d572ec47c30e26c3447eafeb6d3a9e8aee73732396" "ed0b4fc082715fc1d6a547650752cd8ec76c400ef72eb159543db1770a27caa7" "42b9d85321f5a152a6aef0cc8173e701f572175d6711361955ecfb4943fe93af" "021720af46e6e78e2be7875b2b5b05344f4e21fad70d17af7acfd6922386b61e" "9fcac3986e3550baac55dc6175195a4c7537e8aa082043dcbe3f93f548a3a1e0" "242527ce24b140d304381952aa7a081179a9848d734446d913ca8ef0af3cef21" "8cb818e0658f6cc59928a8f2b2917adc36d882267bf816994e00c5b8fcbf6933" "3fa81193ab414a4d54cde427c2662337c2cab5dd4eb17ffff0d90bca97581eb6" "44247f2a14c661d96d2bff302f1dbf37ebe7616935e4682102b68c0b6cc80095" "73bff6f2ef60f8a1238a9ca666235d258e3acdeeed85d092ca532788dd7a33c4" "05eeb814f74b2fd4f2e6e37b4d604eb9b1daaaedfa5e692f1d485250c6b553eb" "0055e55e6a357a941027139152a67f93376616d3501055d06852f10fdc16bac0" "1f3113447a652b8436a9938bbac71ecaf022cc73ecd0d76182eb9713aa781f17" "b755c709cb46ba4599ab3a3c189a056e9736cbbb39ed9ecfc1ab1aa3d6f79021" "75c5c39809c52d48cb9dcbf1694bf2d27d5f6fd053777c194e0b69d8e49031c0" "54e08527b4f4b127ebf7359acbbbecfab55152da01716c4809682eb71937fd33" "81db42d019a738d388596533bd1b5d66aef3663842172f3696733c0aab05a150" "ef1e992ef341e86397b39ee6b41c1368e1b33d45b0848feac6a8e8d5753daa67" "ad109c1ad8115573f40e22ac2b996693b5d48052fa37b5919f70ea37c62a965e" "b143ad150e25f9b6d09ae313718f85cc785c89445f3369f74bd0d836d5881c56" "dc9a8d70c4f94a28aafc7833f8d05667601968e6c9bf998791c39fcb3e4679c9" "125fd2180e880802ae98b85f282b17f0aa8fa6cb9fc4f33d7fb19a38c40acef0" "4d80487632a0a5a72737a7fc690f1f30266668211b17ba836602a8da890c2118" "9a155066ec746201156bb39f7518c1828a73d67742e11271e4f24b7b178c4710" "4bfced46dcfc40c45b076a1758ca106a947b1b6a6ff79a3281f3accacfb3243c" "31992d4488dba5b28ddb0c16914bf5726dc41588c2b1c1a2fd16516ea92c1d8e" "0e33022384e4db1374827f51e3d9e9a2d56282c2e3568c22f1c12ad80e20cf0c" "83db918b06f0b1df1153f21c0d47250556c7ffb5b5e6906d21749f41737babb7" "47744f6c8133824bdd104acc4280dbed4b34b85faa05ac2600f716b0226fb3f6" "8b313e1793da427e90c034dbe74f3ad9092ac291846c0f855908c42a6bda1ff4" "43c1a8090ed19ab3c0b1490ce412f78f157d69a29828aa977dae941b994b4147" "bc4b650c41b16b98166b35da94b366c6a9e1e7883bbf4937c897fb7bd05aa619" "e9460a84d876da407d9e6accf9ceba453e2f86f8b86076f37c08ad155de8223c" "8ec2e01474ad56ee33bc0534bdbe7842eea74dccfb576e09f99ef89a705f5501" "d606ac41cdd7054841941455c0151c54f8bff7e4e050255dbd4ae4d60ab640c1" "4f2ede02b3324c2f788f4e0bad77f7ebc1874eff7971d2a2c9b9724a50fb3f65" "2b6bd2ebad907ee42b3ffefa4831f348e3652ea8245570cdda67f0034f07db93" "7f3ef7724515515443f961ef87fee655750512473b1f5bf890e2dc7e065f240c" "65d9573b64ec94844f95e6055fe7a82451215f551c45275ca5b78653d505bc42" "39dffaee0e575731c909bb3e4b411f1c4759c3d7510bf02aa5aef322a596dd57" "2cf7f9d1d8e4d735ba53facdc3c6f3271086b6906c4165b12e4fd8e3865469a6" default))
'(devil-lighter " ɤ")
'(devil-prompt "ɤ %t")
'(devil-repeatable-keys
'(("%k /")
("%k d")
("%k k")
("%k m ^")
("%k m e")
("%k m b" "%k m f" "%k m a" "% k m e")
("%k m @" "%k m h")
("%k m y")
("%k p" "%k n" "%k b" "%k f" "%k a" "%k e")
("%k s" "%k r")
("%k x [" "%k x ]")
("%k x ^" "%k x {" "%k x }")
("%k x o")
("%k x u")))
'(ement fennel-mode ox-gemini org-superstar omtose-phellack-theme pyvenv-auto paredit warm-night-theme geiser-guile geiser geiser-chicken spacegray-theme soft-charcoal-theme slime abyss-theme ample-theme djvu elpher ox-rst ripgrep unicode-fonts no-spam uuid marginalia embark-consult embark orderless selectrum consult vertico dockerfile-mode x509-mode forth-mode browse-at-remote cider sesman clojure-mode eziam-theme scad-mode acme-theme sexy-monochrome-theme monotropic-theme constant-theme graphviz-dot-mode mood-line mood-one-theme modus-vivendi-theme modus-operandi-theme browse-url-dwim magit parchment-theme almost-mono-themes borland-blue-theme nordless-theme northcode-theme nord-theme nofrils-acme-theme multikeyfreq fireplace boon csv-mode ein markdown-mode puppet-mode dad-joke keyfreq avy-zap avy ggtags counsel-projectile projectile command-log-mode counsel vc-fossil visible-mark esup sudden-death jammer arjen-grey-theme atom-dark-theme clues-theme dark-krystal-theme darkburn-theme eink-theme foggy-night-theme green-screen-theme gruvbox-theme heroku-theme inverse-acme-theme iodine-theme labburn-theme leuven-theme evil-visual-mark-mode excorporate telephone-line xah-fly-keys which-key url-http-ntlm toml-mode plan9-theme ergoemacs-mode))
'(logstash-conf org-mind-map lentic web-server weyland-yutani-theme sly nov ement fennel-mode ox-gemini org-superstar omtose-phellack-theme pyvenv-auto paredit warm-night-theme geiser-guile geiser geiser-chicken spacegray-theme soft-charcoal-theme slime abyss-theme ample-theme djvu elpher ox-rst ripgrep unicode-fonts no-spam uuid marginalia embark-consult embark orderless selectrum consult vertico dockerfile-mode x509-mode forth-mode browse-at-remote cider sesman clojure-mode eziam-theme scad-mode acme-theme sexy-monochrome-theme monotropic-theme constant-theme graphviz-dot-mode mood-line mood-one-theme modus-vivendi-theme modus-operandi-theme browse-url-dwim magit parchment-theme almost-mono-themes borland-blue-theme nordless-theme northcode-theme nord-theme nofrils-acme-theme multikeyfreq fireplace boon csv-mode ein markdown-mode puppet-mode dad-joke keyfreq avy-zap avy ggtags counsel-projectile projectile command-log-mode counsel vc-fossil visible-mark esup sudden-death jammer arjen-grey-theme atom-dark-theme clues-theme dark-krystal-theme darkburn-theme eink-theme foggy-night-theme green-screen-theme gruvbox-theme heroku-theme inverse-acme-theme iodine-theme labburn-theme leuven-theme evil-visual-mark-mode excorporate telephone-line xah-fly-keys which-key url-http-ntlm toml-mode plan9-theme ergoemacs-mode))
;;; weyland-yutani-theme.el --- Emacs theme based off Alien movie franchise -*- lexical-binding:t -*-
;; Copyright (C) 2020 , Joe Staursky
;; Author: Joe Staursky
;; Homepage: https://github.com/jstaursky/weyland-yutani-theme
;; Version: 0.1
;; Package-Requires: ((emacs "24.1"))
;; SPECIAL THANKS goes to emacs-theme-generator
;; was a huge help in getting started.
;; (goto https://github.com/mswift42/theme-creator).
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;; This file is not part of Emacs.
;;; Commentary:
;;; Theme based off of the Alien Movie Franchise. Regardless of opinion on the
;;; movies' storyline, the use colors has always been gorgeous.
;;; Code:
(deftheme weyland-yutani)
(defun weyland-yutani-theme-face-specifier (&rest L)
"Simplifies face specifications.
Encloses each list element inside list 'L' with the appropriate
boilerplate to achieve the standard '(face (( (class
color) (min-colors 89)) . plist))' face specification without all
the parenthetical noise."
(let (res)
(dolist (item L res)
(push `(,(car item)
(( ((class color)
(min-colors 89))
,(cdr item) ))) res))))
(let (
(fg "#b0bcce")
(fg-alt "#606873") ;#606873
(hl "#26282c")
(White "#C3D0DF")
(base0 "#9ca4b7")
(base1 "#8c97a7")
(base2 "#6e788c")
(base3 "#8f8e9a")
(base4 "#3e4044")
(base5 "#4e5054")
(base6 "#717ea5")
(base6.1 "#94a5d0")
(base7 "#505a76")
(bg "#1f2226")
(bg-alt "#26282c")
(bg-Black "#2b2f37")
(bg-darker "#1f2024")
(_bg-light-Black "#2E2F2F")
(bg-Blue "#272c3b")
(bg-CharlesGreen "#272D2D")
(bg-Green "#3a4f34")
(_bg-Grey "#434157")
(bg-Grey-alt "#343a4f")
(bg-Orchid "#3b3559")
(bg-Red "#4f343a")
(bg-Violet "#504361")
(very-dark-bg "#020202")
(key2 "#7ABE5B")
(key3 "#6aa454")
;; Main Palette
(HarlequinGreen "#83CB55") ;#79c151 #a2e960 #8ED559
(Indigo "#877CEB")
(Violet "#c291eb")
(Magenta "#C264C6")
(IcebergBlue "#4F9FD2")
(ArcticBlue "#59b9b4")
(ArcticBlue-alt "#67bfba")
(Gold "#b9b174")
(Orchid "#e372dd")
;; ACCENT COLORS
(Crimson "#d06985")
(Mustard "#90b55b")
(Yellow "#b9b65e")
(Purple "#AD83EB")
;; DIMM VARIANTS
(dimm-Crimson "#cc5655")
;; PALE VARIANTS
(pale-Crimson "#b95e76")
;; LIGHT VARIANTS
(_light-Crimson "#FF6066")
(Orange "#e98061")
(light-IcebergBlue "#4FAED9")
(light-Indigo "#A28BE7")
(light-Orchid "#ee78e8")
(light-Purple "#ba86f4")
(light-Blue "#63A4FF")
;; DARK VARIANTS
(dark-Crimson "#ba464a")
(dark-Slate "#3c4666")
(dark-Gold "#7e784c")
(dark-Purple "#7c73cc")
(bg-dark-Black "#242733")
(bg-Arctic-Blue "#26303d")
(dark-Red "#d2344c")
;; VIBRANT VARIANTS
(vibrant-Green "#86dc2f")
(vibrant-Red "#ff6c6b")
(vibrant-Crimson "#df5155")
(vibrant-Purple "#AD83EB")
(vibrant-Finch "#F4ED1A")
(vibrant-Yellow "#ffbb1c")
;; VERSION CONTROL
(wylnyut-diff-changed "#9965ba")
(wylnyut-diff-deleted "#df3e36")
(wylnyut-diff-added "#4f8920"))
(apply
'custom-theme-set-faces
'weyland-yutani
(weyland-yutani-theme-face-specifier
;; FACE :foreground :background :MISC
`(default :foreground ,fg
:background ,bg :distant-foreground ,bg)
`(default-italic
:italic t)
`(header-line :foreground ,HarlequinGreen :background ,bg-Grey-alt
:distant-foreground ,bg)
`(cursor :background ,White)
`(fringe :foreground ,Purple :background ,bg)
`(hl-line :background ,hl)
`(region :foreground ,light-Indigo :background ,bg-Blue)
`(vertical-border :foreground "#4a5677")
`(highlight :foreground ,bg :background ,vibrant-Green)
`(minibuffer-prompt :foreground ,HarlequinGreen)
`(font-lock-builtin-face :foreground ,Indigo)
`(font-lock-comment-face :foreground ,fg-alt :distant-foreground ,base2)
`(font-lock-constant-face :foreground ,IcebergBlue)
`(font-lock-doc-face :foreground ,base2)
`(font-lock-function-name-face :foreground ,Violet)
`(font-lock-keyword-face :foreground ,HarlequinGreen)
`(font-lock-negation-char-face :foreground ,IcebergBlue)
`(font-lock-reference-face :foreground ,IcebergBlue)
`(font-lock-string-face :foreground ,ArcticBlue-alt :background ,bg-Arctic-Blue)
`(font-lock-type-face :foreground ,Indigo)
`(font-lock-variable-name-face :foreground ,Magenta)
`(font-lock-warning-face :foreground ,Crimson)
`(highlight-numbers-number :foreground ,Orchid)
`(match :foreground ,pale-Crimson :background ,bg-darker)
`(trailing-whitespace :background ,IcebergBlue)
;; MODELINE
`(mode-line :foreground ,fg :background ,bg-Black
:box (:color ,dark-Slate :line-width 1))
`(mode-line-buffer-id :foreground ,Gold :background nil
:bold nil)
`(mode-line-inactive :foreground ,fg-alt :background ,bg
:box (:color ,dark-Slate :line-width 1))
`(mode-line-buffer-id-inactive :foreground ,dark-Gold)
`(mode-line-emphasis :foreground ,fg :background nil
:bold nil)
`(mode-line-highlight :foreground ,HarlequinGreen
:bold t)
`(hi-yellow
:foreground ,bg
:background ,Mustard) ; cannot think of any reason I would want a bright Yellow face.
;; MODE SUPPORT: lsp
`(lsp-face-highlight-read :foreground ,White :bold t :underline ,fg)
`(lsp-face-highlight-write :foreground ,White :bold t)
`(lsp-headerline-breadcrumb-path-error-face
:underline (:color ,dark-Red :style line))
`(lsp-face-highlight-textual :bolt t)
`(lsp-ui-peek-peek :inherit org-block)
`(lsp-ui-peek-filename :foreground ,HarlequinGreen)
`(lsp-ui-peek-highlight :bold t
; :box (:color ,dark-Slate :line-width -2)
)
`(lsp-ui-peek-selection :background nil :foreground ,light-Purple)
`(lsp-ui-peek-header :inherit org-block-begin-line)
`(lsp-ui-peek-footer :inherit org-block-end-line)
;; MODE SUPPORT: tree-sitter
`(tree-sitter-hl-face:number :foreground ,Orange)
`(tree-sitter-hl-face:constant
:inherit tree-sitter-hl-face:number)
`(tree-sitter-hl-face:function.macro
:inherit tree-sitter-hl-face:number)
`(tree-sitter-hl-face:punctuation nil)
`(tree-sitter-hl-face:operator :foreground "#73b34b"
:bold t)
`(tree-sitter-hl-face:property :inherit default :italic t)
`(tree-sitter-hl-face:method.call :inherit tree-sitter-hl-face:function.call
:weight normal)
;; MODE SUPPORT: powerline
`(powerline-active0
:inherit mode-line)
`(powerline-active1 :background ,bg-alt)
`(powerline-active2 :background ,bg-alt
:inherit mode-line)
`(powerline-inactive0
:inherit mode-line-inactive)
`(powerline-inactive1
:inherit mode-line-inactive)
`(powerline-inactive2
:inherit mode-line-inactive)
`(which-func :foreground ,light-IcebergBlue
:italic t)
;; MISC BUILTIN
`(custom-group-tag :foreground ,HarlequinGreen
:height 1.2)
`(custom-variable-tag :foreground ,Gold)
`(link :foreground ,IcebergBlue
:underline t)
`(show-paren-match :foreground ,Violet :background ,bg-Violet
:bold t)
`(shadow :foreground ,base6)
`(isearch :foreground ,Crimson :background ,base4
:bold t)
;; NOTE emacs built with gtk cannot customize this.
`(scroll-bar :foreground ,Orchid :background ,dark-Purple)
`(completions-first-difference :foreground ,Magenta)
`(completions-common-part :foreground ,Violet)
`(spacemacs-micro-state-binding-face
:inherit modeline)
`(spacemacs-transient-state-title-face :foreground ,vibrant-Green)
`(flycheck-error
:underline
(:color ,vibrant-Red :style line))
;; MODE SUPPORT: Ebrowse
`(ebrowse-root-class :foreground ,HarlequinGreen)
`(ebrowse-default :foreground ,Indigo)
`(ebrowse-member-class :foreground ,IcebergBlue
:height 1.2)
`(ebrowse-member-attribute :foreground ,vibrant-Purple)
`(ebrowse-progress :background ,vibrant-Green)
`(ggtags-global-line :background ,dark-Slate)
`(compilation-info :foreground ,vibrant-Green)
;; MODE SUPPORT: git-gutter
`(git-gutter:added :foreground ,wylnyut-diff-added)
`(git-gutter:deleted :foreground ,wylnyut-diff-deleted)
`(git-gutter:modified :foreground ,wylnyut-diff-changed)
`(git-gutter:separator :foreground ,bg)
`(git-gutter:unchanged :foreground ,bg)
;; MODE SUPPORT: git-gutter-fr
`(git-gutter-fr:added :foreground ,wylnyut-diff-added)
`(git-gutter-fr:deleted :foreground ,wylnyut-diff-deleted)
`(git-gutter-fr:modified :foreground ,wylnyut-diff-changed)
;; MODE SUPPORT: git-gutter+
`(git-gutter+-commit-header-face :foreground ,fg)
`(git-gutter+-added :foreground ,wylnyut-diff-added)
`(git-gutter+-deleted :foreground ,wylnyut-diff-deleted)
`(git-gutter+-modified :foreground ,wylnyut-diff-changed)
`(git-gutter+-separator :foreground ,fg)
`(git-gutter+-unchanged :foreground ,fg)
;; MODE SUPPORT: git-gutter-fr+
`(git-gutter-fr+-added :foreground ,wylnyut-diff-added)
`(git-gutter-fr+-deleted :foreground ,wylnyut-diff-deleted)
`(git-gutter-fr+-modified :foreground ,wylnyut-diff-changed)
;; MODE SUPPORT: diff-hl
`(diff-hl-change :foreground ,wylnyut-diff-changed :background ,wylnyut-diff-changed)
`(diff-hl-insert :foreground ,wylnyut-diff-added :background ,wylnyut-diff-added)
`(diff-hl-delete :foreground ,wylnyut-diff-deleted :background ,wylnyut-diff-deleted)
;; MODE SUPPORT: scala
`(scala-font-lock:var-face :inherit font-lock-variable-name-face)
;; MODE SUPPORT: rtags
`(rtags-errline :foreground ,vibrant-Red :background nil
:underline
(:color ,vibrant-Red :style line))
`(rtags-warnline :foreground ,vibrant-Red :background nil
:bold t
:underline
(:color ,vibrant-Red :style wave))
;; MODE SUPPORT: info-documentation
`(info-function-ref-item :foreground ,HarlequinGreen :background ,bg-Grey-alt
:underline ,very-dark-bg)
`(info-reference-item :foreground ,vibrant-Purple :background ,bg-dark-Black
:box (:color ,bg-dark-Black :line-width -1))
;; MODE SUPPORT: org-mode
`(org-property-value :inherit fixed-pitch)
`(org-headline-done :foreground "#606873" :strike-through t)
`(org-indent
:inherit (org-hide fixed-pitch))
`(org-ref-ref-face :foreground ,Yellow)
`(org-ref-cite-face :foreground ,light-Orchid
:underline t)
`(org-document-title :foreground ,HarlequinGreen
:underline t
:height 1.5)
`(org-agenda-calendar-event :foreground ,White)
`(org-time-grid :foreground ,base6)
`(org-hide :foreground ,base3)
`(org-footnote :foreground ,base3
:underline t)
`(org-agenda-current-time
:inherit org-time-grid)
`(org-warning :foreground ,vibrant-Crimson
:bold t)
`(org-upcoming-deadline
:inherit org-warning
:italic t)
`(org-upcoming-distant-deadline :foreground ,dark-Crimson)
`(org-special-keyword :foreground ,Violet)
`(org-date :foreground ,Magenta
:underline t)
`(org-agenda-structure :foreground "#4e94c2"
:background "#212a31"
:extend t
:height 1.3
:italic t
:weight bold)
`(org-agenda-date :foreground ,HarlequinGreen :background ,bg-Grey-alt
:underline ,very-dark-bg
:distant-foreground ,bg)
`(org-agenda-date-weekend :foreground ,base3
:bold nil
:weight normal)
`(org-agenda-date-today :foreground ,HarlequinGreen
:underline t
:weight bold
:height 1.4)
`(org-scheduled :foreground ,Indigo)
`(org-scheduled-today :foreground ,IcebergBlue)
`(org-document-info-keyword :foreground ,Violet)
`(org-sexp-date :foreground ,base3
:inherit fixed-pitch)
;; DONE
`(org-level-1 :foreground ,HarlequinGreen
:bold t
:height 1.3)
`(org-level-2 :foreground ,IcebergBlue
:bold t
:height 1.2)
`(org-level-3 :foreground ,ArcticBlue
:bold t
:height 1.1)
`(org-level-4 :foreground ,Violet)
`(org-level-5 :foreground ,Indigo)
`(org-level-6 :foreground ,Magenta)
`(org-level-7 :foreground ,Gold)
;; Face for days on which a task should start to be done.
`(org-habit-ready-face :foreground "black" :background ,vibrant-Yellow
:underline t
:overline t)
;; Face for days on which a task is due.
`(org-habit-alert-face
:inherit org-habit-ready-face
:bold t)
`(org-habit-alert-future-face :background ,bg)
`(org-habit-overdue-face
:bold t
:inherit org-habit-ready-face)
`(org-habit-clear-face :foreground ,vibrant-Yellow :background ,bg-Grey-alt)
;; Face for future days on which a task shouldn’t be done yet.
`(org-habit-clear-future-face :foreground ,bg :background ,bg-Grey-alt)
`(org-habit-overdue-future-face :foreground ,bg :background ,dark-Red
:underline t
:overline t)
`(org-block :background ,bg-Black
:extend t)
`(org-block-begin-line :foreground ,base6.1 :background ,bg-Grey-alt
:underline ,bg-dark-Black
:extend t)
`(org-block-end-line
:overline ,bg-dark-Black
:inherit org-block-begin-line)
`(org-quote
:foreground ,White
:background ,bg-darker
:slant normal
:extend t
)
`(org-code :foreground ,Orange)
`(org-verbatim :foreground ,HarlequinGreen)
`(org-agenda-calendar-event
:inherit default)
`(org-link
:inherit link)
`(org-todo :foreground ,Yellow
:underline t
:bold t
:italic t
:height 1.1)
`(org-done
:foreground "#7cc742" ; <= VERY slight difference to HarlequinGreen—but noticable, however not enough to warrant new color variable.
:bold t)
`(org-agenda-done :foreground ,base7
:bold t
:strike-through ,base7)
`(org-ellipsis :foreground ,Indigo)
;; MOVE SUPPORT: avy, ace
`(avy-lead-face :foreground ,vibrant-Green :background ,bg
:bold t)
`(avy-lead-face-0 :foreground ,White :background ,bg)
`(avy-lead-face-2 :foreground ,dimm-Crimson :background ,bg)
`(avy-background-face :foreground ,base2)
;; MODE SUPPORT: rainbow-delimiters
`(rainbow-delimiters-unmatched-face :foreground ,Crimson)
`(rainbow-delimiters-depth-1-face :foreground ,Purple)
`(rainbow-delimiters-depth-2-face :foreground ,Indigo)
`(rainbow-delimiters-depth-3-face :foreground ,Magenta)
`(rainbow-delimiters-depth-4-face :foreground ,ArcticBlue)
`(rainbow-delimiters-depth-5-face :foreground ,HarlequinGreen)
`(rainbow-delimiters-depth-6-face :foreground ,fg)
`(rainbow-delimiters-depth-7-face :foreground ,Indigo)
`(rainbow-delimiters-depth-8-face :foreground ,Magenta)
;; MODE SUPPORT: company
`(company-tooltip-annotation-selection :foreground ,bg
:italic t)
`(company-tooltip-annotation :foreground ,ArcticBlue)
; Colors that fill the body the toolti (main bg and fg)
`(company-tooltip :foreground ,base0 :background ,bg-darker)
; Color that match as you type
`(company-tooltip-common :foreground ,light-Indigo)
; Color for matching text in the completion selection
`(company-tooltip-common-selection :foreground ,bg :bold t)
; hl-line for company popup
`(company-tooltip-selection :foreground ,bg :background ,light-Indigo)
`(company-echo :foreground ,bg :background ,fg)
`(company-scrollbar-fg :background ,Magenta)
`(company-scrollbar-bg :background ,base4)
`(company-echo-common :foreground ,bg :background ,fg)
`(company-preview :foreground ,key2 :background ,bg)
`(company-preview-common :foreground ,base1 :background ,bg-alt)
`(company-preview-search :foreground ,Indigo :background ,bg)
`(company-tooltip-mouse
:inherit highlight)
`(company-template-field
:inherit region)
`(font-latex-sectioning-5-face :foreground "#C77AE1"
:inherit variable-pitch
:bold t
:height 1.1)
`(font-latex-bold-face :foreground ,Indigo)
`(font-latex-italic-face :foreground ,key3
:italic t)
`(font-latex-script-char-face :foreground ,Orange)
`(font-latex-subscript-face
:underline "#876444"
:height .7)
`(font-latex-superscript-face
:height .7)
`(font-latex-string-face :foreground ,ArcticBlue)
`(font-latex-match-reference-keywords :foreground ,IcebergBlue)
`(font-latex-match-variable-keywords :foreground ,Magenta)
`(font-latex-warning-face :foreground ,Orange)
;; MODE SUPPORT: ido
`(ido-only-match :foreground ,Crimson)
`(ido-first-match :foreground ,HarlequinGreen
:bold t)
`(ido-subdir :foreground ,Gold)
`(ido-first-match :foreground ,vibrant-Green)
`(ido-only-match :foreground ,vibrant-Green
:italic t
:bold t)
`(aw-leading-char-face :foreground ,vibrant-Green
:height 1.9
:bold t
:box (:color ,dark-Slate :line-width -2))
`(gnus-header-content :foreground ,HarlequinGreen)
`(gnus-header-from :foreground ,Magenta)
`(gnus-header-name :foreground ,Indigo)
`(gnus-header-subject :foreground ,Violet
:bold t)
`(mu4e-view-url-number-face :foreground ,Indigo)
`(mu4e-cited-1-face :foreground ,base0)
`(mu4e-cited-7-face :foreground ,base1)
`(mu4e-header-marks-face :foreground ,Indigo)
`(ffap :foreground ,base3)
`(js2-private-function-call :foreground ,IcebergBlue)
`(js2-jsdoc-html-tag-delimiter :foreground ,ArcticBlue)
`(js2-jsdoc-html-tag-name :foreground ,key2)
`(js2-external-variable :foreground ,Indigo )
`(js2-function-param :foreground ,IcebergBlue)
`(js2-jsdoc-value :foreground ,ArcticBlue)
`(js2-private-member :foreground ,base1)
`(js3-warning-face
:underline ,HarlequinGreen)
`(js3-error-face
:underline ,Crimson)
`(js3-external-variable-face :foreground ,Magenta)
`(js3-function-param-face :foreground ,key3)
`(js3-jsdoc-tag-face :foreground ,HarlequinGreen)
`(js3-instance-member-face :foreground ,IcebergBlue)
`(ac-completion-face :foreground ,HarlequinGreen
:underline t)
`(info-quoted-name :foreground ,Indigo)
`(info-string :foreground ,ArcticBlue)
`(icompletep-determined :foreground ,Indigo)
`(undo-tree-visualizer-current-face :foreground ,Indigo)
`(undo-tree-visualizer-default-face :foreground ,base0)
`(undo-tree-visualizer-unmodified-face :foreground ,Magenta)
`(undo-tree-visualizer-register-face :foreground ,Indigo)
`(slime-repl-inputed-output-face :foreground ,Indigo)
`(trailing-whitespace :foreground nil :background ,fg-alt)
;; MODE SUPPORT: org-rifle
`(helm-org-rifle-separator
:height .3
:box (:line-width -1 :color ,base7)
:extend t)
`(smerge-markers
:background ,bg-Black
:underline ,vibrant-Purple
:overline ,vibrant-Purple)
`(smerge-refined-removed :foreground ,vibrant-Red)
`(smerge-refined-added :foreground ,vibrant-Green)
`(smerge-upper :foreground "#dbddee" :background "#2a3341")
`(smerge-lower :foreground "#F0EDFE" :background ,bg-Violet)
`(git-commit-comment-file :foreground ,Crimson)
`(magit-filename :foreground ,Violet)
`(magit-diff-file-heading :foreground ,Crimson
:bold t
:italic t
:height 1.15)
`(magit-item-highlight :background ,base4)
`(magit-section-heading :foreground ,key2
:weight bold
:height 1.3)
`(magit-hunk-heading :background ,base4)
`(magit-section-highlight :background ,bg-alt)
`(magit-diff-hunk-heading-highlight :foreground ,bg :background ,Violet
:weight bold)
`(magit-diff-hunk-heading :foreground ,bg :background ,bg-Violet)
`(magit-section-highlight :background ,bg-Blue)
`(magit-diff-added :foreground ,key3 :background ,bg-Green)
`(magit-diff-added-highlight :foreground ,Mustard :background ,bg-Green)
`(magit-diff-removed-highlight :foreground ,vibrant-Red :background ,bg-Red)
`(magit-diff-removed :foreground ,dimm-Crimson :background ,bg-Red)
`(magit-dimmed :foreground ,base5)
`(magit-diff-our :foreground ,vibrant-Red :background ,bg-Red)
`(magit-diff-our-highlight :foreground ,vibrant-Red :background ,bg-Red)
`(magit-diff-context-highlight :foreground ,base0 :background ,bg-dark-Black)
`(magit-diff-context
:inherit magit-dimmed)
`(magit-diff-base-highlight :foreground ,Orange :background ,bg-Red)
`(magit-diffstat-added :foreground ,Indigo)
`(magit-diffstat-removed :foreground ,Magenta)
`(magit-process-ok :foreground ,Violet
:weight bold)
`(magit-process-ng :foreground ,Crimson
:weight bold)
`(magit-branch :foreground ,IcebergBlue
:weight bold)
`(magit-branch-remote :foreground ,light-Blue)
`(magit-branch-local :foreground ,Purple)
`(magit-log-author :foreground ,base1)
`(magit-hash :foreground ,base0)
`(magit-diff-file-header :foreground ,base0 :background ,base4)
`(lazy-highlight
:inherit highlight)
`(term :foreground ,fg :background ,bg)
`(term-color-black :foreground ,base4 :background ,base4)
`(term-color-blue :foreground ,Violet :background ,Violet)
`(term-color-red :foreground ,HarlequinGreen :background ,base4)
`(term-color-green :foreground ,Indigo :background ,base4)
`(term-color-yellow :foreground ,Magenta :background ,Magenta)
`(term-color-magenta :foreground ,Indigo :background ,Indigo)
`(term-color-cyan :foreground ,ArcticBlue :background ,ArcticBlue)
`(term-color-white :foreground ,base0 :background ,base0)
`(xref-file-header :foreground ,Gold)
`(ggtags-highlight :underline nil)
`(helm-buffer-modified :foreground ,Crimson :italic t)
`(helm-buffer-directory :foreground ,Gold)
`(helm-header :foreground ,base0 :background ,bg
:underline nil
:box nil)
`(helm-header-line-left-margin :foreground ,bg :background ,ArcticBlue)
`(helm-match :foreground ,light-Purple)
`(helm-source-header :foreground ,HarlequinGreen :background ,bg
:underline nil
:weight bold
:overline t)
`(helm-selection :foreground ,light-Orchid :background ,bg-Orchid
:underline nil
:extend t)
`(helm-selection-line :background ,bg-alt)
`(helm-M-x-key :foreground ,light-Purple)
`(helm-candidate-number :foreground ,bg :background ,fg)
`(helm-separator :foreground ,Indigo :background ,bg)
`(helm-time-zone-current :foreground ,Indigo :background ,bg)
`(helm-time-zone-home :foreground ,Indigo :background ,bg)
`(helm-buffer-not-saved :foreground ,Indigo :background ,bg)
`(helm-buffer-process :foreground ,Indigo :background ,bg)
`(helm-buffer-saved-out :foreground ,fg :background ,bg)
`(helm-buffer-size :foreground ,fg :background ,bg)
`(helm-ff-directory :foreground ,Violet :background ,bg
:weight bold)
`(helm-ff-dotted-directory :foreground ,fg-alt :background ,bg)
`(helm-ff-file :foreground ,fg :background ,bg
:weight normal)
`(helm-ff-executable :foreground ,key2 :background ,bg
:weight normal)
`(helm-ff-invalid-symlink :foreground ,key3 :background ,bg
:weight bold)
`(helm-ff-symlink :foreground ,HarlequinGreen :background ,bg
:weight bold)
`(helm-ff-prefix :foreground ,bg :background ,HarlequinGreen
:weight normal)
`(helm-grep-cmd-line :foreground ,fg :background ,bg)
`(helm-grep-file :foreground ,fg :background ,bg)
`(helm-grep-finish :foreground ,base0 :background ,bg)
`(helm-grep-lineno :foreground ,fg :background ,bg)
`(helm-grep-match :foreground nil :background nil
:inherit helm-match)
`(helm-grep-running :foreground ,Violet :background ,bg)
`(helm-moccur-buffer :foreground ,Violet :background ,bg)
`(helm-source-go-package-godoc-description :foreground ,ArcticBlue)
`(helm-bookmark-w3m :foreground ,Indigo)
`(helm-visible-mark :foreground ,ArcticBlue :background ,bg-Blue
:extend t)
`(helm-swoop-target-line-face :foreground ,vibrant-Green :background ,bg-CharlesGreen
:extend t)
`(helm-swoop-target-word-face
:inherit highlight)
;; Face for highlighting odd-numbered non-current differences in buffer A.
`(ediff-odd-diff-A
:foreground "#ffc8c6"
:background "#834e4e")
`(ediff-even-diff-A
:foreground "#ffefee"
:background "#846867")
`(ediff-odd-diff-B
:foreground "#aae3a8"
:background "#4e6b4d")
`(ediff-even-diff-B
:foreground "#c8e5c7"
:background "#698368")
`(ediff-odd-diff-C
:foreground "#e0ded4"
:background "#585648")
`(ediff-even-diff-C
:foreground "#ede6c7"
:background "#6c674c")
`(ediff-current-diff-A
:foreground "#c7d0db"
:background "#553333") ;
`(ediff-current-diff-B
:foreground "#e7ebef"
:background "#335533")
`(ediff-current-diff-C :bold t
:foreground ,vibrant-Finch
:background "#555432")
`(ediff-fine-diff-A
:foreground "#e7ebef"
:background "#aa2222")
`(ediff-fine-diff-B
:foreground ,bg-darker
:background "#7daa22")
`(ediff-fine-diff-C
:foreground "#c5c987"
:background "#555432")
`(web-mode-builtin-face
:inherit ,font-lock-builtin-face)
`(web-mode-comment-face
:inherit ,font-lock-comment-face)
`(web-mode-constant-face
:inherit ,font-lock-constant-face)
`(web-mode-keyword-face :foreground ,HarlequinGreen)
`(web-mode-doctype-face
:inherit ,font-lock-comment-face)
`(web-mode-function-name-face
:inherit ,font-lock-function-name-face)
`(web-mode-string-face :foreground ,ArcticBlue)
`(web-mode-type-face
:inherit ,font-lock-type-face)
`(web-mode-html-attr-name-face :foreground ,Violet)
`(web-mode-html-attr-value-face :foreground ,HarlequinGreen)
`(web-mode-warning-face
:inherit ,font-lock-warning-face)
`(web-mode-html-tag-face :foreground ,Indigo)
`(jde-java-font-lock-package-face :foreground ,Magenta)
`(jde-java-font-lock-public-face :foreground ,HarlequinGreen)
`(jde-java-font-lock-private-face :foreground ,HarlequinGreen)
`(jde-java-font-lock-constant-face :foreground ,IcebergBlue)
`(jde-java-font-lock-modifier-face :foreground ,key3)
`(jde-jave-font-lock-protected-face :foreground ,HarlequinGreen)
`(jde-java-font-lock-number-face :foreground ,Magenta))))
;;;###autoload
(when load-file-name
(add-to-list 'custom-theme-load-path
(file-name-as-directory (file-name-directory load-file-name))))
(provide-theme 'weyland-yutani)
;; Shuts Package-Lint up.
(provide 'weyland-yutani-theme)
;;; weyland-yutani-theme.el ends here
(define-package "weyland-yutani-theme" "20210802.2251" "Emacs theme based off Alien movie franchise"
'((emacs "24.1"))
:commit "e89a63a62e071180c9cdd9067679fadc3f7bf796" :authors
'(("Joe Staursky"))
:maintainers
'(("Joe Staursky"))
:maintainer
'("Joe Staursky")
:url "https://github.com/jstaursky/weyland-yutani-theme")
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; weyland-yutani-theme-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from weyland-yutani-theme.el
(when load-file-name (add-to-list 'custom-theme-load-path (file-name-as-directory (file-name-directory load-file-name))))
(register-definition-prefixes "weyland-yutani-theme" '("weyland-yutani-theme-face-specifier"))
;;; End of scraped data
(provide 'weyland-yutani-theme-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; weyland-yutani-theme-autoloads.el ends here
This is web-server.info, produced by makeinfo version 6.7 from
web-server.texi.
This file documents the Emacs Web Server (web-server)
Copyright (C) 2013 Eric Schulte <schulte.eric@gmail.com>
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
Version 1.3 or any later version published by the Free Software
Foundation; with the Invariant Section being “GNU GENERAL PUBLIC
LICENSE,” A copy of the license is included in the section entitled
“GNU Free Documentation License.”
INFO-DIR-SECTION Emacs
START-INFO-DIR-ENTRY
* Web Server: (web-server). Web Server for Emacs.
END-INFO-DIR-ENTRY
File: web-server.info, Node: Top, Next: Introduction, Prev: (dir), Up: (dir)
Emacs Web Server User Manual
****************************
This file documents the Emacs Web Server (web-server)
Copyright (C) 2013 Eric Schulte <schulte.eric@gmail.com>
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
Version 1.3 or any later version published by the Free Software
Foundation; with the Invariant Section being “GNU GENERAL PUBLIC
LICENSE,” A copy of the license is included in the section entitled
“GNU Free Documentation License.”
* Menu:
* Introduction:: Overview of the Emacs Web Server
* Handlers:: Handlers respond to HTTP requests
* Requests:: Getting information on HTTP requests
* Usage Examples:: Examples demonstrating usage
* Function Index:: List of Functions
Appendices
* Copying:: The GNU General Public License gives
you permission to redistribute GNU Emacs on
certain terms; it also explains that there is
no warranty.
* GNU Free Documentation License:: The license for this documentation.
* Index:: Complete index.
File: web-server.info, Node: Introduction, Next: Handlers, Prev: Top, Up: Top
1 Introduction
**************
The Emacs Web Server is a Web server implemented entirely in Emacs Lisp.
HTTP requests are matched to handlers (*note Handlers::) which are Emacs
Lisp functions. Handlers receive as their only argument a request
object (*note Requests::) which holds information about the request and
a process holding the HTTP network connection. Handlers write their
responses directly to the network process.
A number of examples (*note Usage Examples::) demonstrate usage of
the Emacs Web Server. All public functions of the Emacs Web Server are
listed (*note Function Index::).
File: web-server.info, Node: Handlers, Next: Requests, Prev: Handlers, Up: Top
2 Handlers
**********
The function ‘ws-start’ takes takes two arguments ‘handlers’ and ‘port’.
It starts a server listening on ‘port’ responding to requests with
‘handlers’. ‘Handlers’ may be either a single function or an
association list composed of pairs of matchers and handler functions.
When ‘handlers’ is a single function the given function is used to serve
every request, when it is an association list, the function of the first
matcher to match each request handles that request.
2.1 Matchers
============
Matchers may be a regular expression or a function. Regular expression
matchers consists of an HTTP header and a regular expression. When the
regular expression matches the content of the given header the matcher
succeeds and the associated handler is called. For example the
following matches any ‘GET’ request whose path starts with the substring
“foo”.
(:GET . "^foo")
A function matcher is a function which takes the request object
(*note Requests::) and succeeds when the function returns a non-nil
value. For example the following matcher matches every request,
(lambda (_) t)
and the following matches only requests in which the supplied
“number” parameter is odd.
(lambda (request)
(oddp (string-to-number (cdr (assoc "number" request)))))
2.2 Handler Function
====================
Each handler is a function which takes a request object (*note
Requests::) as its only argument. The function may respond to the
request by writing to the network process held in the ‘process’ field of
the request object. For example, the ‘process-send-string’ function may
be used to write string data to a request as in the following.
(process-send-string (process request) "hello world")
When the handler function exits the connection is terminated unless
the handler function returns the keyword ‘:keep-alive’.
File: web-server.info, Node: Requests, Next: Usage Examples, Prev: Handlers, Up: Top
3 Requests
**********
Each HTTP requests is represented using a ‘ws-request’ object (*note
ws-request::). The request object serves two purposes, one internal and
one external. Internally, request objects are used to hold state while
HTTP headers are parsed incrementally as the HTTP request text is
received from the network. Externally, request objects are used to
decide which handler to call, and are then passed as the only argument
to the called handler.
In addition to fields used internally, each ‘ws-request’ object holds
the network process in the ‘process’ and holds all HTTP headers and
request GET or POST parameters in the ‘headers’ alist. HTML Headers are
keyed using uppercase keywords (e.g., ‘:GET’), and user supplied
parameters are keyed using the string name of the parameter.
The ‘process’ field may be used by handlers to send data to a client
as in the following example.
(process-send-string (process request) "hello world")
The ‘headers’ field may be used to access request information such as
the requested path,
(cdr (assoc :GET (headers request)))
or named parameters as from a web form.
(cdr (assoc "message" (headers request)))
File: web-server.info, Node: Usage Examples, Next: Hello World, Prev: Requests, Up: Top
4 Usage Examples
****************
These examples demonstrate usage.
* Menu:
* Hello World:: Serve “Hello World” to every request
* Hello World UTF8:: Serve “Hello World” w/UTF8 encoding
* Hello World HTML:: Serve “Hello World” in HTML
* File Server:: Serve files from a document root
* URL Parameter Echo:: Echo parameters from a URL query string
* POST Echo:: Echo POST parameters back
* Basic Authentication:: BASIC HTTP authentication
* Org-mode Export:: Export files to HTML and Tex
* File Upload:: Upload files and return their sha1sum
* Web Socket:: Web socket echo server
* Gzipped Transfer Encoding:: Gzip content encoding
* Chunked Transfer Encoding:: Chunked transfer encoding
File: web-server.info, Node: Hello World, Next: Hello World UTF8, Prev: Usage Examples, Up: Usage Examples
4.1 Hello World
===============
The simplest possible “hello world” example. The handler consists of a
single (matcher . handler) pair. The function matcher matches _every_
incoming HTTP request. The handler responds by setting the content type
to ‘text/plain’, and then sending the string “hello world”. When the
handler exits the network connection of the request is closed.
;;; hello-world.el --- simple hello world server using Emacs Web Server
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
(lambda (request)
(with-slots (process headers) request
(ws-response-header process 200 '("Content-type" . "text/plain"))
(process-send-string process "hello world")))
9000)
File: web-server.info, Node: Hello World UTF8, Next: Hello World HTML, Prev: Hello World, Up: Usage Examples
4.2 Hello World UTF8
====================
This example only differs from the previous in that the “Content-type”
indicates UTF8 encoded data, and the hello world sent is selected at
random from a list of different languages.
;;; hello-world-utf8.el --- utf8 hello world server using Emacs Web Server
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
(lambda (request)
(with-slots (process headers) request
(let ((hellos '("こんにちは"
"안녕하세요"
"góðan dag"
"Grüßgott"
"hyvää päivää"
"yá'át'ééh"
"Γεια σας"
"Вiтаю"
"გამარჯობა"
"नमस्ते"
"你好")))
(ws-response-header process 200
'("Content-type" . "text/plain; charset=utf-8"))
(process-send-string process
(concat (nth (random (length hellos)) hellos) " world")))))
9001)
File: web-server.info, Node: Hello World HTML, Next: File Server, Prev: Hello World UTF8, Up: Usage Examples
4.3 Hello World HTML
====================
;;; hello-world-html.el --- html hello world server using Emacs Web Server
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
(lambda (request)
(with-slots (process headers) request
(ws-response-header process 200 '("Content-type" . "text/html"))
(process-send-string process "<html>
<head>
<title>Hello World</title>
</head>
<body>
<b>hello world</b>
</body>
</html>")))
9002)
This variation of the “hello world” example sends a ‘text/html’
response instead of a simple ‘text/plain’ response.
File: web-server.info, Node: File Server, Next: URL Parameter Echo, Prev: Hello World HTML, Up: Usage Examples
4.4 File Server
===============
The following example implements a file server which will serve files
from the ‘docroot’ document root set to the current working directory in
this example. Four helper functions are used; ‘ws-in-directory-p’ is
used to check if the requested path is within the document root. If not
then ‘ws-send-404’ is used to send a default “File Not Found”. If so
then the file is served with ‘ws-send-file’ (which appropriately sets
the mime-type of the response based on the extension of the file) if it
is a file or is served with ‘ws-send-directory-list’ if it is a
directory.
;;; file-server.el --- serve any files using Emacs Web Server
;; Copyright (C) 2014 Free Software Foundation, Inc.
(lexical-let ((docroot default-directory))
(ws-start
(lambda (request)
(with-slots (process headers) request
(let ((path (substring (cdr (assoc :GET headers)) 1)))
(if (ws-in-directory-p docroot path)
(if (file-directory-p path)
(ws-send-directory-list process
(expand-file-name path docroot) "^[^\.]")
(ws-send-file process (expand-file-name path docroot)))
(ws-send-404 process)))))
9003))
File: web-server.info, Node: URL Parameter Echo, Next: POST Echo, Prev: File Server, Up: Usage Examples
4.5 URL Parameter Echo
======================
This example demonstrates access of URL-encoded parameters in a ‘GET’
request. For example the following URL
<http://localhost:9005/example?foo=bar&baz=qux> will render as the
following HTML table.
foo bar
baz qux
;;; url-param-echo.el --- echo back url-paramed message using Emacs Web Server
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
'(((:GET . ".*") .
(lambda (request)
(with-slots (process headers) request
(ws-response-header process 200 '("Content-type" . "text/html"))
(process-send-string process
(concat "URL Parameters:</br><table><tr>"
(mapconcat (lambda (pair)
(format "<th>%s</th><td>%s</td>"
(car pair) (cdr pair)))
(cl-remove-if-not (lambda (el) (stringp (car el)))
headers)
"</tr><tr>")
"</tr></table>"))))))
9004)
File: web-server.info, Node: POST Echo, Next: Basic Authentication, Prev: URL Parameter Echo, Up: Usage Examples
4.6 POST Echo
=============
The following example echos back the content of the “message” field in a
‘POST’ request.
;;; post-echo.el --- echo back posted message using Emacs Web Server
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
'(((:POST . ".*") .
(lambda (request)
(with-slots (process headers) request
(let ((message (cdr (assoc "message" headers))))
(ws-response-header process 200 '("Content-type" . "text/plain"))
(process-send-string process
(if message
(format "you said %S\n" (cdr (assoc 'content message)))
"This is a POST request, but it has no \"message\".\n"))))))
((:GET . ".*") .
(lambda (request)
(with-slots (process) request
(ws-response-header process 200 '("Content-type" . "text/plain"))
(process-send-string process
"This is a GET request not a POST request.\n")))))
9005)
File: web-server.info, Node: Basic Authentication, Next: Org-mode Export, Prev: POST Echo, Up: Usage Examples
4.7 Basic Authentication
========================
The following example demonstrates BASIC HTTP authentication. The
handler prompts an unauthenticated client for authentication by sending
a “WWW-Authenticate” header.
(ws-response-header process 401
'("WWW-Authenticate" . "Basic realm=\"example\"")
'("Content-type" . "text/plain"))
The client replies by setting the “Authorization” HTTP header which
is parsed into a list of the form ‘(PROTOCOL USERNAME . PASSWORD)’.
Currently only BASIC HTTP authentication is supported.
Note: BASIC HTTP authentication passes user credentials in plain text
between the client and the server and should generally only be used with
HTTPS network encryption. While the Emacs web server currently doesn’t
support HTTPS network encryption it may be run behind an HTTPS proxy
server (e.g., Apache or Nginx) with HTTPS support.
;;; basic-authentication.el --- basic authentication
;; Copyright (C) 2014 Free Software Foundation, Inc.
(lexical-let ((users '(("foo" . "bar")
("baz" . "qux"))))
(ws-start
(ws-with-authentication
(lambda (request)
(with-slots (process headers) request
(let ((user (caddr (assoc :AUTHORIZATION headers))))
(ws-response-header process 200 '("Content-type" . "text/plain"))
(process-send-string process (format "welcome %s" user)))))
users)
9006))
File: web-server.info, Node: Org-mode Export, Next: File Upload, Prev: Basic Authentication, Up: Usage Examples
4.8 Org-mode Export
===================
The following example exports a directory of Org-mode files as either
text, HTML or LaTeX. The Org-mode export engine is used to export files
on-demand as they are requested.
;;; org-mode-file-server.el --- serve on-demand exported Org-mode files
;; Copyright (C) 2014 Free Software Foundation, Inc.
(lexical-let ((docroot "/tmp/"))
(ws-start
(lambda (request)
(with-slots (process headers) request
(let ((path (ws-in-directory-p ; check if path is in docroot
docroot (substring (cdr (assoc :GET headers)) 1))))
(unless path (ws-send-404 process)) ; send 404 if not in docroot
(if (file-directory-p path)
(progn ;; send directory listing, convert org files to html/tex/txt
(ws-response-header proc 200 (cons "Content-type" "text/html"))
(process-send-string proc
(concat "<ul>"
(mapconcat
(lambda (f)
(let* ((full (expand-file-name f path))
(end (if (file-directory-p full) "/" ""))
(url (url-encode-url (concat f end))))
(format "<li><a href=%s>%s</li>" url f)))
(apply #'append
(mapcar
(lambda (f)
(list (concat f ".txt")
(concat f ".tex")
(concat f ".html")))
(mapcar #'file-name-sans-extension
(directory-files path nil
"^[^\.].*org$"))))
"\n") "</ul>")))
;; Export the file as requested and return the result
(let* ((base (file-name-sans-extension path))
(type (case (intern (downcase (file-name-extension path)))
(html 'html)
(tex 'latex)
(txt 'ascii)
(t (ws-error process "%S export not supported"
(file-name-extension path)))))
(orig (concat base ".org")))
(unless (file-exists-p orig) (ws-send-404 process))
(save-window-excursion (find-file orig)
(org-export-to-file type path))
(ws-send-file process path))))))
9007))
File: web-server.info, Node: File Upload, Next: Web Socket, Prev: Org-mode Export, Up: Usage Examples
4.9 File Upload
===============
The following example demonstrates accessing an uploaded file. This
simple server accesses the file named “file” and returns it’s sha1sum
and file name.
;;; file-upload.el --- use an uploaded file
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
'(((:POST . ".*") .
(lambda (request)
(with-slots (process headers) request
(ws-response-header process 200 '("Content-type" . "text/plain"))
(let ((file (cdr (assoc "file" headers))))
(process-send-string process
(concat (sha1 (cdr (assoc 'content file))) " "
(cdr (assoc 'filename file)) "\n")))))))
9008)
A file may be uploaded from an HTML form, or using the ‘curl’ program
as in the following example.
$ curl -s -F file=usr/share/emacs/24.3/etc/COPYING localhost:9008
8624bcdae55baeef00cd11d5dfcfa60f68710a02 COPYING
$ sha1sum /usr/share/emacs/24.3/etc/COPYING
8624bcdae55baeef00cd11d5dfcfa60f68710a02 /usr/share/emacs/24.3/etc/COPYING
File: web-server.info, Node: Web Socket, Next: Chunked Transfer Encoding, Prev: File Upload, Up: Usage Examples
4.10 Web Socket
===============
Example demonstrating the use of web sockets for full duplex
communication between clients and the server. Handlers may use the
‘ws-web-socket-connect’ function (*note ws-web-socket-connect::) to
check for and respond to a web socket upgrade request sent by the client
(as demonstrated with the ‘new WebSocket’ JavaScript code in the
example). Upon successfully initializing a web socket connection the
call to ‘ws-web-socket-connect’ will return the web socket network
process. This process may then be used by the server to communicate
with the client over the web socket using the ‘process-send-string’ and
‘ws-web-socket-frame’ functions. All web socket communication must be
wrapped in frames using the ‘ws-web-socket-frame’ function.
The handler must pass a function as the second argument to
‘ws-web-socket-connect’. This function will be called on every web
socket message received from the client.
Note: in order to keep the web socket connection alive the request
handler from which ‘ws-web-socket-connect’ is called must return the
‘:keep-alive’ keyword, as demonstrated in the example.
;;; web-sockets.el --- communicate via web-sockets
;; Copyright (C) 2014 Free Software Foundation, Inc.
(lexical-let* ((web-socket-port 9009)
(web-socket-page
(format "<html>
<head>
<script type=\"text/javascript\">
var ws;
function connect(){
ws = new WebSocket(\"ws://localhost:%d/\");
ws.onopen = function() { alert(\"connected\"); };
ws.onmessage = function(msg) { alert(\"server: \" + msg.data); };
ws.onclose = function() { alert(\"connection closed\"); };
}
function message(){ ws.send(\"foo\"); }
function close(){ ws.close(); };
</script>
</head>
<body>
<ol>
<li>Press \"connect\" to initialize the web socket connection to
the server. The server will complete the web socket
handshake at which point you'll see an alert with the text
\"connected\".</li>
<li>Press \"message\" to send the string \"foo\" to the server.
The server will reply with the text \"you said: foo\" which
you will see in an alert as \"server: you said: foo\".</li>
<li>Press \"close\" to close the connection. After the server
responds with a close frame you will see an alert with the
text \"connection closed\".</li>
</ol>
<a href=\"javascript:connect()\">connect</a>
<a href=\"javascript:message()\">message</a>
<a href=\"javascript:close()\">close</a>
</body>
</html>" web-socket-port)))
(ws-start
(lambda (request)
(with-slots (process headers) request
;; if a web-socket request, then connect and keep open
(if (ws-web-socket-connect request
(lambda (proc string)
(process-send-string proc
(ws-web-socket-frame (concat "you said: " string)))))
(prog1 :keep-alive (setq my-connection process))
;; otherwise send the index page
(ws-response-header process 200 '("Content-type" . "text/html"))
(process-send-string process web-socket-page))))
web-socket-port))
File: web-server.info, Node: Gzipped Transfer Encoding, Next: Chunked Transfer Encoding, Prev: Web Socket, Up: Usage Examples
4.11 Gzipped Transfer Encoding
==============================
HTTP Responses may be compressed by setting the “gzip” (or “compress” or
“deflate”) content- or transfer-encoding HTTP headers in
‘ws-response-header’. Any further data sent to the process using
‘ws-send’ will automatically be appropriately compressed.
;;; content-encoding-gzip.el -- gzip content encoding
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
(lambda (request)
(with-slots (process headers) request
(ws-response-header process 200
'("Content-type" . "text/plain; charset=utf-8")
'("Content-Encoding" . "x-gzip"))
(let ((s "Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Donec
hendrerit tempor tellus. Donec pretium posuere tellus. Proin quam
nisl, tincidunt et, mattis eget, convallis nec, purus. Cum sociis
natoque penatibus et magnis dis parturient montes, nascetur
ridiculus mus. Nulla posuere. Donec vitae dolor. Nullam tristique
diam non turpis. Cras placerat accumsan nulla. Nullam rutrum. Nam
vestibulum accumsan nisl.
Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Donec
hendrerit tempor tellus. Donec pretium posuere tellus. Proin quam
nisl, tincidunt et, mattis eget, convallis nec, purus. Cum sociis
natoque penatibus et magnis dis parturient montes, nascetur
ridiculus mus. Nulla posuere. Donec vitae dolor. Nullam tristique
diam non turpis. Cras placerat accumsan nulla. Nullam rutrum. Nam
vestibulum accumsan nisl."))
(ws-send process s))))
9016)
File: web-server.info, Node: Chunked Transfer Encoding, Next: Function Index, Prev: Web Socket, Up: Usage Examples
4.12 Chunked Transfer Encoding
==============================
Similarly, HTTP Responses may be sent using the “chunked” transfer
encoding by passing the appropriate HTTP header to ‘ws-response-header’.
Any further data sent to the process using ‘ws-send’ will automatically
be appropriately encoded for chunked transfer.
;;; transfer-encoding-chunked.el -- chunked transfer encoding
;; Copyright (C) 2014 Free Software Foundation, Inc.
(ws-start
(lambda (request)
(let ((s "
Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Donec
hendrerit tempor tellus. Donec pretium posuere tellus. Proin quam
nisl, tincidunt et, mattis eget, convallis nec, purus. Cum sociis
natoque penatibus et magnis dis parturient montes, nascetur
ridiculus mus. Nulla posuere. Donec vitae dolor. Nullam tristique
diam non turpis. Cras placerat accumsan nulla. Nullam rutrum. Nam
vestibulum accumsan nisl.
Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Donec
hendrerit tempor tellus. Donec pretium posuere tellus. Proin quam
nisl, tincidunt et, mattis eget, convallis nec, purus. Cum sociis
natoque penatibus et magnis dis parturient montes, nascetur
ridiculus mus. Nulla posuere. Donec vitae dolor. Nullam tristique
diam non turpis. Cras placerat accumsan nulla. Nullam rutrum. Nam
vestibulum accumsan nisl.
"))
(with-slots (process headers) request
(ws-response-header process 200
'("Content-type" . "text/plain; charset=utf-8")
'("Transfer-Encoding" . "chunked"))
(ws-send process s) (sit-for 0.5)
(ws-send process s) (sit-for 0.5)
(ws-send process s) (sit-for 0.5)
(ws-send process s))))
9017)
File: web-server.info, Node: Function Index, Next: Copying, Prev: Usage Examples, Up: Top
5 Function Index
****************
The following functions implement the Emacs Web Server public API.
5.1 Objects
===========
The following objects represent web servers and requests.
-- Class: ws-server handlers process port requests
Every Emacs web server is an instance of the ‘ws-server’ class.
Each instance includes the ‘handlers’ association list and ‘port’
passed to ‘ws-start’, as well as the server network ‘process’ and a
list of all active ‘requests’.
-- Class: ws-request process pending context boundary index active
headers
The ‘ws-request’ class represents an active web request. The
‘process’ field holds the network process of the client and may be
used by handlers to respond to requests. The ‘headers’ field holds
an alist of information on the request for use by handlers. The
remaining ‘pending’, ‘context’, ‘boundary’, ‘index’ and ‘active’
fields are used to maintain header parsing information across calls
to the ‘ws-filter’ function.
5.2 Starting and Stopping Servers
=================================
The following functions start and stop Emacs web servers. The
‘ws-servers’ list holds all running servers.
-- Function: ws-start handlers port &optional log-buffer &rest
network-args
‘ws-start’ starts a server listening on ‘port’ using ‘handlers’
(*note Handlers::) to match and respond to requests. An instance
of the ‘ws-server’ class is returned.
-- Variable: ws-servers
The ‘ws-servers’ list holds all active Emacs web servers.
-- Function: ws-stop server
‘ws-stop’ stops ‘server’ deletes all related processes, and frees
the server’s port. Evaluate the following to stop all emacs web
servers.
(mapc #'ws-stop ws-servers)
-- Function: ws-stop-all
‘ws-stop-all’ stops all emacs web servers by mapping ‘ws-stop’ over
‘ws-servers’.
5.3 Convenience Functions
=========================
The following convenience functions automate many common tasks
associated with responding to HTTP requests.
-- Function: ws-response-header process code &rest headers
Send the headers required to start an HTTP response to ‘proc’.
‘proc’ should be a ‘ws-request’ ‘proc’ of an active request.
For example start a standard 200 “OK” HTML response with the
following.
(ws-response-header process 200 '("Content-type" . "text/html"))
The encoding may optionally be set in the HTTP header. Send a UTF8
encoded response with the following.
(ws-response-header process 200
'("Content-type" . "text/plain; charset=utf-8"))
Additionally, when “Content-Encoding” or “Transfer-Encoding”
headers are supplied any subsequent data written to ‘proc’ using
‘ws-send’ will be encoded appropriately including sending the
appropriate data upon the end of transmission for chunked transfer
encoding.
For example with the header ‘("Content-Encoding" . "gzip")’, any
data subsequently written to ‘proc’ using ‘ws-send’ will be
compressed using the command specified in ‘ws-gzip-cmd’. See *note
Gzipped Transfer Encoding:: and *note Chunked Transfer Encoding::
for more complete examples.
-- Function: ws-send proc string
Send ‘string’ to process ‘proc’. If any Content or Transfer
encodings are in use, apply them to ‘string’ before sending.
-- Function: ws-send-500 process &rest msg-and-args
‘ws-send-500’ sends a default 500 “Internal Server Error” response
to ‘process’.
-- Function: ws-send-404 process &rest msg-and-args
‘ws-send-500’ sends a default 404 “File Not Found” response to
‘process’.
-- Function: ws-send-file process path &optional mime-type
‘ws-send-file’ sends the file located at ‘path’ to ‘process’. If
the optional ‘mime-type’ is not set, then the mime-type is
determined by calling ‘mm-default-file-encoding’ on ‘path’ or is
set to “application/octet-stream” if no mime-type can be
determined.
-- Function: ws-send-directory-list process directory &optional match
‘ws-send-directory-list’ sends the a listing of the files located
in ‘directory’ to ‘process’. The list is sent as an HTML list of
links to the files. Optional argument ‘match’ may be set to a
regular expression, in which case only those files that match are
listed.
-- Function: ws-in-directory-p parent path
Check if ‘path’ is under the ‘parent’ directory.
(ws-in-directory-p "/tmp/" "pics")
⇒ "/tmp/pics"
(ws-in-directory-p "/tmp/" "..")
⇒ nil
(ws-in-directory-p "/tmp/" "~/pics")
⇒ nil
-- Function: ws-with-authentication handler credentials &optional realm
unauth invalid
Return a version of ‘handler’ which is protected by ‘credentials’.
Handler should be a normal handler function (*note Handlers::) and
‘credentials’ should be an association list of usernames and
passwords.
For example, a server running the following handlers,
(list (cons '(:GET . ".*") 'view-handler)
(cons '(:POST . ".*") 'edit-handler))
could have authorization added by changing the handlers to the
following.
(list (cons '(:GET . ".*") view-handler)
(cons '(:POST . ".*") (ws-with-authentication
'org-ehtml-edit-handler
'(("admin" . "password")))))
-- Function: ws-web-socket-connect request handler
If ‘request’ is a web socket upgrade request (indicated by the
presence of the ‘:SEC-WEBSOCKET-KEY’ header argument) establish a
web socket connection to the client. Call ‘handler’ on web socket
messages received from the client.
(ws-web-socket-connect request
(lambda (proc string)
(process-send-string proc
(ws-web-socket-frame (concat "you said: " string)))))
⇒ #<process ws-server <127.0.0.1:34921>>
5.4 Customization Variables
===========================
The following variables may be changed to control the behavior of the
web server. Specifically the ‘ws-*-cmd’ variables specify the command
lines used to compress data according to content and or transfer
encoding HTTP headers passed to *note ws-response-header::.
-- Variable: ws-compress-cmd
Command used for the “compress” Content or Transfer coding.
-- Variable: ws-deflate-cmd
Command used for the “deflate” Content or Transfer coding.
-- Variable: ws-gzip-cmd
Command used for the “gzip” Content or Transfer coding.
File: web-server.info, Node: Copying, Next: GNU Free Documentation License, Prev: Function Index, Up: Top
Appendix A GNU GENERAL PUBLIC LICENSE
*************************************
Version 3, 29 June 2007
Copyright © 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies of this
license document, but changing it is not allowed.
Preamble
========
The GNU General Public License is a free, copyleft license for software
and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program—to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers’ and authors’ protection, the GPL clearly explains
that there is no warranty for this free software. For both users’ and
authors’ sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users’ freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
====================
0. Definitions.
“This License” refers to version 3 of the GNU General Public
License.
“Copyright” also means copyright-like laws that apply to other
kinds of works, such as semiconductor masks.
“The Program” refers to any copyrightable work licensed under this
License. Each licensee is addressed as “you”. “Licensees” and
“recipients” may be individuals or organizations.
To “modify” a work means to copy from or adapt all or part of the
work in a fashion requiring copyright permission, other than the
making of an exact copy. The resulting work is called a “modified
version” of the earlier work or a work “based on” the earlier work.
A “covered work” means either the unmodified Program or a work
based on the Program.
To “propagate” a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on
a computer or modifying a private copy. Propagation includes
copying, distribution (with or without modification), making
available to the public, and in some countries other activities as
well.
To “convey” a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user
through a computer network, with no transfer of a copy, is not
conveying.
An interactive user interface displays “Appropriate Legal Notices”
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to
the extent that warranties are provided), that licensees may convey
the work under this License, and how to view a copy of this
License. If the interface presents a list of user commands or
options, such as a menu, a prominent item in the list meets this
criterion.
1. Source Code.
The “source code” for a work means the preferred form of the work
for making modifications to it. “Object code” means any non-source
form of a work.
A “Standard Interface” means an interface that either is an
official standard defined by a recognized standards body, or, in
the case of interfaces specified for a particular programming
language, one that is widely used among developers working in that
language.
The “System Libraries” of an executable work include anything,
other than the work as a whole, that (a) is included in the normal
form of packaging a Major Component, but which is not part of that
Major Component, and (b) serves only to enable use of the work with
that Major Component, or to implement a Standard Interface for
which an implementation is available to the public in source code
form. A “Major Component”, in this context, means a major
essential component (kernel, window system, and so on) of the
specific operating system (if any) on which the executable work
runs, or a compiler used to produce the work, or an object code
interpreter used to run it.
The “Corresponding Source” for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts
to control those activities. However, it does not include the
work’s System Libraries, or general-purpose tools or generally
available free programs which are used unmodified in performing
those activities but which are not part of the work. For example,
Corresponding Source includes interface definition files associated
with source files for the work, and the source code for shared
libraries and dynamically linked subprograms that the work is
specifically designed to require, such as by intimate data
communication or control flow between those subprograms and other
parts of the work.
The Corresponding Source need not include anything that users can
regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running
a covered work is covered by this License only if the output, given
its content, constitutes a covered work. This License acknowledges
your rights of fair use or other equivalent, as provided by
copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise
remains in force. You may convey covered works to others for the
sole purpose of having them make modifications exclusively for you,
or provide you with facilities for running those works, provided
that you comply with the terms of this License in conveying all
material for which you do not control copyright. Those thus making
or running the covered works for you must do so exclusively on your
behalf, under your direction and control, on terms that prohibit
them from making any copies of your copyrighted material outside
their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section
10 makes it unnecessary.
3. Protecting Users’ Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under
article 11 of the WIPO copyright treaty adopted on 20 December
1996, or similar laws prohibiting or restricting circumvention of
such measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such
circumvention is effected by exercising rights under this License
with respect to the covered work, and you disclaim any intention to
limit operation or modification of the work as a means of
enforcing, against the work’s users, your or third parties’ legal
rights to forbid circumvention of technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program’s source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the
code; keep intact all notices of the absence of any warranty; and
give all recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these
conditions:
a. The work must carry prominent notices stating that you
modified it, and giving a relevant date.
b. The work must carry prominent notices stating that it is
released under this License and any conditions added under
section 7. This requirement modifies the requirement in
section 4 to “keep intact all notices”.
c. You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable
section 7 additional terms, to the whole of the work, and all
its parts, regardless of how they are packaged. This License
gives no permission to license the work in any other way, but
it does not invalidate such permission if you have separately
received it.
d. If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has
interactive interfaces that do not display Appropriate Legal
Notices, your work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered
work, and which are not combined with it such as to form a larger
program, in or on a volume of a storage or distribution medium, is
called an “aggregate” if the compilation and its resulting
copyright are not used to limit the access or legal rights of the
compilation’s users beyond what the individual works permit.
Inclusion of a covered work in an aggregate does not cause this
License to apply to the other parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this
License, in one of these ways:
a. Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b. Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that
product model, to give anyone who possesses the object code
either (1) a copy of the Corresponding Source for all the
software in the product that is covered by this License, on a
durable physical medium customarily used for software
interchange, for a price no more than your reasonable cost of
physically performing this conveying of source, or (2) access
to copy the Corresponding Source from a network server at no
charge.
c. Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially,
and only if you received the object code with such an offer,
in accord with subsection 6b.
d. Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to
the Corresponding Source in the same way through the same
place at no further charge. You need not require recipients
to copy the Corresponding Source along with the object code.
If the place to copy the object code is a network server, the
Corresponding Source may be on a different server (operated by
you or a third party) that supports equivalent copying
facilities, provided you maintain clear directions next to the
object code saying where to find the Corresponding Source.
Regardless of what server hosts the Corresponding Source, you
remain obligated to ensure that it is available for as long as
needed to satisfy these requirements.
e. Convey the object code using peer-to-peer transmission,
provided you inform other peers where the object code and
Corresponding Source of the work are being offered to the
general public at no charge under subsection 6d.
A separable portion of the object code, whose source code is
excluded from the Corresponding Source as a System Library, need
not be included in conveying the object code work.
A “User Product” is either (1) a “consumer product”, which means
any tangible personal property which is normally used for personal,
family, or household purposes, or (2) anything designed or sold for
incorporation into a dwelling. In determining whether a product is
a consumer product, doubtful cases shall be resolved in favor of
coverage. For a particular product received by a particular user,
“normally used” refers to a typical or common use of that class of
product, regardless of the status of the particular user or of the
way in which the particular user actually uses, or expects or is
expected to use, the product. A product is a consumer product
regardless of whether the product has substantial commercial,
industrial or non-consumer uses, unless such uses represent the
only significant mode of use of the product.
“Installation Information” for a User Product means any methods,
procedures, authorization keys, or other information required to
install and execute modified versions of a covered work in that
User Product from a modified version of its Corresponding Source.
The information must suffice to ensure that the continued
functioning of the modified object code is in no case prevented or
interfered with solely because modification has been made.
If you convey an object code work under this section in, or with,
or specifically for use in, a User Product, and the conveying
occurs as part of a transaction in which the right of possession
and use of the User Product is transferred to the recipient in
perpetuity or for a fixed term (regardless of how the transaction
is characterized), the Corresponding Source conveyed under this
section must be accompanied by the Installation Information. But
this requirement does not apply if neither you nor any third party
retains the ability to install modified object code on the User
Product (for example, the work has been installed in ROM).
The requirement to provide Installation Information does not
include a requirement to continue to provide support service,
warranty, or updates for a work that has been modified or installed
by the recipient, or for the User Product in which it has been
modified or installed. Access to a network may be denied when the
modification itself materially and adversely affects the operation
of the network or violates the rules and protocols for
communication across the network.
Corresponding Source conveyed, and Installation Information
provided, in accord with this section must be in a format that is
publicly documented (and with an implementation available to the
public in source code form), and must require no special password
or key for unpacking, reading or copying.
7. Additional Terms.
“Additional permissions” are terms that supplement the terms of
this License by making exceptions from one or more of its
conditions. Additional permissions that are applicable to the
entire Program shall be treated as though they were included in
this License, to the extent that they are valid under applicable
law. If additional permissions apply only to part of the Program,
that part may be used separately under those permissions, but the
entire Program remains governed by this License without regard to
the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part
of it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material
you add to a covered work, you may (if authorized by the copyright
holders of that material) supplement the terms of this License with
terms:
a. Disclaiming warranty or limiting liability differently from
the terms of sections 15 and 16 of this License; or
b. Requiring preservation of specified reasonable legal notices
or author attributions in that material or in the Appropriate
Legal Notices displayed by works containing it; or
c. Prohibiting misrepresentation of the origin of that material,
or requiring that modified versions of such material be marked
in reasonable ways as different from the original version; or
d. Limiting the use for publicity purposes of names of licensors
or authors of the material; or
e. Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f. Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified
versions of it) with contractual assumptions of liability to
the recipient, for any liability that these contractual
assumptions directly impose on those licensors and authors.
All other non-permissive additional terms are considered “further
restrictions” within the meaning of section 10. If the Program as
you received it, or any part of it, contains a notice stating that
it is governed by this License along with a term that is a further
restriction, you may remove that term. If a license document
contains a further restriction but permits relicensing or conveying
under this License, you may add to a covered work material governed
by the terms of that license document, provided that the further
restriction does not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in
the form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights
under this License (including any patent licenses granted under the
third paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the
copyright holder fails to notify you of the violation by some
reasonable means prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from
that copyright holder, and you cure the violation prior to 30 days
after your receipt of the notice.
Termination of your rights under this section does not terminate
the licenses of parties who have received copies or rights from you
under this License. If your rights have been terminated and not
permanently reinstated, you do not qualify to receive new licenses
for the same material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer
transmission to receive a copy likewise does not require
acceptance. However, nothing other than this License grants you
permission to propagate or modify any covered work. These actions
infringe copyright if you do not accept this License. Therefore,
by modifying or propagating a covered work, you indicate your
acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not
responsible for enforcing compliance by third parties with this
License.
An “entity transaction” is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a
covered work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party’s predecessor in interest had or
could give under the previous paragraph, plus a right to possession
of the Corresponding Source of the work from the predecessor in
interest, if the predecessor has it or can get it with reasonable
efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you
may not impose a license fee, royalty, or other charge for exercise
of rights granted under this License, and you may not initiate
litigation (including a cross-claim or counterclaim in a lawsuit)
alleging that any patent claim is infringed by making, using,
selling, offering for sale, or importing the Program or any portion
of it.
11. Patents.
A “contributor” is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based.
The work thus licensed is called the contributor’s “contributor
version”.
A contributor’s “essential patent claims” are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner,
permitted by this License, of making, using, or selling its
contributor version, but do not include claims that would be
infringed only as a consequence of further modification of the
contributor version. For purposes of this definition, “control”
includes the right to grant patent sublicenses in a manner
consistent with the requirements of this License.
Each contributor grants you a non-exclusive, worldwide,
royalty-free patent license under the contributor’s essential
patent claims, to make, use, sell, offer for sale, import and
otherwise run, modify and propagate the contents of its contributor
version.
In the following three paragraphs, a “patent license” is any
express agreement or commitment, however denominated, not to
enforce a patent (such as an express permission to practice a
patent or covenant not to sue for patent infringement). To “grant”
such a patent license to a party means to make such an agreement or
commitment not to enforce a patent against the party.
If you convey a covered work, knowingly relying on a patent
license, and the Corresponding Source of the work is not available
for anyone to copy, free of charge and under the terms of this
License, through a publicly available network server or other
readily accessible means, then you must either (1) cause the
Corresponding Source to be so available, or (2) arrange to deprive
yourself of the benefit of the patent license for this particular
work, or (3) arrange, in a manner consistent with the requirements
of this License, to extend the patent license to downstream
recipients. “Knowingly relying” means you have actual knowledge
that, but for the patent license, your conveying the covered work
in a country, or your recipient’s use of the covered work in a
country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate,
modify or convey a specific copy of the covered work, then the
patent license you grant is automatically extended to all
recipients of the covered work and works based on it.
A patent license is “discriminatory” if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that
are specifically granted under this License. You may not convey a
covered work if you are a party to an arrangement with a third
party that is in the business of distributing software, under which
you make payment to the third party based on the extent of your
activity of conveying the work, and under which the third party
grants, to any of the parties who would receive the covered work
from you, a discriminatory patent license (a) in connection with
copies of the covered work conveyed by you (or copies made from
those copies), or (b) primarily for and in connection with specific
products or compilations that contain the covered work, unless you
entered into that arrangement, or that patent license was granted,
prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others’ Freedom.
If conditions are imposed on you (whether by court order, agreement
or otherwise) that contradict the conditions of this License, they
do not excuse you from the conditions of this License. If you
cannot convey a covered work so as to satisfy simultaneously your
obligations under this License and any other pertinent obligations,
then as a consequence you may not convey it at all. For example,
if you agree to terms that obligate you to collect a royalty for
further conveying from those to whom you convey the Program, the
only way you could satisfy both those terms and this License would
be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a
single combined work, and to convey the resulting work. The terms
of this License will continue to apply to the part which is the
covered work, but the special requirements of the GNU Affero
General Public License, section 13, concerning interaction through
a network will apply to the combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new
versions of the GNU General Public License from time to time. Such
new versions will be similar in spirit to the present version, but
may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU
General Public License “or any later version” applies to it, you
have the option of following the terms and conditions either of
that numbered version or of any later version published by the Free
Software Foundation. If the Program does not specify a version
number of the GNU General Public License, you may choose any
version ever published by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that
proxy’s public statement of acceptance of a version permanently
authorizes you to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE
COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM “AS IS”
WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE
RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.
SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES
AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR
DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA
BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF
THE POSSIBILITY OF SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely
approximates an absolute waiver of all civil liability in
connection with the Program, unless a warranty or assumption of
liability accompanies a copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
===========================
How to Apply These Terms to Your New Programs
=============================================
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these
terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least the
“copyright” line and a pointer to where the full notice is found.
ONE LINE TO GIVE THE PROGRAM'S NAME AND A BRIEF IDEA OF WHAT IT DOES.
Copyright (C) YEAR NAME OF AUTHOR
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper
mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
PROGRAM Copyright (C) YEAR NAME OF AUTHOR
This program comes with ABSOLUTELY NO WARRANTY; for details type ‘show w’.
This is free software, and you are welcome to redistribute it
under certain conditions; type ‘show c’ for details.
The hypothetical commands ‘show w’ and ‘show c’ should show the
appropriate parts of the General Public License. Of course, your
program’s commands might be different; for a GUI interface, you would
use an “about box”.
You should also get your employer (if you work as a programmer) or
school, if any, to sign a “copyright disclaimer” for the program, if
necessary. For more information on this, and how to apply and follow
the GNU GPL, see <http://www.gnu.org/licenses/>.
The GNU General Public License does not permit incorporating your
program into proprietary programs. If your program is a subroutine
library, you may consider it more useful to permit linking proprietary
applications with the library. If this is what you want to do, use the
GNU Lesser General Public License instead of this License. But first,
please read <http://www.gnu.org/philosophy/why-not-lgpl.html>.
File: web-server.info, Node: GNU Free Documentation License, Next: Index, Prev: Copying, Up: Top
Appendix B GNU Free Documentation License
*****************************************
Version 1.3, 3 November 2008
Copyright © 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc.
<http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
0. PREAMBLE
The purpose of this License is to make a manual, textbook, or other
functional and useful document “free” in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or
noncommercially. Secondarily, this License preserves for the
author and publisher a way to get credit for their work, while not
being considered responsible for modifications made by others.
This License is a kind of “copyleft”, which means that derivative
works of the document must themselves be free in the same sense.
It complements the GNU General Public License, which is a copyleft
license designed for free software.
We have designed this License in order to use it for manuals for
free software, because free software needs free documentation: a
free program should come with manuals providing the same freedoms
that the software does. But this License is not limited to
software manuals; it can be used for any textual work, regardless
of subject matter or whether it is published as a printed book. We
recommend this License principally for works whose purpose is
instruction or reference.
1. APPLICABILITY AND DEFINITIONS
This License applies to any manual or other work, in any medium,
that contains a notice placed by the copyright holder saying it can
be distributed under the terms of this License. Such a notice
grants a world-wide, royalty-free license, unlimited in duration,
to use that work under the conditions stated herein. The
“Document”, below, refers to any such manual or work. Any member
of the public is a licensee, and is addressed as “you”. You accept
the license if you copy, modify or distribute the work in a way
requiring permission under copyright law.
A “Modified Version” of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
A “Secondary Section” is a named appendix or a front-matter section
of the Document that deals exclusively with the relationship of the
publishers or authors of the Document to the Document’s overall
subject (or to related matters) and contains nothing that could
fall directly within that overall subject. (Thus, if the Document
is in part a textbook of mathematics, a Secondary Section may not
explain any mathematics.) The relationship could be a matter of
historical connection with the subject or with related matters, or
of legal, commercial, philosophical, ethical or political position
regarding them.
The “Invariant Sections” are certain Secondary Sections whose
titles are designated, as being those of Invariant Sections, in the
notice that says that the Document is released under this License.
If a section does not fit the above definition of Secondary then it
is not allowed to be designated as Invariant. The Document may
contain zero Invariant Sections. If the Document does not identify
any Invariant Sections then there are none.
The “Cover Texts” are certain short passages of text that are
listed, as Front-Cover Texts or Back-Cover Texts, in the notice
that says that the Document is released under this License. A
Front-Cover Text may be at most 5 words, and a Back-Cover Text may
be at most 25 words.
A “Transparent” copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images composed
of pixels) generic paint programs or (for drawings) some widely
available drawing editor, and that is suitable for input to text
formatters or for automatic translation to a variety of formats
suitable for input to text formatters. A copy made in an otherwise
Transparent file format whose markup, or absence of markup, has
been arranged to thwart or discourage subsequent modification by
readers is not Transparent. An image format is not Transparent if
used for any substantial amount of text. A copy that is not
“Transparent” is called “Opaque”.
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, LaTeX input format,
SGML or XML using a publicly available DTD, and standard-conforming
simple HTML, PostScript or PDF designed for human modification.
Examples of transparent image formats include PNG, XCF and JPG.
Opaque formats include proprietary formats that can be read and
edited only by proprietary word processors, SGML or XML for which
the DTD and/or processing tools are not generally available, and
the machine-generated HTML, PostScript or PDF produced by some word
processors for output purposes only.
The “Title Page” means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the
material this License requires to appear in the title page. For
works in formats which do not have any title page as such, “Title
Page” means the text near the most prominent appearance of the
work’s title, preceding the beginning of the body of the text.
The “publisher” means any person or entity that distributes copies
of the Document to the public.
A section “Entitled XYZ” means a named subunit of the Document
whose title either is precisely XYZ or contains XYZ in parentheses
following text that translates XYZ in another language. (Here XYZ
stands for a specific section name mentioned below, such as
“Acknowledgements”, “Dedications”, “Endorsements”, or “History”.)
To “Preserve the Title” of such a section when you modify the
Document means that it remains a section “Entitled XYZ” according
to this definition.
The Document may include Warranty Disclaimers next to the notice
which states that this License applies to the Document. These
Warranty Disclaimers are considered to be included by reference in
this License, but only as regards disclaiming warranties: any other
implication that these Warranty Disclaimers may have is void and
has no effect on the meaning of this License.
2. VERBATIM COPYING
You may copy and distribute the Document in any medium, either
commercially or noncommercially, provided that this License, the
copyright notices, and the license notice saying this License
applies to the Document are reproduced in all copies, and that you
add no other conditions whatsoever to those of this License. You
may not use technical measures to obstruct or control the reading
or further copying of the copies you make or distribute. However,
you may accept compensation in exchange for copies. If you
distribute a large enough number of copies you must also follow the
conditions in section 3.
You may also lend copies, under the same conditions stated above,
and you may publicly display copies.
3. COPYING IN QUANTITY
If you publish printed copies (or copies in media that commonly
have printed covers) of the Document, numbering more than 100, and
the Document’s license notice requires Cover Texts, you must
enclose the copies in covers that carry, clearly and legibly, all
these Cover Texts: Front-Cover Texts on the front cover, and
Back-Cover Texts on the back cover. Both covers must also clearly
and legibly identify you as the publisher of these copies. The
front cover must present the full title with all words of the title
equally prominent and visible. You may add other material on the
covers in addition. Copying with changes limited to the covers, as
long as they preserve the title of the Document and satisfy these
conditions, can be treated as verbatim copying in other respects.
If the required texts for either cover are too voluminous to fit
legibly, you should put the first ones listed (as many as fit
reasonably) on the actual cover, and continue the rest onto
adjacent pages.
If you publish or distribute Opaque copies of the Document
numbering more than 100, you must either include a machine-readable
Transparent copy along with each Opaque copy, or state in or with
each Opaque copy a computer-network location from which the general
network-using public has access to download using public-standard
network protocols a complete Transparent copy of the Document, free
of added material. If you use the latter option, you must take
reasonably prudent steps, when you begin distribution of Opaque
copies in quantity, to ensure that this Transparent copy will
remain thus accessible at the stated location until at least one
year after the last time you distribute an Opaque copy (directly or
through your agents or retailers) of that edition to the public.
It is requested, but not required, that you contact the authors of
the Document well before redistributing any large number of copies,
to give them a chance to provide you with an updated version of the
Document.
4. MODIFICATIONS
You may copy and distribute a Modified Version of the Document
under the conditions of sections 2 and 3 above, provided that you
release the Modified Version under precisely this License, with the
Modified Version filling the role of the Document, thus licensing
distribution and modification of the Modified Version to whoever
possesses a copy of it. In addition, you must do these things in
the Modified Version:
A. Use in the Title Page (and on the covers, if any) a title
distinct from that of the Document, and from those of previous
versions (which should, if there were any, be listed in the
History section of the Document). You may use the same title
as a previous version if the original publisher of that
version gives permission.
B. List on the Title Page, as authors, one or more persons or
entities responsible for authorship of the modifications in
the Modified Version, together with at least five of the
principal authors of the Document (all of its principal
authors, if it has fewer than five), unless they release you
from this requirement.
C. State on the Title page the name of the publisher of the
Modified Version, as the publisher.
D. Preserve all the copyright notices of the Document.
E. Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.
F. Include, immediately after the copyright notices, a license
notice giving the public permission to use the Modified
Version under the terms of this License, in the form shown in
the Addendum below.
G. Preserve in that license notice the full lists of Invariant
Sections and required Cover Texts given in the Document’s
license notice.
H. Include an unaltered copy of this License.
I. Preserve the section Entitled “History”, Preserve its Title,
and add to it an item stating at least the title, year, new
authors, and publisher of the Modified Version as given on the
Title Page. If there is no section Entitled “History” in the
Document, create one stating the title, year, authors, and
publisher of the Document as given on its Title Page, then add
an item describing the Modified Version as stated in the
previous sentence.
J. Preserve the network location, if any, given in the Document
for public access to a Transparent copy of the Document, and
likewise the network locations given in the Document for
previous versions it was based on. These may be placed in the
“History” section. You may omit a network location for a work
that was published at least four years before the Document
itself, or if the original publisher of the version it refers
to gives permission.
K. For any section Entitled “Acknowledgements” or “Dedications”,
Preserve the Title of the section, and preserve in the section
all the substance and tone of each of the contributor
acknowledgements and/or dedications given therein.
L. Preserve all the Invariant Sections of the Document, unaltered
in their text and in their titles. Section numbers or the
equivalent are not considered part of the section titles.
M. Delete any section Entitled “Endorsements”. Such a section
may not be included in the Modified Version.
N. Do not retitle any existing section to be Entitled
“Endorsements” or to conflict in title with any Invariant
Section.
O. Preserve any Warranty Disclaimers.
If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no
material copied from the Document, you may at your option designate
some or all of these sections as invariant. To do this, add their
titles to the list of Invariant Sections in the Modified Version’s
license notice. These titles must be distinct from any other
section titles.
You may add a section Entitled “Endorsements”, provided it contains
nothing but endorsements of your Modified Version by various
parties—for example, statements of peer review or that the text has
been approved by an organization as the authoritative definition of
a standard.
You may add a passage of up to five words as a Front-Cover Text,
and a passage of up to 25 words as a Back-Cover Text, to the end of
the list of Cover Texts in the Modified Version. Only one passage
of Front-Cover Text and one of Back-Cover Text may be added by (or
through arrangements made by) any one entity. If the Document
already includes a cover text for the same cover, previously added
by you or by arrangement made by the same entity you are acting on
behalf of, you may not add another; but you may replace the old
one, on explicit permission from the previous publisher that added
the old one.
The author(s) and publisher(s) of the Document do not by this
License give permission to use their names for publicity for or to
assert or imply endorsement of any Modified Version.
5. COMBINING DOCUMENTS
You may combine the Document with other documents released under
this License, under the terms defined in section 4 above for
modified versions, provided that you include in the combination all
of the Invariant Sections of all of the original documents,
unmodified, and list them all as Invariant Sections of your
combined work in its license notice, and that you preserve all
their Warranty Disclaimers.
The combined work need only contain one copy of this License, and
multiple identical Invariant Sections may be replaced with a single
copy. If there are multiple Invariant Sections with the same name
but different contents, make the title of each such section unique
by adding at the end of it, in parentheses, the name of the
original author or publisher of that section if known, or else a
unique number. Make the same adjustment to the section titles in
the list of Invariant Sections in the license notice of the
combined work.
In the combination, you must combine any sections Entitled
“History” in the various original documents, forming one section
Entitled “History”; likewise combine any sections Entitled
“Acknowledgements”, and any sections Entitled “Dedications”. You
must delete all sections Entitled “Endorsements.”
6. COLLECTIONS OF DOCUMENTS
You may make a collection consisting of the Document and other
documents released under this License, and replace the individual
copies of this License in the various documents with a single copy
that is included in the collection, provided that you follow the
rules of this License for verbatim copying of each of the documents
in all other respects.
You may extract a single document from such a collection, and
distribute it individually under this License, provided you insert
a copy of this License into the extracted document, and follow this
License in all other respects regarding verbatim copying of that
document.
7. AGGREGATION WITH INDEPENDENT WORKS
A compilation of the Document or its derivatives with other
separate and independent documents or works, in or on a volume of a
storage or distribution medium, is called an “aggregate” if the
copyright resulting from the compilation is not used to limit the
legal rights of the compilation’s users beyond what the individual
works permit. When the Document is included in an aggregate, this
License does not apply to the other works in the aggregate which
are not themselves derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half
of the entire aggregate, the Document’s Cover Texts may be placed
on covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic
form. Otherwise they must appear on printed covers that bracket
the whole aggregate.
8. TRANSLATION
Translation is considered a kind of modification, so you may
distribute translations of the Document under the terms of section
4. Replacing Invariant Sections with translations requires special
permission from their copyright holders, but you may include
translations of some or all Invariant Sections in addition to the
original versions of these Invariant Sections. You may include a
translation of this License, and all the license notices in the
Document, and any Warranty Disclaimers, provided that you also
include the original English version of this License and the
original versions of those notices and disclaimers. In case of a
disagreement between the translation and the original version of
this License or a notice or disclaimer, the original version will
prevail.
If a section in the Document is Entitled “Acknowledgements”,
“Dedications”, or “History”, the requirement (section 4) to
Preserve its Title (section 1) will typically require changing the
actual title.
9. TERMINATION
You may not copy, modify, sublicense, or distribute the Document
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense, or distribute it is void,
and will automatically terminate your rights under this License.
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the
copyright holder fails to notify you of the violation by some
reasonable means prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from
that copyright holder, and you cure the violation prior to 30 days
after your receipt of the notice.
Termination of your rights under this section does not terminate
the licenses of parties who have received copies or rights from you
under this License. If your rights have been terminated and not
permanently reinstated, receipt of a copy of some or all of the
same material does not give you any rights to use it.
10. FUTURE REVISIONS OF THIS LICENSE
The Free Software Foundation may publish new, revised versions of
the GNU Free Documentation License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns. See
<http://www.gnu.org/copyleft/>.
Each version of the License is given a distinguishing version
number. If the Document specifies that a particular numbered
version of this License “or any later version” applies to it, you
have the option of following the terms and conditions either of
that specified version or of any later version that has been
published (not as a draft) by the Free Software Foundation. If the
Document does not specify a version number of this License, you may
choose any version ever published (not as a draft) by the Free
Software Foundation. If the Document specifies that a proxy can
decide which future versions of this License can be used, that
proxy’s public statement of acceptance of a version permanently
authorizes you to choose that version for the Document.
11. RELICENSING
“Massive Multiauthor Collaboration Site” (or “MMC Site”) means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works. A
public wiki that anybody can edit is an example of such a server.
A “Massive Multiauthor Collaboration” (or “MMC”) contained in the
site means any set of copyrightable works thus published on the MMC
site.
“CC-BY-SA” means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.
“Incorporate” means to publish or republish a Document, in whole or
in part, as part of another Document.
An MMC is “eligible for relicensing” if it is licensed under this
License, and if all works that were first published under this
License somewhere other than this MMC, and subsequently
incorporated in whole or in part into the MMC, (1) had no cover
texts or invariant sections, and (2) were thus incorporated prior
to November 1, 2008.
The operator of an MMC Site may republish an MMC contained in the
site under CC-BY-SA on the same site at any time before August 1,
2009, provided the MMC is eligible for relicensing.
ADDENDUM: How to use this License for your documents
====================================================
To use this License in a document you have written, include a copy of
the License in the document and put the following copyright and license
notices just after the title page:
Copyright (C) YEAR YOUR NAME.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
Texts. A copy of the license is included in the section entitled ``GNU
Free Documentation License''.
If you have Invariant Sections, Front-Cover Texts and Back-Cover
Texts, replace the “with...Texts.” line with this:
with the Invariant Sections being LIST THEIR TITLES, with
the Front-Cover Texts being LIST, and with the Back-Cover Texts
being LIST.
If you have Invariant Sections without Cover Texts, or some other
combination of the three, merge those two alternatives to suit the
situation.
If your document contains nontrivial examples of program code, we
recommend releasing these examples in parallel under your choice of free
software license, such as the GNU General Public License, to permit
their use in free software.
File: web-server.info, Node: Index, Prev: GNU Free Documentation License, Up: Top
Index
*****
�[index�]
* Menu:
* content type: Function Index. (line 60)
* function index: Function Index. (line 6)
* handler function: Handlers. (line 41)
* handlers: Handlers. (line 6)
* introduction: Introduction. (line 6)
* matchers: Handlers. (line 17)
* requests: Requests. (line 6)
* start and stop: Function Index. (line 32)
* usage examples: Usage Examples. (line 6)
* ws-compress-cmd: Function Index. (line 165)
* ws-deflate-cmd: Function Index. (line 168)
* ws-gzip-cmd: Function Index. (line 171)
* ws-in-directory-p: Function Index. (line 113)
* ws-request: Function Index. (line 19)
* ws-response-header: Function Index. (line 60)
* ws-send: Function Index. (line 87)
* ws-send-404: Function Index. (line 95)
* ws-send-500: Function Index. (line 91)
* ws-send-directory-list: Function Index. (line 106)
* ws-send-file: Function Index. (line 99)
* ws-server: Function Index. (line 13)
* ws-servers: Function Index. (line 41)
* ws-start: Function Index. (line 35)
* ws-stop: Function Index. (line 44)
* ws-stop-all: Function Index. (line 50)
* ws-web-socket-connect: Function Index. (line 145)
* ws-with-authentication: Function Index. (line 125)
Tag Table:
Node: Top709
Node: Introduction2088
Node: Handlers2778
Node: Requests4796
Node: Usage Examples6114
Node: Hello World7048
Node: Hello World UTF87885
Node: Hello World HTML9065
Node: File Server9780
Node: URL Parameter Echo11143
Node: POST Echo12377
Node: Basic Authentication13446
Node: Org-mode Export14987
Node: File Upload17729
Node: Web Socket18885
Node: Gzipped Transfer Encoding22129
Node: Chunked Transfer Encoding23797
Node: Function Index25592
Ref: ws-server25876
Ref: ws-request26202
Ref: ws-start26966
Ref: ws-servers27253
Ref: ws-stop27346
Ref: ws-stop-all27579
Ref: ws-response-header27872
Ref: ws-send29112
Ref: ws-send-50029291
Ref: ws-send-40429448
Ref: ws-send-file29598
Ref: ws-send-directory-list29971
Ref: ws-in-directory-p30353
Ref: ws-with-authentication30672
Ref: ws-web-socket-connect31508
Ref: ws-compress-cmd32395
Ref: ws-deflate-cmd32495
Ref: ws-gzip-cmd32593
Node: Copying32685
Node: GNU Free Documentation License70476
Node: Index95831
End Tag Table
Local Variables:
coding: utf-8
End:
;;; web-server.el --- Emacs Web Server -*- lexical-binding: t -*-
;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte.eric@gmail.com>
;; Maintainer: Eric Schulte <schulte.eric@gmail.com>
;; Version: 0.1.2
;; Package-Requires: ((emacs "24.1") (cl-lib "0.6"))
;; Keywords: http, server, network
;; URL: https://github.com/eschulte/emacs-web-server
;; This software is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A web server in Emacs running handlers written in Emacs Lisp.
;;
;; Full support for GET and POST requests including URL-encoded
;; parameters and multipart/form data. Supports web sockets.
;;
;; See the examples/ directory for examples demonstrating the usage of
;; the Emacs Web Server. The following launches a simple "hello
;; world" server.
;;
;; (ws-start
;; '(((lambda (_) t) . ; match every request
;; (lambda (request) ; reply with "hello world"
;; (with-slots (process) request
;; (ws-response-header process 200 '("Content-type" . "text/plain"))
;; (process-send-string process "hello world")))))
;; 9000)
;;; Code:
(require 'web-server-status-codes)
(require 'mail-parse) ; to parse multipart data in headers
(require 'mm-encode) ; to look-up mime types for files
(require 'url-util) ; to decode url-encoded params
(require 'eieio)
(require 'cl-lib)
(defclass ws-server ()
((handlers :initarg :handlers :accessor ws-handlers :initform nil)
(process :initarg :process :accessor ws-process :initform nil)
(port :initarg :port :accessor ws-port :initform nil)
(requests :initarg :requests :accessor ws-requests :initform nil)))
(defclass ws-request ()
((process :initarg :process :accessor ws-process :initform nil)
(pending :initarg :pending :accessor ws-pending :initform "")
(context :initarg :context :accessor ws-context :initform nil)
(boundary :initarg :boundary :accessor ws-boundary :initform nil)
(index :initarg :index :accessor ws-index :initform 0)
(active :initarg :active :accessor ws-active :initform nil)
(headers :initarg :headers :accessor ws-headers :initform (list nil))
(body :initarg :body :accessor ws-body :initform "")))
(defvar ws-servers nil
"List holding all web servers.")
(defvar ws-log-time-format "%Y.%m.%d.%H.%M.%S.%N"
"Logging time format passed to `format-time-string'.")
(defvar ws-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
"This GUID is defined in RFC6455.")
;;;###autoload
(defun ws-start (handlers port &optional log-buffer &rest network-args)
"Start a server using HANDLERS and return the server object.
HANDLERS may be a single function (which is then called on every
request) or a list of conses of the form (MATCHER . FUNCTION),
where the FUNCTION associated with the first successful MATCHER
is called. Handler functions are called with two arguments, the
process and the request object.
A MATCHER may be either a function (in which case it is called on
the request object) or a cons cell of the form (KEYWORD . STRING)
in which case STRING is matched against the value of the header
specified by KEYWORD.
Any supplied NETWORK-ARGS are assumed to be keyword arguments for
`make-network-process' to which they are passed directly.
For example, the following starts a simple hello-world server on
port 8080.
(ws-start
(lambda (request)
(with-slots (process headers) request
(process-send-string process
\"HTTP/1.1 200 OK\\r\\nContent-Type: text/plain\\r\\n\\r\\nhello world\")))
8080)
Equivalently, the following starts an identical server using a
function MATCH and the `ws-response-header' convenience
function.
(ws-start
`(((lambda (_) t) .
(lambda (request)
(with-slots ((proc process)) request
(ws-response-header proc 200 '(\"Content-Type\" . \"text/plain\"))
(process-send-string proc \"hello world\")))))
8080)
"
(let ((server (make-instance 'ws-server :handlers handlers :port port))
(log (when log-buffer (get-buffer-create log-buffer))))
(setf (ws-process server)
(apply
#'make-network-process
:name "ws-server"
:service (ws-port server)
:filter 'ws-filter
:server t
:nowait (< emacs-major-version 26)
:family 'ipv4
:coding 'no-conversion
:plist (append (list :server server)
(when log (list :log-buffer log)))
:log (when log
(lambda (proc request message)
(let ((c (process-contact request))
(buf (plist-get (process-plist proc) :log-buffer)))
(with-current-buffer buf
(goto-char (point-max))
(insert (format "%s\t%s\t%s\t%s"
(format-time-string ws-log-time-format)
(cl-first c) (cl-second c) message))))))
network-args))
(push server ws-servers)
server))
(defun ws-stop (server)
"Stop SERVER."
(setq ws-servers (remove server ws-servers))
(mapc #'delete-process (append (mapcar #'ws-process (ws-requests server))
(list (ws-process server)))))
(defun ws-stop-all ()
"Stop all servers in `ws-servers'."
(interactive)
(mapc #'ws-stop ws-servers))
(defvar ws-http-common-methods '(GET HEAD POST PUT DELETE TRACE)
"HTTP methods from http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html.")
(defvar ws-http-method-rx
(format "^\\(%s\\) \\([^[:space:]]+\\) \\([^[:space:]]+\\)$"
(mapconcat #'symbol-name ws-http-common-methods "\\|")))
(defun ws-parse-query-string (string)
"Thin wrapper around `url-parse-query-string'."
(mapcar (lambda (pair) (cons (cl-first pair) (cl-second pair)))
(url-parse-query-string string nil 'allow-newlines)))
(defun ws-parse (proc string)
"Parse HTTP headers in STRING reporting errors to PROC."
(cl-flet ((to-keyword (s) (intern (concat ":" (upcase s)))))
(cond
;; Method
((string-match ws-http-method-rx string)
(let ((method (to-keyword (match-string 1 string)))
(url (match-string 2 string)))
(if (string-match "?" url)
(cons (cons method (substring url 0 (match-beginning 0)))
(ws-parse-query-string
(url-unhex-string (substring url (match-end 0)))))
(list (cons method url)))))
;; Authorization
((string-match "^AUTHORIZATION: \\([^[:space:]]+\\) \\(.*\\)$" string)
(let ((protocol (to-keyword (match-string 1 string)))
(credentials (match-string 2 string)))
(list (cons :AUTHORIZATION
(cons protocol
(cl-case protocol
(:BASIC
(let ((cred (base64-decode-string credentials)))
(if (string-match ":" cred)
(cons (substring cred 0 (match-beginning 0))
(substring cred (match-end 0)))
(ws-error proc "bad credentials: %S" cred))))
(t (ws-error proc "un-support protocol: %s"
protocol))))))))
;; All other headers
((string-match "^\\([^[:space:]]+\\): \\(.*\\)$" string)
(list (cons (to-keyword (match-string 1 string))
(match-string 2 string))))
(:otherwise (ws-error proc "bad header: %S" string) nil))))
(defun ws-trim (string)
(while (and (> (length string) 0)
(or (and (string-match "[\r\n]" (substring string -1))
(setq string (substring string 0 -1)))
(and (string-match "[\r\n]" (substring string 0 1))
(setq string (substring string 1))))))
string)
(defun ws-parse-multipart/form (proc string)
;; ignore empty and non-content blocks
(when (string-match "Content-Disposition:[[:space:]]*\\(.*\\)\r\n" string)
(let ((dp (cdr (mail-header-parse-content-disposition
(match-string 1 string))))
(last-index (match-end 0))
index)
;; every line up until the double \r\n is a header
(while (and (setq index (string-match "\r\n" string last-index))
(not (= index last-index)))
(setcdr (last dp) (ws-parse proc (substring string last-index index)))
(setq last-index (+ 2 index)))
;; after double \r\n is all content
(cons (cdr (assoc 'name dp))
(cons (cons 'content (substring string (+ 2 last-index)))
dp)))))
(defun ws-filter (proc string)
(with-slots (handlers requests) (plist-get (process-plist proc) :server)
(unless (cl-find-if (lambda (c) (equal proc (ws-process c))) requests)
(push (make-instance 'ws-request :process proc) requests))
(let ((request (cl-find-if (lambda (c) (equal proc (ws-process c))) requests)))
(with-slots (pending) request (setq pending (concat pending string)))
(unless (ws-active request) ; don't re-start if request is being parsed
(setf (ws-active request) t)
(when (not (eq (catch 'close-connection
(if (ws-parse-request request)
(ws-call-handler request handlers)
:keep-alive))
:keep-alive))
;; Properly shut down processes requiring an ending (e.g., chunked)
(let ((ender (plist-get (process-plist proc) :ender)))
(when ender (process-send-string proc ender)))
(setq requests (cl-remove-if (lambda (r) (eql proc (ws-process r))) requests))
(delete-process proc))))))
(defun ws-parse-request (request)
"Parse request STRING from REQUEST with process PROC.
Return non-nil only when parsing is complete."
(catch 'finished-parsing-headers
(with-slots (process pending context boundary headers body index) request
(let ((delimiter (concat "\r\n" (if boundary (concat "--" boundary) "")))
;; Track progress through string, always work with the
;; section of string between INDEX and NEXT-INDEX.
next-index
body-stored)
;; parse headers and append to request
(while (setq next-index (string-match delimiter pending index))
(let ((tmp (+ next-index (length delimiter))))
(if (= index next-index) ; double \r\n ends current run of headers
(progn
;; Store the body
(unless
;; Multipart form data has multiple passes - store on
;; first pass only.
body-stored
(let ((after-headers (substring pending index)))
(when (string-prefix-p "\r\n" after-headers)
(setq body
;; Trim off the additional CRLF
(substring after-headers 2))))
(setq body-stored t))
(cl-case context
;; Parse URL data.
;; http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4
(application/x-www-form-urlencoded
(mapc (lambda (pair) (setcdr (last headers) (list pair)))
(ws-parse-query-string
(replace-regexp-in-string
"\\+" " "
(ws-trim (substring pending index)))))
(throw 'finished-parsing-headers t))
;; Set custom delimiter for multipart form data.
(multipart/form-data
(setq delimiter (concat "\r\n--" boundary)))
;; No special context so we're done.
(t (throw 'finished-parsing-headers t))))
(if (eql context 'multipart/form-data)
(progn
(setcdr (last headers)
(list (ws-parse-multipart/form process
(substring pending index next-index))))
;; Boundary suffixed by "--" indicates end of the headers.
(when (and (> (length pending) (+ tmp 2))
(string= (substring pending tmp (+ tmp 2)) "--"))
(throw 'finished-parsing-headers t)))
;; Standard header parsing.
(let ((header (ws-parse process (substring pending
index next-index))))
;; Content-Type indicates that the next double \r\n
;; will be followed by a special type of content which
;; will require special parsing. Thus we will note
;; the type in the CONTEXT variable for parsing
;; dispatch above.
(when (and (caar header) (eql (caar header) :CONTENT-TYPE))
(cl-destructuring-bind (type &rest data)
(mail-header-parse-content-type (cdar header))
(setq boundary (cdr (assoc 'boundary data)))
(setq context (intern (downcase type)))))
;; All other headers are collected directly.
(setcdr (last headers) header))))
(setq index tmp)))))
(setf (ws-active request) nil)
nil))
(defun ws-call-handler (request handlers)
(catch 'matched-handler
(when (functionp handlers)
(throw 'matched-handler
(condition-case e (funcall handlers request)
(error (ws-error (ws-process request) "Caught Error: %S" e)))))
(mapc (lambda (handler)
(let ((match (car handler))
(function (cdr handler)))
(when (or (and (consp match)
(assoc (car match) (ws-headers request))
(string-match (cdr match)
(cdr (assoc (car match)
(ws-headers request)))))
(and (functionp match) (funcall match request)))
(throw 'matched-handler
(condition-case e (funcall function request)
(error (ws-error (ws-process request)
"Caught Error: %S" e)))))))
handlers)
(ws-error (ws-process request) "no handler matched request: %S"
(ws-headers request))))
(defun ws-error (proc msg &rest args)
(let ((buf (plist-get (process-plist proc) :log-buffer))
(c (process-contact proc)))
(when buf
(with-current-buffer buf
(goto-char (point-max))
(insert (format "%s\t%s\t%s\tWS-ERROR: %s"
(format-time-string ws-log-time-format)
(cl-first c) (cl-second c)
(apply #'format msg args)))))
(apply #'ws-send-500 proc msg args)))
;;; Web Socket
;; Implement to conform to http://tools.ietf.org/html/rfc6455.
;; The `ws-message' object is used to hold state across multiple calls
;; of the process filter on the websocket network process. The fields
;; play the following roles.
;; process ------ holds the process itself, used for communication
;; pending ------ holds text received from the client but not yet parsed
;; active ------- indicates that parsing is active to avoid re-entry
;; of the `ws-web-socket-parse-messages' function
;; new ---------- indicates that new text was received during parsing
;; and causes `ws-web-socket-parse-messages' to be
;; called again after it terminates
;; data --------- holds the data of parsed messages
;; handler ------ holds the user-supplied function of two arguments
;; called on the process and the data of parsed
;; messages
(defclass ws-message () ; web socket message object
((process :initarg :process :accessor ws-process :initform "")
(pending :initarg :pending :accessor ws-pending :initform "")
(active :initarg :active :accessor ws-active :initform nil)
(new :initarg :new :accessor ws-new :initform nil)
(data :initarg :data :accessor ws-data :initform "")
(handler :initarg :handler :accessor ws-handler :initform "")))
(defun ws-web-socket-connect (request handler)
"Establish a web socket connection with request.
If the connection is successful this function will throw
`:keep-alive' to `close-connection' skipping any remaining code
in the request handler. If no web-socket connection is
established (e.g., because REQUEST is not attempting to establish
a connection) then no actions are taken and nil is returned.
Second argument HANDLER should be a function of two arguments,
the process and a string, which will be called on all complete
messages as they are received and parsed from the network."
(with-slots (process headers) request
(when (assoc :SEC-WEBSOCKET-KEY headers)
;; Accept the connection
(ws-response-header process 101
(cons "Upgrade" "websocket")
(cons "Connection" "upgrade")
(cons "Sec-WebSocket-Accept"
(ws-web-socket-handshake
(cdr (assoc :SEC-WEBSOCKET-KEY headers)))))
;; Setup the process filter
(set-process-coding-system process 'binary)
(set-process-plist
process (list :message (make-instance 'ws-message
:handler handler :process process)))
(set-process-filter process 'ws-web-socket-filter)
process)))
(defun ws-web-socket-filter (process string)
(let ((message (plist-get (process-plist process) :message)))
(if (ws-active message) ; don't re-start if message is being parsed
(setf (ws-new message) string)
(setf (ws-pending message) (concat (ws-pending message) string))
(setf (ws-active message) t)
(ws-web-socket-parse-messages message))
(setf (ws-active message) nil)))
(defun ws-web-socket-mask (masking-key data)
(let ((masking-data (apply #'concat (make-list (+ 1 (/ (length data) 4))
masking-key))))
(apply #'string (cl-mapcar #'logxor masking-data data))))
;; Binary framing protocol
;; from http://tools.ietf.org/html/rfc6455#section-5.2
;;
;; 0 1 2 3
;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
;; +-+-+-+-+-------+-+-------------+-------------------------------+
;; |F|R|R|R| opcode|M| Payload len | Extended payload length |
;; |I|S|S|S| (4) |A| (7) | (16/64) |
;; |N|V|V|V| |S| | (if payload len==126/127) |
;; | |1|2|3| |K| | |
;; +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - +
;; | Extended payload length continued, if payload len == 127 |
;; + - - - - - - - - - - - - - - - +-------------------------------+
;; | |Masking-key, if MASK set to 1 |
;; +-------------------------------+-------------------------------+
;; | Masking-key (continued) | Payload Data |
;; +-------------------------------- - - - - - - - - - - - - - - - +
;; : Payload Data continued ... :
;; + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
;; | Payload Data continued ... |
;; +---------------------------------------------------------------+
;;
(defun ws-web-socket-parse-messages (message)
"Web socket filter to pass whole frames to the client.
See RFC6455."
(with-slots (process active pending data handler new) message
(let ((index 0))
(cl-labels ((int-to-bits (int size)
(let ((result (make-bool-vector size nil)))
(mapc (lambda (place)
(let ((val (expt 2 place)))
(when (>= int val)
(setq int (- int val))
(aset result place t))))
(reverse (number-sequence 0 (- size 1))))
(reverse (append result nil))))
(bits-to-int (bits)
(let ((place 0))
(apply #'+
(mapcar (lambda (bit)
(prog1 (if bit (expt 2 place) 0) (cl-incf place)))
(reverse bits)))))
(bits (length)
(apply #'append
(mapcar (lambda (int) (int-to-bits int 8))
(cl-subseq
pending index (cl-incf index length))))))
(let (fin rsvs opcode mask pl mask-key)
;; Parse fin bit, rsvs bits and opcode
(let ((byte (bits 1)))
(setq fin (car byte)
rsvs (cl-subseq byte 1 4)
opcode
(let ((it (bits-to-int (cl-subseq byte 4))))
(cl-case it
(0 :CONTINUATION)
(1 :TEXT)
(2 :BINARY)
((3 4 5 6 7) :NON-CONTROL)
(8 :CLOSE)
(9 :PING)
(10 :PONG)
((11 12 13 14 15) :CONTROL)
;; If an unknown opcode is received, the receiving
;; endpoint MUST _Fail the WebSocket Connection_.
(t (ws-error process
"Web Socket Fail: bad opcode %d" it))))))
(unless (cl-every #'null rsvs)
;; MUST be 0 unless an extension is negotiated that defines
;; meanings for non-zero values.
(ws-error process "Web Socket Fail: non-zero RSV 1 2 or 3"))
;; Parse mask and payload length
(let ((byte (bits 1)))
(setq mask (car byte)
pl (bits-to-int (cl-subseq byte 1))))
(unless (eq mask t)
;; All frames sent from client to server have this bit set to 1.
(ws-error process "Web Socket Fail: client must mask data"))
(cond
((= pl 126) (setq pl (bits-to-int (bits 2))))
((= pl 127) (setq pl (bits-to-int (bits 8)))))
;; unmask data
(when mask (setq mask-key (cl-subseq pending index (cl-incf index 4))))
(setq data (concat data
(ws-web-socket-mask
mask-key (cl-subseq pending index (+ index pl)))))
(if fin
;; wipe the message state and call the handler
(let ((it data))
(setq data "" active nil pending "" new nil)
;; close on a close frame, otherwise call the handler
(if (not (eql opcode :CLOSE))
(funcall handler process it)
(process-send-string process
(unibyte-string (logior (lsh 1 7) 8) 0))))
;; add any remaining un-parsed network data to pending
(when (< (+ index pl) (length pending))
(setq pending (substring pending (+ index pl)))))))
;; possibly re-parse any pending input
(when (ws-new message) (ws-web-socket-parse-messages message)))))
(defun ws-web-socket-frame (string &optional opcode)
"Frame STRING for web socket communication."
(let* ((fin 1) ;; set to 0 if not final frame
(len (length string))
(opcode (cl-ecase (or opcode :TEXT) (:TEXT 1) (:BINARY 2))))
;; Does not do any masking which is only required of client communication
(concat
(cond
((< len 126) (unibyte-string (logior (lsh fin 7) opcode) len))
((< len 65536) (unibyte-string (logior (lsh fin 7) opcode) 126
;; extended 16-bit length
(logand (lsh len -8) 255)
(logand len 255)))
(t (unibyte-string (logior (lsh fin 7) opcode) 127
;; more extended 64-bit length
(logand (lsh len -56) 255)
(logand (lsh len -48) 255)
(logand (lsh len -40) 255)
(logand (lsh len -32) 255)
(logand (lsh len -24) 255)
(logand (lsh len -16) 255)
(logand (lsh len -8) 255)
(logand len 255))))
string)))
;;; Content and Transfer encoding support
(defvar ws-compress-cmd "compress"
"Command used for the \"compress\" Content or Transfer coding.")
(defvar ws-deflate-cmd "zlib-flate -compress"
"Command used for the \"deflate\" Content or Transfer coding.")
(defvar ws-gzip-cmd "gzip"
"Command used for the \"gzip\" Content or Transfer coding.")
(defmacro ws-encoding-cmd-to-fn (cmd)
"Return a function which applies CMD to strings."
`(lambda (s)
(with-temp-buffer
(insert s)
(shell-command-on-region (point-min) (point-max) ,cmd nil 'replace)
(buffer-string))))
(defun ws-chunk (string)
"Convert STRING to a valid chunk for HTTP chunked Transfer-encoding."
(format "%x\r\n%s\r\n" (string-bytes string) string))
;;; Convenience functions to write responses
(defun ws-response-header (proc code &rest headers)
"Send the headers for an HTTP response to PROC.
CODE should be an HTTP status code, see `ws-status-codes' for a
list of known codes.
When \"Content-Encoding\" or \"Transfer-Encoding\" headers are
supplied any subsequent data written to PROC using `ws-send' will
be encoded appropriately including sending the appropriate data
upon the end of transmission for chunked transfer encoding.
For example with the header `(\"Content-Encoding\" . \"gzip\")',
any data subsequently written to PROC using `ws-send' will be
compressed using the command specified in `ws-gzip-cmd'."
;; update process to reflect any Content or Transfer encodings
(let ((content (cdr (assoc "Content-Encoding" headers)))
(transfer (cdr (assoc "Transfer-Encoding" headers))))
(when content
(set-process-plist proc
(append
(list :content-encoding
(cl-ecase (intern content)
((compress x-compress) (ws-encoding-cmd-to-fn ws-compress-cmd))
((deflate x-deflate) (ws-encoding-cmd-to-fn ws-deflate-cmd))
((gzip x-gzip) (ws-encoding-cmd-to-fn ws-gzip-cmd))
(identity #'identity)
((exi pack200-zip)
(ws-error proc "`%s' Content-encoding not supported."
content))))
(process-plist proc))))
(when transfer
(set-process-plist proc
(append
(when (string= transfer "chunked") (list :ender "0\r\n\r\n"))
(list :transfer-encoding
(cl-ecase (intern transfer)
(chunked #'ws-chunk)
((compress x-compress) (ws-encoding-cmd-to-fn ws-compress-cmd))
((deflate x-deflate) (ws-encoding-cmd-to-fn ws-deflate-cmd))
((gzip x-gzip) (ws-encoding-cmd-to-fn ws-gzip-cmd))))
(process-plist proc)))))
(let ((headers
(cons
(format "HTTP/1.1 %d %s" code (cdr (assoc code ws-status-codes)))
(mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) headers))))
(setcdr (last headers) (list "" ""))
(process-send-string proc (mapconcat #'identity headers "\r\n"))))
(defun ws-send (proc string)
"Send STRING to process PROC.
If any Content or Transfer encodings are in use, apply them to
STRING before sending."
(let
((cc (or (plist-get (process-plist proc) :content-encoding) #'identity))
(tc (or (plist-get (process-plist proc) :transfer-encoding) #'identity)))
(process-send-string proc (funcall tc (funcall cc string)))))
(defun ws-send-500 (proc &rest msg-and-args)
"Send 500 \"Internal Server Error\" to PROC with an optional message."
(ws-response-header proc 500
'("Content-type" . "text/plain"))
(process-send-string proc (if msg-and-args
(apply #'format msg-and-args)
"500 Internal Server Error"))
(throw 'close-connection nil))
(defun ws-send-404 (proc &rest msg-and-args)
"Send 404 \"Not Found\" to PROC with an optional message."
(ws-response-header proc 404
'("Content-type" . "text/plain"))
(process-send-string proc (if msg-and-args
(apply #'format msg-and-args)
"404 Not Found"))
(throw 'close-connection nil))
(defun ws-send-file (proc path &optional mime-type)
"Send PATH to PROC.
Optionally explicitly set MIME-TYPE, otherwise it is guessed by
`mm-default-file-encoding'."
(let ((mime (or mime-type
(mm-default-file-encoding path)
"application/octet-stream")))
(process-send-string proc
(with-temp-buffer
(insert-file-contents-literally path)
(ws-response-header proc 200
(cons "Content-type" mime)
(cons "Content-length" (- (point-max) (point-min))))
(buffer-string)))))
(defun ws-send-directory-list (proc directory &optional match)
"Send a listing of files in DIRECTORY to PROC.
Optional argument MATCH is passed to `directory-files' and may be
used to limit the files sent."
(ws-response-header proc 200 (cons "Content-type" "text/html"))
(process-send-string proc
(concat "<ul>"
(mapconcat (lambda (f)
(let* ((full (expand-file-name f directory))
(end (if (file-directory-p full) "/" ""))
(url (url-encode-url (concat f end))))
(format "<li><a href=%s>%s</li>" url f)))
(directory-files directory nil match)
"\n")
"</ul>")))
(defun ws-in-directory-p (parent path)
"Check if PATH is under the PARENT directory.
If so return PATH, if not return nil. Note: the PARENT directory
must be full expanded as with `expand-file-name' and should not
contain e.g., \"~\" for a user home directory."
(if (zerop (length path))
parent
(let ((expanded (expand-file-name path parent)))
(and (>= (length expanded) (length parent))
(string= parent (substring expanded 0 (length parent)))
expanded))))
(defun ws-with-authentication (handler credentials
&optional realm unauth invalid)
"Return a version of HANDLER protected by CREDENTIALS.
HANDLER should be a function as passed to `ws-start', and
CREDENTIALS should be an alist of elements of the form (USERNAME
. PASSWORD).
Optional argument REALM sets the realm in the authentication
challenge. Optional arguments UNAUTH and INVALID should be
functions which are called on the request when no authentication
information, or invalid authentication information are provided
respectively."
(let ((handler handler)
(credentials credentials)
(realm realm)
(unauth unauth)
(invalid invalid))
(lambda (request)
(with-slots (process headers) request
(let ((auth (cddr (assoc :AUTHORIZATION headers))))
(cond
;; no authentication information provided
((not auth)
(if unauth
(funcall unauth request)
(ws-response-header process 401
(cons "WWW-Authenticate"
(format "Basic realm=%S" (or realm "restricted")))
'("Content-type" . "text/plain"))
(process-send-string process "authentication required")))
;; valid authentication information
((string= (cdr auth) (cdr (assoc (car auth) credentials)))
(funcall handler request))
;; invalid authentication information
(t
(if invalid
(funcall invalid request)
(ws-response-header process 403 '("Content-type" . "text/plain"))
(process-send-string process "invalid credentials")))))))))
(defun ws-web-socket-handshake (key)
"Perform the handshake defined in RFC6455."
(base64-encode-string (sha1 (concat (ws-trim key) ws-guid) nil nil 'binary)))
;;; Enable the old accessors without the `ws-' namespace as obsolete.
;;; Lets plan to remove these within a year of the date they were
;;; marked obsolete, so that would be roughly 2021-03-12.
(define-obsolete-function-alias 'active 'ws-active "2020-03-12")
(define-obsolete-function-alias 'body 'ws-body "2020-03-12")
(define-obsolete-function-alias 'boundary 'ws-boundary "2020-03-12")
(define-obsolete-function-alias 'context 'ws-context "2020-03-12")
(define-obsolete-function-alias 'data 'ws-data "2020-03-12")
(define-obsolete-function-alias 'handler 'ws-handler "2020-03-12")
(define-obsolete-function-alias 'handlers 'ws-handlers "2020-03-12")
(define-obsolete-function-alias 'headers 'ws-headers "2020-03-12")
(define-obsolete-function-alias 'index 'ws-index "2020-03-12")
(define-obsolete-function-alias 'new 'ws-new "2020-03-12")
(define-obsolete-function-alias 'pending 'ws-pending "2020-03-12")
(define-obsolete-function-alias 'port 'ws-port "2020-03-12")
(define-obsolete-function-alias 'process 'ws-process "2020-03-12")
(define-obsolete-function-alias 'requests 'ws-requests "2020-03-12")
(provide 'web-server)
;;; web-server.el ends here
;;; web-server-status-codes.el --- Emacs Web Server HTML status codes -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
;; This software is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Code:
(defvar ws-status-codes
'((100 . "Continue")
(101 . "Switching Protocols")
(102 . "Processing")
(200 . "OK")
(201 . "Created")
(202 . "Accepted")
(203 . "Non-Authoritative Information")
(204 . "No Content")
(205 . "Reset Content")
(206 . "Partial Content")
(207 . "Multi-Status")
(208 . "Already Reported")
(226 . "IM Used")
(300 . "Multiple Choices")
(301 . "Moved Permanently")
(302 . "Found")
(303 . "See Other")
(304 . "Not Modified")
(305 . "Use Proxy")
(306 . "Switch Proxy")
(307 . "Temporary Redirect")
(308 . "Permanent Redirect")
(400 . "Bad Request")
(401 . "Unauthorized")
(402 . "Payment Required")
(403 . "Forbidden")
(404 . "Not Found")
(405 . "Method Not Allowed")
(406 . "Not Acceptable")
(407 . "Proxy Authentication Required")
(408 . "Request Timeout")
(409 . "Conflict")
(410 . "Gone")
(411 . "Length Required")
(412 . "Precondition Failed")
(413 . "Request Entity Too Large")
(414 . "Request-URI Too Long")
(415 . "Unsupported Media Type")
(416 . "Requested Range Not Satisfiable")
(417 . "Expectation Failed")
(418 . "I'm a teapot")
(419 . "Authentication Timeout")
(420 . "Method Failure")
(420 . "Enhance Your Calm")
(422 . "Unprocessable Entity")
(423 . "Locked")
(424 . "Failed Dependency")
(424 . "Method Failure")
(425 . "Unordered Collection")
(426 . "Upgrade Required")
(428 . "Precondition Required")
(429 . "Too Many Requests")
(431 . "Request Header Fields Too Large")
(440 . "Login Timeout")
(444 . "No Response")
(449 . "Retry With")
(450 . "Blocked by Windows Parental Controls")
(451 . "Unavailable For Legal Reasons")
(451 . "Redirect")
(494 . "Request Header Too Large")
(495 . "Cert Error")
(496 . "No Cert")
(497 . "HTTP to HTTPS")
(499 . "Client Closed Request")
(500 . "Internal Server Error")
(501 . "Not Implemented")
(502 . "Bad Gateway")
(503 . "Service Unavailable")
(504 . "Gateway Timeout")
(505 . "HTTP Version Not Supported")
(506 . "Variant Also Negotiates")
(507 . "Insufficient Storage")
(508 . "Loop Detected")
(509 . "Bandwidth Limit Exceeded")
(510 . "Not Extended")
(511 . "Network Authentication Required")
(520 . "Origin Error")
(522 . "Connection timed out")
(523 . "Proxy Declined Request")
(524 . "A timeout occurred")
(598 . "Network read timeout error")
(599 . "Network connect timeout error"))
"Possible HTML status codes with names.
From http://en.wikipedia.org/wiki/List_of_HTTP_status_codes.")
(provide 'web-server-status-codes)
;;; web-server-status-codes.el ends here
(define-package "web-server" "20210708.2242" "Emacs Web Server"
'((emacs "24.1")
(cl-lib "0.6"))
:commit "6357a1c2d1718778503f7ee0909585094117525b" :authors
'(("Eric Schulte" . "schulte.eric@gmail.com"))
:maintainers
'(("Eric Schulte" . "schulte.eric@gmail.com"))
:maintainer
'("Eric Schulte" . "schulte.eric@gmail.com")
:keywords
'("http" "server" "network")
:url "https://github.com/eschulte/emacs-web-server")
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; web-server-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from web-server.el
(autoload 'ws-start "web-server" "\
Start a server using HANDLERS and return the server object.
HANDLERS may be a single function (which is then called on every
request) or a list of conses of the form (MATCHER . FUNCTION),
where the FUNCTION associated with the first successful MATCHER
is called. Handler functions are called with two arguments, the
process and the request object.
A MATCHER may be either a function (in which case it is called on
the request object) or a cons cell of the form (KEYWORD . STRING)
in which case STRING is matched against the value of the header
specified by KEYWORD.
Any supplied NETWORK-ARGS are assumed to be keyword arguments for
`make-network-process' to which they are passed directly.
For example, the following starts a simple hello-world server on
port 8080.
(ws-start
(lambda (request)
(with-slots (process headers) request
(process-send-string process
\"HTTP/1.1 200 OK\\r\\nContent-Type: text/plain\\r\\n\\r\\nhello world\")))
8080)
Equivalently, the following starts an identical server using a
function MATCH and the `ws-response-header' convenience
function.
(ws-start
`(((lambda (_) t) .
(lambda (request)
(with-slots ((proc process)) request
(ws-response-header proc 200 '(\"Content-Type\" . \"text/plain\"))
(process-send-string proc \"hello world\")))))
8080)
(fn HANDLERS PORT &optional LOG-BUFFER &rest NETWORK-ARGS)")
(register-definition-prefixes "web-server" '("ws-"))
;;; Generated autoloads from web-server-status-codes.el
(register-definition-prefixes "web-server-status-codes" '("ws-status-codes"))
;;; End of scraped data
(provide 'web-server-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; web-server-autoloads.el ends here
This is gpl.info, produced by makeinfo version 6.7 from gpl.texi.
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies of this
license document, but changing it is not allowed.
Preamble
========
The GNU General Public License is a free, copyleft license for software
and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
====================
0. Definitions.
"This License" refers to version 3 of the GNU General Public
License.
"Copyright" also means copyright-like laws that apply to other
kinds of works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the
work in a fashion requiring copyright permission, other than the
making of an exact copy. The resulting work is called a "modified
version" of the earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work
based on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on
a computer or modifying a private copy. Propagation includes
copying, distribution (with or without modification), making
available to the public, and in some countries other activities as
well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user
through a computer network, with no transfer of a copy, is not
conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to
the extent that warranties are provided), that licensees may convey
the work under this License, and how to view a copy of this
License. If the interface presents a list of user commands or
options, such as a menu, a prominent item in the list meets this
criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an
official standard defined by a recognized standards body, or, in
the case of interfaces specified for a particular programming
language, one that is widely used among developers working in that
language.
The "System Libraries" of an executable work include anything,
other than the work as a whole, that (a) is included in the normal
form of packaging a Major Component, but which is not part of that
Major Component, and (b) serves only to enable use of the work with
that Major Component, or to implement a Standard Interface for
which an implementation is available to the public in source code
form. A "Major Component", in this context, means a major
essential component (kernel, window system, and so on) of the
specific operating system (if any) on which the executable work
runs, or a compiler used to produce the work, or an object code
interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts
to control those activities. However, it does not include the
work's System Libraries, or general-purpose tools or generally
available free programs which are used unmodified in performing
those activities but which are not part of the work. For example,
Corresponding Source includes interface definition files associated
with source files for the work, and the source code for shared
libraries and dynamically linked subprograms that the work is
specifically designed to require, such as by intimate data
communication or control flow between those subprograms and other
parts of the work.
The Corresponding Source need not include anything that users can
regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running
a covered work is covered by this License only if the output, given
its content, constitutes a covered work. This License acknowledges
your rights of fair use or other equivalent, as provided by
copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise
remains in force. You may convey covered works to others for the
sole purpose of having them make modifications exclusively for you,
or provide you with facilities for running those works, provided
that you comply with the terms of this License in conveying all
material for which you do not control copyright. Those thus making
or running the covered works for you must do so exclusively on your
behalf, under your direction and control, on terms that prohibit
them from making any copies of your copyrighted material outside
their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section
10 makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under
article 11 of the WIPO copyright treaty adopted on 20 December
1996, or similar laws prohibiting or restricting circumvention of
such measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such
circumvention is effected by exercising rights under this License
with respect to the covered work, and you disclaim any intention to
limit operation or modification of the work as a means of
enforcing, against the work's users, your or third parties' legal
rights to forbid circumvention of technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the
code; keep intact all notices of the absence of any warranty; and
give all recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these
conditions:
a. The work must carry prominent notices stating that you
modified it, and giving a relevant date.
b. The work must carry prominent notices stating that it is
released under this License and any conditions added under
section 7. This requirement modifies the requirement in
section 4 to "keep intact all notices".
c. You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable
section 7 additional terms, to the whole of the work, and all
its parts, regardless of how they are packaged. This License
gives no permission to license the work in any other way, but
it does not invalidate such permission if you have separately
received it.
d. If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has
interactive interfaces that do not display Appropriate Legal
Notices, your work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered
work, and which are not combined with it such as to form a larger
program, in or on a volume of a storage or distribution medium, is
called an "aggregate" if the compilation and its resulting
copyright are not used to limit the access or legal rights of the
compilation's users beyond what the individual works permit.
Inclusion of a covered work in an aggregate does not cause this
License to apply to the other parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this
License, in one of these ways:
a. Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b. Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that
product model, to give anyone who possesses the object code
either (1) a copy of the Corresponding Source for all the
software in the product that is covered by this License, on a
durable physical medium customarily used for software
interchange, for a price no more than your reasonable cost of
physically performing this conveying of source, or (2) access
to copy the Corresponding Source from a network server at no
charge.
c. Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially,
and only if you received the object code with such an offer,
in accord with subsection 6b.
d. Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to
the Corresponding Source in the same way through the same
place at no further charge. You need not require recipients
to copy the Corresponding Source along with the object code.
If the place to copy the object code is a network server, the
Corresponding Source may be on a different server (operated by
you or a third party) that supports equivalent copying
facilities, provided you maintain clear directions next to the
object code saying where to find the Corresponding Source.
Regardless of what server hosts the Corresponding Source, you
remain obligated to ensure that it is available for as long as
needed to satisfy these requirements.
e. Convey the object code using peer-to-peer transmission,
provided you inform other peers where the object code and
Corresponding Source of the work are being offered to the
general public at no charge under subsection 6d.
A separable portion of the object code, whose source code is
excluded from the Corresponding Source as a System Library, need
not be included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means
any tangible personal property which is normally used for personal,
family, or household purposes, or (2) anything designed or sold for
incorporation into a dwelling. In determining whether a product is
a consumer product, doubtful cases shall be resolved in favor of
coverage. For a particular product received by a particular user,
"normally used" refers to a typical or common use of that class of
product, regardless of the status of the particular user or of the
way in which the particular user actually uses, or expects or is
expected to use, the product. A product is a consumer product
regardless of whether the product has substantial commercial,
industrial or non-consumer uses, unless such uses represent the
only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to
install and execute modified versions of a covered work in that
User Product from a modified version of its Corresponding Source.
The information must suffice to ensure that the continued
functioning of the modified object code is in no case prevented or
interfered with solely because modification has been made.
If you convey an object code work under this section in, or with,
or specifically for use in, a User Product, and the conveying
occurs as part of a transaction in which the right of possession
and use of the User Product is transferred to the recipient in
perpetuity or for a fixed term (regardless of how the transaction
is characterized), the Corresponding Source conveyed under this
section must be accompanied by the Installation Information. But
this requirement does not apply if neither you nor any third party
retains the ability to install modified object code on the User
Product (for example, the work has been installed in ROM).
The requirement to provide Installation Information does not
include a requirement to continue to provide support service,
warranty, or updates for a work that has been modified or installed
by the recipient, or for the User Product in which it has been
modified or installed. Access to a network may be denied when the
modification itself materially and adversely affects the operation
of the network or violates the rules and protocols for
communication across the network.
Corresponding Source conveyed, and Installation Information
provided, in accord with this section must be in a format that is
publicly documented (and with an implementation available to the
public in source code form), and must require no special password
or key for unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of
this License by making exceptions from one or more of its
conditions. Additional permissions that are applicable to the
entire Program shall be treated as though they were included in
this License, to the extent that they are valid under applicable
law. If additional permissions apply only to part of the Program,
that part may be used separately under those permissions, but the
entire Program remains governed by this License without regard to
the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part
of it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material
you add to a covered work, you may (if authorized by the copyright
holders of that material) supplement the terms of this License with
terms:
a. Disclaiming warranty or limiting liability differently from
the terms of sections 15 and 16 of this License; or
b. Requiring preservation of specified reasonable legal notices
or author attributions in that material or in the Appropriate
Legal Notices displayed by works containing it; or
c. Prohibiting misrepresentation of the origin of that material,
or requiring that modified versions of such material be marked
in reasonable ways as different from the original version; or
d. Limiting the use for publicity purposes of names of licensors
or authors of the material; or
e. Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f. Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified
versions of it) with contractual assumptions of liability to
the recipient, for any liability that these contractual
assumptions directly impose on those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as
you received it, or any part of it, contains a notice stating that
it is governed by this License along with a term that is a further
restriction, you may remove that term. If a license document
contains a further restriction but permits relicensing or conveying
under this License, you may add to a covered work material governed
by the terms of that license document, provided that the further
restriction does not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in
the form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights
under this License (including any patent licenses granted under the
third paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the
copyright holder fails to notify you of the violation by some
reasonable means prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from
that copyright holder, and you cure the violation prior to 30 days
after your receipt of the notice.
Termination of your rights under this section does not terminate
the licenses of parties who have received copies or rights from you
under this License. If your rights have been terminated and not
permanently reinstated, you do not qualify to receive new licenses
for the same material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer
transmission to receive a copy likewise does not require
acceptance. However, nothing other than this License grants you
permission to propagate or modify any covered work. These actions
infringe copyright if you do not accept this License. Therefore,
by modifying or propagating a covered work, you indicate your
acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not
responsible for enforcing compliance by third parties with this
License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a
covered work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or
could give under the previous paragraph, plus a right to possession
of the Corresponding Source of the work from the predecessor in
interest, if the predecessor has it or can get it with reasonable
efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you
may not impose a license fee, royalty, or other charge for exercise
of rights granted under this License, and you may not initiate
litigation (including a cross-claim or counterclaim in a lawsuit)
alleging that any patent claim is infringed by making, using,
selling, offering for sale, or importing the Program or any portion
of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based.
The work thus licensed is called the contributor's "contributor
version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner,
permitted by this License, of making, using, or selling its
contributor version, but do not include claims that would be
infringed only as a consequence of further modification of the
contributor version. For purposes of this definition, "control"
includes the right to grant patent sublicenses in a manner
consistent with the requirements of this License.
Each contributor grants you a non-exclusive, worldwide,
royalty-free patent license under the contributor's essential
patent claims, to make, use, sell, offer for sale, import and
otherwise run, modify and propagate the contents of its contributor
version.
In the following three paragraphs, a "patent license" is any
express agreement or commitment, however denominated, not to
enforce a patent (such as an express permission to practice a
patent or covenant not to sue for patent infringement). To "grant"
such a patent license to a party means to make such an agreement or
commitment not to enforce a patent against the party.
If you convey a covered work, knowingly relying on a patent
license, and the Corresponding Source of the work is not available
for anyone to copy, free of charge and under the terms of this
License, through a publicly available network server or other
readily accessible means, then you must either (1) cause the
Corresponding Source to be so available, or (2) arrange to deprive
yourself of the benefit of the patent license for this particular
work, or (3) arrange, in a manner consistent with the requirements
of this License, to extend the patent license to downstream
recipients. "Knowingly relying" means you have actual knowledge
that, but for the patent license, your conveying the covered work
in a country, or your recipient's use of the covered work in a
country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate,
modify or convey a specific copy of the covered work, then the
patent license you grant is automatically extended to all
recipients of the covered work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that
are specifically granted under this License. You may not convey a
covered work if you are a party to an arrangement with a third
party that is in the business of distributing software, under which
you make payment to the third party based on the extent of your
activity of conveying the work, and under which the third party
grants, to any of the parties who would receive the covered work
from you, a discriminatory patent license (a) in connection with
copies of the covered work conveyed by you (or copies made from
those copies), or (b) primarily for and in connection with specific
products or compilations that contain the covered work, unless you
entered into that arrangement, or that patent license was granted,
prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement
or otherwise) that contradict the conditions of this License, they
do not excuse you from the conditions of this License. If you
cannot convey a covered work so as to satisfy simultaneously your
obligations under this License and any other pertinent obligations,
then as a consequence you may not convey it at all. For example,
if you agree to terms that obligate you to collect a royalty for
further conveying from those to whom you convey the Program, the
only way you could satisfy both those terms and this License would
be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a
single combined work, and to convey the resulting work. The terms
of this License will continue to apply to the part which is the
covered work, but the special requirements of the GNU Affero
General Public License, section 13, concerning interaction through
a network will apply to the combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new
versions of the GNU General Public License from time to time. Such
new versions will be similar in spirit to the present version, but
may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU
General Public License "or any later version" applies to it, you
have the option of following the terms and conditions either of
that numbered version or of any later version published by the Free
Software Foundation. If the Program does not specify a version
number of the GNU General Public License, you may choose any
version ever published by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that
proxy's public statement of acceptance of a version permanently
authorizes you to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE
COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS"
WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE
RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.
SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES
AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR
DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA
BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF
THE POSSIBILITY OF SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely
approximates an absolute waiver of all civil liability in
connection with the Program, unless a warranty or assumption of
liability accompanies a copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
===========================
How to Apply These Terms to Your New Programs
=============================================
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these
terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
ONE LINE TO GIVE THE PROGRAM'S NAME AND A BRIEF IDEA OF WHAT IT DOES.
Copyright (C) YEAR NAME OF AUTHOR
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper
mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
PROGRAM Copyright (C) YEAR NAME OF AUTHOR
This program comes with ABSOLUTELY NO WARRANTY; for details type 'show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type 'show c' for details.
The hypothetical commands 'show w' and 'show c' should show the
appropriate parts of the General Public License. Of course, your
program's commands might be different; for a GUI interface, you would
use an "about box".
You should also get your employer (if you work as a programmer) or
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. For more information on this, and how to apply and follow
the GNU GPL, see <http://www.gnu.org/licenses/>.
The GNU General Public License does not permit incorporating your
program into proprietary programs. If your program is a subroutine
library, you may consider it more useful to permit linking proprietary
applications with the library. If this is what you want to do, use the
GNU Lesser General Public License instead of this License. But first,
please read <http://www.gnu.org/philosophy/why-not-lgpl.html>.
Tag Table:
End Tag Table
Local Variables:
coding: utf-8
End:
This is doclicense.info, produced by makeinfo version 6.7 from
doclicense.texi.
Version 1.3, 3 November 2008
Copyright (C) 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc.
<http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
0. PREAMBLE
The purpose of this License is to make a manual, textbook, or other
functional and useful document "free" in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or
noncommercially. Secondarily, this License preserves for the
author and publisher a way to get credit for their work, while not
being considered responsible for modifications made by others.
This License is a kind of "copyleft", which means that derivative
works of the document must themselves be free in the same sense.
It complements the GNU General Public License, which is a copyleft
license designed for free software.
We have designed this License in order to use it for manuals for
free software, because free software needs free documentation: a
free program should come with manuals providing the same freedoms
that the software does. But this License is not limited to
software manuals; it can be used for any textual work, regardless
of subject matter or whether it is published as a printed book. We
recommend this License principally for works whose purpose is
instruction or reference.
1. APPLICABILITY AND DEFINITIONS
This License applies to any manual or other work, in any medium,
that contains a notice placed by the copyright holder saying it can
be distributed under the terms of this License. Such a notice
grants a world-wide, royalty-free license, unlimited in duration,
to use that work under the conditions stated herein. The
"Document", below, refers to any such manual or work. Any member
of the public is a licensee, and is addressed as "you". You accept
the license if you copy, modify or distribute the work in a way
requiring permission under copyright law.
A "Modified Version" of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
A "Secondary Section" is a named appendix or a front-matter section
of the Document that deals exclusively with the relationship of the
publishers or authors of the Document to the Document's overall
subject (or to related matters) and contains nothing that could
fall directly within that overall subject. (Thus, if the Document
is in part a textbook of mathematics, a Secondary Section may not
explain any mathematics.) The relationship could be a matter of
historical connection with the subject or with related matters, or
of legal, commercial, philosophical, ethical or political position
regarding them.
The "Invariant Sections" are certain Secondary Sections whose
titles are designated, as being those of Invariant Sections, in the
notice that says that the Document is released under this License.
If a section does not fit the above definition of Secondary then it
is not allowed to be designated as Invariant. The Document may
contain zero Invariant Sections. If the Document does not identify
any Invariant Sections then there are none.
The "Cover Texts" are certain short passages of text that are
listed, as Front-Cover Texts or Back-Cover Texts, in the notice
that says that the Document is released under this License. A
Front-Cover Text may be at most 5 words, and a Back-Cover Text may
be at most 25 words.
A "Transparent" copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images composed
of pixels) generic paint programs or (for drawings) some widely
available drawing editor, and that is suitable for input to text
formatters or for automatic translation to a variety of formats
suitable for input to text formatters. A copy made in an otherwise
Transparent file format whose markup, or absence of markup, has
been arranged to thwart or discourage subsequent modification by
readers is not Transparent. An image format is not Transparent if
used for any substantial amount of text. A copy that is not
"Transparent" is called "Opaque".
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, LaTeX input format,
SGML or XML using a publicly available DTD, and standard-conforming
simple HTML, PostScript or PDF designed for human modification.
Examples of transparent image formats include PNG, XCF and JPG.
Opaque formats include proprietary formats that can be read and
edited only by proprietary word processors, SGML or XML for which
the DTD and/or processing tools are not generally available, and
the machine-generated HTML, PostScript or PDF produced by some word
processors for output purposes only.
The "Title Page" means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the
material this License requires to appear in the title page. For
works in formats which do not have any title page as such, "Title
Page" means the text near the most prominent appearance of the
work's title, preceding the beginning of the body of the text.
The "publisher" means any person or entity that distributes copies
of the Document to the public.
A section "Entitled XYZ" means a named subunit of the Document
whose title either is precisely XYZ or contains XYZ in parentheses
following text that translates XYZ in another language. (Here XYZ
stands for a specific section name mentioned below, such as
"Acknowledgements", "Dedications", "Endorsements", or "History".)
To "Preserve the Title" of such a section when you modify the
Document means that it remains a section "Entitled XYZ" according
to this definition.
The Document may include Warranty Disclaimers next to the notice
which states that this License applies to the Document. These
Warranty Disclaimers are considered to be included by reference in
this License, but only as regards disclaiming warranties: any other
implication that these Warranty Disclaimers may have is void and
has no effect on the meaning of this License.
2. VERBATIM COPYING
You may copy and distribute the Document in any medium, either
commercially or noncommercially, provided that this License, the
copyright notices, and the license notice saying this License
applies to the Document are reproduced in all copies, and that you
add no other conditions whatsoever to those of this License. You
may not use technical measures to obstruct or control the reading
or further copying of the copies you make or distribute. However,
you may accept compensation in exchange for copies. If you
distribute a large enough number of copies you must also follow the
conditions in section 3.
You may also lend copies, under the same conditions stated above,
and you may publicly display copies.
3. COPYING IN QUANTITY
If you publish printed copies (or copies in media that commonly
have printed covers) of the Document, numbering more than 100, and
the Document's license notice requires Cover Texts, you must
enclose the copies in covers that carry, clearly and legibly, all
these Cover Texts: Front-Cover Texts on the front cover, and
Back-Cover Texts on the back cover. Both covers must also clearly
and legibly identify you as the publisher of these copies. The
front cover must present the full title with all words of the title
equally prominent and visible. You may add other material on the
covers in addition. Copying with changes limited to the covers, as
long as they preserve the title of the Document and satisfy these
conditions, can be treated as verbatim copying in other respects.
If the required texts for either cover are too voluminous to fit
legibly, you should put the first ones listed (as many as fit
reasonably) on the actual cover, and continue the rest onto
adjacent pages.
If you publish or distribute Opaque copies of the Document
numbering more than 100, you must either include a machine-readable
Transparent copy along with each Opaque copy, or state in or with
each Opaque copy a computer-network location from which the general
network-using public has access to download using public-standard
network protocols a complete Transparent copy of the Document, free
of added material. If you use the latter option, you must take
reasonably prudent steps, when you begin distribution of Opaque
copies in quantity, to ensure that this Transparent copy will
remain thus accessible at the stated location until at least one
year after the last time you distribute an Opaque copy (directly or
through your agents or retailers) of that edition to the public.
It is requested, but not required, that you contact the authors of
the Document well before redistributing any large number of copies,
to give them a chance to provide you with an updated version of the
Document.
4. MODIFICATIONS
You may copy and distribute a Modified Version of the Document
under the conditions of sections 2 and 3 above, provided that you
release the Modified Version under precisely this License, with the
Modified Version filling the role of the Document, thus licensing
distribution and modification of the Modified Version to whoever
possesses a copy of it. In addition, you must do these things in
the Modified Version:
A. Use in the Title Page (and on the covers, if any) a title
distinct from that of the Document, and from those of previous
versions (which should, if there were any, be listed in the
History section of the Document). You may use the same title
as a previous version if the original publisher of that
version gives permission.
B. List on the Title Page, as authors, one or more persons or
entities responsible for authorship of the modifications in
the Modified Version, together with at least five of the
principal authors of the Document (all of its principal
authors, if it has fewer than five), unless they release you
from this requirement.
C. State on the Title page the name of the publisher of the
Modified Version, as the publisher.
D. Preserve all the copyright notices of the Document.
E. Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.
F. Include, immediately after the copyright notices, a license
notice giving the public permission to use the Modified
Version under the terms of this License, in the form shown in
the Addendum below.
G. Preserve in that license notice the full lists of Invariant
Sections and required Cover Texts given in the Document's
license notice.
H. Include an unaltered copy of this License.
I. Preserve the section Entitled "History", Preserve its Title,
and add to it an item stating at least the title, year, new
authors, and publisher of the Modified Version as given on the
Title Page. If there is no section Entitled "History" in the
Document, create one stating the title, year, authors, and
publisher of the Document as given on its Title Page, then add
an item describing the Modified Version as stated in the
previous sentence.
J. Preserve the network location, if any, given in the Document
for public access to a Transparent copy of the Document, and
likewise the network locations given in the Document for
previous versions it was based on. These may be placed in the
"History" section. You may omit a network location for a work
that was published at least four years before the Document
itself, or if the original publisher of the version it refers
to gives permission.
K. For any section Entitled "Acknowledgements" or "Dedications",
Preserve the Title of the section, and preserve in the section
all the substance and tone of each of the contributor
acknowledgements and/or dedications given therein.
L. Preserve all the Invariant Sections of the Document, unaltered
in their text and in their titles. Section numbers or the
equivalent are not considered part of the section titles.
M. Delete any section Entitled "Endorsements". Such a section
may not be included in the Modified Version.
N. Do not retitle any existing section to be Entitled
"Endorsements" or to conflict in title with any Invariant
Section.
O. Preserve any Warranty Disclaimers.
If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no
material copied from the Document, you may at your option designate
some or all of these sections as invariant. To do this, add their
titles to the list of Invariant Sections in the Modified Version's
license notice. These titles must be distinct from any other
section titles.
You may add a section Entitled "Endorsements", provided it contains
nothing but endorsements of your Modified Version by various
parties--for example, statements of peer review or that the text
has been approved by an organization as the authoritative
definition of a standard.
You may add a passage of up to five words as a Front-Cover Text,
and a passage of up to 25 words as a Back-Cover Text, to the end of
the list of Cover Texts in the Modified Version. Only one passage
of Front-Cover Text and one of Back-Cover Text may be added by (or
through arrangements made by) any one entity. If the Document
already includes a cover text for the same cover, previously added
by you or by arrangement made by the same entity you are acting on
behalf of, you may not add another; but you may replace the old
one, on explicit permission from the previous publisher that added
the old one.
The author(s) and publisher(s) of the Document do not by this
License give permission to use their names for publicity for or to
assert or imply endorsement of any Modified Version.
5. COMBINING DOCUMENTS
You may combine the Document with other documents released under
this License, under the terms defined in section 4 above for
modified versions, provided that you include in the combination all
of the Invariant Sections of all of the original documents,
unmodified, and list them all as Invariant Sections of your
combined work in its license notice, and that you preserve all
their Warranty Disclaimers.
The combined work need only contain one copy of this License, and
multiple identical Invariant Sections may be replaced with a single
copy. If there are multiple Invariant Sections with the same name
but different contents, make the title of each such section unique
by adding at the end of it, in parentheses, the name of the
original author or publisher of that section if known, or else a
unique number. Make the same adjustment to the section titles in
the list of Invariant Sections in the license notice of the
combined work.
In the combination, you must combine any sections Entitled
"History" in the various original documents, forming one section
Entitled "History"; likewise combine any sections Entitled
"Acknowledgements", and any sections Entitled "Dedications". You
must delete all sections Entitled "Endorsements."
6. COLLECTIONS OF DOCUMENTS
You may make a collection consisting of the Document and other
documents released under this License, and replace the individual
copies of this License in the various documents with a single copy
that is included in the collection, provided that you follow the
rules of this License for verbatim copying of each of the documents
in all other respects.
You may extract a single document from such a collection, and
distribute it individually under this License, provided you insert
a copy of this License into the extracted document, and follow this
License in all other respects regarding verbatim copying of that
document.
7. AGGREGATION WITH INDEPENDENT WORKS
A compilation of the Document or its derivatives with other
separate and independent documents or works, in or on a volume of a
storage or distribution medium, is called an "aggregate" if the
copyright resulting from the compilation is not used to limit the
legal rights of the compilation's users beyond what the individual
works permit. When the Document is included in an aggregate, this
License does not apply to the other works in the aggregate which
are not themselves derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half
of the entire aggregate, the Document's Cover Texts may be placed
on covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic
form. Otherwise they must appear on printed covers that bracket
the whole aggregate.
8. TRANSLATION
Translation is considered a kind of modification, so you may
distribute translations of the Document under the terms of section
4. Replacing Invariant Sections with translations requires special
permission from their copyright holders, but you may include
translations of some or all Invariant Sections in addition to the
original versions of these Invariant Sections. You may include a
translation of this License, and all the license notices in the
Document, and any Warranty Disclaimers, provided that you also
include the original English version of this License and the
original versions of those notices and disclaimers. In case of a
disagreement between the translation and the original version of
this License or a notice or disclaimer, the original version will
prevail.
If a section in the Document is Entitled "Acknowledgements",
"Dedications", or "History", the requirement (section 4) to
Preserve its Title (section 1) will typically require changing the
actual title.
9. TERMINATION
You may not copy, modify, sublicense, or distribute the Document
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense, or distribute it is void,
and will automatically terminate your rights under this License.
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the
copyright holder fails to notify you of the violation by some
reasonable means prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from
that copyright holder, and you cure the violation prior to 30 days
after your receipt of the notice.
Termination of your rights under this section does not terminate
the licenses of parties who have received copies or rights from you
under this License. If your rights have been terminated and not
permanently reinstated, receipt of a copy of some or all of the
same material does not give you any rights to use it.
10. FUTURE REVISIONS OF THIS LICENSE
The Free Software Foundation may publish new, revised versions of
the GNU Free Documentation License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns. See
<http://www.gnu.org/copyleft/>.
Each version of the License is given a distinguishing version
number. If the Document specifies that a particular numbered
version of this License "or any later version" applies to it, you
have the option of following the terms and conditions either of
that specified version or of any later version that has been
published (not as a draft) by the Free Software Foundation. If the
Document does not specify a version number of this License, you may
choose any version ever published (not as a draft) by the Free
Software Foundation. If the Document specifies that a proxy can
decide which future versions of this License can be used, that
proxy's public statement of acceptance of a version permanently
authorizes you to choose that version for the Document.
11. RELICENSING
"Massive Multiauthor Collaboration Site" (or "MMC Site") means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works. A
public wiki that anybody can edit is an example of such a server.
A "Massive Multiauthor Collaboration" (or "MMC") contained in the
site means any set of copyrightable works thus published on the MMC
site.
"CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.
"Incorporate" means to publish or republish a Document, in whole or
in part, as part of another Document.
An MMC is "eligible for relicensing" if it is licensed under this
License, and if all works that were first published under this
License somewhere other than this MMC, and subsequently
incorporated in whole or in part into the MMC, (1) had no cover
texts or invariant sections, and (2) were thus incorporated prior
to November 1, 2008.
The operator of an MMC Site may republish an MMC contained in the
site under CC-BY-SA on the same site at any time before August 1,
2009, provided the MMC is eligible for relicensing.
ADDENDUM: How to use this License for your documents
====================================================
To use this License in a document you have written, include a copy of
the License in the document and put the following copyright and license
notices just after the title page:
Copyright (C) YEAR YOUR NAME.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
Texts. A copy of the license is included in the section entitled ``GNU
Free Documentation License''.
If you have Invariant Sections, Front-Cover Texts and Back-Cover
Texts, replace the "with...Texts." line with this:
with the Invariant Sections being LIST THEIR TITLES, with
the Front-Cover Texts being LIST, and with the Back-Cover Texts
being LIST.
If you have Invariant Sections without Cover Texts, or some other
combination of the three, merge those two alternatives to suit the
situation.
If your document contains nontrivial examples of program code, we
recommend releasing these examples in parallel under your choice of free
software license, such as the GNU General Public License, to permit
their use in free software.
Tag Table:
End Tag Table
Local Variables:
coding: utf-8
End:
This is the file .../info/dir, which contains the
topmost node of the Info hierarchy, called (dir)Top.
The first time you invoke Info you start off looking at this node.
File: dir, Node: Top This is the top of the INFO tree
This (the Directory node) gives a menu of major topics.
Typing "q" exits, "H" lists all Info commands, "d" returns here,
"h" gives a primer for first-timers,
"mEmacs<Return>" visits the Emacs manual, etc.
In Emacs, you can click mouse button 2 on a menu item or cross reference
to select it.
* Menu:
Emacs
* Web Server: (web-server). Web Server for Emacs.
;;; -*- Mode: LISP; Syntax: Common-lisp; -*-
;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
;;; xref.lisp
;;; ****************************************************************
;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp
;;; ****************************************************************
;;;
;;; The List Callers system is a portable Common Lisp cross referencing
;;; utility. It grovels over a set of files and compiles a database of the
;;; locations of all references for each symbol used in the files.
;;; List Callers is similar to the Symbolics Who-Calls and the
;;; Xerox Masterscope facilities.
;;;
;;; When you change a function or variable definition, it can be useful
;;; to know its callers, in order to update each of them to the new
;;; definition. Similarly, having a graphic display of the structure
;;; (e.g., call graph) of a program can help make undocumented code more
;;; understandable. This static code analyzer facilitates both capabilities.
;;; The database compiled by xref is suitable for viewing by a graphical
;;; browser. (Note: the reference graph is not necessarily a DAG. Since many
;;; graphical browsers assume a DAG, this will lead to infinite loops.
;;; Some code which is useful in working around this problem is included,
;;; as well as a sample text-indenting outliner and an interface to Bates'
;;; PSGraph Postscript Graphing facility.)
;;;
;;; Written by Mark Kantrowitz, July 1990.
;;;
;;; Address: School of Computer Science
;;; Carnegie Mellon University
;;; Pittsburgh, PA 15213
;;;
;;; Copyright (c) 1990. All rights reserved.
;;;
;;; See general license below.
;;;
;;; ****************************************************************
;;; General License Agreement and Lack of Warranty *****************
;;; ****************************************************************
;;;
;;; This software is distributed in the hope that it will be useful (both
;;; in and of itself and as an example of lisp programming), but WITHOUT
;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
;;; the consequences of using it or for whether it serves any particular
;;; purpose or works at all. No warranty is made about the software or its
;;; performance.
;;;
;;; Use and copying of this software and the preparation of derivative
;;; works based on this software are permitted, so long as the following
;;; conditions are met:
;;; o The copyright notice and this entire notice are included intact
;;; and prominently carried on all copies and supporting documentation.
;;; o No fees or compensation are charged for use, copies, or
;;; access to this software. You may charge a nominal
;;; distribution fee for the physical act of transferring a
;;; copy, but you may not charge for the program itself.
;;; o If you modify this software, you must cause the modified
;;; file(s) to carry prominent notices (a Change Log)
;;; describing the changes, who made the changes, and the date
;;; of those changes.
;;; o Any work distributed or published that in whole or in part
;;; contains or is a derivative of this software or any part
;;; thereof is subject to the terms of this agreement. The
;;; aggregation of another unrelated program with this software
;;; or its derivative on a volume of storage or distribution
;;; medium does not bring the other program under the scope
;;; of these terms.
;;; o Permission is granted to manufacturers and distributors of
;;; lisp compilers and interpreters to include this software
;;; with their distribution.
;;;
;;; This software is made available AS IS, and is distributed without
;;; warranty of any kind, either expressed or implied.
;;;
;;; In no event will the author(s) or their institutions be liable to you
;;; for damages, including lost profits, lost monies, or other special,
;;; incidental or consequential damages arising out of or in connection
;;; with the use or inability to use (including but not limited to loss of
;;; data or data being rendered inaccurate or losses sustained by third
;;; parties or a failure of the program to operate as documented) the
;;; program, even if you have been advised of the possibility of such
;;; damanges, or for any claim by any other party, whether in an action of
;;; contract, negligence, or other tortious action.
;;;
;;; The current version of this software and a variety of related utilities
;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory
;;; user/ai/lang/lisp/code/tools/xref/
;;;
;;; Please send bug reports, comments, questions and suggestions to
;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes
;;; or improvements you may make.
;;;
;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list,
;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email
;;; address, and affiliation. This mailing list is primarily for
;;; notification about major updates, bug fixes, and additions to the lisp
;;; utilities collection. The mailing list is intended to have low traffic.
;;;
;;; ********************************
;;; Change Log *********************
;;; ********************************
;;;
;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript
;;; graphs to be inserted in Scribe documents.
;;; 21-FEB-91 mk Added warning if not compiled.
;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at
;;; toplevel.
;;; 21-JAN-91 mk Added file xref-test.lisp to test xref.
;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax.
;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also
;;; added parameter *handle-macro-forms*, defaulting to T.
;;; 16-JAN-91 mk Modified print-caller-tree and related functions
;;; to allow the user to specify root nodes. If the user
;;; doesn't specify them, it will default to all root
;;; nodes, as before.
;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify
;;; the direction of the graphing. Either :call-graph,
;;; where the children of a node are those functions called
;;; by the node, or :caller-graph where the children of a
;;; node are the callers of the node. :call-graph is the
;;; default.
;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation
;;; in print-indented-tree.
;;; 16-JUL-90 mk Functions with argument lists of () were being ignored
;;; because of a (when form) wrapped around the body of
;;; record-callers. Then intent of (when form) was as an extra
;;; safeguard against infinite looping. This wasn't really
;;; necessary, so it has been removed.
;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of
;;; optionals.
;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the
;;; CLOS class hierarchy. This really doesn't belong here,
;;; and should be moved to psgraph.lisp as an example of how
;;; to use psgraph.
;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member
;;; had an error which caused many references to be missed.
;;; 16-JUL-90 mk Added ability to save/load processed databases.
;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the
;;; source is loaded.
;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself.
;;; The arg to macro-function must be a symbol.
;;; 7-APR-12 heller Break lines at 80 columns.
;;; ********************************
;;; To Do **************************
;;; ********************************
;;;
;;; Verify that:
;;; o null forms don't cause it to infinite loop.
;;; o nil matches against null argument lists.
;;; o declarations and doc are being ignored.
;;;
;;; Would be nice if in addition to showing callers of a function, it
;;; displayed the context of the calls to the function (e.g., the
;;; immediately surrounding form). This entails storing entries of
;;; the form (symbol context*) in the database and augmenting
;;; record-callers to keep the context around. The only drawbacks is
;;; that it would cons a fair bit. If we do this, we should store
;;; additional information as well in the database, such as the caller
;;; pattern type (e.g., variable vs. function).
;;;
;;; Write a translator from BNF (at least as much of BNF as is used
;;; in CLtL2), to the format used here.
;;;
;;; Should automatically add new patterns for new functions and macros
;;; based on their arglists. Probably requires much more than this
;;; simple code walker, so there isn't much we can do.
;;;
;;; Defmacro is a problem, because it often hides internal function
;;; calls within backquote and quote, which we normally ignore. If
;;; we redefine QUOTE's pattern so that it treats the arg like a FORM,
;;; we'll probably get them (though maybe the syntax will be mangled),
;;; but most likely a lot of spurious things as well.
;;;
;;; Define an operation for Defsystem which will run XREF-FILE on the
;;; files of the system. Or yet simpler, when XREF sees a LOAD form
;;; for which the argument is a string, tries to recursively call
;;; XREF-FILE on the specified file. Then one could just XREF-FILE
;;; the file which loads the system. (This should be a program
;;; parameter.)
;;;
;;; Have special keywords which the user may place in a file to have
;;; XREF-FILE ignore a region.
;;;
;;; Should we distinguish flet and labels from defun? I.e., note that
;;; flet's definitions are locally defined, instead of just lumping
;;; them in with regular definitions.
;;;
;;; Add patterns for series, loop macro.
;;;
;;; Need to integrate the variable reference database with the other
;;; databases, yet maintain separation. So we can distinguish all
;;; the different types of variable and function references, without
;;; multiplying databases.
;;;
;;; Would pay to comment record-callers and record-callers* in more
;;; depth.
;;;
;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT)
;;; ********************************
;;; Notes **************************
;;; ********************************
;;;
;;; XREF has been tested (successfully) in the following lisps:
;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
;;; Macintosh Allegro Common Lisp (1.3.2)
;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90)
;;; Lucid CL (Version 2.1 6-DEC-87)
;;;
;;; XREF has been tested (unsuccessfully) in the following lisps:
;;; Ibuki Common Lisp (01/01, October 15, 1987)
;;; - if interpreted, runs into stack overflow
;;; - does not compile (tried ibcl on Suns, PMAXes and RTs)
;;; seems to be due to a limitation in the c compiler.
;;;
;;; XREF needs to be tested in the following lisps:
;;; Symbolics Common Lisp (8.0)
;;; Lucid Common Lisp (3.0, 4.0)
;;; KCL (June 3, 1987 or later)
;;; AKCL (1.86, June 30, 1987 or later)
;;; TI (Release 4.1 or later)
;;; Golden Common Lisp (3.1 IBM-PC)
;;; VAXLisp (2.0, 3.1)
;;; HP Common Lisp (same as Lucid?)
;;; Procyon Common Lisp
;;; ****************************************************************
;;; Documentation **************************************************
;;; ****************************************************************
;;;
;;; XREF analyzes a user's program, determining which functions call a
;;; given function, and the location of where variables are bound/assigned
;;; and used. The user may retrieve this information for either a single
;;; symbol, or display the call graph of portions of the program
;;; (including the entire program). This allows the programmer to debug
;;; and document the program's structure.
;;;
;;; XREF is primarily intended for analyzing large programs, where it is
;;; difficult, if not impossible, for the programmer to grasp the structure
;;; of the whole program. Nothing precludes using XREF for smaller programs,
;;; where it can be useful for inspecting the relationships between pieces
;;; of the program and for documenting the program.
;;;
;;; Two aspects of the Lisp programming language greatly simplify the
;;; analysis of Lisp programs:
;;; o Lisp programs are naturally represented as data.
;;; Successive definitions from a file are easily read in
;;; as list structure.
;;; o The basic syntax of Lisp is uniform. A list program
;;; consists of a set of nested forms, where each form is
;;; a list whose car is a tag (e.g., function name) that
;;; specifies the structure of the rest of the form.
;;; Thus Lisp programs, when represented as data, can be considered to be
;;; parse trees. Given a grammar of syntax patterns for the language, XREF
;;; recursively descends the parse tree for a given definition, computing
;;; a set of relations that hold for the definition at each node in the
;;; tree. For example, one kind of relation is that the function defined
;;; by the definition calls the functions in its body. The relations are
;;; stored in a database for later examination by the user.
;;;
;;; While XREF currently only works for programs written in Lisp, it could
;;; be extended to other programming languages by writing a function to
;;; generate parse trees for definitions in that language, and a core
;;; set of patterns for the language's syntax.
;;;
;;; Since XREF normally does a static syntactic analysis of the program,
;;; it does not detect references due to the expansion of a macro definition.
;;; To do this in full generality XREF would have to have knowledge about the
;;; semantics of the program (e.g., macros which call other functions to
;;; do the expansion). This entails either modifying the compiler to
;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing
;;; a walk of loaded code and macroexpanding as needed (PCL code walker).
;;; The former is not portable, while the latter requires that the code
;;; used by macros be loaded and in working order. On the other hand, then
;;; we would need no special knowledge about macros (excluding the 24 special
;;; forms of Lisp).
;;;
;;; Parameters may be set to enable macro expansion in XREF. Then XREF
;;; will expand any macros for which it does not have predefined patterns.
;;; (For example, most Lisps will implement dolist as a macro. Since XREF
;;; has a pattern defined for dolist, it will not call macroexpand-1 on
;;; a form whose car is dolist.) For this to work properly, the code must
;;; be loaded before being processed by XREF, and XREF's parameters should
;;; be set so that it processes forms in their proper packages.
;;;
;;; If macro expansion is disabled, the default rules for handling macro
;;; references may not be sufficient for some user-defined macros, because
;;; macros allow a variety of non-standard syntactic extensions to the
;;; language. In this case, the user may specify additional templates in
;;; a manner similar to that in which the core Lisp grammar was specified.
;;;
;;; ********************************
;;; User Guide *********************
;;; ********************************
;;; -----
;;; The following functions are called to cross reference the source files.
;;;
;;; XREF-FILES (&rest files) [FUNCTION]
;;; Grovels over the lisp code located in source file FILES, using
;;; xref-file.
;;;
;;; XREF-FILE (filename &optional clear-tables verbose) [Function]
;;; Cross references the function and variable calls in FILENAME by
;;; walking over the source code located in the file. Defaults type of
;;; filename to ".lisp". Chomps on the code using record-callers and
;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the
;;; callers database before processing the file. Specify CLEAR-TABLES as
;;; nil to append to the database. If VERBOSE is T (the default), prints
;;; out the name of the file, one progress dot for each form processed,
;;; and the total number of forms.
;;;
;;; -----
;;; The following functions display information about the uses of the
;;; specified symbol as a function, variable, or constant.
;;;
;;; LIST-CALLERS (symbol) [FUNCTION]
;;; Lists all functions which call SYMBOL as a function (function
;;; invocation).
;;;
;;; LIST-READERS (symbol) [FUNCTION]
;;; Lists all functions which refer to SYMBOL as a variable
;;; (variable reference).
;;;
;;; LIST-SETTERS (symbol) [FUNCTION]
;;; Lists all functions which bind/set SYMBOL as a variable
;;; (variable mutation).
;;;
;;; LIST-USERS (symbol) [FUNCTION]
;;; Lists all functions which use SYMBOL as a variable or function.
;;;
;;; WHO-CALLS (symbol &optional how) [FUNCTION]
;;; Lists callers of symbol. HOW may be :function, :reader, :setter,
;;; or :variable."
;;;
;;; WHAT-FILES-CALL (symbol) [FUNCTION]
;;; Lists names of files that contain uses of SYMBOL
;;; as a function, variable, or constant.
;;;
;;; SOURCE-FILE (symbol) [FUNCTION]
;;; Lists the names of files in which SYMBOL is defined/used.
;;;
;;; LIST-CALLEES (symbol) [FUNCTION]
;;; Lists names of functions and variables called by SYMBOL.
;;;
;;; -----
;;; The following functions may be useful for viewing the database and
;;; debugging the calling patterns.
;;;
;;; *LAST-FORM* () [VARIABLE]
;;; The last form read from the file. Useful for figuring out what went
;;; wrong when xref-file drops into the debugger.
;;;
;;; *XREF-VERBOSE* t [VARIABLE]
;;; When T, xref-file(s) prints out the names of the files it looks at,
;;; progress dots, and the number of forms read.
;;;
;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE]
;;; Default set of caller types (as specified in the patterns) to ignore
;;; in the database handling functions. :lisp is CLtL 1st edition,
;;; :lisp2 is additional patterns from CLtL 2nd edition.
;;;
;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE]
;;; When non-NIL, and XREF-FILE sees a package-setting form like
;;; IN-PACKAGE, sets the current package to the specified package by
;;; evaluating the form. When done with the file, xref-file resets the
;;; package to its original value. In some of the displaying functions,
;;; when this variable is non-NIL one may specify that all symbols from a
;;; particular set of packages be ignored. This is only useful if the
;;; files use different packages with conflicting names.
;;;
;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE]
;;; When T, XREF-FILE tries to be smart about forms which occur in
;;; a function position, such as lambdas and arbitrary Lisp forms.
;;; If so, it recursively calls record-callers with pattern 'FORM.
;;; If the form is a lambda, makes the caller a caller of
;;; :unnamed-lambda.
;;;
;;; *HANDLE-MACRO-FORMS* t [VARIABLE]
;;; When T, if the file was loaded before being processed by XREF, and
;;; the car of a form is a macro, it notes that the parent calls the
;;; macro, and then calls macroexpand-1 on the form.
;;;
;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE]
;;; Specifies whether we graph up or down. If :call-graph, the children
;;; of a node are the functions it calls. If :caller-graph, the
;;; children of a node are the functions that call it.
;;;
;;; *INDENT-AMOUNT* 3 [VARIABLE]
;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE.
;;;
;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION]
;;; Prints out the name of each symbol and all its callers. Specify
;;; database :callers (the default) to get function call references,
;;; :file to the get files in which the symbol is called, :readers to get
;;; variable references, and :setters to get variable binding and
;;; assignments. Ignores functions of types listed in types-to-ignore.
;;;
;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION]
;;; (types-to-ignore *types-to-ignore*)
;;; compact root-nodes)
;;; Prints the calling trees (which may actually be a full graph and not
;;; necessarily a DAG) as indented text trees using
;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children
;;; of a node are the functions called by the node, or :caller-graph for
;;; trees where the children of a node are the functions the node calls.
;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the
;;; patterns) to ignore in printing out the database. For example,
;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is
;;; a flag to tell the program to try to compact the trees a bit by not
;;; printing trees if they have already been seen. ROOT-NODES is a list
;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to
;;; find all root nodes in the database.
;;;
;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION]
;;; (types-to-ignore *types-to-ignore*)
;;; compact)
;;; Outputs list structure of a tree which roughly represents the
;;; possibly cyclical structure of the caller database.
;;; If mode is :call-graph, the children of a node are the functions
;;; it calls. If mode is :caller-graph, the children of a node are the
;;; functions that call it.
;;; If compact is T, tries to eliminate the already-seen nodes, so
;;; that the graph for a node is printed at most once. Otherwise it will
;;; duplicate the node's tree (except for cycles). This is usefull
;;; because the call tree is actually a directed graph, so we can either
;;; duplicate references or display only the first one.
;;;
;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION]
;;; Makes a hash table of file dependencies for the references listed in
;;; DATABASE. This function may be useful for automatically resolving
;;; file references for automatic creation of a system definition
;;; (defsystem).
;;;
;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION]
;;; Prints a list of file dependencies for the references listed in
;;; DATABASE. This function may be useful for automatically computing
;;; file loading constraints for a system definition tool.
;;;
;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION]
;;; Saves the contents of the current callers database to a file. This
;;; file can be loaded to restore the previous contents of the
;;; database. (For large systems it can take a long time to crunch
;;; through the code, so this can save some time.)
;;;
;;; -----
;;; The following macros define new function and macro call patterns.
;;; They may be used to extend the static analysis tool to handle
;;; new def forms, extensions to Common Lisp, and program defs.
;;;
;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO]
;;; Defines NAME to be equivalent to the specified pattern. Useful for
;;; making patterns more readable. For example, the LAMBDA-LIST is
;;; defined as a pattern substitution, making the definition of the
;;; DEFUN caller-pattern simpler.
;;;
;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO]
;;; Defines NAME as a function/macro call with argument structure
;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to
;;; the pattern, which may be used to exclude references to NAME while
;;; viewing the database. For example, all the Common Lisp definitions
;;; have a caller-type of :lisp or :lisp2, so that you can exclude
;;; references to common lisp functions from the calling tree.
;;;
;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO]
;;; Defines NAME as a variable reference of type CALLER-TYPE. This is
;;; mainly used to establish the caller-type of the variable.
;;;
;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO]
;;; For defining function caller pattern syntax synonyms. For each name
;;; in DESTINATIONS, defines its pattern as a copy of the definition
;;; of SOURCE. Allows a large number of identical patterns to be defined
;;; simultaneously. Must occur after the SOURCE has been defined.
;;;
;;; -----
;;; This system includes pattern definitions for the latest
;;; common lisp specification, as published in Guy Steele,
;;; Common Lisp: The Language, 2nd Edition.
;;;
;;; Patterns may be either structures to match, or a predicate
;;; like symbolp/numberp/stringp. The pattern specification language
;;; is similar to the notation used in CLtL2, but in a more lisp-like
;;; form:
;;; (:eq name) The form element must be eq to the symbol NAME.
;;; (:test test) TEST must be true when applied to the form element.
;;; (:typep type) The form element must be of type TYPE.
;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order,
;;; until one succeeds.
;;; Equivalent to { pat1 | pat2 | ... }
;;; (:rest pattern) The remaining form elements are grouped into a
;;; list which is matched against PATTERN.
;;; (:optional pat1 ...) The patterns may optionally match against the
;;; form element.
;;; Equivalent to [ pat1 ... ].
;;; (:star pat1 ...) The patterns may match against the patterns
;;; any number of times, including 0.
;;; Equivalent to { pat1 ... }*.
;;; (:plus pat1 ...) The patterns may match against the patterns
;;; any number of times, but at least once.
;;; Equivalent to { pat1 ... }+.
;;; &optional, &key, Similar in behavior to the corresponding
;;; &rest lambda-list keywords.
;;; FORM A random lisp form. If a cons, assumes the
;;; car is a function or macro and tries to
;;; match the args against that symbol's pattern.
;;; If a symbol, assumes it's a variable reference.
;;; :ignore Ignores the corresponding form element.
;;; NAME The corresponding form element should be
;;; the name of a new definition (e.g., the
;;; first arg in a defun pattern is NAME.
;;; FUNCTION, MACRO The corresponding form element should be
;;; a function reference not handled by FORM.
;;; Used in the definition of apply and funcall.
;;; VAR The corresponding form element should be
;;; a variable definition or mutation. Used
;;; in the definition of let, let*, etc.
;;; VARIABLE The corresponding form element should be
;;; a variable reference.
;;;
;;; In all other pattern symbols, it looks up the symbols pattern substitution
;;; and recursively matches against the pattern. Automatically destructures
;;; list structure that does not include consing dots.
;;;
;;; Among the pattern substitution names defined are:
;;; STRING, SYMBOL, NUMBER Appropriate :test patterns.
;;; LAMBDA-LIST Matches against a lambda list.
;;; BODY Matches against a function body definition.
;;; FN Matches against #'function, 'function,
;;; and lambdas. This is used in the definition
;;; of apply, funcall, and the mapping patterns.
;;; and others...
;;;
;;; Here's some sample pattern definitions:
;;; (define-caller-pattern defun
;;; (name lambda-list
;;; (:star (:or documentation-string declaration))
;;; (:star form))
;;; :lisp)
;;; (define-caller-pattern funcall (fn (:star form)) :lisp)
;;;
;;; In general, the system is intelligent enough to handle any sort of
;;; simple funcall. One only need specify the syntax for functions and
;;; macros which use optional arguments, keyword arguments, or some
;;; argument positions are special, such as in apply and funcall, or
;;; to indicate that the function is of the specified caller type.
;;;
;;;
;;; NOTES:
;;;
;;; XRef assumes syntactically correct lisp code.
;;;
;;; This is by no means perfect. For example, let and let* are treated
;;; identically, instead of differentiating between serial and parallel
;;; binding. But it's still a useful tool. It can be helpful in
;;; maintaining code, debugging problems with patch files, determining
;;; whether functions are multiply defined, and help you remember where
;;; a function is defined or called.
;;;
;;; XREF runs best when compiled.
;;; ********************************
;;; References *********************
;;; ********************************
;;;
;;; Xerox Interlisp Masterscope Program:
;;; Larry M Masinter, Global program analysis in an interactive environment
;;; PhD Thesis, Stanford University, 1980.
;;;
;;; Symbolics Who-Calls Database:
;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986
;;; Genera 7.0, pp 183-185.
;;;
;;; ********************************
;;; Example ************************
;;; ********************************
;;;
;;; Here is an example of running XREF on a short program.
;;; [In Scribe documentation, give a simple short program and resulting
;;; XREF output, including postscript call graphs.]
#|
<cl> (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp")
Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp.
................................................
48 forms processed.
<cl> (xref:display-database :readers)
*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE.
*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO.
*DIRECTION* is referenced by CREATE-POSITION-INFO.
*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT.
*ROOT-IS-SEQUENCE* is referenced by GRAPH.
*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE.
*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO.
*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE.
*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE.
*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE.
<cl> (xref:print-caller-trees :root-nodes '(display-graph))
Rooted calling trees:
DISPLAY-GRAPH
CREATE-POSITION-INFO
CALCULATE-POSITION-INFO
CALCULATE-POSITION
NODE-POSITION-ALREADY-SET-FLAG
NODE-LEVEL-ALREADY-SET-FLAG
CALCULATE-POSITION-IN-LEVEL
NODE-CHILDREN
NODE-LEVEL
CALCULATE-POSITION
NEW-CALCULATE-BREADTH
NODE-CHILDREN
BREADTH
OPPOSITE-DIMENSION
NODE-HEIGHT
NODE-WIDTH
NEW-CALCULATE-BREADTH
NODE-PARENTS
OPPOSITE-DIMENSION
NODE-HEIGHT
NODE-WIDTH
OPPOSITE-POSITION
NODE-Y
NODE-X
NODE-LEVEL
CALCULATE-LEVEL-POSITION
NODE-LEVEL
NODE-POSITION
NODE-X
NODE-Y
DIMENSION
NODE-WIDTH
NODE-HEIGHT
CALCULATE-LEVEL-POSITION-BEFORE
NODE-LEVEL
NODE-POSITION
NODE-X
NODE-Y
NODE-WIDTH
NODE-HEIGHT
DIMENSION
NODE-WIDTH
NODE-HEIGHT
|#
;;; ****************************************************************
;;; List Callers ***************************************************
;;; ****************************************************************
(defpackage :pxref
(:use :common-lisp)
(:export #:list-callers
#:list-users
#:list-readers
#:list-setters
#:what-files-call
#:who-calls
#:list-callees
#:source-file
#:clear-tables
#:define-pattern-substitution
#:define-caller-pattern
#:define-variable-pattern
#:define-caller-pattern-synonyms
#:clear-patterns
#:*last-form*
#:*xref-verbose*
#:*handle-package-forms*
#:*handle-function-forms*
#:*handle-macro-forms*
#:*types-to-ignore*
#:*last-caller-tree*
#:*default-graphing-mode*
#:*indent-amount*
#:xref-file
#:xref-files
#:write-callers-database-to-file
#:display-database
#:print-caller-trees
#:make-caller-tree
#:print-indented-tree
#:determine-file-dependencies
#:print-file-dependencies
#:psgraph-xref
))
(in-package "PXREF")
;;; Warn user if they're loading the source instead of compiling it first.
;(eval-when (compile load eval)
; (defvar compiled-p nil))
;(eval-when (compile load)
; (setq compiled-p t))
;(eval-when (load eval)
; (unless compiled-p
; (warn "This file should be compiled before loading for best results.")))
(eval-when (eval)
(warn "This file should be compiled before loading for best results."))
;;; ********************************
;;; Primitives *********************
;;; ********************************
(defun lookup (symbol environment)
(dolist (frame environment)
(when (member symbol frame)
(return symbol))))
(defun car-eq (list item)
(and (consp list)
(eq (car list) item)))
;;; ********************************
;;; Callers Database ***************
;;; ********************************
(defvar *file-callers-database* (make-hash-table :test #'equal)
"Contains name and list of file callers (files which call) for that name.")
(defvar *callers-database* (make-hash-table :test #'equal)
"Contains name and list of callers (function invocation) for that name.")
(defvar *readers-database* (make-hash-table :test #'equal)
"Contains name and list of readers (variable use) for that name.")
(defvar *setters-database* (make-hash-table :test #'equal)
"Contains name and list of setters (variable mutation) for that name.")
(defvar *callees-database* (make-hash-table :test #'equal)
"Contains name and list of functions and variables it calls.")
(defun callers-list (name &optional (database :callers))
(case database
(:file (gethash name *file-callers-database*))
(:callees (gethash name *callees-database*))
(:callers (gethash name *callers-database*))
(:readers (gethash name *readers-database*))
(:setters (gethash name *setters-database*))))
(defsetf callers-list (name &optional (database :callers)) (caller)
`(setf (gethash ,name (case ,database
(:file *file-callers-database*)
(:callees *callees-database*)
(:callers *callers-database*)
(:readers *readers-database*)
(:setters *setters-database*)))
,caller))
(defun list-callers (symbol)
"Lists all functions which call SYMBOL as a function (function invocation)."
(callers-list symbol :callers))
(defun list-readers (symbol)
"Lists all functions which refer to SYMBOL as a variable
(variable reference)."
(callers-list symbol :readers))
(defun list-setters (symbol)
"Lists all functions which bind/set SYMBOL as a variable
(variable mutation)."
(callers-list symbol :setters))
(defun list-users (symbol)
"Lists all functions which use SYMBOL as a variable or function."
(values (list-callers symbol)
(list-readers symbol)
(list-setters symbol)))
(defun who-calls (symbol &optional how)
"Lists callers of symbol. HOW may be :function, :reader, :setter,
or :variable."
;; would be nice to have :macro and distinguish variable
;; binding from assignment. (i.e., variable binding, assignment, and use)
(case how
(:function (list-callers symbol))
(:reader (list-readers symbol))
(:setter (list-setters symbol))
(:variable (append (list-readers symbol)
(list-setters symbol)))
(otherwise (append (list-callers symbol)
(list-readers symbol)
(list-setters symbol)))))
(defun what-files-call (symbol)
"Lists names of files that contain uses of SYMBOL
as a function, variable, or constant."
(callers-list symbol :file))
(defun list-callees (symbol)
"Lists names of functions and variables called by SYMBOL."
(callers-list symbol :callees))
(defvar *source-file* (make-hash-table :test #'equal)
"Contains function name and source file for that name.")
(defun source-file (symbol)
"Lists the names of files in which SYMBOL is defined/used."
(gethash symbol *source-file*))
(defsetf source-file (name) (value)
`(setf (gethash ,name *source-file*) ,value))
(defun clear-tables ()
(clrhash *file-callers-database*)
(clrhash *callers-database*)
(clrhash *callees-database*)
(clrhash *readers-database*)
(clrhash *setters-database*)
(clrhash *source-file*))
;;; ********************************
;;; Pattern Database ***************
;;; ********************************
;;; Pattern Types
(defvar *pattern-caller-type* (make-hash-table :test #'equal))
(defun pattern-caller-type (name)
(gethash name *pattern-caller-type*))
(defsetf pattern-caller-type (name) (value)
`(setf (gethash ,name *pattern-caller-type*) ,value))
;;; Pattern Substitutions
(defvar *pattern-substitution-table* (make-hash-table :test #'equal)
"Stores general patterns for function destructuring.")
(defun lookup-pattern-substitution (name)
(gethash name *pattern-substitution-table*))
(defmacro define-pattern-substitution (name pattern)
"Defines NAME to be equivalent to the specified pattern. Useful for
making patterns more readable. For example, the LAMBDA-LIST is
defined as a pattern substitution, making the definition of the
DEFUN caller-pattern simpler."
`(setf (gethash ',name *pattern-substitution-table*)
',pattern))
;;; Function/Macro caller patterns:
;;; The car of the form is skipped, so we don't need to specify
;;; (:eq function-name) like we would for a substitution.
;;;
;;; Patterns must be defined in the XREF package because the pattern
;;; language is tested by comparing symbols (using #'equal) and not
;;; their printreps. This is fine for the lisp grammer, because the XREF
;;; package depends on the LISP package, so a symbol like 'xref::cons is
;;; translated automatically into 'lisp::cons. However, since
;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and
;;; 'baz::bar are inherited from the same package (e.g., LISP),
;;; if package handling is turned on the user must specify package
;;; names in the caller pattern definitions for functions that occur
;;; in packages other than LISP, otherwise the symbols will not match.
;;;
;;; Perhaps we should enforce the definition of caller patterns in the
;;; XREF package by wrapping the body of define-caller-pattern in
;;; the XREF package:
;;; (defmacro define-caller-pattern (name value &optional caller-type)
;;; (let ((old-package *package*))
;;; (setf *package* (find-package "XREF"))
;;; (prog1
;;; `(progn
;;; (when ',caller-type
;;; (setf (pattern-caller-type ',name) ',caller-type))
;;; (when ',value
;;; (setf (gethash ',name *caller-pattern-table*)
;;; ',value)))
;;; (setf *package* old-package))))
;;; Either that, or for the purpose of pattern testing we should compare
;;; printreps. [The latter makes the primitive patterns like VAR
;;; reserved words.]
(defvar *caller-pattern-table* (make-hash-table :test #'equal)
"Stores patterns for function destructuring.")
(defun lookup-caller-pattern (name)
(gethash name *caller-pattern-table*))
(defmacro define-caller-pattern (name pattern &optional caller-type)
"Defines NAME as a function/macro call with argument structure
described by PATTERN. CALLER-TYPE, if specified, assigns a type to
the pattern, which may be used to exclude references to NAME while
viewing the database. For example, all the Common Lisp definitions
have a caller-type of :lisp or :lisp2, so that you can exclude
references to common lisp functions from the calling tree."
`(progn
(when ',caller-type
(setf (pattern-caller-type ',name) ',caller-type))
(when ',pattern
(setf (gethash ',name *caller-pattern-table*)
',pattern))))
;;; For defining variables
(defmacro define-variable-pattern (name &optional caller-type)
"Defines NAME as a variable reference of type CALLER-TYPE. This is
mainly used to establish the caller-type of the variable."
`(progn
(when ',caller-type
(setf (pattern-caller-type ',name) ',caller-type))))
;;; For defining synonyms. Means much less space taken up by the patterns.
(defmacro define-caller-pattern-synonyms (source destinations)
"For defining function caller pattern syntax synonyms. For each name
in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE.
Allows a large number of identical patterns to be defined simultaneously.
Must occur after the SOURCE has been defined."
`(let ((source-type (pattern-caller-type ',source))
(source-pattern (gethash ',source *caller-pattern-table*)))
(when source-type
(dolist (dest ',destinations)
(setf (pattern-caller-type dest) source-type)))
(when source-pattern
(dolist (dest ',destinations)
(setf (gethash dest *caller-pattern-table*)
source-pattern)))))
(defun clear-patterns ()
(clrhash *pattern-substitution-table*)
(clrhash *caller-pattern-table*)
(clrhash *pattern-caller-type*))
;;; ********************************
;;; Cross Reference Files **********
;;; ********************************
(defvar *last-form* ()
"The last form read from the file. Useful for figuring out what went wrong
when xref-file drops into the debugger.")
(defvar *xref-verbose* t
"When T, xref-file(s) prints out the names of the files it looks at,
progress dots, and the number of forms read.")
;;; This needs to first clear the tables?
(defun xref-files (&rest files)
"Grovels over the lisp code located in source file FILES, using xref-file."
;; If the arg is a list, use it.
(when (listp (car files)) (setq files (car files)))
(dolist (file files)
(xref-file file nil))
(values))
(defvar *handle-package-forms* nil ;'(lisp::in-package)
"When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE,
sets the current package to the specified package by evaluating the
form. When done with the file, xref-file resets the package to its
original value. In some of the displaying functions, when this variable
is non-NIL one may specify that all symbols from a particular set of
packages be ignored. This is only useful if the files use different
packages with conflicting names.")
(defvar *normal-readtable* (copy-readtable nil)
"Normal, unadulterated CL readtable.")
(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*))
"Cross references the function and variable calls in FILENAME by
walking over the source code located in the file. Defaults type of
filename to \".lisp\". Chomps on the code using record-callers and
record-callers*. If CLEAR-TABLES is T (the default), it clears the callers
database before processing the file. Specify CLEAR-TABLES as nil to
append to the database. If VERBOSE is T (the default), prints out the
name of the file, one progress dot for each form processed, and the
total number of forms."
;; Default type to "lisp"
(when (and (null (pathname-type filename))
(not (probe-file filename)))
(cond ((stringp filename)
(setf filename (concatenate 'string filename ".lisp")))
((pathnamep filename)
(setf filename (merge-pathnames filename
(make-pathname :type "lisp"))))))
(when clear-tables (clear-tables))
(let ((count 0)
(old-package *package*)
(*readtable* *normal-readtable*))
(when verbose
(format t "~&Cross-referencing file ~A.~&" filename))
(with-open-file (stream filename :direction :input)
(do ((form (read stream nil :eof) (read stream nil :eof)))
((eq form :eof))
(incf count)
(when verbose
(format *standard-output* ".")
(force-output *standard-output*))
(setq *last-form* form)
(record-callers filename form)
;; Package Magic.
(when (and *handle-package-forms*
(consp form)
(member (car form) *handle-package-forms*))
(eval form))))
(when verbose
(format t "~&~D forms processed." count))
(setq *package* old-package)
(values)))
(defvar *handle-function-forms* t
"When T, XREF-FILE tries to be smart about forms which occur in
a function position, such as lambdas and arbitrary Lisp forms.
If so, it recursively calls record-callers with pattern 'FORM.
If the form is a lambda, makes the caller a caller of :unnamed-lambda.")
(defvar *handle-macro-forms* t
"When T, if the file was loaded before being processed by XREF, and the
car of a form is a macro, it notes that the parent calls the macro,
and then calls macroexpand-1 on the form.")
(defvar *callees-database-includes-variables* nil)
(defun record-callers (filename form
&optional pattern parent (environment nil)
funcall)
"RECORD-CALLERS is the main routine used to walk down the code. It matches
the PATTERN against the FORM, possibly adding statements to the database.
PARENT is the name defined by the current outermost definition; it is
the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used
to keep track of the scoping of variables. FUNCALL deals with the type
of variable assignment and hence how the environment should be modified.
RECORD-CALLERS handles atomic patterns and simple list-structure patterns.
For complex list-structure pattern destructuring, it calls RECORD-CALLERS*."
; (when form)
(unless pattern (setq pattern 'FORM))
(cond ((symbolp pattern)
(case pattern
(:IGNORE
;; Ignores the rest of the form.
(values t parent environment))
(NAME
;; This is the name of a new definition.
(push filename (source-file form))
(values t form environment))
((FUNCTION MACRO)
;; This is the name of a call.
(cond ((and *handle-function-forms* (consp form))
;; If we're a cons and special handling is on,
(when (eq (car form) 'lambda)
(pushnew filename (callers-list :unnamed-lambda :file))
(when parent
(pushnew parent (callers-list :unnamed-lambda
:callers))
(pushnew :unnamed-lambda (callers-list parent
:callees))))
(record-callers filename form 'form parent environment))
(t
;; If we're just a regular function name call.
(pushnew filename (callers-list form :file))
(when parent
(pushnew parent (callers-list form :callers))
(pushnew form (callers-list parent :callees)))
(values t parent environment))))
(VAR
;; This is the name of a new variable definition.
;; Includes arglist parameters.
(when (and (symbolp form) (not (keywordp form))
(not (member form lambda-list-keywords)))
(pushnew form (car environment))
(pushnew filename (callers-list form :file))
(when parent
; (pushnew form (callers-list parent :callees))
(pushnew parent (callers-list form :setters)))
(values t parent environment)))
(VARIABLE
;; VAR reference
(pushnew filename (callers-list form :file))
(when (and parent (not (lookup form environment)))
(pushnew parent (callers-list form :readers))
(when *callees-database-includes-variables*
(pushnew form (callers-list parent :callees))))
(values t parent environment))
(FORM
;; A random form (var or funcall).
(cond ((consp form)
;; Get new pattern from TAG.
(let ((new-pattern (lookup-caller-pattern (car form))))
(pushnew filename (callers-list (car form) :file))
(when parent
(pushnew parent (callers-list (car form) :callers))
(pushnew (car form) (callers-list parent :callees)))
(cond ((and new-pattern (cdr form))
;; Special Pattern and there's stuff left
;; to be processed. Note that we check if
;; a pattern is defined for the form before
;; we check to see if we can macroexpand it.
(record-callers filename (cdr form) new-pattern
parent environment :funcall))
((and *handle-macro-forms*
(symbolp (car form)) ; pnorvig 9/9/93
(macro-function (car form)))
;; The car of the form is a macro and
;; macro processing is turned on. Macroexpand-1
;; the form and try again.
(record-callers filename
(macroexpand-1 form)
'form parent environment
:funcall))
((null (cdr form))
;; No more left to be processed. Note that
;; this must occur after the macros clause,
;; since macros can expand into more code.
(values t parent environment))
(t
;; Random Form. We assume it is a function call.
(record-callers filename (cdr form)
'((:star FORM))
parent environment :funcall)))))
(t
(when (and (not (lookup form environment))
(not (numberp form))
;; the following line should probably be
;; commented out?
(not (keywordp form))
(not (stringp form))
(not (eq form t))
(not (eq form nil)))
(pushnew filename (callers-list form :file))
;; ??? :callers
(when parent
(pushnew parent (callers-list form :readers))
(when *callees-database-includes-variables*
(pushnew form (callers-list parent :callees)))))
(values t parent environment))))
(otherwise
;; Pattern Substitution
(let ((new-pattern (lookup-pattern-substitution pattern)))
(if new-pattern
(record-callers filename form new-pattern
parent environment)
(when (eq pattern form)
(values t parent environment)))))))
((consp pattern)
(case (car pattern)
(:eq (when (eq (second pattern) form)
(values t parent environment)))
(:test (when (funcall (eval (second pattern)) form)
(values t parent environment)))
(:typep (when (typep form (second pattern))
(values t parent environment)))
(:or (dolist (subpat (rest pattern))
(multiple-value-bind (processed parent environment)
(record-callers filename form subpat
parent environment)
(when processed
(return (values processed parent environment))))))
(:rest ; (:star :plus :optional :rest)
(record-callers filename form (second pattern)
parent environment))
(otherwise
(multiple-value-bind (d p env)
(record-callers* filename form pattern
parent (cons nil environment))
(values d p (if funcall environment env))))))))
(defun record-callers* (filename form pattern parent environment
&optional continuation
in-optionals in-keywords)
"RECORD-CALLERS* handles complex list-structure patterns, such as
ordered lists of subpatterns, patterns involving :star, :plus,
&optional, &key, &rest, and so on. CONTINUATION is a stack of
unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding
stacks which determine whether &rest or &key has been seen yet in
the current pattern."
;; form must be a cons or nil.
; (when form)
(if (null pattern)
(if (null continuation)
(values t parent environment)
(record-callers* filename form (car continuation) parent environment
(cdr continuation)
(cdr in-optionals)
(cdr in-keywords)))
(let ((pattern-elt (car pattern)))
(cond ((car-eq pattern-elt :optional)
(if (null form)
(values t parent environment)
(multiple-value-bind (processed par env)
(record-callers* filename form (cdr pattern-elt)
parent environment
(cons (cdr pattern) continuation)
(cons (car in-optionals) in-optionals)
(cons (car in-keywords) in-keywords))
(if processed
(values processed par env)
(record-callers* filename form (cdr pattern)
parent environment continuation
in-optionals in-keywords)))))
((car-eq pattern-elt :star)
(if (null form)
(values t parent environment)
(multiple-value-bind (processed par env)
(record-callers* filename form (cdr pattern-elt)
parent environment
(cons pattern continuation)
(cons (car in-optionals) in-optionals)
(cons (car in-keywords) in-keywords))
(if processed
(values processed par env)
(record-callers* filename form (cdr pattern)
parent environment continuation
in-optionals in-keywords)))))
((car-eq pattern-elt :plus)
(record-callers* filename form (cdr pattern-elt)
parent environment
(cons (cons (cons :star (cdr pattern-elt))
(cdr pattern))
continuation)
(cons (car in-optionals) in-optionals)
(cons (car in-keywords) in-keywords)))
((car-eq pattern-elt :rest)
(record-callers filename form pattern-elt parent environment))
((eq pattern-elt '&optional)
(record-callers* filename form (cdr pattern)
parent environment continuation
(cons t in-optionals)
(cons (car in-keywords) in-keywords)))
((eq pattern-elt '&rest)
(record-callers filename form (second pattern)
parent environment))
((eq pattern-elt '&key)
(record-callers* filename form (cdr pattern)
parent environment continuation
(cons (car in-optionals) in-optionals)
(cons t in-keywords)))
((null form)
(when (or (car in-keywords) (car in-optionals))
(values t parent environment)))
((consp form)
(multiple-value-bind (processed parent environment)
(record-callers filename (if (car in-keywords)
(cadr form)
(car form))
pattern-elt
parent environment)
(cond (processed
(record-callers* filename (if (car in-keywords)
(cddr form)
(cdr form))
(cdr pattern)
parent environment
continuation
in-optionals in-keywords))
((or (car in-keywords)
(car in-optionals))
(values t parent environment)))))))))
;;; ********************************
;;; Misc Utilities *****************
;;; ********************************
(defvar *types-to-ignore*
'(:lisp ; CLtL 1st Edition
:lisp2 ; CLtL 2nd Edition additional patterns
)
"Default set of caller types (as specified in the patterns) to ignore
in the database handling functions. :lisp is CLtL 1st edition,
:lisp2 is additional patterns from CLtL 2nd edition.")
(defun display-database (&optional (database :callers)
(types-to-ignore *types-to-ignore*))
"Prints out the name of each symbol and all its callers. Specify database
:callers (the default) to get function call references, :fill to the get
files in which the symbol is called, :readers to get variable references,
and :setters to get variable binding and assignments. Ignores functions
of types listed in types-to-ignore."
(maphash #'(lambda (name callers)
(unless (or (member (pattern-caller-type name)
types-to-ignore)
;; When we're doing fancy package crap,
;; allow us to ignore symbols based on their
;; packages.
(when *handle-package-forms*
(member (symbol-package name)
types-to-ignore
:key #'find-package)))
(format t "~&~S is referenced by~{ ~S~}."
name callers)))
(ecase database
(:file *file-callers-database*)
(:callers *callers-database*)
(:readers *readers-database*)
(:setters *setters-database*))))
(defun write-callers-database-to-file (filename)
"Saves the contents of the current callers database to a file. This
file can be loaded to restore the previous contents of the
database. (For large systems it can take a long time to crunch
through the code, so this can save some time.)"
(with-open-file (stream filename :direction :output)
(format stream "~&(clear-tables)")
(maphash #'(lambda (x y)
(format stream "~&(setf (source-file '~S) '~S)"
x y))
*source-file*)
(maphash #'(lambda (x y)
(format stream "~&(setf (callers-list '~S :file) '~S)"
x y))
*file-callers-database*)
(maphash #'(lambda (x y)
(format stream "~&(setf (callers-list '~S :callers) '~S)"
x y))
*callers-database*)
(maphash #'(lambda (x y)
(format stream "~&(setf (callers-list '~S :callees) '~S)"
x y))
*callees-database*)
(maphash #'(lambda (x y)
(format stream "~&(setf (callers-list '~S :readers) '~S)"
x y))
*readers-database*)
(maphash #'(lambda (x y)
(format stream "~&(setf (callers-list '~S :setters) '~S)"
x y))
*setters-database*)))
;;; ********************************
;;; Print Caller Trees *************
;;; ********************************
;;; The following function is useful for reversing a caller table into
;;; a callee table. Possibly later we'll extend xref to create two
;;; such database hash tables. Needs to include vars as well.
(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*))
"Makes a copy of the hash table in which (name value*) pairs
are inverted to (value name*) pairs."
(let ((target (make-hash-table :test #'equal)))
(maphash #'(lambda (key values)
(dolist (value values)
(unless (member (pattern-caller-type key)
types-to-ignore)
(pushnew key (gethash value target)))))
table)
target))
;;; Resolve file references for automatic creation of a defsystem file.
(defun determine-file-dependencies (&optional (database *callers-database*))
"Makes a hash table of file dependencies for the references listed in
DATABASE. This function may be useful for automatically resolving
file references for automatic creation of a system definition (defsystem)."
(let ((file-ref-ht (make-hash-table :test #'equal)))
(maphash #'(lambda (key values)
(let ((key-file (source-file key)))
(when key
(dolist (value values)
(let ((value-file (source-file value)))
(when value-file
(dolist (s key-file)
(dolist (d value-file)
(pushnew d (gethash s file-ref-ht))))))))))
database)
file-ref-ht))
(defun print-file-dependencies (&optional (database *callers-database*))
"Prints a list of file dependencies for the references listed in DATABASE.
This function may be useful for automatically computing file loading
constraints for a system definition tool."
(maphash #'(lambda (key value) (format t "~&~S --> ~S" key value))
(determine-file-dependencies database)))
;;; The following functions demonstrate a possible way to interface
;;; xref to a graphical browser such as psgraph to mimic the capabilities
;;; of Masterscope's graphical browser.
(defvar *last-caller-tree* nil)
(defvar *default-graphing-mode* :call-graph
"Specifies whether we graph up or down. If :call-graph, the children
of a node are the functions it calls. If :caller-graph, the children
of a node are the functions that call it.")
(defun gather-tree (parents &optional already-seen
(mode *default-graphing-mode*)
(types-to-ignore *types-to-ignore*) compact)
"Extends the tree, copying it into list structure, until it repeats
a reference (hits a cycle)."
(let ((*already-seen* nil)
(database (case mode
(:call-graph *callees-database*)
(:caller-graph *callers-database*))))
(declare (special *already-seen*))
(labels
((amass-tree
(parents &optional already-seen)
(let (result this-item)
(dolist (parent parents)
(unless (member (pattern-caller-type parent)
types-to-ignore)
(pushnew parent *already-seen*)
(if (member parent already-seen)
(setq this-item nil) ; :ignore
(if compact
(multiple-value-setq (this-item already-seen)
(amass-tree (gethash parent database)
(cons parent already-seen)))
(setq this-item
(amass-tree (gethash parent database)
(cons parent already-seen)))))
(setq parent (format nil "~S" parent))
(when (consp parent) (setq parent (cons :xref-list parent)))
(unless (eq this-item :ignore)
(push (if this-item
(list parent this-item)
parent)
result))))
(values result ;(reverse result)
already-seen))))
(values (amass-tree parents already-seen)
*already-seen*))))
(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*)
(types-to-ignore *types-to-ignore*))
"Returns a list of uncalled callers (roots) and called callers (potential
cycles)."
(let ((uncalled-callers nil)
(called-callers nil)
(database (ecase mode
(:call-graph *callers-database*)
(:caller-graph *callees-database*)))
(other-database (ecase mode
(:call-graph *callees-database*)
(:caller-graph *callers-database*))))
(maphash #'(lambda (name value)
(declare (ignore value))
(unless (member (pattern-caller-type name)
types-to-ignore)
(if (gethash name database)
(push name called-callers)
(push name uncalled-callers))))
other-database)
(values uncalled-callers called-callers)))
(defun make-caller-tree (&optional (mode *default-graphing-mode*)
(types-to-ignore *types-to-ignore*) compact)
"Outputs list structure of a tree which roughly represents the possibly
cyclical structure of the caller database.
If mode is :call-graph, the children of a node are the functions it calls.
If mode is :caller-graph, the children of a node are the functions that
call it.
If compact is T, tries to eliminate the already-seen nodes, so that
the graph for a node is printed at most once. Otherwise it will duplicate
the node's tree (except for cycles). This is usefull because the call tree
is actually a directed graph, so we can either duplicate references or
display only the first one."
;; Would be nice to print out line numbers and whenever we skip a duplicated
;; reference, print the line number of the full reference after the node.
(multiple-value-bind (uncalled-callers called-callers)
(find-roots-and-cycles mode types-to-ignore)
(multiple-value-bind (trees already-seen)
(gather-tree uncalled-callers nil mode types-to-ignore compact)
(setq *last-caller-tree* trees)
(let ((more-trees (gather-tree (set-difference called-callers
already-seen)
already-seen
mode types-to-ignore compact)))
(values trees more-trees)))))
(defvar *indent-amount* 3
"Number of spaces to indent successive levels in PRINT-INDENTED-TREE.")
(defun print-indented-tree (trees &optional (indent 0))
"Simple code to print out a list-structure tree (such as those created
by make-caller-tree) as indented text."
(when trees
(dolist (tree trees)
(cond ((and (listp tree) (eq (car tree) :xref-list))
(format t "~&~VT~A" indent (cdr tree)))
((listp tree)
(format t "~&~VT~A" indent (car tree))
(print-indented-tree (cadr tree) (+ indent *indent-amount*)))
(t
(format t "~&~VT~A" indent tree))))))
(defun print-caller-trees (&key (mode *default-graphing-mode*)
(types-to-ignore *types-to-ignore*)
compact
root-nodes)
"Prints the calling trees (which may actually be a full graph and not
necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE.
MODE is :call-graph for trees where the children of a node are the
functions called by the node, or :caller-graph for trees where the
children of a node are the functions the node calls. TYPES-TO-IGNORE
is a list of funcall types (as specified in the patterns) to ignore
in printing out the database. For example, '(:lisp) would ignore all
calls to common lisp functions. COMPACT is a flag to tell the program
to try to compact the trees a bit by not printing trees if they have
already been seen. ROOT-NODES is a list of root nodes of trees to
display. If ROOT-NODES is nil, tries to find all root nodes in the
database."
(multiple-value-bind (rooted cycles)
(if root-nodes
(values (gather-tree root-nodes nil mode types-to-ignore compact))
(make-caller-tree mode types-to-ignore compact))
(when rooted
(format t "~&Rooted calling trees:")
(print-indented-tree rooted 2))
(when cycles
(when rooted
(format t "~2%"))
(format t "~&Cyclic calling trees:")
(print-indented-tree cycles 2))))
;;; ********************************
;;; Interface to PSGraph ***********
;;; ********************************
#|
;;; Interface to Bates' PostScript Graphing Utility
(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph")
(defparameter *postscript-output-directory* "")
(defun psgraph-xref (&key (mode *default-graphing-mode*)
(output-directory *postscript-output-directory*)
(types-to-ignore *types-to-ignore*)
(compact t)
(shrink t)
root-nodes
insert)
;; If root-nodes is a non-nil list, uses that list as the starting
;; position. Otherwise tries to find all roots in the database.
(multiple-value-bind (rooted cycles)
(if root-nodes
(values (gather-tree root-nodes nil mode types-to-ignore compact))
(make-caller-tree mode types-to-ignore compact))
(psgraph-output (append rooted cycles) output-directory shrink insert)))
(defun psgraph-output (list-of-trees directory shrink &optional insert)
(let ((psgraph:*fontsize* 9)
(psgraph:*second-fontsize* 7)
; (psgraph:*boxkind* "fill")
(psgraph:*boxgray* "0") ; .8
(psgraph:*edgewidth* "1")
(psgraph:*edgegray* "0"))
(labels ((stringify (thing)
(cond ((stringp thing) (string-downcase thing))
((symbolp thing) (string-downcase (symbol-name thing)))
((and (listp thing) (eq (car thing) :xref-list))
(stringify (cdr thing)))
((listp thing) (stringify (car thing)))
(t (string thing)))))
(dolist (item list-of-trees)
(let* ((fname (stringify item))
(filename (concatenate 'string directory
(string-trim '(#\: #\|) fname)
".ps")))
(format t "~&Creating PostScript file ~S." filename)
(with-open-file (*standard-output* filename
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
;; Note that the #'eq prints the DAG as a tree. If
;; you replace it with #'equal, it will print it as
;; a DAG, which I think is slightly ugly.
(psgraph:psgraph item
#'caller-tree-children #'caller-info shrink
insert #'eq)))))))
(defun caller-tree-children (tree)
(when (and tree (listp tree) (not (eq (car tree) :xref-list)))
(cadr tree)))
(defun caller-tree-node (tree)
(when tree
(cond ((and (listp tree) (eq (car tree) :xref-list))
(cdr tree))
((listp tree)
(car tree))
(t
tree))))
(defun caller-info (tree)
(let ((node (caller-tree-node tree)))
(list node)))
|#
#|
;;; Code to print out graphical trees of CLOS class hierarchies.
(defun print-class-hierarchy (&optional (start-class 'anything)
(file "classes.ps"))
(let ((start (find-class start-class)))
(when start
(with-open-file (*standard-output* file :direction :output)
(psgraph:psgraph start
#'clos::class-direct-subclasses
#'(lambda (x)
(list (format nil "~A" (clos::class-name x))))
t nil #'eq)))))
|#
;;; ****************************************************************
;;; Cross Referencing Patterns for Common Lisp *********************
;;; ****************************************************************
(clear-patterns)
;;; ********************************
;;; Pattern Substitutions **********
;;; ********************************
(define-pattern-substitution integer (:test #'integerp))
(define-pattern-substitution rational (:test #'rationalp))
(define-pattern-substitution symbol (:test #'symbolp))
(define-pattern-substitution string (:test #'stringp))
(define-pattern-substitution number (:test #'numberp))
(define-pattern-substitution lambda-list
((:star var)
(:optional (:eq &optional)
(:star (:or var
(var (:optional form (:optional var))))))
(:optional (:eq &rest) var)
(:optional (:eq &key) (:star (:or var
((:or var
(keyword var))
(:optional form (:optional var)))))
(:optional &allow-other-keys))
(:optional (:eq &aux)
(:star (:or var
(var (:optional form)))))))
(define-pattern-substitution test form)
(define-pattern-substitution body
((:star (:or declaration documentation-string))
(:star form)))
(define-pattern-substitution documentation-string string)
(define-pattern-substitution initial-value form)
(define-pattern-substitution tag symbol)
(define-pattern-substitution declaration ((:eq declare)(:rest :ignore)))
(define-pattern-substitution destination form)
(define-pattern-substitution control-string string)
(define-pattern-substitution format-arguments
((:star form)))
(define-pattern-substitution fn
(:or ((:eq quote) function)
((:eq function) function)
function))
;;; ********************************
;;; Caller Patterns ****************
;;; ********************************
;;; Types Related
(define-caller-pattern coerce (form :ignore) :lisp)
(define-caller-pattern type-of (form) :lisp)
(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2)
(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2)
;;; Lambdas and Definitions
(define-variable-pattern lambda-list-keywords :lisp)
(define-variable-pattern lambda-parameters-limit :lisp)
(define-caller-pattern lambda (lambda-list (:rest body)) :lisp)
(define-caller-pattern defun
(name lambda-list
(:star (:or documentation-string declaration))
(:star form))
:lisp)
;;; perhaps this should use VAR, instead of NAME
(define-caller-pattern defvar
(var (:optional initial-value (:optional documentation-string)))
:lisp)
(define-caller-pattern defparameter
(var initial-value (:optional documentation-string))
:lisp)
(define-caller-pattern defconstant
(var initial-value (:optional documentation-string))
:lisp)
(define-caller-pattern eval-when
(:ignore ; the situations
(:star form))
:lisp)
;;; Logical Values
(define-variable-pattern nil :lisp)
(define-variable-pattern t :lisp)
;;; Predicates
(define-caller-pattern typep (form form) :lisp)
(define-caller-pattern subtypep (form form) :lisp)
(define-caller-pattern null (form) :lisp)
(define-caller-pattern symbolp (form) :lisp)
(define-caller-pattern atom (form) :lisp)
(define-caller-pattern consp (form) :lisp)
(define-caller-pattern listp (form) :lisp)
(define-caller-pattern numberp (form) :lisp)
(define-caller-pattern integerp (form) :lisp)
(define-caller-pattern rationalp (form) :lisp)
(define-caller-pattern floatp (form) :lisp)
(define-caller-pattern realp (form) :lisp2)
(define-caller-pattern complexp (form) :lisp)
(define-caller-pattern characterp (form) :lisp)
(define-caller-pattern stringp (form) :lisp)
(define-caller-pattern bit-vector-p (form) :lisp)
(define-caller-pattern vectorp (form) :lisp)
(define-caller-pattern simple-vector-p (form) :lisp)
(define-caller-pattern simple-string-p (form) :lisp)
(define-caller-pattern simple-bit-vector-p (form) :lisp)
(define-caller-pattern arrayp (form) :lisp)
(define-caller-pattern packagep (form) :lisp)
(define-caller-pattern functionp (form) :lisp)
(define-caller-pattern compiled-function-p (form) :lisp)
(define-caller-pattern commonp (form) :lisp)
;;; Equality Predicates
(define-caller-pattern eq (form form) :lisp)
(define-caller-pattern eql (form form) :lisp)
(define-caller-pattern equal (form form) :lisp)
(define-caller-pattern equalp (form form) :lisp)
;;; Logical Operators
(define-caller-pattern not (form) :lisp)
(define-caller-pattern or ((:star form)) :lisp)
(define-caller-pattern and ((:star form)) :lisp)
;;; Reference
;;; Quote is a problem. In Defmacro & friends, we'd like to actually
;;; look at the argument, 'cause it hides internal function calls
;;; of the defmacro.
(define-caller-pattern quote (:ignore) :lisp)
(define-caller-pattern function ((:or fn form)) :lisp)
(define-caller-pattern symbol-value (form) :lisp)
(define-caller-pattern symbol-function (form) :lisp)
(define-caller-pattern fdefinition (form) :lisp2)
(define-caller-pattern boundp (form) :lisp)
(define-caller-pattern fboundp (form) :lisp)
(define-caller-pattern special-form-p (form) :lisp)
;;; Assignment
(define-caller-pattern setq ((:star var form)) :lisp)
(define-caller-pattern psetq ((:star var form)) :lisp)
(define-caller-pattern set (form form) :lisp)
(define-caller-pattern makunbound (form) :lisp)
(define-caller-pattern fmakunbound (form) :lisp)
;;; Generalized Variables
(define-caller-pattern setf ((:star form form)) :lisp)
(define-caller-pattern psetf ((:star form form)) :lisp)
(define-caller-pattern shiftf ((:plus form) form) :lisp)
(define-caller-pattern rotatef ((:star form)) :lisp)
(define-caller-pattern define-modify-macro
(name
lambda-list
fn
(:optional documentation-string))
:lisp)
(define-caller-pattern defsetf
(:or (name name (:optional documentation-string))
(name lambda-list (var)
(:star (:or declaration documentation-string))
(:star form)))
:lisp)
(define-caller-pattern define-setf-method
(name lambda-list
(:star (:or declaration documentation-string))
(:star form))
:lisp)
(define-caller-pattern get-setf-method (form) :lisp)
(define-caller-pattern get-setf-method-multiple-value (form) :lisp)
;;; Function invocation
(define-caller-pattern apply (fn form (:star form)) :lisp)
(define-caller-pattern funcall (fn (:star form)) :lisp)
;;; Simple sequencing
(define-caller-pattern progn ((:star form)) :lisp)
(define-caller-pattern prog1 (form (:star form)) :lisp)
(define-caller-pattern prog2 (form form (:star form)) :lisp)
;;; Variable bindings
(define-caller-pattern let
(((:star (:or var (var &optional form))))
(:star declaration)
(:star form))
:lisp)
(define-caller-pattern let*
(((:star (:or var (var &optional form))))
(:star declaration)
(:star form))
:lisp)
(define-caller-pattern compiler-let
(((:star (:or var (var form))))
(:star form))
:lisp)
(define-caller-pattern progv
(form form (:star form)) :lisp)
(define-caller-pattern flet
(((:star (name lambda-list
(:star (:or declaration
documentation-string))
(:star form))))
(:star form))
:lisp)
(define-caller-pattern labels
(((:star (name lambda-list
(:star (:or declaration
documentation-string))
(:star form))))
(:star form))
:lisp)
(define-caller-pattern macrolet
(((:star (name lambda-list
(:star (:or declaration
documentation-string))
(:star form))))
(:star form))
:lisp)
(define-caller-pattern symbol-macrolet
(((:star (var form))) (:star declaration) (:star form))
:lisp2)
;;; Conditionals
(define-caller-pattern if (test form (:optional form)) :lisp)
(define-caller-pattern when (test (:star form)) :lisp)
(define-caller-pattern unless (test (:star form)) :lisp)
(define-caller-pattern cond ((:star (test (:star form)))) :lisp)
(define-caller-pattern case
(form
(:star ((:or symbol
((:star symbol)))
(:star form))))
:lisp)
(define-caller-pattern typecase (form (:star (symbol (:star form))))
:lisp)
;;; Blocks and Exits
(define-caller-pattern block (name (:star form)) :lisp)
(define-caller-pattern return-from (function (:optional form)) :lisp)
(define-caller-pattern return ((:optional form)) :lisp)
;;; Iteration
(define-caller-pattern loop ((:star form)) :lisp)
(define-caller-pattern do
(((:star (:or var
(var (:optional form (:optional form)))))) ; init step
(form (:star form)) ; end-test result
(:star declaration)
(:star (:or tag form))) ; statement
:lisp)
(define-caller-pattern do*
(((:star (:or var
(var (:optional form (:optional form))))))
(form (:star form))
(:star declaration)
(:star (:or tag form)))
:lisp)
(define-caller-pattern dolist
((var form (:optional form))
(:star declaration)
(:star (:or tag form)))
:lisp)
(define-caller-pattern dotimes
((var form (:optional form))
(:star declaration)
(:star (:or tag form)))
:lisp)
;;; Mapping
(define-caller-pattern mapcar (fn form (:star form)) :lisp)
(define-caller-pattern maplist (fn form (:star form)) :lisp)
(define-caller-pattern mapc (fn form (:star form)) :lisp)
(define-caller-pattern mapl (fn form (:star form)) :lisp)
(define-caller-pattern mapcan (fn form (:star form)) :lisp)
(define-caller-pattern mapcon (fn form (:star form)) :lisp)
;;; The "Program Feature"
(define-caller-pattern tagbody ((:star (:or tag form))) :lisp)
(define-caller-pattern prog
(((:star (:or var (var (:optional form)))))
(:star declaration)
(:star (:or tag form)))
:lisp)
(define-caller-pattern prog*
(((:star (:or var (var (:optional form)))))
(:star declaration)
(:star (:or tag form)))
:lisp)
(define-caller-pattern go (tag) :lisp)
;;; Multiple Values
(define-caller-pattern values ((:star form)) :lisp)
(define-variable-pattern multiple-values-limit :lisp)
(define-caller-pattern values-list (form) :lisp)
(define-caller-pattern multiple-value-list (form) :lisp)
(define-caller-pattern multiple-value-call (fn (:star form)) :lisp)
(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp)
(define-caller-pattern multiple-value-bind
(((:star var)) form
(:star declaration)
(:star form))
:lisp)
(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp)
(define-caller-pattern nth-value (form form) :lisp2)
;;; Dynamic Non-Local Exits
(define-caller-pattern catch (tag (:star form)) :lisp)
(define-caller-pattern throw (tag form) :lisp)
(define-caller-pattern unwind-protect (form (:star form)) :lisp)
;;; Macros
(define-caller-pattern macro-function (form) :lisp)
(define-caller-pattern defmacro
(name
lambda-list
(:star (:or declaration documentation-string))
(:star form))
:lisp)
(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp)
(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp)
(define-variable-pattern *macroexpand-hook* :lisp)
;;; Destructuring
(define-caller-pattern destructuring-bind
(lambda-list form
(:star declaration)
(:star form))
:lisp2)
;;; Compiler Macros
(define-caller-pattern define-compiler-macro
(name lambda-list
(:star (:or declaration documentation-string))
(:star form))
:lisp2)
(define-caller-pattern compiler-macro-function (form) :lisp2)
(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2)
(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore))
:lisp2)
;;; Environments
(define-caller-pattern variable-information (form &optional :ignore)
:lisp2)
(define-caller-pattern function-information (fn &optional :ignore) :lisp2)
(define-caller-pattern declaration-information (form &optional :ignore) :lisp2)
(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2)
(define-caller-pattern define-declaration
(name
lambda-list
(:star form))
:lisp2)
(define-caller-pattern parse-macro (name lambda-list form) :lisp2)
(define-caller-pattern enclose (form &optional :ignore) :lisp2)
;;; Declarations
(define-caller-pattern declare ((:rest :ignore)) :lisp)
(define-caller-pattern proclaim ((:rest :ignore)) :lisp)
(define-caller-pattern locally ((:star declaration) (:star form)) :lisp)
(define-caller-pattern declaim ((:rest :ignore)) :lisp2)
(define-caller-pattern the (form form) :lisp)
;;; Symbols
(define-caller-pattern get (form form (:optional form)) :lisp)
(define-caller-pattern remprop (form form) :lisp)
(define-caller-pattern symbol-plist (form) :lisp)
(define-caller-pattern getf (form form (:optional form)) :lisp)
(define-caller-pattern remf (form form) :lisp)
(define-caller-pattern get-properties (form form) :lisp)
(define-caller-pattern symbol-name (form) :lisp)
(define-caller-pattern make-symbol (form) :lisp)
(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp)
(define-caller-pattern gensym ((:optional :ignore)) :lisp)
(define-variable-pattern *gensym-counter* :lisp2)
(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp)
(define-caller-pattern symbol-package (form) :lisp)
(define-caller-pattern keywordp (form) :lisp)
;;; Packages
(define-variable-pattern *package* :lisp)
(define-caller-pattern make-package ((:rest :ignore)) :lisp)
(define-caller-pattern in-package ((:rest :ignore)) :lisp)
(define-caller-pattern find-package ((:rest :ignore)) :lisp)
(define-caller-pattern package-name ((:rest :ignore)) :lisp)
(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp)
(define-caller-pattern rename-package ((:rest :ignore)) :lisp)
(define-caller-pattern package-use-list ((:rest :ignore)) :lisp)
(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp)
(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp)
(define-caller-pattern list-all-packages () :lisp)
(define-caller-pattern delete-package ((:rest :ignore)) :lisp2)
(define-caller-pattern intern (form &optional :ignore) :lisp)
(define-caller-pattern find-symbol (form &optional :ignore) :lisp)
(define-caller-pattern unintern (form &optional :ignore) :lisp)
(define-caller-pattern export ((:or symbol ((:star symbol)))
&optional :ignore) :lisp)
(define-caller-pattern unexport ((:or symbol ((:star symbol)))
&optional :ignore) :lisp)
(define-caller-pattern import ((:or symbol ((:star symbol)))
&optional :ignore) :lisp)
(define-caller-pattern shadowing-import ((:or symbol ((:star symbol)))
&optional :ignore) :lisp)
(define-caller-pattern shadow ((:or symbol ((:star symbol)))
&optional :ignore) :lisp)
(define-caller-pattern use-package ((:rest :ignore)) :lisp)
(define-caller-pattern unuse-package ((:rest :ignore)) :lisp)
(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2)
(define-caller-pattern find-all-symbols (form) :lisp)
(define-caller-pattern do-symbols
((var (:optional form (:optional form)))
(:star declaration)
(:star (:or tag form)))
:lisp)
(define-caller-pattern do-external-symbols
((var (:optional form (:optional form)))
(:star declaration)
(:star (:or tag form)))
:lisp)
(define-caller-pattern do-all-symbols
((var (:optional form))
(:star declaration)
(:star (:or tag form)))
:lisp)
(define-caller-pattern with-package-iterator
((name form (:plus :ignore))
(:star form))
:lisp2)
;;; Modules
(define-variable-pattern *modules* :lisp)
(define-caller-pattern provide (form) :lisp)
(define-caller-pattern require (form &optional :ignore) :lisp)
;;; Numbers
(define-caller-pattern zerop (form) :lisp)
(define-caller-pattern plusp (form) :lisp)
(define-caller-pattern minusp (form) :lisp)
(define-caller-pattern oddp (form) :lisp)
(define-caller-pattern evenp (form) :lisp)
(define-caller-pattern = (form (:star form)) :lisp)
(define-caller-pattern /= (form (:star form)) :lisp)
(define-caller-pattern > (form (:star form)) :lisp)
(define-caller-pattern < (form (:star form)) :lisp)
(define-caller-pattern <= (form (:star form)) :lisp)
(define-caller-pattern >= (form (:star form)) :lisp)
(define-caller-pattern max (form (:star form)) :lisp)
(define-caller-pattern min (form (:star form)) :lisp)
(define-caller-pattern - (form (:star form)) :lisp)
(define-caller-pattern + (form (:star form)) :lisp)
(define-caller-pattern * (form (:star form)) :lisp)
(define-caller-pattern / (form (:star form)) :lisp)
(define-caller-pattern 1+ (form) :lisp)
(define-caller-pattern 1- (form) :lisp)
(define-caller-pattern incf (form form) :lisp)
(define-caller-pattern decf (form form) :lisp)
(define-caller-pattern conjugate (form) :lisp)
(define-caller-pattern gcd ((:star form)) :lisp)
(define-caller-pattern lcm ((:star form)) :lisp)
(define-caller-pattern exp (form) :lisp)
(define-caller-pattern expt (form form) :lisp)
(define-caller-pattern log (form (:optional form)) :lisp)
(define-caller-pattern sqrt (form) :lisp)
(define-caller-pattern isqrt (form) :lisp)
(define-caller-pattern abs (form) :lisp)
(define-caller-pattern phase (form) :lisp)
(define-caller-pattern signum (form) :lisp)
(define-caller-pattern sin (form) :lisp)
(define-caller-pattern cos (form) :lisp)
(define-caller-pattern tan (form) :lisp)
(define-caller-pattern cis (form) :lisp)
(define-caller-pattern asin (form) :lisp)
(define-caller-pattern acos (form) :lisp)
(define-caller-pattern atan (form &optional form) :lisp)
(define-variable-pattern pi :lisp)
(define-caller-pattern sinh (form) :lisp)
(define-caller-pattern cosh (form) :lisp)
(define-caller-pattern tanh (form) :lisp)
(define-caller-pattern asinh (form) :lisp)
(define-caller-pattern acosh (form) :lisp)
(define-caller-pattern atanh (form) :lisp)
;;; Type Conversions and Extractions
(define-caller-pattern float (form (:optional form)) :lisp)
(define-caller-pattern rational (form) :lisp)
(define-caller-pattern rationalize (form) :lisp)
(define-caller-pattern numerator (form) :lisp)
(define-caller-pattern denominator (form) :lisp)
(define-caller-pattern floor (form (:optional form)) :lisp)
(define-caller-pattern ceiling (form (:optional form)) :lisp)
(define-caller-pattern truncate (form (:optional form)) :lisp)
(define-caller-pattern round (form (:optional form)) :lisp)
(define-caller-pattern mod (form form) :lisp)
(define-caller-pattern rem (form form) :lisp)
(define-caller-pattern ffloor (form (:optional form)) :lisp)
(define-caller-pattern fceiling (form (:optional form)) :lisp)
(define-caller-pattern ftruncate (form (:optional form)) :lisp)
(define-caller-pattern fround (form (:optional form)) :lisp)
(define-caller-pattern decode-float (form) :lisp)
(define-caller-pattern scale-float (form form) :lisp)
(define-caller-pattern float-radix (form) :lisp)
(define-caller-pattern float-sign (form (:optional form)) :lisp)
(define-caller-pattern float-digits (form) :lisp)
(define-caller-pattern float-precision (form) :lisp)
(define-caller-pattern integer-decode-float (form) :lisp)
(define-caller-pattern complex (form (:optional form)) :lisp)
(define-caller-pattern realpart (form) :lisp)
(define-caller-pattern imagpart (form) :lisp)
(define-caller-pattern logior ((:star form)) :lisp)
(define-caller-pattern logxor ((:star form)) :lisp)
(define-caller-pattern logand ((:star form)) :lisp)
(define-caller-pattern logeqv ((:star form)) :lisp)
(define-caller-pattern lognand (form form) :lisp)
(define-caller-pattern lognor (form form) :lisp)
(define-caller-pattern logandc1 (form form) :lisp)
(define-caller-pattern logandc2 (form form) :lisp)
(define-caller-pattern logorc1 (form form) :lisp)
(define-caller-pattern logorc2 (form form) :lisp)
(define-caller-pattern boole (form form form) :lisp)
(define-variable-pattern boole-clr :lisp)
(define-variable-pattern boole-set :lisp)
(define-variable-pattern boole-1 :lisp)
(define-variable-pattern boole-2 :lisp)
(define-variable-pattern boole-c1 :lisp)
(define-variable-pattern boole-c2 :lisp)
(define-variable-pattern boole-and :lisp)
(define-variable-pattern boole-ior :lisp)
(define-variable-pattern boole-xor :lisp)
(define-variable-pattern boole-eqv :lisp)
(define-variable-pattern boole-nand :lisp)
(define-variable-pattern boole-nor :lisp)
(define-variable-pattern boole-andc1 :lisp)
(define-variable-pattern boole-andc2 :lisp)
(define-variable-pattern boole-orc1 :lisp)
(define-variable-pattern boole-orc2 :lisp)
(define-caller-pattern lognot (form) :lisp)
(define-caller-pattern logtest (form form) :lisp)
(define-caller-pattern logbitp (form form) :lisp)
(define-caller-pattern ash (form form) :lisp)
(define-caller-pattern logcount (form) :lisp)
(define-caller-pattern integer-length (form) :lisp)
(define-caller-pattern byte (form form) :lisp)
(define-caller-pattern byte-size (form) :lisp)
(define-caller-pattern byte-position (form) :lisp)
(define-caller-pattern ldb (form form) :lisp)
(define-caller-pattern ldb-test (form form) :lisp)
(define-caller-pattern mask-field (form form) :lisp)
(define-caller-pattern dpb (form form form) :lisp)
(define-caller-pattern deposit-field (form form form) :lisp)
;;; Random Numbers
(define-caller-pattern random (form (:optional form)) :lisp)
(define-variable-pattern *random-state* :lisp)
(define-caller-pattern make-random-state ((:optional form)) :lisp)
(define-caller-pattern random-state-p (form) :lisp)
;;; Implementation Parameters
(define-variable-pattern most-positive-fixnum :lisp)
(define-variable-pattern most-negative-fixnum :lisp)
(define-variable-pattern most-positive-short-float :lisp)
(define-variable-pattern least-positive-short-float :lisp)
(define-variable-pattern least-negative-short-float :lisp)
(define-variable-pattern most-negative-short-float :lisp)
(define-variable-pattern most-positive-single-float :lisp)
(define-variable-pattern least-positive-single-float :lisp)
(define-variable-pattern least-negative-single-float :lisp)
(define-variable-pattern most-negative-single-float :lisp)
(define-variable-pattern most-positive-double-float :lisp)
(define-variable-pattern least-positive-double-float :lisp)
(define-variable-pattern least-negative-double-float :lisp)
(define-variable-pattern most-negative-double-float :lisp)
(define-variable-pattern most-positive-long-float :lisp)
(define-variable-pattern least-positive-long-float :lisp)
(define-variable-pattern least-negative-long-float :lisp)
(define-variable-pattern most-negative-long-float :lisp)
(define-variable-pattern least-positive-normalized-short-float :lisp2)
(define-variable-pattern least-negative-normalized-short-float :lisp2)
(define-variable-pattern least-positive-normalized-single-float :lisp2)
(define-variable-pattern least-negative-normalized-single-float :lisp2)
(define-variable-pattern least-positive-normalized-double-float :lisp2)
(define-variable-pattern least-negative-normalized-double-float :lisp2)
(define-variable-pattern least-positive-normalized-long-float :lisp2)
(define-variable-pattern least-negative-normalized-long-float :lisp2)
(define-variable-pattern short-float-epsilon :lisp)
(define-variable-pattern single-float-epsilon :lisp)
(define-variable-pattern double-float-epsilon :lisp)
(define-variable-pattern long-float-epsilon :lisp)
(define-variable-pattern short-float-negative-epsilon :lisp)
(define-variable-pattern single-float-negative-epsilon :lisp)
(define-variable-pattern double-float-negative-epsilon :lisp)
(define-variable-pattern long-float-negative-epsilon :lisp)
;;; Characters
(define-variable-pattern char-code-limit :lisp)
(define-variable-pattern char-font-limit :lisp)
(define-variable-pattern char-bits-limit :lisp)
(define-caller-pattern standard-char-p (form) :lisp)
(define-caller-pattern graphic-char-p (form) :lisp)
(define-caller-pattern string-char-p (form) :lisp)
(define-caller-pattern alpha-char-p (form) :lisp)
(define-caller-pattern upper-case-p (form) :lisp)
(define-caller-pattern lower-case-p (form) :lisp)
(define-caller-pattern both-case-p (form) :lisp)
(define-caller-pattern digit-char-p (form (:optional form)) :lisp)
(define-caller-pattern alphanumericp (form) :lisp)
(define-caller-pattern char= ((:star form)) :lisp)
(define-caller-pattern char/= ((:star form)) :lisp)
(define-caller-pattern char< ((:star form)) :lisp)
(define-caller-pattern char> ((:star form)) :lisp)
(define-caller-pattern char<= ((:star form)) :lisp)
(define-caller-pattern char>= ((:star form)) :lisp)
(define-caller-pattern char-equal ((:star form)) :lisp)
(define-caller-pattern char-not-equal ((:star form)) :lisp)
(define-caller-pattern char-lessp ((:star form)) :lisp)
(define-caller-pattern char-greaterp ((:star form)) :lisp)
(define-caller-pattern char-not-greaterp ((:star form)) :lisp)
(define-caller-pattern char-not-lessp ((:star form)) :lisp)
(define-caller-pattern char-code (form) :lisp)
(define-caller-pattern char-bits (form) :lisp)
(define-caller-pattern char-font (form) :lisp)
(define-caller-pattern code-char (form (:optional form form)) :lisp)
(define-caller-pattern make-char (form (:optional form form)) :lisp)
(define-caller-pattern characterp (form) :lisp)
(define-caller-pattern char-upcase (form) :lisp)
(define-caller-pattern char-downcase (form) :lisp)
(define-caller-pattern digit-char (form (:optional form form)) :lisp)
(define-caller-pattern char-int (form) :lisp)
(define-caller-pattern int-char (form) :lisp)
(define-caller-pattern char-name (form) :lisp)
(define-caller-pattern name-char (form) :lisp)
(define-variable-pattern char-control-bit :lisp)
(define-variable-pattern char-meta-bit :lisp)
(define-variable-pattern char-super-bit :lisp)
(define-variable-pattern char-hyper-bit :lisp)
(define-caller-pattern char-bit (form form) :lisp)
(define-caller-pattern set-char-bit (form form form) :lisp)
;;; Sequences
(define-caller-pattern complement (fn) :lisp2)
(define-caller-pattern elt (form form) :lisp)
(define-caller-pattern subseq (form form &optional form) :lisp)
(define-caller-pattern copy-seq (form) :lisp)
(define-caller-pattern length (form) :lisp)
(define-caller-pattern reverse (form) :lisp)
(define-caller-pattern nreverse (form) :lisp)
(define-caller-pattern make-sequence (form form &key form) :lisp)
(define-caller-pattern concatenate (form (:star form)) :lisp)
(define-caller-pattern map (form fn form (:star form)) :lisp)
(define-caller-pattern map-into (form fn (:star form)) :lisp2)
(define-caller-pattern some (fn form (:star form)) :lisp)
(define-caller-pattern every (fn form (:star form)) :lisp)
(define-caller-pattern notany (fn form (:star form)) :lisp)
(define-caller-pattern notevery (fn form (:star form)) :lisp)
(define-caller-pattern reduce (fn form &key (:star form)) :lisp)
(define-caller-pattern fill (form form &key (:star form)) :lisp)
(define-caller-pattern replace (form form &key (:star form)) :lisp)
(define-caller-pattern remove (form form &key (:star form)) :lisp)
(define-caller-pattern remove-if (fn form &key (:star form)) :lisp)
(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern delete (form form &key (:star form)) :lisp)
(define-caller-pattern delete-if (fn form &key (:star form)) :lisp)
(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp)
(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp)
(define-caller-pattern substitute (form form form &key (:star form)) :lisp)
(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern substitute-if-not (form fn form &key (:star form))
:lisp)
(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp)
(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form))
:lisp)
(define-caller-pattern find (form form &key (:star form)) :lisp)
(define-caller-pattern find-if (fn form &key (:star form)) :lisp)
(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern position (form form &key (:star form)) :lisp)
(define-caller-pattern position-if (fn form &key (:star form)) :lisp)
(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern count (form form &key (:star form)) :lisp)
(define-caller-pattern count-if (fn form &key (:star form)) :lisp)
(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern mismatch (form form &key (:star form)) :lisp)
(define-caller-pattern search (form form &key (:star form)) :lisp)
(define-caller-pattern sort (form fn &key (:star form)) :lisp)
(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp)
(define-caller-pattern merge (form form form fn &key (:star form)) :lisp)
;;; Lists
(define-caller-pattern car (form) :lisp)
(define-caller-pattern cdr (form) :lisp)
(define-caller-pattern caar (form) :lisp)
(define-caller-pattern cadr (form) :lisp)
(define-caller-pattern cdar (form) :lisp)
(define-caller-pattern cddr (form) :lisp)
(define-caller-pattern caaar (form) :lisp)
(define-caller-pattern caadr (form) :lisp)
(define-caller-pattern cadar (form) :lisp)
(define-caller-pattern caddr (form) :lisp)
(define-caller-pattern cdaar (form) :lisp)
(define-caller-pattern cdadr (form) :lisp)
(define-caller-pattern cddar (form) :lisp)
(define-caller-pattern cdddr (form) :lisp)
(define-caller-pattern caaaar (form) :lisp)
(define-caller-pattern caaadr (form) :lisp)
(define-caller-pattern caadar (form) :lisp)
(define-caller-pattern caaddr (form) :lisp)
(define-caller-pattern cadaar (form) :lisp)
(define-caller-pattern cadadr (form) :lisp)
(define-caller-pattern caddar (form) :lisp)
(define-caller-pattern cadddr (form) :lisp)
(define-caller-pattern cdaaar (form) :lisp)
(define-caller-pattern cdaadr (form) :lisp)
(define-caller-pattern cdadar (form) :lisp)
(define-caller-pattern cdaddr (form) :lisp)
(define-caller-pattern cddaar (form) :lisp)
(define-caller-pattern cddadr (form) :lisp)
(define-caller-pattern cdddar (form) :lisp)
(define-caller-pattern cddddr (form) :lisp)
(define-caller-pattern cons (form form) :lisp)
(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp)
(define-caller-pattern endp (form) :lisp)
(define-caller-pattern list-length (form) :lisp)
(define-caller-pattern nth (form form) :lisp)
(define-caller-pattern first (form) :lisp)
(define-caller-pattern second (form) :lisp)
(define-caller-pattern third (form) :lisp)
(define-caller-pattern fourth (form) :lisp)
(define-caller-pattern fifth (form) :lisp)
(define-caller-pattern sixth (form) :lisp)
(define-caller-pattern seventh (form) :lisp)
(define-caller-pattern eighth (form) :lisp)
(define-caller-pattern ninth (form) :lisp)
(define-caller-pattern tenth (form) :lisp)
(define-caller-pattern rest (form) :lisp)
(define-caller-pattern nthcdr (form form) :lisp)
(define-caller-pattern last (form (:optional form)) :lisp)
(define-caller-pattern list ((:star form)) :lisp)
(define-caller-pattern list* ((:star form)) :lisp)
(define-caller-pattern make-list (form &key (:star form)) :lisp)
(define-caller-pattern append ((:star form)) :lisp)
(define-caller-pattern copy-list (form) :lisp)
(define-caller-pattern copy-alist (form) :lisp)
(define-caller-pattern copy-tree (form) :lisp)
(define-caller-pattern revappend (form form) :lisp)
(define-caller-pattern nconc ((:star form)) :lisp)
(define-caller-pattern nreconc (form form) :lisp)
(define-caller-pattern push (form form) :lisp)
(define-caller-pattern pushnew (form form &key (:star form)) :lisp)
(define-caller-pattern pop (form) :lisp)
(define-caller-pattern butlast (form (:optional form)) :lisp)
(define-caller-pattern nbutlast (form (:optional form)) :lisp)
(define-caller-pattern ldiff (form form) :lisp)
(define-caller-pattern rplaca (form form) :lisp)
(define-caller-pattern rplacd (form form) :lisp)
(define-caller-pattern subst (form form form &key (:star form)) :lisp)
(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubst (form form form &key (:star form)) :lisp)
(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern sublis (form form &key (:star form)) :lisp)
(define-caller-pattern nsublis (form form &key (:star form)) :lisp)
(define-caller-pattern member (form form &key (:star form)) :lisp)
(define-caller-pattern member-if (fn form &key (:star form)) :lisp)
(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern tailp (form form) :lisp)
(define-caller-pattern adjoin (form form &key (:star form)) :lisp)
(define-caller-pattern union (form form &key (:star form)) :lisp)
(define-caller-pattern nunion (form form &key (:star form)) :lisp)
(define-caller-pattern intersection (form form &key (:star form)) :lisp)
(define-caller-pattern nintersection (form form &key (:star form)) :lisp)
(define-caller-pattern set-difference (form form &key (:star form)) :lisp)
(define-caller-pattern nset-difference (form form &key (:star form)) :lisp)
(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp)
(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp)
(define-caller-pattern subsetp (form form &key (:star form)) :lisp)
(define-caller-pattern acons (form form form) :lisp)
(define-caller-pattern pairlis (form form (:optional form)) :lisp)
(define-caller-pattern assoc (form form &key (:star form)) :lisp)
(define-caller-pattern assoc-if (fn form) :lisp)
(define-caller-pattern assoc-if-not (fn form) :lisp)
(define-caller-pattern rassoc (form form &key (:star form)) :lisp)
(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp)
(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp)
;;; Hash Tables
(define-caller-pattern make-hash-table (&key (:star form)) :lisp)
(define-caller-pattern hash-table-p (form) :lisp)
(define-caller-pattern gethash (form form (:optional form)) :lisp)
(define-caller-pattern remhash (form form) :lisp)
(define-caller-pattern maphash (fn form) :lisp)
(define-caller-pattern clrhash (form) :lisp)
(define-caller-pattern hash-table-count (form) :lisp)
(define-caller-pattern with-hash-table-iterator
((name form) (:star form)) :lisp2)
(define-caller-pattern hash-table-rehash-size (form) :lisp2)
(define-caller-pattern hash-table-rehash-threshold (form) :lisp2)
(define-caller-pattern hash-table-size (form) :lisp2)
(define-caller-pattern hash-table-test (form) :lisp2)
(define-caller-pattern sxhash (form) :lisp)
;;; Arrays
(define-caller-pattern make-array (form &key (:star form)) :lisp)
(define-variable-pattern array-rank-limit :lisp)
(define-variable-pattern array-dimension-limit :lisp)
(define-variable-pattern array-total-size-limit :lisp)
(define-caller-pattern vector ((:star form)) :lisp)
(define-caller-pattern aref (form (:star form)) :lisp)
(define-caller-pattern svref (form form) :lisp)
(define-caller-pattern array-element-type (form) :lisp)
(define-caller-pattern array-rank (form) :lisp)
(define-caller-pattern array-dimension (form form) :lisp)
(define-caller-pattern array-dimensions (form) :lisp)
(define-caller-pattern array-total-size (form) :lisp)
(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp)
(define-caller-pattern array-row-major-index (form (:star form)) :lisp)
(define-caller-pattern row-major-aref (form form) :lisp2)
(define-caller-pattern adjustable-array-p (form) :lisp)
(define-caller-pattern bit (form (:star form)) :lisp)
(define-caller-pattern sbit (form (:star form)) :lisp)
(define-caller-pattern bit-and (form form (:optional form)) :lisp)
(define-caller-pattern bit-ior (form form (:optional form)) :lisp)
(define-caller-pattern bit-xor (form form (:optional form)) :lisp)
(define-caller-pattern bit-eqv (form form (:optional form)) :lisp)
(define-caller-pattern bit-nand (form form (:optional form)) :lisp)
(define-caller-pattern bit-nor (form form (:optional form)) :lisp)
(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp)
(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp)
(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp)
(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp)
(define-caller-pattern bit-not (form (:optional form)) :lisp)
(define-caller-pattern array-has-fill-pointer-p (form) :lisp)
(define-caller-pattern fill-pointer (form) :lisp)
(define-caller-pattern vector-push (form form) :lisp)
(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp)
(define-caller-pattern vector-pop (form) :lisp)
(define-caller-pattern adjust-array (form form &key (:star form)) :lisp)
;;; Strings
(define-caller-pattern char (form form) :lisp)
(define-caller-pattern schar (form form) :lisp)
(define-caller-pattern string= (form form &key (:star form)) :lisp)
(define-caller-pattern string-equal (form form &key (:star form)) :lisp)
(define-caller-pattern string< (form form &key (:star form)) :lisp)
(define-caller-pattern string> (form form &key (:star form)) :lisp)
(define-caller-pattern string<= (form form &key (:star form)) :lisp)
(define-caller-pattern string>= (form form &key (:star form)) :lisp)
(define-caller-pattern string/= (form form &key (:star form)) :lisp)
(define-caller-pattern string-lessp (form form &key (:star form)) :lisp)
(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp)
(define-caller-pattern make-string (form &key (:star form)) :lisp)
(define-caller-pattern string-trim (form form) :lisp)
(define-caller-pattern string-left-trim (form form) :lisp)
(define-caller-pattern string-right-trim (form form) :lisp)
(define-caller-pattern string-upcase (form &key (:star form)) :lisp)
(define-caller-pattern string-downcase (form &key (:star form)) :lisp)
(define-caller-pattern string-capitalize (form &key (:star form)) :lisp)
(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp)
(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp)
(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp)
(define-caller-pattern string (form) :lisp)
;;; Structures
(define-caller-pattern defstruct
((:or name (name (:rest :ignore)))
(:optional documentation-string)
(:plus :ignore))
:lisp)
;;; The Evaluator
(define-caller-pattern eval (form) :lisp)
(define-variable-pattern *evalhook* :lisp)
(define-variable-pattern *applyhook* :lisp)
(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp)
(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp)
(define-caller-pattern constantp (form) :lisp)
;;; Streams
(define-variable-pattern *standard-input* :lisp)
(define-variable-pattern *standard-output* :lisp)
(define-variable-pattern *error-output* :lisp)
(define-variable-pattern *query-io* :lisp)
(define-variable-pattern *debug-io* :lisp)
(define-variable-pattern *terminal-io* :lisp)
(define-variable-pattern *trace-output* :lisp)
(define-caller-pattern make-synonym-stream (symbol) :lisp)
(define-caller-pattern make-broadcast-stream ((:star form)) :lisp)
(define-caller-pattern make-concatenated-stream ((:star form)) :lisp)
(define-caller-pattern make-two-way-stream (form form) :lisp)
(define-caller-pattern make-echo-stream (form form) :lisp)
(define-caller-pattern make-string-input-stream (form &optional form form)
:lisp)
(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp)
(define-caller-pattern get-output-stream-string (form) :lisp)
(define-caller-pattern with-open-stream
((var form)
(:star declaration)
(:star form))
:lisp)
(define-caller-pattern with-input-from-string
((var form &key (:star form))
(:star declaration)
(:star form))
:lisp)
(define-caller-pattern with-output-to-string
((var (:optional form))
(:star declaration)
(:star form))
:lisp)
(define-caller-pattern streamp (form) :lisp)
(define-caller-pattern open-stream-p (form) :lisp2)
(define-caller-pattern input-stream-p (form) :lisp)
(define-caller-pattern output-stream-p (form) :lisp)
(define-caller-pattern stream-element-type (form) :lisp)
(define-caller-pattern close (form (:rest :ignore)) :lisp)
(define-caller-pattern broadcast-stream-streams (form) :lisp2)
(define-caller-pattern concatenated-stream-streams (form) :lisp2)
(define-caller-pattern echo-stream-input-stream (form) :lisp2)
(define-caller-pattern echo-stream-output-stream (form) :lisp2)
(define-caller-pattern synonym-stream-symbol (form) :lisp2)
(define-caller-pattern two-way-stream-input-stream (form) :lisp2)
(define-caller-pattern two-way-stream-output-stream (form) :lisp2)
(define-caller-pattern interactive-stream-p (form) :lisp2)
(define-caller-pattern stream-external-format (form) :lisp2)
;;; Reader
(define-variable-pattern *read-base* :lisp)
(define-variable-pattern *read-suppress* :lisp)
(define-variable-pattern *read-eval* :lisp2)
(define-variable-pattern *readtable* :lisp)
(define-caller-pattern copy-readtable (&optional form form) :lisp)
(define-caller-pattern readtablep (form) :lisp)
(define-caller-pattern set-syntax-from-char (form form &optional form form)
:lisp)
(define-caller-pattern set-macro-character (form fn &optional form) :lisp)
(define-caller-pattern get-macro-character (form (:optional form)) :lisp)
(define-caller-pattern make-dispatch-macro-character (form &optional form form)
:lisp)
(define-caller-pattern set-dispatch-macro-character
(form form fn (:optional form)) :lisp)
(define-caller-pattern get-dispatch-macro-character
(form form (:optional form)) :lisp)
(define-caller-pattern readtable-case (form) :lisp2)
(define-variable-pattern *print-readably* :lisp2)
(define-variable-pattern *print-escape* :lisp)
(define-variable-pattern *print-pretty* :lisp)
(define-variable-pattern *print-circle* :lisp)
(define-variable-pattern *print-base* :lisp)
(define-variable-pattern *print-radix* :lisp)
(define-variable-pattern *print-case* :lisp)
(define-variable-pattern *print-gensym* :lisp)
(define-variable-pattern *print-level* :lisp)
(define-variable-pattern *print-length* :lisp)
(define-variable-pattern *print-array* :lisp)
(define-caller-pattern with-standard-io-syntax
((:star declaration)
(:star form))
:lisp2)
(define-caller-pattern read (&optional form form form form) :lisp)
(define-variable-pattern *read-default-float-format* :lisp)
(define-caller-pattern read-preserving-whitespace
(&optional form form form form) :lisp)
(define-caller-pattern read-delimited-list (form &optional form form) :lisp)
(define-caller-pattern read-line (&optional form form form form) :lisp)
(define-caller-pattern read-char (&optional form form form form) :lisp)
(define-caller-pattern unread-char (form (:optional form)) :lisp)
(define-caller-pattern peek-char (&optional form form form form) :lisp)
(define-caller-pattern listen ((:optional form)) :lisp)
(define-caller-pattern read-char-no-hang ((:star form)) :lisp)
(define-caller-pattern clear-input ((:optional form)) :lisp)
(define-caller-pattern read-from-string (form (:star form)) :lisp)
(define-caller-pattern parse-integer (form &rest :ignore) :lisp)
(define-caller-pattern read-byte ((:star form)) :lisp)
(define-caller-pattern write (form &key (:star form)) :lisp)
(define-caller-pattern prin1 (form (:optional form)) :lisp)
(define-caller-pattern print (form (:optional form)) :lisp)
(define-caller-pattern pprint (form (:optional form)) :lisp)
(define-caller-pattern princ (form (:optional form)) :lisp)
(define-caller-pattern write-to-string (form &key (:star form)) :lisp)
(define-caller-pattern prin1-to-string (form) :lisp)
(define-caller-pattern princ-to-string (form) :lisp)
(define-caller-pattern write-char (form (:optional form)) :lisp)
(define-caller-pattern write-string (form &optional form &key (:star form))
:lisp)
(define-caller-pattern write-line (form &optional form &key (:star form))
:lisp)
(define-caller-pattern terpri ((:optional form)) :lisp)
(define-caller-pattern fresh-line ((:optional form)) :lisp)
(define-caller-pattern finish-output ((:optional form)) :lisp)
(define-caller-pattern force-output ((:optional form)) :lisp)
(define-caller-pattern clear-output ((:optional form)) :lisp)
(define-caller-pattern print-unreadable-object
((form form &key (:star form))
(:star declaration)
(:star form))
:lisp2)
(define-caller-pattern write-byte (form form) :lisp)
(define-caller-pattern format
(destination
control-string
(:rest format-arguments))
:lisp)
(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp)
(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp)
;;; Pathnames
(define-caller-pattern wild-pathname-p (form &optional form) :lisp2)
(define-caller-pattern pathname-match-p (form form) :lisp2)
(define-caller-pattern translate-pathname (form form form &key (:star form))
:lisp2)
(define-caller-pattern logical-pathname (form) :lisp2)
(define-caller-pattern translate-logical-pathname (form &key (:star form))
:lisp2)
(define-caller-pattern logical-pathname-translations (form) :lisp2)
(define-caller-pattern load-logical-pathname-translations (form) :lisp2)
(define-caller-pattern compile-file-pathname (form &key form) :lisp2)
(define-caller-pattern pathname (form) :lisp)
(define-caller-pattern truename (form) :lisp)
(define-caller-pattern parse-namestring ((:star form)) :lisp)
(define-caller-pattern merge-pathnames ((:star form)) :lisp)
(define-variable-pattern *default-pathname-defaults* :lisp)
(define-caller-pattern make-pathname ((:star form)) :lisp)
(define-caller-pattern pathnamep (form) :lisp)
(define-caller-pattern pathname-host (form) :lisp)
(define-caller-pattern pathname-device (form) :lisp)
(define-caller-pattern pathname-directory (form) :lisp)
(define-caller-pattern pathname-name (form) :lisp)
(define-caller-pattern pathname-type (form) :lisp)
(define-caller-pattern pathname-version (form) :lisp)
(define-caller-pattern namestring (form) :lisp)
(define-caller-pattern file-namestring (form) :lisp)
(define-caller-pattern directory-namestring (form) :lisp)
(define-caller-pattern host-namestring (form) :lisp)
(define-caller-pattern enough-namestring (form (:optional form)) :lisp)
(define-caller-pattern user-homedir-pathname (&optional form) :lisp)
(define-caller-pattern open (form &key (:star form)) :lisp)
(define-caller-pattern with-open-file
((var form (:rest :ignore))
(:star declaration)
(:star form))
:lisp)
(define-caller-pattern rename-file (form form) :lisp)
(define-caller-pattern delete-file (form) :lisp)
(define-caller-pattern probe-file (form) :lisp)
(define-caller-pattern file-write-date (form) :lisp)
(define-caller-pattern file-author (form) :lisp)
(define-caller-pattern file-position (form (:optional form)) :lisp)
(define-caller-pattern file-length (form) :lisp)
(define-caller-pattern file-string-length (form form) :lisp2)
(define-caller-pattern load (form &key (:star form)) :lisp)
(define-variable-pattern *load-verbose* :lisp)
(define-variable-pattern *load-print* :lisp2)
(define-variable-pattern *load-pathname* :lisp2)
(define-variable-pattern *load-truename* :lisp2)
(define-caller-pattern make-load-form (form) :lisp2)
(define-caller-pattern make-load-form-saving-slots (form &optional form)
:lisp2)
(define-caller-pattern directory (form &key (:star form)) :lisp)
;;; Errors
(define-caller-pattern error (form (:star form)) :lisp)
(define-caller-pattern cerror (form form (:star form)) :lisp)
(define-caller-pattern warn (form (:star form)) :lisp)
(define-variable-pattern *break-on-warnings* :lisp)
(define-caller-pattern break (&optional form (:star form)) :lisp)
(define-caller-pattern check-type (form form (:optional form)) :lisp)
(define-caller-pattern assert
(form
(:optional ((:star var))
(:optional form (:star form))))
:lisp)
(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp)
(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp)
(define-caller-pattern ecase
(form
(:star ((:or symbol ((:star symbol)))
(:star form))))
:lisp)
(define-caller-pattern ccase
(form
(:star ((:or symbol ((:star symbol)))
(:star form))))
:lisp)
;;; The Compiler
(define-caller-pattern compile (form (:optional form)) :lisp)
(define-caller-pattern compile-file (form &key (:star form)) :lisp)
(define-variable-pattern *compile-verbose* :lisp2)
(define-variable-pattern *compile-print* :lisp2)
(define-variable-pattern *compile-file-pathname* :lisp2)
(define-variable-pattern *compile-file-truename* :lisp2)
(define-caller-pattern load-time-value (form (:optional form)) :lisp2)
(define-caller-pattern disassemble (form) :lisp)
(define-caller-pattern function-lambda-expression (fn) :lisp2)
(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form))
:lisp2)
;;; Documentation
(define-caller-pattern documentation (form form) :lisp)
(define-caller-pattern trace ((:star form)) :lisp)
(define-caller-pattern untrace ((:star form)) :lisp)
(define-caller-pattern step (form) :lisp)
(define-caller-pattern time (form) :lisp)
(define-caller-pattern describe (form &optional form) :lisp)
(define-caller-pattern describe-object (form &optional form) :lisp2)
(define-caller-pattern inspect (form) :lisp)
(define-caller-pattern room ((:optional form)) :lisp)
(define-caller-pattern ed ((:optional form)) :lisp)
(define-caller-pattern dribble ((:optional form)) :lisp)
(define-caller-pattern apropos (form (:optional form)) :lisp)
(define-caller-pattern apropos-list (form (:optional form)) :lisp)
(define-caller-pattern get-decoded-time () :lisp)
(define-caller-pattern get-universal-time () :lisp)
(define-caller-pattern decode-universal-time (form &optional form) :lisp)
(define-caller-pattern encode-universal-time
(form form form form form form &optional form) :lisp)
(define-caller-pattern get-internal-run-time () :lisp)
(define-caller-pattern get-internal-real-time () :lisp)
(define-caller-pattern sleep (form) :lisp)
(define-caller-pattern lisp-implementation-type () :lisp)
(define-caller-pattern lisp-implementation-version () :lisp)
(define-caller-pattern machine-type () :lisp)
(define-caller-pattern machine-version () :lisp)
(define-caller-pattern machine-instance () :lisp)
(define-caller-pattern software-type () :lisp)
(define-caller-pattern software-version () :lisp)
(define-caller-pattern short-site-name () :lisp)
(define-caller-pattern long-site-name () :lisp)
(define-variable-pattern *features* :lisp)
(define-caller-pattern identity (form) :lisp)
;;; Pretty Printing
(define-variable-pattern *print-pprint-dispatch* :lisp2)
(define-variable-pattern *print-right-margin* :lisp2)
(define-variable-pattern *print-miser-width* :lisp2)
(define-variable-pattern *print-lines* :lisp2)
(define-caller-pattern pprint-newline (form &optional form) :lisp2)
(define-caller-pattern pprint-logical-block
((var form &key (:star form))
(:star form))
:lisp2)
(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2)
(define-caller-pattern pprint-pop () :lisp2)
(define-caller-pattern pprint-indent (form form &optional form) :lisp2)
(define-caller-pattern pprint-tab (form form form &optional form) :lisp2)
(define-caller-pattern pprint-fill (form form &optional form form) :lisp2)
(define-caller-pattern pprint-linear (form form &optional form form) :lisp2)
(define-caller-pattern pprint-tabular (form form &optional form form form)
:lisp2)
(define-caller-pattern formatter (control-string) :lisp2)
(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2)
(define-caller-pattern pprint-dispatch (form &optional form) :lisp2)
(define-caller-pattern set-pprint-dispatch (form form &optional form form)
:lisp2)
;;; CLOS
(define-caller-pattern add-method (fn form) :lisp2)
(define-caller-pattern call-method (form form) :lisp2)
(define-caller-pattern call-next-method ((:star form)) :lisp2)
(define-caller-pattern change-class (form form) :lisp2)
(define-caller-pattern class-name (form) :lisp2)
(define-caller-pattern class-of (form) :lisp2)
(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2)
(define-caller-pattern defclass (name &rest :ignore) :lisp2)
(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2)
(define-caller-pattern define-method-combination
(name lambda-list ((:star :ignore))
(:optional ((:eq :arguments) :ignore))
(:optional ((:eq :generic-function) :ignore))
(:star (:or declaration documentation-string))
(:star form))
:lisp2)
(define-caller-pattern defmethod
(name (:star symbol) lambda-list
(:star (:or declaration documentation-string))
(:star form))
:lisp2)
(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2)
(define-caller-pattern find-class (form &optional form form) :lisp2)
(define-caller-pattern find-method (fn &rest :ignore) :lisp2)
(define-caller-pattern function-keywords (&rest :ignore) :lisp2)
(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form))
:lisp2)
(define-caller-pattern generic-labels
(((:star (name lambda-list))) (:star form))
:lisp2)
(define-caller-pattern generic-function (lambda-list) :lisp2)
(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2)
(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2)
(define-caller-pattern make-instance (fn (:star form)) :lisp2)
(define-caller-pattern make-instances-obsolete (fn) :lisp2)
(define-caller-pattern method-combination-error (form (:star form)) :lisp2)
(define-caller-pattern method-qualifiers (fn) :lisp2)
(define-caller-pattern next-method-p () :lisp2)
(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2)
(define-caller-pattern no-next-method (fn (:star form)) :lisp2)
(define-caller-pattern print-object (form form) :lisp2)
(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2)
(define-caller-pattern remove-method (fn form) :lisp2)
(define-caller-pattern shared-initialize (form form (:star form)) :lisp2)
(define-caller-pattern slot-boundp (form form) :lisp2)
(define-caller-pattern slot-exists-p (form form) :lisp2)
(define-caller-pattern slot-makeunbound (form form) :lisp2)
(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2)
(define-caller-pattern slot-unbound (fn form form) :lisp2)
(define-caller-pattern slot-value (form form) :lisp2)
(define-caller-pattern update-instance-for-different-class
(form form (:star form)) :lisp2)
(define-caller-pattern update-instance-for-redefined-class
(form form (:star form)) :lisp2)
(define-caller-pattern with-accessors
(((:star :ignore)) form
(:star declaration)
(:star form))
:lisp2)
(define-caller-pattern with-added-methods
((name lambda-list) form
(:star form))
:lisp2)
(define-caller-pattern with-slots
(((:star :ignore)) form
(:star declaration)
(:star form))
:lisp2)
;;; Conditions
(define-caller-pattern signal (form (:star form)) :lisp2)
(define-variable-pattern *break-on-signals* :lisp2)
(define-caller-pattern handler-case (form (:star (form ((:optional var))
(:star form))))
:lisp2)
(define-caller-pattern ignore-errors ((:star form)) :lisp2)
(define-caller-pattern handler-bind (((:star (form form)))
(:star form))
:lisp2)
(define-caller-pattern define-condition (name &rest :ignore) :lisp2)
(define-caller-pattern make-condition (form &rest :ignore) :lisp2)
(define-caller-pattern with-simple-restart
((name form (:star form)) (:star form)) :lisp2)
(define-caller-pattern restart-case
(form
(:star (form form (:star form))))
:lisp2)
(define-caller-pattern restart-bind
(((:star (name fn &key (:star form))))
(:star form))
:lisp2)
(define-caller-pattern with-condition-restarts
(form form
(:star declaration)
(:star form))
:lisp2)
(define-caller-pattern compute-restarts (&optional form) :lisp2)
(define-caller-pattern restart-name (form) :lisp2)
(define-caller-pattern find-restart (form &optional form) :lisp2)
(define-caller-pattern invoke-restart (form (:star form)) :lisp2)
(define-caller-pattern invoke-restart-interactively (form) :lisp2)
(define-caller-pattern abort (&optional form) :lisp2)
(define-caller-pattern continue (&optional form) :lisp2)
(define-caller-pattern muffle-warning (&optional form) :lisp2)
(define-caller-pattern store-value (form &optional form) :lisp2)
(define-caller-pattern use-value (form &optional form) :lisp2)
(define-caller-pattern invoke-debugger (form) :lisp2)
(define-variable-pattern *debugger-hook* :lisp2)
(define-caller-pattern simple-condition-format-string (form) :lisp2)
(define-caller-pattern simple-condition-format-arguments (form) :lisp2)
(define-caller-pattern type-error-datum (form) :lisp2)
(define-caller-pattern type-error-expected-type (form) :lisp2)
(define-caller-pattern package-error-package (form) :lisp2)
(define-caller-pattern stream-error-stream (form) :lisp2)
(define-caller-pattern file-error-pathname (form) :lisp2)
(define-caller-pattern cell-error-name (form) :lisp2)
(define-caller-pattern arithmetic-error-operation (form) :lisp2)
(define-caller-pattern arithmetic-error-operands (form) :lisp2)
;;; For ZetaLisp Flavors
(define-caller-pattern send (form fn (:star form)) :flavors)
;;; This file is intended to be loaded by an implementation to
;;; get a running slynk server
;;; e.g. sbcl --load start-slynk.lisp
;;;
;;; Default port is 4005
;;; For additional slynk-side configurations see
;;; 6.2 section of the Slime user manual.
(load (make-pathname :name "slynk-loader" :type "lisp"
:defaults *load-truename*))
(slynk-loader:init
:delete nil ; delete any existing SLYNK packages
:reload nil) ; reload SLYNK, even if the SLYNK package already exists
(slynk:create-server :port 4005
;; if non-nil the connection won't be closed
;; after connecting
:dont-close t)
;;;; slynk.lisp --- Server for SLY commands.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;;; This file defines the "Slynk" TCP server for Emacs to talk to. The
;;; code in this file is purely portable Common Lisp. We do require a
;;; smattering of non-portable functions in order to write the server,
;;; so we have defined them in `slynk-backend.lisp' and implemented
;;; them separately for each Lisp implementation. These extensions are
;;; available to us here via the `SLYNK-BACKEND' package.
(defpackage :slynk
(:use :cl :slynk-backend :slynk-match :slynk-rpc)
(:export #:startup-multiprocessing
#:start-server
#:create-server
#:stop-server
#:restart-server
#:ed-in-emacs
#:inspect-in-emacs
#:print-indentation-lossage
#:invoke-sly-debugger
#:slynk-debugger-hook
#:emacs-inspect
;;#:inspect-slot-for-emacs
#:authenticate-client
#:*loopback-interface*
#:*buffer-readtable*
#:process-requests)
;; These are user-configurable variables:
(:export #:*communication-style*
#:*dont-close*
#:*fasl-pathname-function*
#:*log-events*
#:*log-output*
#:*configure-emacs-indentation*
#:*readtable-alist*
#:*global-debugger*
#:*sly-db-quit-restart*
#:*backtrace-printer-bindings*
#:*default-worker-thread-bindings*
#:*macroexpand-printer-bindings*
#:*slynk-pprint-bindings*
#:*string-elision-length*
#:*inspector-verbose*
#:*require-module*
#:*eval-for-emacs-wrappers*
#:*debugger-extra-options*
;; These are exceptions: they are defined later in
;; slynk-mrepl.lisp
;;
#:*globally-redirect-io*
#:*use-dedicated-output-stream*
#:*dedicated-output-stream-port*
#:*dedicated-output-stream-buffering*
;; This is SETFable.
#:debug-on-slynk-error
;; These are re-exported directly from the backend:
#:buffer-first-change
#:frame-source-location
#:gdb-initial-commands
#:restart-frame
#:sly-db-step
#:sly-db-break
#:sly-db-break-on-return
#:default-directory
#:set-default-directory
#:quit-lisp
#:eval-for-emacs
#:eval-in-emacs
#:y-or-n-p-in-emacs
#:*find-definitions-right-trim*
#:*find-definitions-left-trim*
#:*after-toggle-trace-hook*
#:*echo-number-alist*
#:*present-number-alist*))
(in-package :slynk)
;;;; Top-level variables, constants, macros
(defconstant cl-package (find-package :cl)
"The COMMON-LISP package.")
(defconstant +keyword-package+ (find-package :keyword)
"The KEYWORD package.")
(defconstant default-server-port 4005
"The default TCP port for the server (when started manually).")
(defvar *slynk-debug-p* t
"When true, print extra debugging information.")
(defvar *m-x-sly-from-emacs* nil
"Bound to non-nil in START-SERVER.")
(defvar *backtrace-pprint-dispatch-table*
(let ((table (copy-pprint-dispatch nil)))
(flet ((print-string (stream string)
(cond (*print-escape*
(escape-string string stream
:map '((#\" . "\\\"")
(#\\ . "\\\\")
(#\newline . "\\n")
(#\return . "\\r"))))
(t (write-string string stream)))))
(set-pprint-dispatch 'string #'print-string 0 table)
table)))
(defvar *backtrace-printer-bindings*
`((*print-pretty* . t)
(*print-readably* . nil)
(*print-level* . 4)
(*print-length* . 6)
(*print-lines* . 1)
(*print-right-margin* . 200)
(*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*))
"Pretter settings for printing backtraces.")
(defvar *default-worker-thread-bindings* '()
"An alist to initialize dynamic variables in worker threads.
The list has the form ((VAR . VALUE) ...). Each variable VAR will be
bound to the corresponding VALUE.")
(defun call-with-bindings (alist fun)
"Call FUN with variables bound according to ALIST.
ALIST is a list of the form ((VAR . VAL) ...)."
(if (null alist)
(funcall fun)
(let* ((rlist (reverse alist))
(vars (mapcar #'car rlist))
(vals (mapcar #'cdr rlist)))
(progv vars vals
(funcall fun)))))
(defmacro with-bindings (alist &body body)
"See `call-with-bindings'.
Bindings appearing earlier in the list take priority"
`(call-with-bindings ,alist (lambda () ,@body)))
;;; The `DEFSLYFUN' macro defines a function that Emacs can call via
;;; RPC.
(defvar *slyfuns* (make-hash-table)
"A map of Sly functions.")
(defmacro defslyfun (name arglist &body rest)
"A DEFUN for functions that Emacs can call by RPC."
`(progn
(defun ,name ,arglist ,@rest)
(setf (gethash ',name *slyfuns*) #',name)
;; see <http://www.franz.com/support/documentation/6.2/\
;; doc/pages/variables/compiler/\
;; s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
(eval-when (:compile-toplevel :load-toplevel :execute)
(export ',name (symbol-package ',name)))))
(defun missing-arg ()
"A function that the compiler knows will never to return a value.
You can use (MISSING-ARG) as the initform for defstruct slots that
must always be supplied. This way the :TYPE slot option need not
include some arbitrary initial value like NIL."
(error "A required &KEY or &OPTIONAL argument was not supplied."))
;;;; Hooks
;;;
;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
;;; simple indirection. The interface is more CLish than the Emacs
;;; Lisp one.
(defmacro add-hook (place function)
"Add FUNCTION to the list of values on PLACE."
`(pushnew ,function ,place))
(defun run-hook (functions &rest arguments)
"Call each of FUNCTIONS with ARGUMENTS."
(dolist (function functions)
(apply function arguments)))
(defvar *new-connection-hook* '()
"This hook is run each time a connection is established.
The connection structure is given as the argument.
Backend code should treat the connection structure as opaque.")
(defvar *connection-closed-hook* '()
"This hook is run when a connection is closed.
The connection as passed as an argument.
Backend code should treat the connection structure as opaque.")
(defvar *pre-reply-hook* '()
"Hook run (without arguments) immediately before replying to an RPC.")
(defvar *after-init-hook* '()
"Hook run after user init files are loaded.")
;;;; Connections
;;;
;;; Connection structures represent the network connections between
;;; Emacs and Lisp.
;;;
(defstruct (connection
(:constructor %make-connection)
(:conc-name connection-)
(:print-function print-connection))
;; The listening socket. (usually closed)
;;
(socket (missing-arg) :type t :read-only t)
;; Character I/O stream of socket connection. Read-only to avoid
;; race conditions during initialization.
;;
(socket-io (missing-arg) :type stream :read-only t)
;; An alist of (ID . CHANNEL) entries. Channels are good for
;; streaming data over the wire (see their description in sly.el)
;;
(channel-counter 0 :type number)
(channels '() :type list)
;; A list of LISTENER objects. Each listener has a couple of streams
;; and an environment (an alist of bindings)
;;
(listeners '() :type list)
;; A list of INSPECTOR objects. Each inspector has its own history
;; of inspected objects. An inspector might also be tied to a
;; specific thread.
;;
(inspectors '() :type list)
;;Cache of macro-indentation information that
;; has been sent to Emacs. This is used for preparing deltas to
;; update Emacs's knowledge. Maps: symbol ->
;; indentation-specification
;;
(indentation-cache (make-hash-table :test 'eq) :type hash-table)
;; The list of packages represented in the cache:
;;
(indentation-cache-packages '())
;; The communication style used.
;;
(communication-style nil :type (member nil :spawn :sigio :fd-handler))
)
(defun print-connection (conn stream depth)
(declare (ignore depth))
(print-unreadable-object (conn stream :type t :identity t)))
(defstruct (singlethreaded-connection (:include connection)
(:conc-name sconn.))
;; The SIGINT handler we should restore when the connection is
;; closed.
saved-sigint-handler
;; A queue of events. Not all events can be processed in order and
;; we need a place to stored them.
(event-queue '() :type list)
;; A counter that is incremented whenever an event is added to the
;; queue. This is used to detected modifications to the event queue
;; by interrupts. The counter wraps around.
(events-enqueued 0 :type fixnum))
(defstruct (multithreaded-connection (:include connection)
(:conc-name mconn.))
;; In multithreaded systems we delegate certain tasks to specific
;; threads. The `reader-thread' is responsible for reading network
;; requests from Emacs and sending them to the `control-thread'; the
;; `control-thread' is responsible for dispatching requests to the
;; threads that should handle them.
reader-thread
control-thread
auto-flush-thread
indentation-cache-thread
;; List of threads that are currently processing requests. We use
;; this to find the newest/current thread for an interrupt. In the
;; future we may store here (thread . request-tag) pairs so that we
;; can interrupt specific requests.
(active-threads '() :type list)
)
(defvar *emacs-connection* nil
"The connection to Emacs currently in use.")
(defun make-connection (socket stream style)
(let ((conn (funcall (ecase style
(:spawn
#'make-multithreaded-connection)
((:sigio nil :fd-handler)
#'make-singlethreaded-connection))
:socket socket
:socket-io stream
:communication-style style)))
(run-hook *new-connection-hook* conn)
(send-to-sentinel `(:add-connection ,conn))
conn))
(defslyfun ping (tag)
tag)
(defun safe-backtrace ()
(ignore-errors
(call-with-debugging-environment
(lambda () (backtrace 0 nil)))))
(define-condition slynk-error (error)
((backtrace :initarg :backtrace :reader slynk-error.backtrace)
(condition :initarg :condition :reader slynk-error.condition))
(:report (lambda (c s) (princ (slynk-error.condition c) s)))
(:documentation "Condition which carries a backtrace."))
(defun signal-slynk-error (condition &optional (backtrace (safe-backtrace)))
(error 'slynk-error :condition condition :backtrace backtrace))
(defvar *debug-on-slynk-protocol-error* nil
"When non-nil invoke the system debugger on errors that were
signalled during decoding/encoding the wire protocol. Do not set this
to T unless you want to debug slynk internals.")
(defmacro with-slynk-error-handler ((connection) &body body)
"Close the connection on internal `slynk-error's."
(let ((conn (gensym)))
`(let ((,conn ,connection))
(handler-case
(handler-bind ((slynk-error
(lambda (condition)
(when *debug-on-slynk-protocol-error*
(invoke-default-debugger condition)))))
(progn . ,body))
(slynk-error (condition)
(close-connection ,conn
(slynk-error.condition condition)
(slynk-error.backtrace condition)))))))
(defmacro with-panic-handler ((connection) &body body)
"Close the connection on unhandled `serious-condition's."
(let ((conn (gensym)))
`(let ((,conn ,connection))
(handler-bind ((serious-condition
(lambda (condition)
(close-connection ,conn condition (safe-backtrace))
(abort condition))))
. ,body))))
(add-hook *new-connection-hook* 'notify-backend-of-connection)
(defun notify-backend-of-connection (connection)
(declare (ignore connection))
(emacs-connected))
;;;; Utilities
;; stolen from Hunchentoot
(defmacro defvar-unbound (name &optional (doc-string ""))
"Convenience macro to declare unbound special variables with a
documentation string."
`(progn
(defvar ,name)
(setf (documentation ',name 'variable) ,doc-string)
',name))
;;;;; Logging
(defvar *slynk-io-package*
(let ((package (make-package :slynk-io-package :use '())))
(import '(nil t quote) package)
package))
(defvar *log-events* nil)
(defvar *log-output* nil) ; should be nil for image dumpers
(defun init-log-output ()
(unless *log-output*
(setq *log-output* (real-output-stream *error-output*))))
(add-hook *after-init-hook* 'init-log-output)
(defun real-input-stream (stream)
(typecase stream
(synonym-stream
(real-input-stream (symbol-value (synonym-stream-symbol stream))))
(two-way-stream
(real-input-stream (two-way-stream-input-stream stream)))
(t stream)))
(defun real-output-stream (stream)
(typecase stream
(synonym-stream
(real-output-stream (symbol-value (synonym-stream-symbol stream))))
(two-way-stream
(real-output-stream (two-way-stream-output-stream stream)))
(t stream)))
(defvar *event-history* (make-array 40 :initial-element nil)
"A ring buffer to record events for better error messages.")
(defvar *event-history-index* 0)
(defvar *enable-event-history* t)
(defun log-event (format-string &rest args)
"Write a message to *terminal-io* when *log-events* is non-nil.
Useful for low level debugging."
(with-standard-io-syntax
(let ((*print-readably* nil)
(*print-pretty* nil)
(*package* *slynk-io-package*))
(when *enable-event-history*
(setf (aref *event-history* *event-history-index*)
(format nil "~?" format-string args))
(setf *event-history-index*
(mod (1+ *event-history-index*) (length *event-history*))))
(when *log-events*
(write-string (escape-non-ascii (format nil "~?" format-string args))
*log-output*)
(force-output *log-output*)))))
(defun event-history-to-list ()
"Return the list of events (older events first)."
(let ((arr *event-history*)
(idx *event-history-index*))
(concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
(defun clear-event-history ()
(fill *event-history* nil)
(setq *event-history-index* 0))
(defun dump-event-history (stream)
(dolist (e (event-history-to-list))
(dump-event e stream)))
(defun dump-event (event stream)
(cond ((stringp event)
(write-string (escape-non-ascii event) stream))
((null event))
(t
(write-string
(escape-non-ascii (format nil "Unexpected event: ~A~%" event))
stream))))
(defun escape-non-ascii (string)
"Return a string like STRING but with non-ascii chars escaped."
(cond ((ascii-string-p string) string)
(t (with-output-to-string (out)
(loop for c across string do
(cond ((ascii-char-p c) (write-char c out))
(t (format out "\\x~4,'0X" (char-code c)))))))))
(defun ascii-string-p (o)
(and (stringp o)
(every #'ascii-char-p o)))
(defun ascii-char-p (c)
(<= (char-code c) 127))
;;;;; Helper macros
(defmacro destructure-case (value &body patterns)
"Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
(let ((operator (gensym "op-"))
(operands (gensym "rand-"))
(tmp (gensym "tmp-")))
`(let* ((,tmp ,value)
(,operator (car ,tmp))
(,operands (cdr ,tmp)))
(case ,operator
,@(loop for (pattern . body) in patterns collect
(if (eq pattern t)
`(t ,@body)
(destructuring-bind (op &rest rands) pattern
`(,op (destructuring-bind ,rands ,operands
,@body)))))
,@(if (eq (caar (last patterns)) t)
'()
`((t (error "destructure-case failed: ~S" ,tmp))))))))
;;; Channels
(defmacro channels () `(connection-channels *emacs-connection*))
(defmacro channel-counter () `(connection-channel-counter *emacs-connection*))
(defclass channel ()
((id :initform (incf (channel-counter))
:reader channel-id)
(thread :initarg :thread :initform (current-thread)
:reader channel-thread)
(name :initarg :name :initform nil)))
(defmethod initialize-instance :after ((ch channel) &key)
;; FIXME: slightly fugly, but I need this to be able to name the
;; thread according to the channel's id.
;;
(with-slots (thread) ch
(when (use-threads-p)
(setf thread (spawn-channel-thread *emacs-connection* ch)))
(slynk-backend:send thread `(:serve-channel ,ch)))
(setf (channels) (nconc (channels) (list ch))))
(defmethod print-object ((c channel) stream)
(print-unreadable-object (c stream :type t)
(with-slots (id name) c
(format stream "~d ~a" id name))))
(defmethod drop-unprocessed-events (channel)
;; FIXME: perhaps this should incorporate most
;; behaviour from it's :after spec currently in slynk-mrepl.lisp)
(declare (ignore channel)))
(defun find-channel (id)
(find id (channels) :key #'channel-id))
(defun find-channel-thread (channel)
(channel-thread channel))
(defun channel-thread-id (channel)
(slynk-backend:thread-id (channel-thread channel)))
(defmethod close-channel (channel &key)
(let ((probe (find-channel (channel-id channel))))
(cond (probe (setf (channels) (delete probe (channels))))
(t (error "Can't close invalid channel: ~a" channel)))))
(defgeneric channel-send (channel selector args)
(:documentation "Send to CHANNEL the message SELECTOR with ARGS."))
(defmacro define-channel-method (selector (channel &rest args) &body body)
`(defmethod channel-send (,channel (selector (eql ',selector)) args)
(destructuring-bind ,args args
. ,body)))
(define-channel-method :teardown ((c channel))
(if (use-threads-p)
;; eventually calls CLOSE-CHANNEL
(throw 'stop-processing 'listener-teardown)
(close-channel c)))
(defun send-to-remote-channel (channel-id msg)
(send-to-emacs `(:channel-send ,channel-id ,msg)))
;;; Listeners
(defclass listener ()
((out :initarg :out :type stream :reader listener-out)
(in :initarg :in :type stream :reader listener-in)
(env)))
(defmacro listeners () `(connection-listeners *emacs-connection*))
(defmethod initialize-instance :after ((l listener) &key initial-env)
(with-slots (out in env) l
(let ((io (make-two-way-stream in out)))
(setf env
(append
initial-env
`((cl:*standard-output* . ,out)
(cl:*standard-input* . ,in)
(cl:*trace-output* . ,out)
(cl:*error-output* . ,out)
(cl:*debug-io* . ,io)
(cl:*query-io* . ,io)
(cl:*terminal-io* . ,io)))))
(assert out nil "Must have an OUT stream")
(assert in nil "Must have an IN stream")
(assert env nil "Must have an ENV"))
(setf (listeners) (nconc (listeners)
(list l))))
(defun call-with-listener (listener fn &optional saving)
(with-slots (env) listener
(with-bindings env
(unwind-protect (funcall fn)
(when saving
(loop for binding in env
do (setf (cdr binding) (symbol-value (car binding)))))))))
(defmacro with-listener-bindings (listener &body body)
"Execute BODY inside LISTENER's environment"
`(call-with-listener ,listener (lambda () ,@body)))
(defmacro saving-listener-bindings (listener &body body)
"Execute BODY inside LISTENER's environment, update it afterwards."
`(call-with-listener ,listener (lambda () ,@body) 'saving))
(defmacro with-default-listener ((connection) &body body)
"Execute BODY with in CONNECTION's default listener."
(let ((listener-sym (gensym))
(body-fn-sym (gensym)))
`(let ((,listener-sym (default-listener ,connection))
(,body-fn-sym #'(lambda () ,@body)))
(if ,listener-sym
(with-listener-bindings ,listener-sym
(funcall ,body-fn-sym))
(funcall ,body-fn-sym)))))
(defun default-listener (connection)
(first (connection-listeners connection)))
(defun flush-listener-streams (listener)
(with-slots (in out) listener
(force-output out)
#-armedbear
(slynk-gray::reset-stream-line-column out)
(clear-input in)))
(defmethod close-listener (l)
(with-slots (in out) l (close in) (close out))
(setf (listeners) (delete l (listeners))))
;;;; Interrupt handling
;; Usually we'd like to enter the debugger when an interrupt happens.
;; But for some operations, in particular send&receive, it's crucial
;; that those are not interrupted when the mailbox is in an
;; inconsistent/locked state. Obviously, if send&receive don't work we
;; can't communicate and the debugger will not work. To solve that
;; problem, we try to handle interrupts only at certain safe-points.
;;
;; Whenever an interrupt happens we call the function
;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the
;; debugger, but if interrupts are disabled the interrupt is put in a
;; queue for later processing. At safe-points, we call
;; CHECK-SLY-INTERRUPTS which looks at the queue and invokes the
;; debugger if needed.
;;
;; The queue for interrupts is stored in a thread local variable.
;; WITH-CONNECTION sets it up. WITH-SLY-INTERRUPTS allows
;; interrupts, i.e. the debugger is entered immediately. When we call
;; "user code" or non-problematic code we allow interrupts. When
;; inside WITHOUT-SLY-INTERRUPTS, interrupts are queued. When we
;; switch from "user code" to more delicate operations we need to
;; disable interrupts. In particular, interrupts should be disabled
;; for SEND and RECEIVE-IF.
;; If true execute interrupts, otherwise queue them.
;; Note: `with-connection' binds *pending-sly-interrupts*.
(defvar *sly-interrupts-enabled*)
(defmacro with-interrupts-enabled% (flag body)
`(progn
,@(if flag '((check-sly-interrupts)))
(multiple-value-prog1
(let ((*sly-interrupts-enabled* ,flag))
,@body)
,@(if flag '((check-sly-interrupts))))))
(defmacro with-sly-interrupts (&body body)
`(with-interrupts-enabled% t ,body))
(defmacro without-sly-interrupts (&body body)
`(with-interrupts-enabled% nil ,body))
(defun queue-thread-interrupt (thread function)
(interrupt-thread thread
(lambda ()
;; safely interrupt THREAD
(when (invoke-or-queue-interrupt function)
(wake-thread thread)))))
(defun invoke-or-queue-interrupt (function)
(log-event "invoke-or-queue-interrupt: ~a~%" function)
(cond ((not (boundp '*sly-interrupts-enabled*))
(without-sly-interrupts
(funcall function)))
(*sly-interrupts-enabled*
(log-event "interrupts-enabled~%")
(funcall function))
(t
(setq *pending-sly-interrupts*
(nconc *pending-sly-interrupts*
(list function)))
(cond ((cdr *pending-sly-interrupts*)
(log-event "too many queued interrupts~%")
(with-simple-restart (continue "Continue from interrupt")
(handler-bind ((serious-condition #'invoke-sly-debugger))
(check-sly-interrupts))))
(t
(log-event "queue-interrupt: ~a~%" function)
(when *interrupt-queued-handler*
(funcall *interrupt-queued-handler*))
t)))))
;; Thread local variable used for flow-control.
;; It's bound by `with-connection'.
(defvar *send-counter*)
(defmacro with-connection ((connection) &body body)
"Execute BODY in the context of CONNECTION."
`(let ((connection ,connection)
(function (lambda () . ,body)))
(if (eq *emacs-connection* connection)
(funcall function)
(let ((*emacs-connection* connection)
(*pending-sly-interrupts* '())
(*send-counter* 0))
(without-sly-interrupts
(with-slynk-error-handler (connection)
(with-default-listener (connection)
(call-with-debugger-hook #'slynk-debugger-hook
function))))))))
(defun call-with-retry-restart (msg thunk)
(loop (with-simple-restart (retry "~a" msg)
(return (funcall thunk)))))
(defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
(check-type msg string)
`(call-with-retry-restart ,msg (lambda () ,@body)))
;;;;; Sentinel
;;;
;;; The sentinel thread manages some global lists.
;;; FIXME: Overdesigned?
(defvar *connections* '()
"List of all active connections, with the most recent at the front.")
(defvar *servers* '()
"A list ((server-socket port thread) ...) describing the listening sockets.
Used to close sockets on server shutdown or restart.")
;; FIXME: we simply access the global variable here. We could ask the
;; sentinel thread instead but then we still have the problem that the
;; connection could be closed before we use it.
(defun default-connection ()
"Return the 'default' Emacs connection.
This connection can be used to talk with Emacs when no specific
connection is in use, i.e. *EMACS-CONNECTION* is NIL.
The default connection is defined (quite arbitrarily) as the most
recently established one."
(car *connections*))
(defun start-sentinel ()
(unless (find-registered 'sentinel)
(let ((thread (spawn #'sentinel :name "Slynk Sentinel")))
(register-thread 'sentinel thread))))
(defun sentinel ()
(catch 'exit-sentinel
(loop (sentinel-serve (receive)))))
(defun send-to-sentinel (msg)
(let ((sentinel (find-registered 'sentinel)))
(cond (sentinel (send sentinel msg))
(t (sentinel-serve msg)))))
(defun sentinel-serve (msg)
(destructure-case msg
((:add-connection conn)
(push conn *connections*))
((:close-connection connection condition backtrace)
(close-connection% connection condition backtrace)
(sentinel-maybe-exit))
((:add-server socket port thread)
(push (list socket port thread) *servers*))
((:stop-server key port)
(sentinel-stop-server key port)
(sentinel-maybe-exit))))
(defun sentinel-stop-server (key value)
(let ((probe (find value *servers* :key (ecase key
(:socket #'car)
(:port #'cadr)))))
(cond (probe
(setq *servers* (delete probe *servers*))
(destructuring-bind (socket _port thread) probe
(declare (ignore _port))
(ignore-errors (close-socket socket))
(when (and thread
(thread-alive-p thread)
(not (eq thread (current-thread))))
(ignore-errors (kill-thread thread)))))
(t
(warn "No server for ~s: ~s" key value)))))
(defun sentinel-maybe-exit ()
(when (and (null *connections*)
(null *servers*)
(and (current-thread)
(eq (find-registered 'sentinel)
(current-thread))))
(register-thread 'sentinel nil)
(throw 'exit-sentinel nil)))
;;;;; Misc
(defun use-threads-p ()
(eq (connection-communication-style *emacs-connection*) :spawn))
(defun current-thread-id ()
(thread-id (current-thread)))
(declaim (inline ensure-list))
(defun ensure-list (thing)
(if (listp thing) thing (list thing)))
;;;;; Symbols
;; FIXME: this docstring is more confusing than helpful.
(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, :CONSTANT, :GENERIC-FUNCTION,
:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
(check-type symbol symbol)
(flet ((type-specifier-p (s)
(or (documentation s 'type)
(not (eq (type-specifier-arglist s) :not-available)))))
(let (result)
(when (boundp symbol) (push (if (constantp symbol)
:constant :boundp) result))
(when (fboundp symbol) (push :fboundp result))
(when (type-specifier-p symbol) (push :typespec 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 (and (fboundp symbol)
(typep (ignore-errors (fdefinition symbol))
'generic-function))
(push :generic-function result))
result)))
;;;; TCP Server
(defvar *communication-style* (preferred-communication-style))
(defvar *dont-close* nil
"Default value of :dont-close argument to start-server and
create-server.")
(defparameter *loopback-interface* "localhost")
(defun start-server (port-file
&key (style *communication-style*)
(dont-close *dont-close*))
"Start the server and write the listen port number to PORT-FILE.
This is the entry point for Emacs."
(setq *m-x-sly-from-emacs* t)
(setup-server 0
(lambda (port) (announce-server-port port-file port))
style dont-close nil))
(defun create-server (&key (port default-server-port)
(style *communication-style*)
(dont-close *dont-close*)
interface
backlog)
"Start a SLYNK server on PORT running in STYLE.
If DONT-CLOSE is true then the listen socket will accept multiple
connections, otherwise it will be closed after the first.
Optionally, an INTERFACE could be specified and swank will bind
the PORT on this interface. By default, interface is \"localhost\"."
(let ((*loopback-interface* (or interface
*loopback-interface*)))
(setup-server port #'simple-announce-function
style dont-close backlog)))
(defun find-external-format-or-lose (coding-system)
(or (find-external-format coding-system)
(error "Unsupported coding system: ~s" coding-system)))
(defmacro restart-loop (form &body clauses)
"Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's
environment before trying again (by returning normally) or giving up (through an
explicit transfer of control), all within an implicit block named nil.
e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))"
`(loop (restart-case (return ,form) ,@clauses)))
(defun socket-quest (port backlog)
"Attempt o create a socket on PORT.
Add a restart, prompting user to enter a new port if PORT is already
taken."
(restart-loop (create-socket *loopback-interface* port :backlog backlog)
(use-value (&optional (new-port (1+ port)))
:report (lambda (stream) (format stream "Try a port other than ~D" port))
:interactive
(lambda ()
(format *query-io* "Enter port (defaults to ~D): " (1+ port))
(finish-output *query-io*) ; necessary for tunnels
(ignore-errors (list (parse-integer (read-line *query-io*)))))
(setq port new-port))))
(defun setup-server (port announce-fn style dont-close backlog)
(init-log-output)
(let* ((socket (socket-quest port backlog))
(port (local-port socket)))
(funcall announce-fn port)
(labels ((serve () (accept-connections socket style dont-close))
(note () (send-to-sentinel `(:add-server ,socket ,port
,(current-thread))))
(serve-loop () (note) (loop do (serve) while dont-close)))
(ecase style
(:spawn (initialize-multiprocessing
(lambda ()
(start-sentinel)
(spawn #'serve-loop :name (format nil "Slynk ~s" port)))))
((:fd-handler :sigio)
(note)
(add-fd-handler socket #'serve))
((nil) (serve-loop))))
port))
(defun stop-server (port)
"Stop server running on PORT."
(send-to-sentinel `(:stop-server :port ,port)))
(defun restart-server (&key (port default-server-port)
(style *communication-style*)
(dont-close *dont-close*))
"Stop the server listening on PORT, then start a new SLYNK server
on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
will accept multiple connections, otherwise it will be closed after the
first."
(stop-server port)
(sleep 5)
(create-server :port port :style style :dont-close dont-close))
(defun accept-connections (socket style dont-close)
(unwind-protect
(let ((client (accept-connection socket :external-format nil
:buffering t)))
(authenticate-client client)
(serve-requests (make-connection socket client style)))
(unless dont-close
(send-to-sentinel `(:stop-server :socket ,socket)))))
(defun authenticate-client (stream)
(let ((secret (sly-secret)))
(when secret
(set-stream-timeout stream 20)
(let ((first-val (read-packet stream)))
(unless (and (stringp first-val) (string= first-val secret))
(error "Incoming connection doesn't know the password.")))
(set-stream-timeout stream nil))))
(defun sly-secret ()
"Finds the magic secret from the user's home directory. Returns nil
if the file doesn't exist; otherwise the first line of the file."
(with-open-file (in
(merge-pathnames (user-homedir-pathname) #p".sly-secret")
:if-does-not-exist nil)
(and in (read-line in nil ""))))
(defun serve-requests (connection)
"Read and process all requests on connections."
(etypecase connection
(multithreaded-connection
(spawn-threads-for-connection connection))
(singlethreaded-connection
(ecase (connection-communication-style connection)
((nil) (simple-serve-requests connection))
(:sigio (install-sigio-handler connection))
(:fd-handler (install-fd-handler connection))))))
(defun stop-serving-requests (connection)
(etypecase connection
(multithreaded-connection
(cleanup-connection-threads connection))
(singlethreaded-connection
(ecase (connection-communication-style connection)
((nil))
(:sigio (deinstall-sigio-handler connection))
(:fd-handler (deinstall-fd-handler connection))))))
(defun announce-server-port (file port)
(with-open-file (s file
:direction :output
:if-exists :error
:if-does-not-exist :create)
(format s "~S~%" port))
(simple-announce-function port))
(defun simple-announce-function (port)
(when *slynk-debug-p*
(format *log-output* "~&;; Slynk started at port: ~D.~%" port)
(force-output *log-output*)))
;;;;; Event Decoding/Encoding
(defun decode-message (stream)
"Read an S-expression from STREAM using the SLY protocol."
(log-event "decode-message~%")
(without-sly-interrupts
(handler-bind ((error #'signal-slynk-error))
(handler-case (read-message stream *slynk-io-package*)
(slynk-reader-error (c)
`(:reader-error ,(slynk-reader-error.packet c)
,(slynk-reader-error.cause c)))))))
(defun encode-message (message stream)
"Write an S-expression to STREAM using the SLY protocol."
(log-event "encode-message~%")
(without-sly-interrupts
(handler-bind ((error #'signal-slynk-error))
(write-message message *slynk-io-package* stream))))
;;;;; Event Processing
(defvar *sly-db-quit-restart* nil
"The restart that will be invoked when the user calls sly-db-quit.")
;; Establish a top-level restart and execute BODY.
;; Execute K if the restart is invoked.
(defmacro with-top-level-restart ((connection k) &body body)
`(with-connection (,connection)
(restart-case
(let ((*sly-db-quit-restart* (find-restart 'abort)))
,@body)
(abort (&optional v)
:report "Return to SLY's top level."
(declare (ignore v))
(force-user-output)
,k))))
(defun handle-requests (connection &optional timeout)
"Read and process :emacs-rex requests.
The processing is done in the extent of the toplevel restart."
(with-connection (connection)
(cond (*sly-db-quit-restart*
(process-requests timeout))
(t
(tagbody
start
(with-top-level-restart (connection (go start))
(process-requests timeout)))))))
(defvar-unbound *channel*
"Current CHANNEL instance used by :EMACS-CHANNEL-SEND messages.")
(defun process-requests (timeout)
"Read and process requests from Emacs.
TIMEOUT has the same meaning as in WAIT-FOR-EVENT."
(catch 'stop-processing
(loop
(multiple-value-bind (event timed-out-p)
(wait-for-event `(or (:emacs-rex . _)
(:emacs-channel-send . _))
timeout)
(when timed-out-p (return))
(destructure-case event
((:emacs-rex &rest args) (apply #'eval-for-emacs args))
((:emacs-channel-send *channel* (selector &rest args))
(channel-send *channel* selector args)))))))
(defun spawn-channel-thread (connection channel)
"Spawn a listener thread for CONNECTION and CHANNEL.
The new thread will block waiting for a :SERVE-CHANNEL message, then
process all requests in series until the :TEARDOWN message, at which
point the thread terminates and CHANNEL is closed."
(slynk-backend:spawn
(lambda ()
(with-connection (connection)
(unwind-protect
(destructure-case
(slynk-backend:receive)
((:serve-channel c)
(assert (eq c channel))
(loop
(with-top-level-restart (connection
(drop-unprocessed-events channel))
(when (eq (process-requests nil)
'listener-teardown)
(return))))))
(close-channel channel))))
:name (with-slots (id name) channel
(format nil "sly-channel-~a-~a" id name))))
(defun current-socket-io ()
(connection-socket-io *emacs-connection*))
(defun close-connection (connection condition backtrace)
(send-to-sentinel `(:close-connection ,connection ,condition ,backtrace)))
(defun close-connection% (c condition backtrace)
(let ((*debugger-hook* nil))
(log-event "close-connection: ~a ...~%" condition)
(format *log-output* "~&;; slynk:close-connection: ~A~%"
(escape-non-ascii (safe-condition-message condition)))
(let ((*emacs-connection* c))
(format *log-output* "~&;; closing ~a channels~%" (length (connection-channels c)))
(mapc #'(lambda (c) (close-channel c :force t)) (connection-channels c))
(format *log-output* "~&;; closing ~a listeners~%" (length (connection-listeners c)))
(ignore-errors
(mapc #'close-listener (connection-listeners c))))
(stop-serving-requests c)
(close (connection-socket-io c))
(setf *connections* (remove c *connections*))
(run-hook *connection-closed-hook* c)
(when (and condition (not (typep condition 'end-of-file)))
(finish-output *log-output*)
(format *log-output* "~&;; Event history start:~%")
(dump-event-history *log-output*)
(format *log-output* "~
;; Event history end.~%~
;; Backtrace:~%~{~A~%~}~
;; Connection to Emacs lost. [~%~
;; condition: ~A~%~
;; type: ~S~%~
;; style: ~S]~%"
(loop for (i f) in backtrace
collect
(ignore-errors
(format nil "~d: ~a" i (escape-non-ascii f))))
(escape-non-ascii (safe-condition-message condition) )
(type-of condition)
(connection-communication-style c)))
(finish-output *log-output*)
(log-event "close-connection ~a ... done.~%" condition)))
;;;;;; Thread based communication
(defun read-loop (connection)
(let ((input-stream (connection-socket-io connection))
(control-thread (mconn.control-thread connection)))
(with-slynk-error-handler (connection)
(loop (send control-thread (decode-message input-stream))))))
(defun dispatch-loop (connection)
(let ((*emacs-connection* connection))
(with-panic-handler (connection)
(loop (dispatch-event connection (receive))))))
(defgeneric thread-for-evaluation (connection id)
(:documentation "Find or create a thread to evaluate the next request.")
(:method ((connection multithreaded-connection) (id (eql t)))
(spawn-worker-thread connection))
(:method ((connection multithreaded-connection) (id (eql :find-existing)))
(car (mconn.active-threads connection)))
(:method (connection (id integer))
(declare (ignorable connection))
(find-thread id))
(:method ((connection singlethreaded-connection) id)
(declare (ignorable connection connection id))
(current-thread)))
(defun interrupt-worker-thread (connection id)
(let ((thread (thread-for-evaluation connection
(cond ((eq id t) :find-existing)
(t id)))))
(log-event "interrupt-worker-thread: ~a ~a~%" id thread)
(if thread
(etypecase connection
(multithreaded-connection
(queue-thread-interrupt thread #'simple-break))
(singlethreaded-connection
(simple-break)))
(encode-message (list :debug-condition (current-thread-id)
(format nil "Thread with id ~a not found"
id))
(current-socket-io)))))
(defun spawn-worker-thread (connection)
(spawn (lambda ()
(with-bindings *default-worker-thread-bindings*
(with-top-level-restart (connection nil)
(let ((thread (current-thread)))
(unwind-protect
(apply #'eval-for-emacs
(cdr (wait-for-event `(:emacs-rex . _))))
(remove-active-thread connection thread))))))
:name "slynk-worker"))
(defun add-active-thread (connection thread)
(etypecase connection
(multithreaded-connection
(push thread (mconn.active-threads connection)))
(singlethreaded-connection)))
(defun remove-active-thread (connection thread)
(etypecase connection
(multithreaded-connection
(setf (mconn.active-threads connection)
(delete thread (mconn.active-threads connection) :count 1)))
(singlethreaded-connection)))
(defun dispatch-event (connection event)
"Handle an event triggered either by Emacs or within Lisp."
(log-event "dispatch-event: ~s~%" event)
(destructure-case event
((:emacs-rex form package thread-id id &rest extra-rex-options)
(let ((thread (thread-for-evaluation connection thread-id)))
(cond (thread
(add-active-thread connection thread)
(send-event thread `(:emacs-rex ,form ,package ,id ,@extra-rex-options)))
(t
(encode-message
(list :invalid-rpc id
(format nil "Thread not found: ~s" thread-id))
(current-socket-io))))))
((:return thread &rest args)
(declare (ignore thread))
(encode-message `(:return ,@args) (current-socket-io)))
((:emacs-interrupt thread-id)
(interrupt-worker-thread connection thread-id))
(((:write-string
:debug :debug-condition :debug-activate :debug-return :channel-send
:presentation-start :presentation-end
:new-package :new-features :ed :indentation-update
:eval :eval-no-wait :background-message :inspect :ping
:y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay)
&rest _)
(declare (ignore _))
(encode-message event (current-socket-io)))
(((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
(send-event (find-thread thread-id) (cons (car event) args)))
((:emacs-channel-send channel-id msg)
(let* ((ch (find-channel channel-id))
(thread (and ch (find-channel-thread ch))))
(cond ((and ch thread)
(send-event thread `(:emacs-channel-send ,ch ,msg)))
(ch
(encode-message
(list :invalid-channel channel-id
"No suitable threads for channel")
(current-socket-io)))
(t
(encode-message
(list :invalid-channel channel-id "Channel not found")
(current-socket-io))))))
((:reader-error packet condition)
(encode-message `(:reader-error ,packet
,(safe-condition-message condition))
(current-socket-io)))))
(defun send-event (thread event)
(log-event "send-event: ~s ~s~%" thread event)
(let ((c *emacs-connection*))
(etypecase c
(multithreaded-connection
(send thread event))
(singlethreaded-connection
(setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event)))
(setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c))
most-positive-fixnum))))))
(defun send-to-emacs (event)
"Send EVENT to Emacs."
;;(log-event "send-to-emacs: ~a" event)
(without-sly-interrupts
(let ((c *emacs-connection*))
(etypecase c
(multithreaded-connection
(send (mconn.control-thread c) event))
(singlethreaded-connection
(dispatch-event c event)))
(maybe-slow-down))))
(defun make-thread-bindings-aware-lambda (fn)
(let ((connection *emacs-connection*)
(send-counter *send-counter*))
(lambda (&rest args)
(let ((*emacs-connection* connection)
(*send-counter* send-counter))
(apply fn args)))))
;;;;;; Flow control
;; After sending N (usually 100) messages we slow down and ping Emacs
;; to make sure that everything we have sent so far was received.
(defconstant send-counter-limit 100)
(defun maybe-slow-down ()
(let ((counter (incf *send-counter*)))
(when (< send-counter-limit counter)
(setf *send-counter* 0)
(ping-pong))))
(defun ping-pong ()
(let* ((tag (make-tag))
(pattern `(:emacs-pong ,tag)))
(send-to-emacs `(:ping ,(current-thread-id) ,tag))
(wait-for-event pattern)))
(defun wait-for-event (pattern &optional timeout)
"Scan the event queue for PATTERN and return the event.
If TIMEOUT is NIL wait until a matching event is enqued.
If TIMEOUT is T only scan the queue without waiting.
The second return value is t if the timeout expired before a matching
event was found."
(log-event "wait-for-event: ~s ~s~%" pattern timeout)
(without-sly-interrupts
(let ((c *emacs-connection*))
(etypecase c
(multithreaded-connection
(receive-if (lambda (e) (event-match-p e pattern)) timeout))
(singlethreaded-connection
(wait-for-event/event-loop c pattern timeout))))))
(defun wait-for-event/event-loop (connection pattern timeout)
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(let ((event (poll-for-event connection pattern)))
(when event (return (car event))))
(let ((events-enqueued (sconn.events-enqueued connection))
(ready (wait-for-input (list (current-socket-io)) timeout)))
(cond ((and timeout (not ready))
(return (values nil t)))
((or (/= events-enqueued (sconn.events-enqueued connection))
(eq ready :interrupt))
;; rescan event queue, interrupts may enqueue new events
)
(t
(assert (equal ready (list (current-socket-io))))
(dispatch-event connection
(decode-message (current-socket-io))))))))
(defun poll-for-event (connection pattern)
(let* ((c connection)
(tail (member-if (lambda (e) (event-match-p e pattern))
(sconn.event-queue c))))
(when tail
(setf (sconn.event-queue c)
(nconc (ldiff (sconn.event-queue c) tail) (cdr tail)))
tail)))
;;; FIXME: Make this use SLYNK-MATCH.
(defun event-match-p (event pattern)
(cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
(member pattern '(nil t)))
(equal event pattern))
((symbolp pattern) t)
((consp pattern)
(case (car pattern)
((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
(t (and (consp event)
(and (event-match-p (car event) (car pattern))
(event-match-p (cdr event) (cdr pattern)))))))
(t (error "Invalid pattern: ~S" pattern))))
(defun spawn-threads-for-connection (connection)
(setf
(mconn.control-thread connection)
(spawn
(lambda ()
"Spawns a reader and indentation threads, then calls DISPATCH-LOOP."
(setf (mconn.reader-thread connection) (spawn (lambda () (read-loop connection))
:name "reader-thread"))
(setf (mconn.indentation-cache-thread connection)
(spawn (lambda () (indentation-cache-loop connection))
:name "slynk-indentation-cache-thread"))
(dispatch-loop connection))
:name "control-thread"))
connection)
(defun cleanup-connection-threads (connection)
(let* ((c connection)
(threads (list (mconn.reader-thread c)
(mconn.control-thread c)
(mconn.auto-flush-thread c)
(mconn.indentation-cache-thread c))))
(dolist (thread threads)
(when (and thread
(thread-alive-p thread)
(not (equal (current-thread) thread)))
(ignore-errors (kill-thread thread))))))
;;;;;; Signal driven IO
(defun install-sigio-handler (connection)
(add-sigio-handler (connection-socket-io connection)
(lambda () (process-io-interrupt connection)))
(handle-requests connection t))
(defvar *io-interupt-level* 0)
(defun process-io-interrupt (connection)
(log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
(let ((*io-interupt-level* (1+ *io-interupt-level*)))
(invoke-or-queue-interrupt
(lambda () (handle-requests connection t))))
(log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
(defun deinstall-sigio-handler (connection)
(log-event "deinstall-sigio-handler...~%")
(remove-sigio-handlers (connection-socket-io connection))
(log-event "deinstall-sigio-handler...done~%"))
;;;;;; SERVE-EVENT based IO
(defun install-fd-handler (connection)
(add-fd-handler (connection-socket-io connection)
(lambda () (handle-requests connection t)))
(setf (sconn.saved-sigint-handler connection)
(install-sigint-handler
(lambda ()
(invoke-or-queue-interrupt
(lambda () (dispatch-interrupt-event connection))))))
(handle-requests connection t))
(defun dispatch-interrupt-event (connection)
(with-connection (connection)
(dispatch-event connection `(:emacs-interrupt ,(current-thread-id)))))
(defun deinstall-fd-handler (connection)
(log-event "deinstall-fd-handler~%")
(remove-fd-handlers (connection-socket-io connection))
(install-sigint-handler (sconn.saved-sigint-handler connection)))
;;;;;; Simple sequential IO
(defun simple-serve-requests (connection)
(unwind-protect
(with-connection (connection)
(call-with-user-break-handler
(lambda ()
(invoke-or-queue-interrupt
(lambda () (dispatch-interrupt-event connection))))
(lambda ()
(with-simple-restart (close-connection "Close SLY connection.")
(let* ((stdin (real-input-stream *standard-input*))
(*standard-input* (make-repl-input-stream connection
stdin)))
(tagbody toplevel
(with-top-level-restart (connection (go toplevel))
(simple-repl))))))))
(close-connection connection nil (safe-backtrace))))
;; this is signalled when our custom stream thinks the end-of-file is reached.
;; (not when the end-of-file on the socket is reached)
(define-condition end-of-repl-input (end-of-file) ())
(defun simple-repl ()
(loop
(format t "~a> " (package-string-for-prompt *package*))
(force-output)
(let ((form (handler-case (read)
(end-of-repl-input () (return)))))
(let* ((- form)
(values (multiple-value-list (eval form))))
(setq *** ** ** * * (car values)
/// // // / / values
+++ ++ ++ + + form)
(cond ((null values) (format t "; No values~&"))
(t (mapc (lambda (v) (format t "~s~&" v)) values)))))))
(defun make-repl-input-stream (connection stdin)
(make-input-stream
(lambda () (repl-input-stream-read connection stdin))))
(defun repl-input-stream-read (connection stdin)
(loop
(let* ((socket (connection-socket-io connection))
(inputs (list socket stdin))
(ready (wait-for-input inputs)))
(cond ((eq ready :interrupt)
(check-sly-interrupts))
((member socket ready)
;; A Sly request from Emacs is pending; make sure to
;; redirect IO to the REPL buffer.
(with-simple-restart (process-input "Continue reading input.")
(let ((*sly-db-quit-restart* (find-restart 'process-input)))
(with-default-listener (connection)
(handle-requests connection t)))))
((member stdin ready)
;; User typed something into the *inferior-lisp* buffer,
;; so do not redirect.
(return (read-non-blocking stdin)))
(t (assert (null ready)))))))
(defun read-non-blocking (stream)
(with-output-to-string (str)
(handler-case
(loop (let ((c (read-char-no-hang stream)))
(unless c (return))
(write-char c str)))
(end-of-file () (error 'end-of-repl-input :stream stream)))))
(defvar *sly-features* nil
"The feature list that has been sent to Emacs.")
(defun send-oob-to-emacs (object)
(send-to-emacs object))
(defun force-user-output ()
(with-default-listener (*emacs-connection*)
(force-output *standard-output*)))
(add-hook *pre-reply-hook* 'force-user-output)
(defun clear-user-input ()
(with-default-listener (*emacs-connection*)
(clear-input *standard-input*)))
;; FIXME: not thread safe.
(defvar *tag-counter* 0)
(defun make-tag ()
(setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
(defun y-or-n-p-in-emacs (format-string &rest arguments)
"Like y-or-n-p, but ask in the Emacs minibuffer."
(let ((tag (make-tag))
(question (apply #'format nil format-string arguments)))
(force-output)
(send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
(third (wait-for-event `(:emacs-return ,tag result)))))
(defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
"Ask user a question in Emacs' minibuffer. Returns \"\" when user
entered nothing, returns NIL when user pressed C-g."
(check-type prompt string) (check-type initial-value (or null string))
(let ((tag (make-tag)))
(force-output)
(send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
,prompt ,initial-value))
(third (wait-for-event `(:emacs-return ,tag result)))))
(defun process-form-for-emacs (form)
"Returns a string which emacs will read as equivalent to
FORM. FORM can contain lists, strings, characters, symbols and
numbers.
Characters are converted emacs' ?<char> notaion, strings are left
as they are (except for espacing any nested \" chars, numbers are
printed in base 10 and symbols are printed as their symbol-name
converted to lower case."
(etypecase form
(string (format nil "~S" form))
(cons (format nil "(~A . ~A)"
(process-form-for-emacs (car form))
(process-form-for-emacs (cdr form))))
(character (format nil "?~C" form))
(symbol (concatenate 'string (when (eq (symbol-package form)
#.(find-package "KEYWORD"))
":")
(string-downcase (symbol-name form))))
(number (let ((*print-base* 10))
(princ-to-string form)))))
(defun eval-in-emacs (form &optional nowait)
"Eval FORM in Emacs.
`sly-enable-evaluate-in-emacs' should be set to T on the Emacs side."
(cond (nowait
(send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
(t
(force-output)
(let ((tag (make-tag)))
(send-to-emacs `(:eval ,(current-thread-id) ,tag
,(process-form-for-emacs form)))
(let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
(destructure-case value
((:ok value) value)
((:error kind . data) (error "~a: ~{~a~}" kind data))
((:abort) (abort))))))))
(defun sly-version-string ()
"Return a string identifying the SLY version.
Return nil if nothing appropriate is available."
(let ((this-file #.(or *compile-file-truename* *load-truename*)))
(with-open-file (s (make-pathname :name "sly" :type "el"
:directory (butlast
(pathname-directory this-file)
1)
:defaults this-file))
(let ((seq (make-array 200 :element-type 'character :initial-element #\null)))
(read-sequence seq s :end 200)
(let* ((beg (search ";; Version:" seq))
(end (position #\NewLine seq :start beg))
(middle (position #\Space seq :from-end t :end end)))
(subseq seq (1+ middle) end))))))
(defvar *slynk-wire-protocol-version* (ignore-errors (sly-version-string))
"The version of the slynk/sly communication protocol.")
(defslyfun connection-info ()
"Return a key-value list of the form:
\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
PID: is the process-id of Lisp process (or nil, depending on the STYLE)
STYLE: the communication style
LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION PROGRAM)
FEATURES: a list of keywords
PACKAGE: a list (&key NAME PROMPT)
VERSION: the protocol version"
(let ((c *emacs-connection*))
(setq *sly-features* *features*)
`(:pid ,(getpid) :style ,(connection-communication-style c)
:encoding (:coding-systems
,(loop for cs in '("utf-8-unix" "iso-latin-1-unix")
when (find-external-format cs) collect cs))
:lisp-implementation (:type ,(lisp-implementation-type)
:name ,(lisp-implementation-type-name)
:version ,(lisp-implementation-version)
:program ,(lisp-implementation-program))
:machine (:instance ,(machine-instance)
:type ,(machine-type)
:version ,(machine-version))
:features ,(features-for-emacs)
:modules ,*modules*
:package (:name ,(package-name *package*)
:prompt ,(package-string-for-prompt *package*))
:version ,*slynk-wire-protocol-version*)))
(defun debug-on-slynk-error ()
(assert (eq *debug-on-slynk-protocol-error* *debug-slynk-backend*))
*debug-on-slynk-protocol-error*)
(defun (setf debug-on-slynk-error) (new-value)
(setf *debug-on-slynk-protocol-error* new-value)
(setf *debug-slynk-backend* new-value))
(defslyfun toggle-debug-on-slynk-error ()
(setf (debug-on-slynk-error) (not (debug-on-slynk-error))))
;;;; Reading and printing
(defvar-unbound *buffer-package*
"Package corresponding to sly-buffer-package.
EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a sly
buffer are best read in this package. See also FROM-STRING and TO-STRING.")
(defvar-unbound *buffer-readtable*
"Readtable associated with the current buffer")
(defmacro with-buffer-syntax ((&optional package-designator
readtable)
&body body)
"Conceptually execute BODY inside a SLY Lisp buffer.
Execute BODY with appropriate *PACKAGE* and *READTABLE* bindings.
PACKAGE-DESIGNATOR, if non-NIL, is anything remotely designating a
package. READTABLE, if non-NIL, must verify CL:READTABLEP.
READTABLE defaults to *BUFFER-READTABLE* as set by
GUESS-BUFFER-READTABLE, which in turn uses a mapping in
*READTABLE-ALIST* as indexed by *BUFFER-PACKAGE*, and *not*
PACKAGE-DESIGNATOR.
This should be used for code that is conceptionally executed in an
Emacs buffer."
`(call-with-buffer-syntax ,package-designator ,readtable (lambda () ,@body)))
(defun call-with-buffer-syntax (package readtable fun)
(let ((*package* (if package
(guess-buffer-package package)
*buffer-package*))
(*buffer-readtable* (or (and (readtablep readtable)
readtable)
*buffer-readtable*)))
;; Don't shadow *readtable* unnecessarily because that prevents
;; the user from assigning to it.
(if (eq *readtable* *buffer-readtable*)
(call-with-syntax-hooks fun)
(let ((*readtable* *buffer-readtable*))
(call-with-syntax-hooks fun)))))
(defmacro without-printing-errors ((&key object stream
(msg "<<error printing object>>"))
&body body)
;; JT: Careful when calling this, make sure STREAM, if provided, is
;; a symbol that alwyas designates a non-nil stream. See gh#287.
"Catches errors during evaluation of BODY and prints MSG instead."
`(handler-case (progn ,@body)
(serious-condition ()
,(cond ((and stream object)
(let ((gstream (gensym "STREAM+")))
`(let ((,gstream ,stream))
(print-unreadable-object (,object ,gstream :type t
:identity t)
(write-string ,msg ,gstream)))))
(stream
`(write-string ,msg ,stream))
(object
`(with-output-to-string (s)
(print-unreadable-object (,object s :type t :identity t)
(write-string ,msg s))))
(t msg)))))
(defun to-string (object)
"Write OBJECT in the *BUFFER-PACKAGE*.
The result may not be readable. Handles problems with PRINT-OBJECT methods
gracefully."
(with-buffer-syntax ()
(let ((*print-readably* nil))
(without-printing-errors (:object object :stream nil)
(prin1-to-string object)))))
(defun from-string (string)
"Read string in the *BUFFER-PACKAGE*"
(with-buffer-syntax ()
(let ((*read-suppress* nil))
(values (read-from-string string)))))
(defun parse-string (string package)
"Read STRING in PACKAGE."
(with-buffer-syntax (package)
(let ((*read-suppress* nil))
(read-from-string string))))
;; FIXME: deal with #\| etc. hard to do portably.
(defun tokenize-symbol (string)
"STRING is interpreted as the string representation of a symbol
and is tokenized accordingly. The result is returned in three
values: The package identifier part, the actual symbol identifier
part, and a flag if the STRING represents a symbol that is
internal to the package identifier part. (Notice that the flag is
also true with an empty package identifier part, as the STRING is
considered to represent a symbol internal to some current package.)"
(let ((package (let ((pos (position #\: string)))
(if pos (subseq string 0 pos) nil)))
(symbol (let ((pos (position #\: string :from-end t)))
(if pos (subseq string (1+ pos)) string)))
(internp (not (= (count #\: string) 1))))
(values symbol package internp)))
(defun tokenize-symbol-thoroughly (string)
"This version of TOKENIZE-SYMBOL handles escape characters."
(let ((package nil)
(token (make-array (length string) :element-type 'character
:fill-pointer 0))
(backslash nil)
(vertical nil)
(internp nil)
(caser (char-casifier string)))
(loop for char across string do
(cond
(backslash
(vector-push-extend char token)
(setq backslash nil))
((char= char #\\) ; Quotes next character, even within |...|
(setq backslash t))
((char= char #\|)
(setq vertical (not vertical)))
(vertical
(vector-push-extend char token))
((char= char #\:)
(cond ((and package internp)
(return-from tokenize-symbol-thoroughly))
(package
(setq internp t))
(t
(setq package token
token (make-array (length string)
:element-type 'character
:fill-pointer 0)))))
(t
(vector-push-extend (funcall caser char) token))))
(unless vertical
(values token package (or (not package) internp)))))
(defun untokenize-symbol (package-name internal-p symbol-name)
"The inverse of TOKENIZE-SYMBOL.
(untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
(untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
(untokenize-symbol nil nil \"foo\") ==> \"foo\"
"
(cond ((not package-name) symbol-name)
(internal-p (cat package-name "::" symbol-name))
(t (cat package-name ":" symbol-name))))
(defun char-casifier (string)
"Return a function which converts characters in STRING according to `readtable-case'."
(ecase (readtable-case *readtable*)
(:preserve #'identity)
(:upcase #'char-upcase)
(:downcase #'char-downcase)
;; :invert only inverts the case if every character of a token is the same
;; case, otherwise it acts like :preserve.
(:invert (let ((upper (count-if #'upper-case-p string)))
(cond ((= upper 0) #'char-upcase)
((= upper (length string)) #'char-downcase)
(t #'identity))))))
(defun find-symbol-with-status (symbol-name status
&optional (package *package*))
(multiple-value-bind (symbol flag) (find-symbol symbol-name package)
(if (and flag (eq flag status))
(values symbol flag)
(values nil nil))))
(defun parse-symbol (string &optional (package *package*))
"Find the symbol named STRING.
Return the symbol and a flag indicating whether the symbols was found."
(multiple-value-bind (sname pname internalp)
(tokenize-symbol-thoroughly string)
(when sname
(let ((package (cond ((string= pname "") +keyword-package+)
(pname (find-package pname))
(t package))))
(if package
(multiple-value-bind (symbol flag)
(if internalp
(find-symbol sname package)
(find-symbol-with-status sname ':external 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)
(if status
(values symbol status)
(error "Unknown symbol: ~A [in ~A]" string package))))
(defun parse-package (string)
"Find the package named STRING.
Return the package or nil."
;; STRING comes usually from a (in-package STRING) form.
(ignore-errors
(find-package (let ((*package* *slynk-io-package*))
(read-from-string string)))))
(defun unparse-name (string)
"Print the name STRING according to the current printer settings."
;; this is intended for package or symbol names
(subseq (prin1-to-string (make-symbol string)) 2))
(defun guess-package (string)
"Guess which package corresponds to STRING.
Return nil if no package matches."
(when string
(or (find-package string)
(parse-package string)
(if (find #\! string) ; for SBCL
(guess-package (substitute #\- #\! string))))))
(defvar *readtable-alist* (default-readtable-alist)
"An alist mapping package names to readtables.")
(defun guess-buffer-readtable (package-name)
(let ((package (guess-package package-name)))
(or (and package
(cdr (assoc (package-name package) *readtable-alist*
:test #'string=)))
*readtable*)))
;;;; Evaluation
(defvar *pending-continuations* '()
"List of continuations for Emacs. (thread local)")
(defun guess-buffer-package (string)
"Return a package for STRING.
Fall back to the current if no such package exists."
(or (and string (guess-package string))
*package*))
(defvar *eval-for-emacs-wrappers* nil
"List of functions for fine-grained control over form evaluation.
Each element must be a function taking an arbitrary number of
arguments, the first of which is a function of no arguments, call it
IN-FUNCTION, while the remaining are bound to the EXTRA-REX-OPTIONS
parameter of EVAL-FOR-EMACS. Every function *must* return another
function of no arguments, call it OUT-FUNCTION, that, when called,
*must* call IN-FUNCTION in whatever dynamic environment it sees fit.
Slynk will go through the elements of this variable in order, passing
a function that evaluates the form coming from Emacs to the first
element until it collects the result of the last, which is finally
called with no arguments.
Be careful when changing this variable since you may mess very basic
functionality of your Slynk, including the ability to correct any
errors you make.")
(defun eval-for-emacs (form buffer-package id &rest extra-rex-options)
"Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
Return the result to the continuation ID. Errors are trapped and
invoke our debugger. EXTRA-REX-OPTIONS are passed to the functions of
*EVAL-FOR-EMACS-WRAPPERS*, which see."
(let (ok result condition)
(unwind-protect
(let ((*buffer-package* (guess-buffer-package buffer-package))
(*buffer-readtable* (guess-buffer-readtable buffer-package))
(*pending-continuations* (cons id *pending-continuations*)))
(check-type *buffer-package* package)
(check-type *buffer-readtable* readtable)
(handler-bind ((t (lambda (c) (setf condition c))))
(setq result (with-sly-interrupts
(flet ((eval-it ()
;; APPLY would be cleaner than EVAL.
;; (setq result (apply (car form) (cdr form)))
(eval form)))
;; Honour *EVAL-FOR-EMACS-WRAPPERS*
;;
(loop for lambda = #'eval-it then
(handler-case
(apply wrapper lambda extra-rex-options)
(error (e)
(warn "~s ignoring wrapper ~a (~a)"
'eval-for-emacs wrapper e)
lambda))
for wrapper in *eval-for-emacs-wrappers*
finally (return (funcall lambda)))))))
(run-hook *pre-reply-hook*)
(setq ok t))
(send-to-emacs `(:return ,(current-thread)
,(if ok
`(:ok ,result)
`(:abort ,(prin1-to-string condition)))
,id)))))
(defun format-integer-length (i) (format nil "~a bit~:p" (integer-length i)))
(defun format-integer-as-hex (i)
(unless (or (minusp i) (> (integer-length i) 64)) (format nil "#x~X" i)))
(defun format-integer-as-octal (i)
(unless (or (minusp i) (> (integer-length i) 8)) (format nil "#o~O" i)))
(defun format-integer-as-binary (i) -128
(unless (or (minusp i) (> (integer-length i) 8)) (format nil "#b~B" i)))
(defun format-ratio-as-float (r) (ignore-errors (format nil "~f" r)))
(defun format-as-percentage-maybe (f) (when (< 0 (abs f) 2) (format nil "~2,'0d%" (* f 100))))
(defparameter *echo-number-alist*
'((integer . (format-integer-length format-integer-as-hex format-integer-as-octal format-integer-as-binary))
(ratio . (format-ratio-as-float format-as-percentage-maybe))
(float . (format-as-percentage-maybe)))
"Alist of functions used for presenting numbers in the echo area.
Each element takes the form (TYPE . FUNCTIONS), where TYPE is a type
designator and FUNCTIONS is a list of function designators for
displaying that number in SLY. Each function takes the number as a
single argument and returns a string, or nil, if that particular
representation is to be disregarded.
Additionally if a given function chooses to return t as its optional
second value, then all the remaining functions following it in the
list are disregarded.")
(defparameter *present-number-alist* nil
"Alist of functions used for presenting numbers the REPL.
This is an \"override\". If nil the (the alist is empty) the value of
*ECHO-NUMBER-ALIST* is used, otherwise the structure is exactly the
same as that variable.")
(defun present-number-considering-alist (number alist)
(let* ((functions (cdr (assoc number alist :test #'typep)))
(extra-presentations
(loop for fn in functions
for (display skip)
= (multiple-value-list
(handler-case
(funcall fn number)
(error (e)
(declare (ignore e))
"<error echoing>")))
when display collect it
until skip)))
(if extra-presentations
(format nil "~A (~{~a~^, ~})"
number extra-presentations)
(format nil "~A" number))))
(defun echo-for-emacs (values &optional (fn #'slynk-pprint))
"Format VALUES in a way suitable to be echoed in the SLY client.
May insert newlines between each of VALUES. Considers
*ECHO-NUMBER-ALIST*."
(let ((*print-readably* nil))
(cond ((null values) "; No value")
((and (numberp (car values))
(null (cdr values)))
(present-number-considering-alist (car values) *echo-number-alist*))
(t
(let ((strings (loop for v in values
collect (funcall fn v))))
(if (some #'(lambda (s) (find #\Newline s))
strings)
(format nil "~{~a~^~%~}" strings)
(format nil "~{~a~^, ~}" strings)))))))
(defun present-for-emacs (value &optional (fn #'slynk-pprint))
"Format VALUE in a way suitable to be displayed in the SLY client.
FN is only used if value is not a number"
(if (numberp value)
(present-number-considering-alist value (or *present-number-alist*
*echo-number-alist*))
(funcall fn value)))
(defslyfun interactive-eval (string)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLY interactive evaluation request.")
(let ((values (multiple-value-list (eval (from-string string)))))
(finish-output)
(echo-for-emacs values)))))
(defslyfun eval-and-grab-output (string)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLY evaluation request.")
(let* ((s (make-string-output-stream))
(*standard-output* s)
(values (multiple-value-list (eval (from-string string)))))
(list (get-output-stream-string s)
(echo-for-emacs values))))))
(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)
(finish-output)
(return (values values -)))
(setq - form)
(setq values (multiple-value-list (eval form)))
(finish-output))))))
(defslyfun interactive-eval-region (string)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLY interactive evaluation request.")
(echo-for-emacs (eval-region string)))))
(defslyfun re-evaluate-defvar (form)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLY evaluation request.")
(let ((form (read-from-string form)))
(destructuring-bind (dv name &optional value doc) form
(declare (ignore value doc))
(assert (eq dv 'defvar))
(makunbound name)
(prin1-to-string (eval form)))))))
(defvar-unbound *string-elision-length*
"Maximum length of a sring before elision by SLYNK-PPRINT.")
(defparameter *slynk-pprint-bindings*
`((*print-pretty* . t)
(*print-level* . nil)
(*print-length* . nil)
(*string-elision-length* . 200)
(*print-circle* . nil)
(*print-gensym* . t)
(*print-readably* . nil))
"A list of variables bindings during pretty printing.
Used by pprint-eval.")
(defun slynk-pprint (object &key (stream nil))
"Pretty print OBJECT to STREAM using *SLYNK-PPRINT-BINDINGS*.
If STREAM is nil, use a string"
(with-bindings *slynk-pprint-bindings*
;; a failsafe for *PRINT-LENGTH* and *PRINT-LEVEL*: if they're NIL
;; and *PRINT-CIRCLE* is also nil we could be in trouble printing
;; recursive structures.
;;
(let ((*print-length* (or *print-length*
(and (not *print-circle*) 512)))
(*print-level* (or *print-level*
(and (not *print-circle*) 20))))
(flet ((write-it (s)
(cond ((and *string-elision-length*
(stringp object)
(> (length object) *string-elision-length*))
(format s "\"~a...[sly-elided string of length ~a]\""
(subseq object 0 *string-elision-length*)
(length object)))
(t
(write object :stream s :pretty t :escape t)))))
(if stream
(without-printing-errors (:object object :stream stream)
(write-it stream))
(without-printing-errors (:object object)
(with-output-to-string (s) (write-it s))))))))
(defun slynk-pprint-values (values &key (stream nil))
"Pretty print each of VALUES to STREAM using *SLYNK-PPRINT-BINDINGS*.
Separated by a newline. If no values indicate that in a comment.
If STREAM is nil, use a string"
(labels ((print-one (object s)
(let ((*slynk-pprint-bindings* nil))
(slynk-pprint object :stream s)))
(print-all (s)
(loop for o in values
do (print-one o s)
(terpri))))
(with-bindings *slynk-pprint-bindings*
(cond ((null values)
(format stream "; No value"))
(t
(if stream
(print-all stream)
(with-output-to-string (s)
(print-all s))))))))
(defun slynk-pprint-to-line (object)
"Print OBJECT to a single line string and return it."
(let ((*slynk-pprint-bindings*
`((*print-lines* . 1)
(*print-right-margin* . 512)
,@*slynk-pprint-bindings*)))
(substitute #\Space #\Newline (slynk-pprint object :stream nil))))
(defslyfun pprint-eval (string)
(with-buffer-syntax ()
(let* ((s (make-string-output-stream))
(values
(let ((*standard-output* s)
(*trace-output* s))
(multiple-value-list (eval (read-from-string string))))))
(cat (get-output-stream-string s)
(slynk-pprint-values values)))))
(defslyfun set-package (name)
"Set *package* to the package named NAME.
Return the full package-name and the string to use in the prompt."
(let ((p (guess-package name)))
(assert (packagep p) nil "Package ~a doesn't exist." name)
(setq *package* p)
(list (package-name p) (package-string-for-prompt p))))
(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 truncate-string (string width &optional ellipsis)
(let ((len (length string)))
(cond ((< len width) string)
(ellipsis (cat (subseq string 0 width) ellipsis))
(t (subseq string 0 width)))))
(defun call/truncated-output-to-string (length function
&optional (ellipsis ".."))
"Call FUNCTION with a new stream, return the output written to the stream.
If FUNCTION tries to write more than LENGTH characters, it will be
aborted and return immediately with the output written so far."
(let ((buffer (make-string (+ length (length ellipsis))))
(fill-pointer 0))
(block buffer-full
(flet ((write-output (string)
(let* ((free (- length fill-pointer))
(count (min free (length string))))
(replace buffer string :start1 fill-pointer :end2 count)
(incf fill-pointer count)
(when (> (length string) free)
(replace buffer ellipsis :start1 fill-pointer)
(return-from buffer-full buffer)))))
(let ((stream (make-output-stream #'write-output)))
(funcall function stream)
(finish-output stream)
(subseq buffer 0 fill-pointer))))))
(defmacro with-string-stream ((var &key length bindings)
&body body)
(cond ((and (not bindings) (not length))
`(with-output-to-string (,var) . ,body))
((not bindings)
`(call/truncated-output-to-string
,length (lambda (,var) . ,body)))
(t
`(with-bindings ,bindings
(with-string-stream (,var :length ,length)
. ,body)))))
(defun escape-string (string stream &key length (map '((#\" . "\\\"")
(#\\ . "\\\\"))))
"Write STRING to STREAM surronded by double-quotes.
LENGTH -- if non-nil truncate output after LENGTH chars.
MAP -- rewrite the chars in STRING according to this alist."
(let ((limit (or length array-dimension-limit)))
(write-char #\" stream)
(loop for c across string
for i from 0 do
(when (= i limit)
(write-string "..." stream)
(return))
(let ((probe (assoc c map)))
(cond (probe (write-string (cdr probe) stream))
(t (write-char c stream)))))
(write-char #\" stream)))
;;;; Prompt
;; FIXME: do we really need 45 lines of code just to figure out the
;; prompt?
(defvar *canonical-package-nicknames*
`((:common-lisp-user . :cl-user))
"Canonical package names to use instead of shortest name/nickname.")
(defvar *auto-abbreviate-dotted-packages* t
"Abbreviate dotted package names to their last component if T.")
(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*
(loop with package-name = (package-name package)
with offset = nil
do (let ((last-dot-pos (position #\. package-name :end offset
:from-end t)))
(unless last-dot-pos
(return nil))
;; If a dot chunk contains only numbers, that chunk most
;; likely represents a version number; so we collect the
;; next chunks, too, until we find one with meat.
(let ((name (subseq package-name (1+ last-dot-pos) offset)))
(if (notevery #'digit-char-p name)
(return (subseq package-name (1+ last-dot-pos)))
(setq offset last-dot-pos)))))))
(defun shortest-package-nickname (package)
"Return the shortest nickname 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)))
(defslyfun ed-in-emacs (&optional what)
"Edit WHAT in Emacs.
WHAT can be:
A pathname or a string,
A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION),
A function name (symbol or cons),
NIL. "
(flet ((canonicalize-filename (filename)
(pathname-to-filename (or (probe-file filename) filename))))
(let ((target
(etypecase what
(null nil)
((or string pathname)
`(:filename ,(canonicalize-filename what)))
((cons (or string pathname) *)
`(:filename ,(canonicalize-filename (car what)) ,@(cdr what)))
((or symbol cons)
`(:function-name ,(prin1-to-string what))))))
(cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
((default-connection)
(with-connection ((default-connection))
(send-oob-to-emacs `(:ed ,target))))
(t (error "No connection"))))))
(defslyfun inspect-in-emacs (what &key wait)
"Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the
inspector has been closed in Emacs."
(flet ((send-it ()
(let ((tag (when wait (make-tag)))
(thread (when wait (current-thread-id))))
(with-buffer-syntax ()
(reset-inspector)
(send-oob-to-emacs `(:inspect ,(inspect-object what)
,thread
,tag)))
(when wait
(wait-for-event `(:emacs-return ,tag result))))))
(cond
(*emacs-connection*
(send-it))
((default-connection)
(with-connection ((default-connection))
(send-it))))
what))
(defslyfun value-for-editing (form)
"Return a readable value of FORM for editing in Emacs.
FORM is expected, but not required, to be SETF'able."
;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
(with-buffer-syntax ()
(let* ((value (eval (read-from-string form)))
(*print-length* nil))
(prin1-to-string value))))
(defslyfun commit-edited-value (form value)
"Set the value of a setf'able FORM to VALUE.
FORM and VALUE are both strings from Emacs."
(with-buffer-syntax ()
(eval `(setf ,(read-from-string form)
,(read-from-string (concatenate 'string "`" value))))
t))
(defun background-message (format-string &rest args)
"Display a message in Emacs' echo area.
Use this function for informative messages only. The message may even
be dropped if we are too busy with other things."
(when *emacs-connection*
(send-to-emacs `(:background-message
,(apply #'format nil format-string args)))))
;; This is only used by the test suite.
(defun sleep-for (seconds)
"Sleep for at least SECONDS seconds.
This is just like cl:sleep but guarantees to sleep
at least SECONDS."
(let* ((start (get-internal-real-time))
(end (+ start
(* seconds internal-time-units-per-second))))
(loop
(let ((now (get-internal-real-time)))
(cond ((< end now) (return))
(t (sleep (/ (- end now)
internal-time-units-per-second))))))))
;;;; Debugger
(defun invoke-sly-debugger (condition)
"Sends a message to Emacs declaring that the debugger has been entered,
then waits to handle further requests from Emacs. Eventually returns
after Emacs causes a restart to be invoked."
(without-sly-interrupts
(cond (*emacs-connection*
(debug-in-emacs condition))
((default-connection)
(with-connection ((default-connection))
(debug-in-emacs condition))))))
(define-condition invoke-default-debugger () ())
(defun slynk-debugger-hook (condition hook)
"Debugger function for binding *DEBUGGER-HOOK*."
(declare (ignore hook))
(handler-case
(call-with-debugger-hook #'slynk-debugger-hook
(lambda () (invoke-sly-debugger condition)))
(invoke-default-debugger ()
(invoke-default-debugger condition))))
(defun invoke-default-debugger (condition)
(call-with-debugger-hook nil (lambda () (invoke-debugger condition))))
(defvar *global-debugger* t
"Non-nil means the Slynk debugger hook will be installed globally.")
(add-hook *new-connection-hook* 'install-debugger)
(defun install-debugger (connection)
(declare (ignore connection))
(when *global-debugger*
(install-debugger-globally #'slynk-debugger-hook)))
;;;;; Debugger loop
;;;
;;; These variables are dynamically bound during debugging.
;;;
(defvar *slynk-debugger-condition* nil
"The condition being debugged.")
(defvar *sly-db-level* 0
"The current level of recursive debugging.")
(defvar *sly-db-initial-frames* 20
"The initial number of backtrace frames to send to Emacs.")
(defvar *sly-db-restarts* nil
"The list of currenlty active restarts.")
(defvar *sly-db-stepping-p* nil
"True during execution of a step command.")
(defun debug-in-emacs (condition)
(let ((*slynk-debugger-condition* condition)
(*sly-db-restarts* (compute-restarts condition))
(*sly-db-quit-restart* (and *sly-db-quit-restart*
(find-restart *sly-db-quit-restart*
condition)))
(*package* (or (and (boundp '*buffer-package*)
(symbol-value '*buffer-package*))
*package*))
(*sly-db-level* (1+ *sly-db-level*))
(*sly-db-stepping-p* nil))
(force-user-output)
(call-with-debugging-environment
(lambda ()
(sly-db-loop *sly-db-level*)))))
(defun sly-db-loop (level)
(unwind-protect
(loop
(with-simple-restart (abort "Return to sly-db level ~D." level)
(send-to-emacs
(list* :debug (current-thread-id) level
(debugger-info-for-emacs 0 *sly-db-initial-frames*)))
(send-to-emacs
(list :debug-activate (current-thread-id) level))
(loop
(handler-case
(destructure-case (wait-for-event
`(or (:emacs-rex . _)
(:emacs-channel-send . _)
(:sly-db-return ,(1+ level))))
((:emacs-rex &rest args) (apply #'eval-for-emacs args))
((:emacs-channel-send channel (selector &rest args))
(channel-send channel selector args))
((:sly-db-return _) (declare (ignore _)) (return nil)))
(sly-db-condition (c)
(handle-sly-db-condition c))))))
(send-to-emacs `(:debug-return
,(current-thread-id) ,level ,*sly-db-stepping-p*))
(wait-for-event `(:sly-db-return ,(1+ level)) t) ; clean event-queue
(when (> level 1)
(send-event (current-thread) `(:sly-db-return ,level)))))
(defun handle-sly-db-condition (condition)
"Handle an internal debugger condition.
Rather than recursively debug the debugger (a dangerous idea!), these
conditions are simply reported."
(let ((real-condition (original-condition condition)))
(send-to-emacs `(:debug-condition ,(current-thread-id)
,(princ-to-string real-condition)))))
(defun %%condition-message (condition)
(let ((limit (ash 1 16)))
(with-string-stream (stream :length limit)
(handler-case
(let ((*print-readably* nil)
(*print-pretty* t)
(*print-right-margin* 65)
(*print-circle* t)
(*print-length* (or *print-length* limit))
(*print-level* (or *print-level* limit))
(*print-lines* (or *print-lines* limit)))
(print-condition condition stream))
(serious-condition (c)
(ignore-errors
(with-standard-io-syntax
(let ((*print-readably* nil))
(format stream "~&Error (~a) printing the following condition: " (type-of c))
(print-unreadable-object (condition stream :type t
:identity t))))))))))
(defun %condition-message (condition)
(string-trim #(#\newline #\space #\tab)
(%%condition-message condition)))
(defvar *sly-db-condition-printer* #'%condition-message
"Function called to print a condition to an SLY-DB buffer.")
(defun safe-condition-message (condition)
"Print condition to a string, handling any errors during printing."
(funcall *sly-db-condition-printer* condition))
(defvar *debugger-extra-options* nil
;; JT@15/08/24: FIXME: Actually, with a nice and proper method-combination for
;; interfaces (as was once quite bravely attempted by Helmut, this variable
;; could go away and contribs could simply add methods to CONDITION-EXTRAS)
;;
"A property list of extra options describing a condition.
This works much like the CONDITION-EXTRAS interface, but can be
dynamically bound by contribs when invoking the debugger.")
(defun debugger-condition-for-emacs ()
(list (safe-condition-message *slynk-debugger-condition*)
(format nil " [Condition of type ~S]"
(type-of *slynk-debugger-condition*))
(append (condition-extras *slynk-debugger-condition*)
*debugger-extra-options*)))
(defun format-restarts-for-emacs ()
"Return a list of restarts for *slynk-debugger-condition* in a
format suitable for Emacs."
(let ((*print-right-margin* most-positive-fixnum))
(loop for restart in *sly-db-restarts* collect
(list (format nil "~:[~;*~]~a"
(eq restart *sly-db-quit-restart*)
(restart-name restart))
(with-output-to-string (stream)
(without-printing-errors (:object restart
:stream stream
:msg "<<error printing restart>>")
(princ restart stream)))))))
;;;;; SLY-DB entry points
(defslyfun sly-db-break-with-default-debugger (dont-unwind)
"Invoke the default debugger."
(cond (dont-unwind
(invoke-default-debugger *slynk-debugger-condition*))
(t
(signal 'invoke-default-debugger))))
(defslyfun backtrace (start end)
"Return a list ((I FRAME PLIST) ...) of frames from START to END.
I is an integer, and can be used to reference the corresponding frame
from Emacs; FRAME is a string representation of an implementation's
frame."
(loop for frame in (compute-backtrace start end)
for i from start collect
(list* i (frame-to-string frame)
(ecase (frame-restartable-p frame)
((nil) nil)
((t) `((:restartable t)))))))
(defun frame-to-string (frame)
(with-string-stream (stream :length (* (or *print-lines* 1)
(or *print-right-margin* 100))
:bindings *backtrace-printer-bindings*)
(handler-case (print-frame frame stream)
(serious-condition ()
(format stream "[error printing frame]")))))
(defslyfun debugger-info-for-emacs (start end)
"Return debugger state, with stack frames from START to END.
The result is a list:
(condition ({restart}*) ({stack-frame}*) (cont*))
where
condition ::= (description type [extra])
restart ::= (name description)
stack-frame ::= (number description [plist])
extra ::= (:references and other random things)
cont ::= continuation
plist ::= (:restartable {nil | t | :unknown})
condition---a pair of strings: message, and type. If show-source is
not nil it is a frame number for which the source should be displayed.
restart---a pair of strings: restart name, and description.
stack-frame---a number from zero (the top), and a printed
representation of the frame's call.
continuation---the id of a pending Emacs continuation.
Below is an example return value. In this case the condition was a
division by zero (multi-line description), and only one frame is being
fetched (start=0, end=1).
((\"Arithmetic error DIVISION-BY-ZERO signalled.
Operation was KERNEL::DIVISION, operands (1 0).\"
\"[Condition of type DIVISION-BY-ZERO]\")
((\"ABORT\" \"Return to Sly toplevel.\")
(\"ABORT\" \"Return to Top-Level.\"))
((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil)))
(4))"
(list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace start end)
*pending-continuations*))
(defun nth-restart (index)
(nth index *sly-db-restarts*))
(defslyfun invoke-nth-restart (index)
(let ((restart (nth-restart index)))
(when restart
(let* ((prompt nil)
(*query-io*
(make-two-way-stream
(make-input-stream
(lambda ()
(format nil "~a~%"
(read-from-minibuffer-in-emacs
(format nil "~a" (or prompt
"[restart prompt] :"))))))
(make-output-stream
#'(lambda (s)
(setq prompt
(concatenate 'string
(or prompt "")
s)))))))
(invoke-restart-interactively restart)))))
(defslyfun sly-db-abort ()
(invoke-restart (find 'abort *sly-db-restarts* :key #'restart-name)))
(defslyfun sly-db-continue ()
(continue))
(defun coerce-to-condition (datum args)
(etypecase datum
(string (make-condition 'simple-error :format-control datum
:format-arguments args))
(symbol (apply #'make-condition datum args))))
(defslyfun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
(with-simple-restart (continue "Continue from break.")
(invoke-sly-debugger (coerce-to-condition datum args))))
;; FIXME: (last (compute-restarts)) looks dubious.
(defslyfun throw-to-toplevel ()
"Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
If we are not evaluating an RPC then ABORT instead."
(let ((restart (or (and *sly-db-quit-restart*
(find-restart *sly-db-quit-restart*))
(car (last (compute-restarts))))))
(cond (restart (invoke-restart restart))
(t (format nil "Restart not active [~s]" *sly-db-quit-restart*)))))
(defslyfun invoke-nth-restart-for-emacs (sly-db-level n)
"Invoke the Nth available restart.
SLY-DB-LEVEL is the debug level when the request was made. If this
has changed, ignore the request."
(when (= sly-db-level *sly-db-level*)
(invoke-nth-restart n)))
(defun wrap-sly-db-vars (form)
`(let ((*sly-db-level* ,*sly-db-level*))
,form))
(defun eval-in-frame-aux (frame string package print)
(let* ((form (wrap-sly-db-vars (parse-string string package)))
(values (multiple-value-list (eval-in-frame form frame))))
(with-buffer-syntax (package)
(funcall print values))))
(defslyfun eval-string-in-frame (string frame package)
(eval-in-frame-aux frame string package #'echo-for-emacs))
(defslyfun pprint-eval-string-in-frame (string frame package)
(eval-in-frame-aux frame string package #'slynk-pprint-values))
(defslyfun frame-package-name (frame)
(let ((pkg (frame-package frame)))
(cond (pkg (package-name pkg))
(t (with-buffer-syntax () (package-name *package*))))))
(defslyfun frame-locals-and-catch-tags (index)
"Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX.
LOCALS is a list of the form ((&key NAME ID VALUE) ...).
TAGS has is a list of strings."
(list (frame-locals-for-emacs index)
(mapcar #'to-string (frame-catch-tags index))))
(defun frame-locals-for-emacs (index)
(loop for var in (frame-locals index)
collect
(destructuring-bind (&key name id value) var
(list :name (let ((*package* (or (frame-package index) *package*)))
(prin1-to-string name))
:id id
:value
(let ((*slynk-pprint-bindings*
(append *slynk-pprint-bindings*
*backtrace-printer-bindings*)))
(slynk-pprint value))))))
(defslyfun sly-db-disassemble (index)
(with-output-to-string (*standard-output*)
(disassemble-frame index)))
(defslyfun sly-db-return-from-frame (index string)
(let ((form (from-string string)))
(to-string (multiple-value-list (return-from-frame index form)))))
(defslyfun sly-db-break (name)
(with-buffer-syntax ()
(sly-db-break-at-start (read-from-string name))))
(defmacro define-stepper-function (name backend-function-name)
`(defslyfun ,name (frame)
(cond ((sly-db-stepper-condition-p *slynk-debugger-condition*)
(setq *sly-db-stepping-p* t)
(,backend-function-name))
((find-restart 'continue)
(activate-stepping frame)
(setq *sly-db-stepping-p* t)
(continue))
(t
(error "Not currently single-stepping, ~
and no continue restart available.")))))
(define-stepper-function sly-db-step sly-db-step-into)
(define-stepper-function sly-db-next sly-db-step-next)
(define-stepper-function sly-db-out sly-db-step-out)
(defslyfun toggle-break-on-signals ()
(setq *break-on-signals* (not *break-on-signals*))
(format nil "*break-on-signals* = ~a" *break-on-signals*))
(defslyfun sdlb-print-condition ()
(princ-to-string *slynk-debugger-condition*))
;;;; Compilation Commands.
(defstruct (compilation-result (:type list))
(type :compilation-result)
notes
(successp nil :type boolean)
(duration 0.0 :type float)
(loadp nil :type boolean)
(faslfile nil :type (or null string)))
(defun measure-time-interval (fun)
"Call FUN and return the first return value and the elapsed time.
The time is measured in seconds."
(declare (type function fun))
(let ((before (get-internal-real-time))) ;
(values
(funcall fun)
(/ (- (get-internal-real-time) before)
(coerce internal-time-units-per-second 'float)))))
(defun make-compiler-note (condition)
"Make a compiler note data structure from a compiler-condition."
(declare (type compiler-condition condition))
(list* :message (message condition)
:severity (severity condition)
:location (location condition)
:references (references condition)
(let ((s (source-context condition)))
(if s (list :source-context s)))))
(defun collect-notes (function)
(let ((notes '()))
(multiple-value-bind (result seconds)
(handler-bind ((compiler-condition
(lambda (c) (push (make-compiler-note c) notes))))
(measure-time-interval
(lambda ()
;; To report location of error-signaling toplevel forms
;; for errors in EVAL-WHEN or during macroexpansion.
(restart-case (multiple-value-list (funcall function))
(abort () :report "Abort compilation." (list nil))))))
(destructuring-bind (successp &optional loadp faslfile) result
(let ((faslfile (etypecase faslfile
(null nil)
(pathname (pathname-to-filename faslfile)))))
(make-compilation-result :notes (reverse notes)
:duration seconds
:successp (if successp t)
:loadp (if loadp t)
:faslfile faslfile))))))
(defun slynk-compile-file* (pathname load-p &rest options &key policy
&allow-other-keys)
(multiple-value-bind (output-pathname warnings? failure?)
(slynk-compile-file pathname
(fasl-pathname pathname options)
nil
(or (guess-external-format pathname)
:default)
:policy policy)
(declare (ignore warnings?))
(values t (not failure?) load-p output-pathname)))
(defvar *compile-file-for-emacs-hook* '(slynk-compile-file*))
(defslyfun compile-file-for-emacs (filename load-p &rest options)
"Compile FILENAME and, when LOAD-P, load the result.
Record compiler notes signalled as `compiler-condition's."
(with-buffer-syntax ()
(collect-notes
(lambda ()
(let ((pathname (filename-to-pathname filename))
(*compile-print* nil)
(*compile-verbose* t))
(loop for hook in *compile-file-for-emacs-hook*
do
(multiple-value-bind (tried success load? output-pathname)
(apply hook pathname load-p options)
(when tried
(return (values success load? output-pathname))))))))))
;; FIXME: now that *compile-file-for-emacs-hook* is there this is
;; redundant and confusing.
(defvar *fasl-pathname-function* nil
"In non-nil, use this function to compute the name for fasl-files.")
(defun pathname-as-directory (pathname)
(append (pathname-directory pathname)
(when (pathname-name pathname)
(list (file-namestring pathname)))))
(defun compile-file-output (file directory)
(make-pathname :directory (pathname-as-directory directory)
:defaults (compile-file-pathname file)))
(defun fasl-pathname (input-file options)
(cond (*fasl-pathname-function*
(funcall *fasl-pathname-function* input-file options))
((getf options :fasl-directory)
(let ((dir (getf options :fasl-directory)))
(assert (char= (aref dir (1- (length dir))) #\/))
(compile-file-output input-file dir)))
(t
(compile-file-pathname input-file))))
(defslyfun compile-string-for-emacs (string buffer position filename policy)
"Compile STRING (exerpted from BUFFER at POSITION).
Record compiler notes signalled as `compiler-condition's."
(let* ((offset (cadr (assoc :position position)))
(line-column (cdr (assoc :line position)))
(line (first line-column))
(column (second line-column)))
(with-buffer-syntax ()
(collect-notes
(lambda ()
(let ((*compile-print* nil)
(*compile-verbose* nil)
(*load-verbose* nil))
(slynk-compile-string string
:buffer buffer
:position offset
:filename filename
:line line
:column column
:policy policy)))))))
(defslyfun compile-multiple-strings-for-emacs (strings policy)
"Compile STRINGS (exerpted from BUFFER at POSITION).
Record compiler notes signalled as `compiler-condition's."
(loop for (string buffer package position filename) in strings collect
(collect-notes
(lambda ()
(with-buffer-syntax (package)
(let ((*compile-print* t) (*compile-verbose* nil))
(slynk-compile-string string
:buffer buffer
:position position
:filename filename
:policy policy)))))))
(defun file-newer-p (new-file old-file)
"Returns true if NEW-FILE is newer than OLD-FILE."
(> (file-write-date new-file) (file-write-date old-file)))
(defun requires-compile-p (source-file)
(let ((fasl-file (probe-file (compile-file-pathname source-file))))
(or (not fasl-file)
(file-newer-p source-file fasl-file))))
(defslyfun compile-file-if-needed (filename loadp)
(let ((pathname (filename-to-pathname filename)))
(cond ((requires-compile-p pathname)
(compile-file-for-emacs pathname loadp))
(t
(collect-notes
(lambda ()
(or (not loadp)
(load (compile-file-pathname pathname)))))))))
;;;; Loading
(defslyfun load-file (filename)
(to-string (load (filename-to-pathname filename))))
;;;;; slynk-require
(defvar *module-loading-method* (find-if #'find-package '(:slynk-loader :asdf))
"Keyword naming the module-loading method.
SLY's own `slynk-loader.lisp' is tried first, then ASDF")
(defvar *asdf-load-in-progress* nil
"Set to t if inside a \"ASDF:LOAD-SYSTEM\" operation.
Introduced to prevent problematic recursive ASDF loads, but going away
soon once non-ASDF loading is removed. (see github#134)")
(defgeneric require-module (method module)
(:documentation
"Use METHOD to load MODULE.
Receives a module name as argument and should return non-nil if it
managed to load it.")
(:method ((method (eql :slynk-loader)) module)
(funcall (intern "REQUIRE-MODULE" :slynk-loader) module))
(:method ((method (eql :asdf)) module)
(unless *asdf-load-in-progress*
(let ((*asdf-load-in-progress* t))
(funcall (intern "LOAD-SYSTEM" :asdf) module)))))
(defun add-to-load-path-1 (path load-path-var)
(pushnew path (symbol-value load-path-var) :test #'equal))
(defgeneric add-to-load-path (method path)
(:documentation
"Using METHOD, consider PATH when searching for modules.")
(:method ((method (eql :slynk-loader)) path)
(add-to-load-path-1 path (intern "*LOAD-PATH*" :slynk-loader)))
(:method ((method (eql :asdf)) path)
(add-to-load-path-1 path (intern "*CENTRAL-REGISTRY*" :asdf))))
(defvar *slynk-require-hook* '()
"Functions run after SLYNK-REQUIRE. Called with new modules.")
(defslyfun slynk-require (modules)
"Load each module in MODULES.
MODULES is a list of strings designators or a single string
designator. Returns a list of all modules available."
(let ((loaded))
(dolist (module (ensure-list modules))
(with-simple-restart (continue "Continue without SLY contrib ~a" module)
(funcall #'require-module *module-loading-method* module)
(push module loaded)
(pushnew (string-upcase module) *modules* :test #'equal))
(loop for fn in *slynk-require-hook*
do (funcall fn loaded)))
(list *modules* loaded)))
(defslyfun slynk-add-load-paths (paths)
(dolist (path paths)
(funcall #'add-to-load-path *module-loading-method* (pathname path))))
;;;; Macroexpansion
(defvar *macroexpand-printer-bindings*
'((*print-circle* . nil)
(*print-pretty* . t)
(*print-escape* . t)
(*print-lines* . nil)
(*print-level* . nil)
(*print-length* . nil)
(*print-case* . :downcase))
"Pretty-pretty bindings to use when expanding macros")
(defun apply-macro-expander (expander string)
(with-buffer-syntax ()
(let ((expansion (funcall expander (from-string string))))
(with-bindings *macroexpand-printer-bindings*
(prin1-to-string expansion)))))
(defslyfun slynk-macroexpand-1 (string)
(apply-macro-expander #'macroexpand-1 string))
(defslyfun slynk-macroexpand (string)
(apply-macro-expander #'macroexpand string))
(defslyfun slynk-macroexpand-all (string)
(apply-macro-expander #'macroexpand-all string))
(defslyfun slynk-compiler-macroexpand-1 (string)
(apply-macro-expander #'compiler-macroexpand-1 string))
(defslyfun slynk-compiler-macroexpand (string)
(apply-macro-expander #'compiler-macroexpand string))
(defslyfun slynk-expand-1 (string)
(apply-macro-expander #'expand-1 string))
(defslyfun slynk-expand (string)
(apply-macro-expander #'expand string))
(defun expand-1 (form)
(multiple-value-bind (expansion expanded?) (macroexpand-1 form)
(if expanded?
(values expansion t)
(compiler-macroexpand-1 form))))
(defun expand (form)
(expand-repeatedly #'expand-1 form))
(defun expand-repeatedly (expander form)
(loop
(multiple-value-bind (expansion expanded?) (funcall expander form)
(unless expanded? (return expansion))
(setq form expansion))))
(defslyfun slynk-format-string-expand (string)
(apply-macro-expander #'format-string-expand string))
(defslyfun disassemble-form (form)
(with-buffer-syntax ()
(with-output-to-string (*standard-output*)
(let ((*print-readably* nil))
(disassemble (eval (read-from-string form)))))))
;;;; Simple arglist display
(defslyfun operator-arglist (name package)
(ignore-errors
(let ((args (arglist (parse-symbol name (guess-buffer-package package)))))
(cond ((eq args :not-available) nil)
(t (princ-to-string (cons name args)))))))
;;;; Documentation
(defun map-if (test fn &rest lists)
"Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
Example:
\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
(apply #'mapcar
(lambda (x) (if (funcall test x) (funcall fn x) x))
lists))
(defun listify (f)
"Return a function like F, but which returns any non-null value
wrapped in a list."
(lambda (x)
(let ((y (funcall f x)))
(and y (list y)))))
(defun call-with-describe-settings (fn)
(let ((*print-readably* nil))
(funcall fn)))
(defmacro with-describe-settings ((&rest _) &body body)
(declare (ignore _))
`(call-with-describe-settings (lambda () ,@body)))
(defun describe-to-string (object)
(with-describe-settings ()
(with-output-to-string (*standard-output*)
(describe object))))
(defslyfun describe-symbol (symbol-name)
(with-buffer-syntax ()
(describe-to-string (parse-symbol-or-lose symbol-name))))
(defslyfun describe-function (name)
(with-buffer-syntax ()
(let ((symbol (parse-symbol-or-lose name)))
(describe-to-string (or (macro-function symbol)
(symbol-function symbol))))))
(defslyfun describe-definition-for-emacs (name kind)
(with-buffer-syntax ()
(with-describe-settings ()
(with-output-to-string (*standard-output*)
(describe-definition (parse-symbol-or-lose name) kind)))))
(defslyfun documentation-symbol (symbol-name)
(with-buffer-syntax ()
(multiple-value-bind (sym foundp) (parse-symbol symbol-name)
(if foundp
(let ((vdoc (documentation sym 'variable))
(fdoc (documentation sym 'function)))
(with-output-to-string (string)
(format string "Documentation for the symbol ~a:~2%" sym)
(unless (or vdoc fdoc)
(format string "Not documented." ))
(when vdoc
(format string "Variable:~% ~a~2%" vdoc))
(when fdoc
(format string "Function:~% Arglist: ~a~2% ~a"
(slynk-backend:arglist sym)
fdoc))))
(format nil "No such symbol, ~a." symbol-name)))))
;;;; Package Commands
(defslyfun list-all-package-names (&optional nicknames)
"Return a list of all package names.
Include the nicknames if NICKNAMES is true."
(mapcar #'unparse-name
(if nicknames
(mapcan #'package-names (list-all-packages))
(mapcar #'package-name (list-all-packages)))))
;;;; Tracing
;; Use eval for the sake of portability...
(defun tracedp (fspec)
(member fspec (eval '(trace))))
(defvar *after-toggle-trace-hook* nil
"Hook called whenever a SPEC is traced or untraced.
If non-nil, called with two arguments SPEC and TRACED-P." )
(defslyfun slynk-toggle-trace (spec-string)
(let* ((spec (from-string spec-string))
(retval (cond ((consp spec) ; handle complicated cases in the backend
(toggle-trace spec))
((tracedp spec)
(eval `(untrace ,spec))
(format nil "~S is now untraced." spec))
(t
(eval `(trace ,spec))
(format nil "~S is now traced." spec))))
(traced-p (let* ((tosearch "is now traced.")
(start (- (length retval)
(length tosearch)))
(end (+ start (length tosearch))))
(search tosearch (subseq retval start end))))
(hook-msg (when *after-toggle-trace-hook*
(funcall *after-toggle-trace-hook*
spec
traced-p))))
(if hook-msg
(format nil "~a~%(also ~a)" retval hook-msg)
retval)))
(defslyfun untrace-all ()
(untrace))
;;;; Undefing
(defslyfun undefine-function (fname-string)
(let ((fname (from-string fname-string)))
(format nil "~S" (fmakunbound fname))))
(defun read-as-function (name)
(eval (from-string (format nil "(function ~A)" name))))
(defslyfun remove-method-by-name (generic-name qualifiers specializers)
"Remove GENERIC-NAME's method with QUALIFIERS and SPECIALIZERS."
(let* ((generic-function (read-as-function generic-name))
(qualifiers (mapcar #'from-string qualifiers))
(specializers (mapcar #'from-string specializers))
(method (find-method generic-function qualifiers specializers)))
(remove-method generic-function method)
t))
(defslyfun generic-method-specs (generic-name)
"Compute ((QUALIFIERS SPECIALIZERS)...) for methods of GENERIC-NAME's gf.
QUALIFIERS and SPECIALIZERS are lists of strings."
(mapcar
(lambda (method)
(list (mapcar #'prin1-to-string (slynk-mop:method-qualifiers method))
(mapcar (lambda (specializer)
(if (typep specializer 'slynk-mop:eql-specializer)
(format nil "(eql ~A)"
(slynk-mop:eql-specializer-object specializer))
(prin1-to-string (class-name specializer))))
(slynk-mop:method-specializers method))))
(slynk-mop:generic-function-methods (read-as-function generic-name))))
(defslyfun unintern-symbol (name package)
(let ((pkg (guess-package package)))
(cond ((not pkg) (format nil "No such package: ~s" package))
(t
(multiple-value-bind (sym found) (parse-symbol name pkg)
(case found
((nil) (format nil "~s not in package ~s" name package))
(t
(unintern sym pkg)
(format nil "Uninterned symbol: ~s" sym))))))))
(defslyfun slynk-delete-package (package-name)
(let ((pkg (or (guess-package package-name)
(error "No such package: ~s" package-name))))
(delete-package pkg)
nil))
;;;; Source Locations
(defslyfun find-definition-for-thing (thing)
(find-source-location thing))
(defslyfun find-source-location-for-emacs (spec)
(find-source-location (value-spec-ref spec)))
(defun value-spec-ref (spec)
(destructure-case spec
((:string string package)
(with-buffer-syntax (package)
(eval (read-from-string string))))
((:inspector part)
(inspector-nth-part part))
((:sly-db frame var)
(frame-var-value frame var))))
(defvar *find-definitions-right-trim* ",:.>")
(defvar *find-definitions-left-trim* "#:<")
(defun find-definitions-find-symbol-or-package (name)
(flet ((do-find (name)
(multiple-value-bind (symbol found name)
(with-buffer-syntax ()
(parse-symbol name))
(cond (found
(return-from find-definitions-find-symbol-or-package
(values symbol found)))
;; Packages are not named by symbols, so
;; not-interned symbols can refer to packages
((find-package name)
(return-from find-definitions-find-symbol-or-package
(values (make-symbol name) t)))))))
(do-find name)
(do-find (string-right-trim *find-definitions-right-trim* name))
(do-find (string-left-trim *find-definitions-left-trim* name))
(do-find (string-left-trim *find-definitions-left-trim*
(string-right-trim
*find-definitions-right-trim* name)))
;; Not exactly robust
(when (and (eql (search "(setf " name :test #'char-equal) 0)
(char= (char name (1- (length name))) #\)))
(multiple-value-bind (symbol found)
(with-buffer-syntax ()
(parse-symbol (subseq name (length "(setf ")
(1- (length name)))))
(when found
(values `(setf ,symbol) t))))))
(defslyfun find-definitions-for-emacs (name)
"Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
DSPEC is a string and LOCATION a source location. NAME is a string."
(multiple-value-bind (symbol found)
(find-definitions-find-symbol-or-package name)
(when found
(mapcar #'xref>elisp (find-definitions symbol)))))
;;; Generic function so contribs can extend it.
(defgeneric xref-doit (type thing)
(:method (type thing)
(declare (ignore type thing))
:not-implemented))
(macrolet ((define-xref-action (xref-type handler)
`(defmethod xref-doit ((type (eql ,xref-type)) thing)
(declare (ignorable type))
(funcall ,handler thing))))
(define-xref-action :calls #'who-calls)
(define-xref-action :calls-who #'calls-who)
(define-xref-action :references #'who-references)
(define-xref-action :binds #'who-binds)
(define-xref-action :sets #'who-sets)
(define-xref-action :macroexpands #'who-macroexpands)
(define-xref-action :specializes #'who-specializes)
(define-xref-action :callers #'list-callers)
(define-xref-action :callees #'list-callees))
(defslyfun xref (type name)
(multiple-value-bind (sexp error) (ignore-errors (from-string name))
(unless error
(let ((xrefs (xref-doit type sexp)))
(if (eq xrefs :not-implemented)
:not-implemented
(mapcar #'xref>elisp xrefs))))))
(defslyfun xrefs (types name)
(loop for type in types
for xrefs = (xref type name)
when (and (not (eq :not-implemented xrefs))
(not (null xrefs)))
collect (cons type xrefs)))
(defun xref>elisp (xref)
(destructuring-bind (name loc) xref
(list (to-string name) loc)))
;;;;; Lazy lists
(defstruct (lcons (:constructor %lcons (car %cdr))
(:predicate lcons?))
car
(%cdr nil :type (or null lcons function))
(forced? nil))
(defmacro lcons (car cdr)
`(%lcons ,car (lambda () ,cdr)))
(defmacro lcons* (car cdr &rest more)
(cond ((null more) `(lcons ,car ,cdr))
(t `(lcons ,car (lcons* ,cdr ,@more)))))
(defun lcons-cdr (lcons)
(let ((cdr (lcons-%cdr lcons)))
(cond ((lcons-forced? lcons) cdr)
(t
(let ((value (funcall cdr)))
(setf (lcons-forced? lcons) t
(lcons-%cdr lcons) value))))))
(defun llist-range (llist start end)
(llist-take (llist-skip llist start) (- end start)))
(defun llist-skip (lcons index)
(do ((i 0 (1+ i))
(l lcons (lcons-cdr l)))
((or (= i index) (null l))
l)))
(defun llist-take (lcons count)
(let ((result '()))
(do ((i 0 (1+ i))
(l lcons (lcons-cdr l)))
((or (= i count)
(null l)))
(push (lcons-car l) result))
(nreverse result)))
(defun iline (label value)
`(:line ,label ,value))
;;;; Inspecting
(defvar-unbound *current-inspector*
"Current inspector, bound by EVAL-FOR-INSPECTOR, maybe to nil.")
(defvar-unbound *target-inspector*
"Target inspector, bound by EVAL-FOR-INSPECTOR, maybe to nil.")
(defun current-inspector ()
(or (and (boundp '*current-inspector*)
*current-inspector*)
(find-inspector "default")
(make-instance 'inspector :name "default")))
(defun target-inspector ()
(or (and (boundp '*target-inspector*)
*target-inspector*)
(current-inspector)))
(defvar *inspector-printer-bindings*
'((*print-lines* . 1)
(*print-right-margin* . 75)
(*print-pretty* . t)
(*print-readably* . nil)))
(defvar *inspector-verbose-printer-bindings*
'((*print-escape* . t)
(*print-circle* . t)
(*print-array* . nil)))
(defclass inspector ()
((verbose-p :initform nil :accessor inspector-verbose-p)
(history :initform (make-array 10 :adjustable t :fill-pointer 0) :accessor inspector-%history)
(name :initarg :name :initform (error "Name this INSPECTOR!") :accessor inspector-name)))
(defmethod print-object ((i inspector) s)
(print-unreadable-object (i s :type t)
(format s "~a/~a" (inspector-name i) (length (inspector-%history i)))))
(defmethod initialize-instance :after ((i inspector) &key name)
(assert (not (find-inspector name)) nil "Already have an inspector named ~a" name)
(push i (connection-inspectors *emacs-connection*)))
(defun find-inspector (name)
(find name (connection-inspectors *emacs-connection*)
:key #'inspector-name :test #'string=))
(defstruct inspector-state)
(defstruct (istate (:conc-name istate.) (:include inspector-state))
object
(parts (make-array 10 :adjustable t :fill-pointer 0))
(actions (make-array 10 :adjustable t :fill-pointer 0))
metadata
content
serial)
(defun ensure-istate-metadata (o indicator default)
(with-struct (istate. object metadata) (current-istate)
(assert (eq object o))
(let ((data (getf metadata indicator default)))
(setf (getf metadata indicator) data)
data)))
(defun current-istate (&optional (inspector (current-inspector)))
(let* ((history (inspector-%history inspector)))
(and (plusp (length history))
(aref history (1- (length history))))))
(defun reset-inspector (&optional (inspector (current-inspector)))
#+sbcl
;; FIXME: On SBCL, for some silly reason, this is needed to lose the
;; references to the history's objects (github##568)
(loop with hist = (inspector-%history inspector)
for i from 0 below (array-dimension hist 0)
do (setf (aref hist i) nil))
(setf (inspector-%history inspector)
(make-array 10 :adjustable t :fill-pointer 0)))
(defslyfun init-inspector (string)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLY inspection request.")
(inspect-object (eval (read-from-string string))))))
(defun inspect-object (o)
(let* ((inspector (target-inspector))
(history (inspector-%history inspector))
(istate (make-istate :object o)))
(vector-push-extend istate history)
(let ((*current-inspector* inspector))
;; HACK! because EMACS-INSPECT may call ENSURE-ISTATE-METADATA
;; which expects its object to be the current istate's objects.
(setf (istate.content istate)
(emacs-inspect o)))
(vector-push-extend :break-history history)
(decf (fill-pointer history))
(istate>elisp istate)))
(defun istate>elisp (istate)
(list :title (prepare-title istate)
:id (assign-index (istate.object istate) (istate.parts istate))
:content (prepare-range istate 0 500)
;; :serial (istate.serial istate)
))
(defun prepare-title (istate)
(if (inspector-verbose-p (current-inspector))
(with-bindings *inspector-verbose-printer-bindings*
(to-string (istate.object istate)))
(with-string-stream (stream :length 200
:bindings *inspector-printer-bindings*)
(print-unreadable-object
((istate.object istate) stream :type t :identity t)))))
(defun prepare-range (istate start end)
(let* ((range (content-range (istate.content istate) start end))
(ps (loop for part in range append (prepare-part part istate))))
(list ps
(if (< (length ps) (- end start))
(+ start (length ps))
(+ end 1000))
start end)))
(defun prepare-part (part istate)
(let ((newline '#.(string #\newline)))
(etypecase part
(string (list part))
(cons (destructure-case part
((:newline) (list newline))
((:value obj &optional str)
(list (value-part obj str (istate.parts istate))))
((:label &rest strs)
(list (list :label (apply #'cat (mapcar #'string strs)))))
((:action label lambda &key (refreshp t))
(list (action-part label lambda refreshp
(istate.actions istate))))
((:line label value)
(list (princ-to-string label) ": "
(value-part value nil (istate.parts istate))
newline)))))))
(defun value-part (object string parts)
(list :value
(or string (print-part-to-string object))
(assign-index object parts)))
(defun action-part (label lambda refreshp actions)
(list :action label (assign-index (list lambda refreshp) actions)))
(defun assign-index (object vector)
(let ((index (fill-pointer vector)))
(vector-push-extend object vector)
index))
(defun print-part-to-string (value)
(let* ((*print-readably* nil)
(string (slynk-pprint-to-line value))
(pos (position value
(inspector-%history (current-inspector))
:key #'istate.object)))
(if pos
(format nil "@~D=~A" pos string)
string)))
(defun content-range (list start end)
(typecase list
(list (let ((len (length list)))
(subseq list start (min len end))))
(lcons (llist-range list start end))))
(defslyfun inspector-nth-part (index)
"Return the current inspector's INDEXth part.
The second value indicates if that part exists at all."
(let* ((parts (istate.parts (current-istate)))
(foundp (< index (length parts))))
(values (and foundp (aref parts index))
foundp)))
(defslyfun inspector-nth-part-or-lose (index)
"Return the current inspector's INDEXth part.
The second value indicates if that part exists at all."
(multiple-value-bind (part foundp)
(inspector-nth-part index)
(if foundp part (error "No part with index ~a" index))))
(defslyfun inspect-nth-part (index)
(with-buffer-syntax ()
(inspect-object (inspector-nth-part index))))
(defslyfun inspector-range (from to)
(prepare-range (current-istate) from to))
(defslyfun inspector-call-nth-action (index &rest args)
(destructuring-bind (fun refreshp) (aref (istate.actions (current-istate)) index)
(apply fun args)
(if refreshp
(inspector-reinspect)
;; tell emacs that we don't want to refresh the inspector buffer
nil)))
(defslyfun inspector-pop ()
"Inspect the previous object.
Return nil if there's no previous object."
(with-buffer-syntax ()
(let* ((history (inspector-%history (current-inspector))))
(when (> (length history) 1)
(decf (fill-pointer history))
(istate>elisp (current-istate))))))
(defslyfun inspector-next ()
"Inspect the next element in the history of inspected objects.."
(with-buffer-syntax ()
(let* ((history (inspector-%history (current-inspector))))
(when (and (< (fill-pointer history)
(array-dimension history 0))
(istate-p (aref history (fill-pointer history))))
(incf (fill-pointer history))
(istate>elisp (current-istate))))))
(defslyfun inspector-reinspect ()
(let ((istate (current-istate)))
(setf (istate.content istate)
(emacs-inspect (istate.object istate)))
(istate>elisp istate)))
(defslyfun inspector-toggle-verbose ()
"Toggle verbosity of inspected object."
(setf (inspector-verbose-p (current-inspector))
(not (inspector-verbose-p (current-inspector))))
(istate>elisp (current-istate)))
(defslyfun inspector-eval (string)
(let* ((obj (istate.object (current-istate)))
(context (eval-context obj))
(form (with-buffer-syntax ((cdr (assoc '*package* context)))
(read-from-string string)))
(ignorable (remove-if #'boundp (mapcar #'car context))))
(to-string (eval `(let ((* ',obj) (- ',form)
. ,(loop for (var . val) in context
unless (constantp var) collect
`(,var ',val)))
(declare (ignorable . ,ignorable))
,form)))))
(defslyfun inspector-history ()
(slynk-pprint-to-line (inspector-%history (current-inspector))))
(defslyfun quit-inspector ()
(reset-inspector)
nil)
(defslyfun describe-inspectee ()
"Describe the currently inspected object."
(with-buffer-syntax ()
(describe-to-string (istate.object (current-istate)))))
(defslyfun describe-inspector-part (index)
"Describe part INDEX of the currently inspected object."
(with-buffer-syntax ()
(describe-to-string (inspector-nth-part index))))
(defslyfun pprint-inspector-part (index)
"Pretty-print part INDEX of the currently inspected object."
(with-buffer-syntax ()
(slynk-pprint (inspector-nth-part index))))
(defslyfun inspect-in-frame (string index)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLY inspection request.")
(reset-inspector)
(inspect-object (eval-in-frame (from-string string) index)))))
(defslyfun inspect-current-condition ()
(with-buffer-syntax ()
(reset-inspector)
(inspect-object *slynk-debugger-condition*)))
(defslyfun inspect-frame-var (frame var)
(with-buffer-syntax ()
(reset-inspector)
(inspect-object (frame-var-value frame var))))
(defslyfun pprint-frame-var (frame var)
(with-buffer-syntax ()
(slynk-pprint (frame-var-value frame var))))
(defslyfun describe-frame-var (frame var)
(with-buffer-syntax ()
(describe-to-string (frame-var-value frame var))))
(defslyfun eval-for-inspector (current
target
slave-slyfun &rest args)
"Call SLAVE-SLYFUN with ARGS in CURRENT inspector, open in TARGET."
(let ((*current-inspector* (and current
(or (find-inspector current)
(make-instance 'inspector :name current))))
(*target-inspector* (and target
(or (find-inspector target)
(make-instance 'inspector :name target)))))
(apply slave-slyfun args)))
;;;;; Lists
(defmethod emacs-inspect ((o cons))
(if (listp (cdr o))
(inspect-list o)
(inspect-cons o)))
(defun inspect-cons (cons)
(label-value-line*
('car (car cons))
('cdr (cdr cons))))
(defun inspect-list (list)
(multiple-value-bind (length tail) (safe-length list)
(flet ((frob (title list)
(list* title '(:newline) (inspect-list-aux list))))
(cond ((not length)
(frob "A circular list:"
(cons (car list)
(ldiff (cdr list) list))))
((not tail)
(frob "A proper list:" list))
(t
(frob "An improper list:" list))))))
(defun inspect-list-aux (list)
(loop for i from 0 for rest on list while (consp rest) append
(if (listp (cdr rest))
(label-value-line i (car rest))
(label-value-line* (i (car rest)) (:tail (cdr rest))))))
(defun safe-length (list)
"Similar to `list-length', but avoid errors on improper lists.
Return two values: the length of the list and the last cdr.
Return NIL if LIST is circular."
(do ((n 0 (+ n 2)) ;Counter.
(fast list (cddr fast)) ;Fast pointer: leaps by 2.
(slow list (cdr slow))) ;Slow pointer: leaps by 1.
(nil)
(cond ((null fast) (return (values n nil)))
((not (consp fast)) (return (values n fast)))
((null (cdr fast)) (return (values (1+ n) (cdr fast))))
((and (eq fast slow) (> n 0)) (return nil))
((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
;;;;; Hashtables
(defun hash-table-to-alist (ht)
(let ((result '()))
(maphash (lambda (key value)
(setq result (acons key value result)))
ht)
result))
(defmethod emacs-inspect ((ht hash-table))
(append
(label-value-line*
("Count" (hash-table-count ht))
("Size" (hash-table-size ht))
("Test" (hash-table-test ht))
("Rehash size" (hash-table-rehash-size ht))
("Rehash threshold" (hash-table-rehash-threshold ht)))
(let ((weakness (hash-table-weakness ht)))
(when weakness
(label-value-line "Weakness:" weakness)))
(unless (zerop (hash-table-count ht))
`((:action "[clear hashtable]"
,(lambda () (clrhash ht))) (:newline)
"Contents: " (:newline)))
(let ((content (hash-table-to-alist ht)))
(cond ((every (lambda (x) (typep (first x) '(or string symbol))) content)
(setf content (sort content 'string< :key #'first)))
((every (lambda (x) (typep (first x) 'real)) content)
(setf content (sort content '< :key #'first))))
(loop for (key . value) in content appending
`((:value ,key) " = " (:value ,value)
" " (:action "[remove entry]"
,(let ((key key))
(lambda () (remhash key ht))))
(:newline))))))
;;;;; Arrays
(defmethod emacs-inspect ((array array))
(lcons*
(iline "Dimensions" (array-dimensions array))
(iline "Element type" (array-element-type array))
(iline "Total size" (array-total-size array))
(iline "Adjustable" (adjustable-array-p array))
(iline "Fill pointer" (if (array-has-fill-pointer-p array)
(fill-pointer array)))
"Contents:" '(:newline)
(labels ((k (i max)
(cond ((= i max) '())
(t (lcons (iline i (row-major-aref array i))
(k (1+ i) max))))))
(k 0 (array-total-size array)))))
;;;;; Chars
(defmethod emacs-inspect :around (object)
(declare (ignore object))
(with-bindings (if (inspector-verbose-p (current-inspector))
*inspector-verbose-printer-bindings*
*inspector-printer-bindings*)
(call-next-method)))
(defmethod emacs-inspect ((char character))
(append
(label-value-line*
("Char code" (char-code char))
("Lower cased" (char-downcase char))
("Upper cased" (char-upcase char)))
(if (get-macro-character char)
`("In the current readtable ("
(:value ,*readtable*) ") it is a macro character: "
(:value ,(get-macro-character char))))))
;;;; Thread listing
(defvar *thread-list* ()
"List of threads displayed in Emacs. We don't care a about
synchronization issues (yet). There can only be one thread listing at
a time.")
(defslyfun list-threads ()
"Return a list (LABELS (ID NAME STATUS ATTRS ...) ...).
LABELS is a list of attribute names and the remaining lists are the
corresponding attribute values per thread.
Example:
((:id :name :status :priority)
(6 \"slynk-indentation-cache-thread\" \"Semaphore timed wait\" 0)
(5 \"reader-thread\" \"Active\" 0)
(4 \"control-thread\" \"Semaphore timed wait\" 0)
(2 \"Slynk Sentinel\" \"Semaphore timed wait\" 0)
(1 \"listener\" \"Active\" 0)
(0 \"Initial\" \"Sleep\" 0))"
(setq *thread-list* (all-threads))
(when (and *emacs-connection*
(use-threads-p)
;; FIXME: hardcoded thread name
(equalp (thread-name (current-thread)) "slynk-worker"))
(setf *thread-list* (delete (current-thread) *thread-list*)))
(let* ((plist (thread-attributes (car *thread-list*)))
(labels (loop for (key) on plist by #'cddr
collect key)))
`((:id :name :status ,@labels)
,@(loop for thread in *thread-list*
for name = (thread-name thread)
for attributes = (thread-attributes thread)
collect (list* (thread-id thread)
(string name)
(thread-status thread)
(loop for label in labels
collect (getf attributes label)))))))
(defslyfun quit-thread-browser ()
(setq *thread-list* nil))
(defun nth-thread (index)
(nth index *thread-list*))
(defslyfun debug-nth-thread (index)
(let ((connection *emacs-connection*))
(queue-thread-interrupt
(nth-thread index)
(lambda ()
(with-connection (connection)
(simple-break))))))
(defslyfun kill-nth-thread (index)
(kill-thread (nth-thread index)))
(defslyfun start-slynk-server-in-thread (index port-file-name)
"Interrupt the INDEXth thread and make it start a slynk server.
The server port is written to PORT-FILE-NAME."
(interrupt-thread (nth-thread index)
(lambda ()
(start-server port-file-name :style nil))))
;;;; Class browser
(defun mop-helper (class-name fn)
(let ((class (find-class class-name nil)))
(if class
(mapcar (lambda (x) (to-string (class-name x)))
(funcall fn class)))))
(defslyfun mop (type symbol-name)
"Return info about classes using mop.
When type is:
:subclasses - return the list of subclasses of class.
:superclasses - return the list of superclasses of class."
(let ((symbol (parse-symbol symbol-name *buffer-package*)))
(ecase type
(:subclasses
(mop-helper symbol #'slynk-mop:class-direct-subclasses))
(:superclasses
(mop-helper symbol #'slynk-mop:class-direct-superclasses)))))
;;;; Automatically synchronized state
;;;
;;; Here we add hooks to push updates of relevant information to
;;; Emacs.
;;;;; *FEATURES*
(defun sync-features-to-emacs ()
"Update Emacs if any relevant Lisp state has changed."
;; FIXME: *sly-features* should be connection-local
(unless (eq *sly-features* *features*)
(setq *sly-features* *features*)
(send-to-emacs (list :new-features (features-for-emacs)))))
(defun features-for-emacs ()
"Return `*sly-features*' in a format suitable to send it to Emacs."
*sly-features*)
(add-hook *pre-reply-hook* 'sync-features-to-emacs)
;;;;; Indentation of macros
;;;
;;; This code decides how macros should be indented (based on their
;;; arglists) and tells Emacs. A per-connection cache is used to avoid
;;; sending redundant information to Emacs -- we just say what's
;;; changed since last time.
;;;
;;; The strategy is to scan all symbols, pick out the macros, and look
;;; for &body-arguments.
(defvar *configure-emacs-indentation* t
"When true, automatically send indentation information to Emacs
after each command.")
(defslyfun update-indentation-information ()
(send-to-indentation-cache `(:update-indentation-information))
nil)
;; This function is for *PRE-REPLY-HOOK*.
(defun sync-indentation-to-emacs ()
"Send any indentation updates to Emacs via CONNECTION."
(when *configure-emacs-indentation*
(send-to-indentation-cache `(:sync-indentation ,*buffer-package*))))
;; Send REQUEST to the cache. If we are single threaded perform the
;; request right away, otherwise delegate the request to the
;; indentation-cache-thread.
(defun send-to-indentation-cache (request)
(let ((c *emacs-connection*))
(etypecase c
(singlethreaded-connection
(handle-indentation-cache-request c request))
(multithreaded-connection
(without-sly-interrupts
(send (mconn.indentation-cache-thread c) request)))
(null t))))
(defun indentation-cache-loop (connection)
(with-connection (connection)
(loop
(restart-case
(handle-indentation-cache-request connection (receive))
(abort ()
:report "Return to the indentation cache request handling loop.")))))
(defun handle-indentation-cache-request (connection request)
(destructure-case request
((:sync-indentation package)
;; PACKAGE may have been deleted...
(when (package-name package)
(let ((fullp (need-full-indentation-update-p connection)))
(perform-indentation-update connection fullp package))))
((:update-indentation-information)
(perform-indentation-update connection t nil))))
(defun need-full-indentation-update-p (connection)
"Return true if the whole indentation cache should be updated.
This is a heuristic to avoid scanning all symbols all the time:
instead, we only do a full scan if the set of packages has changed."
(set-difference (list-all-packages)
(connection-indentation-cache-packages connection)))
(defun perform-indentation-update (connection force package)
"Update the indentation cache in CONNECTION and update Emacs.
If FORCE is true then start again without considering the old cache."
(let ((cache (connection-indentation-cache connection)))
(when force (clrhash cache))
(let ((delta (update-indentation/delta-for-emacs cache force package)))
(setf (connection-indentation-cache-packages connection)
(list-all-packages))
(unless (null delta)
(setf (connection-indentation-cache connection) cache)
(send-to-emacs (list :indentation-update delta))))))
(defun update-indentation/delta-for-emacs (cache force package)
"Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list.
If FORCE is true then check all symbols, otherwise only check symbols
belonging to PACKAGE."
(let ((alist '()))
(flet ((consider (symbol)
(let ((indent (symbol-indentation symbol)))
(when indent
(unless (equal (gethash symbol cache) indent)
(setf (gethash symbol cache) indent)
(let ((pkgs (mapcar #'package-name
(symbol-packages symbol)))
(name (string-downcase symbol)))
(push (list name indent pkgs) alist)))))))
(cond (force
(do-all-symbols (symbol)
(consider symbol)))
((package-name package) ; don't try to iterate over a
; deleted package.
(do-symbols (symbol package)
(when (eq (symbol-package symbol) package)
(consider symbol)))))
alist)))
(defun package-names (package)
"Return the name and all nicknames of PACKAGE in a fresh list."
(cons (package-name package) (copy-list (package-nicknames package))))
(defun symbol-packages (symbol)
"Return the packages where SYMBOL can be found."
(let ((string (string symbol)))
(loop for p in (list-all-packages)
when (eq symbol (find-symbol string p))
collect p)))
(defun cl-symbol-p (symbol)
"Is SYMBOL a symbol in the COMMON-LISP package?"
(eq (symbol-package symbol) cl-package))
(defun known-to-emacs-p (symbol)
"Return true if Emacs has special rules for indenting SYMBOL."
(cl-symbol-p symbol))
(defun symbol-indentation (symbol)
"Return a form describing the indentation of SYMBOL.
The form is to be used as the `sly-common-lisp-indent-function' property
in Emacs."
(if (and (macro-function symbol)
(not (known-to-emacs-p symbol)))
(let ((arglist (arglist symbol)))
(etypecase arglist
((member :not-available)
nil)
(list
(macro-indentation arglist))))
nil))
(defun macro-indentation (arglist)
(if (well-formed-list-p arglist)
(position '&body (remove '&optional (clean-arglist arglist)))
nil))
(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))))))
(defun well-formed-list-p (list)
"Is LIST a proper list terminated by NIL?"
(typecase list
(null t)
(cons (well-formed-list-p (cdr list)))
(t nil)))
(defun print-indentation-lossage (&optional (stream *standard-output*))
"Return the list of symbols whose indentation styles collide incompatibly.
Collisions are caused because package information is ignored."
(let ((table (make-hash-table :test 'equal)))
(flet ((name (s) (string-downcase (symbol-name s))))
(do-all-symbols (s)
(setf (gethash (name s) table)
(cons s (symbol-indentation s))))
(let ((collisions '()))
(do-all-symbols (s)
(let* ((entry (gethash (name s) table))
(owner (car entry))
(indent (cdr entry)))
(unless (or (eq s owner)
(equal (symbol-indentation s) indent)
(and (not (fboundp s))
(null (macro-function s))))
(pushnew owner collisions)
(pushnew s collisions))))
(if (null collisions)
(format stream "~&No worries!~%")
(format stream "~&Symbols with collisions:~%~{ ~S~%~}"
collisions))))))
;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough.
#-clasp
(add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
;;;; Testing
(defslyfun io-speed-test (&optional (n 1000) (m 1))
(let* ((s *standard-output*)
(*trace-output* (make-broadcast-stream s *log-output*)))
(time (progn
(dotimes (i n)
(format s "~D abcdefghijklm~%" i)
(when (zerop (mod n m))
(finish-output s)))
(finish-output s)
(when *emacs-connection*
(eval-in-emacs '(message "done.")))))
(terpri *trace-output*)
(finish-output *trace-output*)
nil))
(defslyfun flow-control-test (n delay)
(let ((stream (make-output-stream
(let ((conn *emacs-connection*))
(lambda (string)
(declare (ignore string))
(with-connection (conn)
(send-to-emacs `(:test-delay ,delay))))))))
(dotimes (i n)
(print i stream)
(force-output stream)
(background-message "flow-control-test: ~d" i))))
;;;; The "official" API
(defpackage :slynk-api (:use))
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((api '(#:*emacs-connection*
#:*m-x-sly-from-emacs*
#:default-connection
;;
#:channel
#:channel-id
#:channel-thread-id
#:close-channel
#:define-channel-method
#:find-channel
#:send-to-remote-channel
#:*channel*
;;
#:listener
#:with-listener-bindings
#:saving-listener-bindings
#:flush-listener-streams
#:default-listener
#:close-listener
;;
#:add-hook
#:*connection-closed-hook*
#:*after-init-hook*
#:*new-connection-hook*
#:*pre-reply-hook*
#:*after-toggle-trace-hook*
#:*eval-for-emacs-wrappers*
#:*debugger-extra-options*
#:*buffer-readtable*
;;
#:defslyfun
#:destructure-case
#:log-event
#:process-requests
#:use-threads-p
#:wait-for-event
#:with-bindings
#:with-connection
#:with-top-level-restart
#:with-sly-interrupts
#:with-buffer-syntax
#:with-retry-restart
#:*loaded-user-init-file*
#:load-user-init-file
#:make-thread-bindings-aware-lambda
;;
#:package-string-for-prompt
;;
#:*slynk-wire-protocol-version*
;;
#:*slynk-require-hook*
;;
#:present-for-emacs
;; packages
;;
#:cl-package
#:+keyword-package+
#:guess-package
#:guess-buffer-package
#:*exclude-symbol-functions*
#:*buffer-package*
#:*slynk-io-package*
#:parse-package
;; symbols
;;
#:tokenize-symbol
#:untokenize-symbol
#:symbol-external-p
#:unparse-name
#:excluded-from-searches-p
;;
;;
#:slynk-pprint
#:slynk-pprint-values
#:slynk-pprint-to-line
;;
;;
#:background-message
#:map-if)))
(loop for sym in api
for slynk-api-sym = (intern (string sym) :slynk-api)
for slynk-sym = (intern (string sym) :slynk)
do (unintern slynk-api-sym :slynk-api)
(import slynk-sym :slynk-api)
(export slynk-sym :slynk-api))))
;;;; INIT, as called from the slynk-loader.lisp and ASDF's loaders
;;;;
(defvar *loaded-user-init-file* nil
"User init file actually loaded from user's home, if any.")
(defun load-user-init-file ()
"Load the user init file, return NIL if it does not exist."
(find-if (lambda (homedir-file)
(load (merge-pathnames (user-homedir-pathname)
homedir-file)
:if-does-not-exist nil))
(list (make-pathname :name ".slynk" :type "lisp")
(make-pathname :name ".slynkrc"))))
(defun init ()
(unless (member :slynk *features*)
(pushnew :slynk *features*))
(setq *loaded-user-init-file* (load-user-init-file))
(run-hook *after-init-hook*))
;; Local Variables:
;; sly-load-failed-fasl: ask
;; End:
;;; -*- lisp -*-
(in-package :asdf)
;; ASDF system definition for loading the Slynk server independently
;; of Emacs.
;;
;; Usage:
;;
;; (push #p"/path/to/this/file/" asdf:*central-registry*)
;; (asdf:load-system :slynk)
;; (slynk:create-server :port PORT) => ACTUAL-PORT
;;
;; (PORT can be zero to mean "any available port".)
;; Then the Slynk server is running on localhost:ACTUAL-PORT. You can
;; use `M-x sly-connect' to connect Emacs to it.
;;
;; This code has been placed in the Public Domain. All warranties
;; are disclaimed.
(defsystem :slynk
:serial t
;; See commit message and GitHub#502, GitHub#501 for the reason
;; for this dedicated sbcl muffling.
#+sbcl
:around-compile
#+sbcl
(lambda (thunk)
(handler-bind (((and warning (not style-warning))
(lambda (c)
(format *error-output* "~&~@<~S: ~3i~:_~A~:>~%"
(class-name (class-of c)) c)
(muffle-warning c))))
(let ((sb-ext:*on-package-variance* '(:warn t)))
(funcall thunk))))
:components
((:file "slynk-match")
(:file "slynk-backend")
;; If/when we require ASDF3, we shall use :if-feature instead
#+(or cmu sbcl scl)
(:file "slynk-source-path-parser")
#+(or cmu ecl sbcl scl)
(:file "slynk-source-file-cache")
#+clisp
(:file "xref")
#+(or clisp clozure clasp)
(:file "metering")
(:module "backend"
:serial t
:components (#+allegro
(:file "allegro")
#+armedbear
(:file "abcl")
#+clisp
(:file "clisp")
#+clozure
(:file "ccl")
#+cmu
(:file "cmucl")
#+cormanlisp
(:file "corman")
#+ecl
(:file "ecl")
#+lispworks
(:file "lispworks")
#+sbcl
(:file "sbcl")
#+clasp
(:file "clasp")
#+scl
(:file "scl")
#+mkcl
(:file "mkcl")))
#-armedbear
(:file "slynk-gray")
(:file "slynk-rpc")
(:file "slynk")
(:file "slynk-completion")
(:file "slynk-apropos")))
(defmethod perform :after ((o load-op) (c (eql (find-system :slynk))))
(format *debug-io* "~&SLYNK's ASDF loader finished.")
(funcall (with-standard-io-syntax (read-from-string "slynk::init"))))
;;; Contrib systems (should probably go into their own file one day)
;;;
(defsystem :slynk/arglists
:depends-on (:slynk)
:components ((:file "../contrib/slynk-arglists")))
(defsystem :slynk/fancy-inspector
:depends-on (:slynk)
:components ((:file "../contrib/slynk-fancy-inspector")))
(defsystem :slynk/package-fu
:depends-on (:slynk)
:components ((:file "../contrib/slynk-package-fu")))
(defsystem :slynk/mrepl
:depends-on (:slynk)
:components ((:file "../contrib/slynk-mrepl")))
(defsystem :slynk/trace-dialog
:depends-on (:slynk)
:components ((:file "../contrib/slynk-trace-dialog")))
(defsystem :slynk/profiler
:depends-on (:slynk)
:components ((:file "../contrib/slynk-profiler")))
(defsystem :slynk/stickers
:depends-on (:slynk)
:components ((:file "../contrib/slynk-stickers")))
(defsystem :slynk/indentation
:depends-on (:slynk)
:components ((:file "../contrib/slynk-indentation")))
(defsystem :slynk/retro
:depends-on (:slynk)
:components ((:file "../contrib/slynk-retro")))
;;;; Source-paths
;;; CMUCL/SBCL use a data structure called "source-path" to locate
;;; subforms. The compiler assigns a source-path to each form in a
;;; compilation unit. Compiler notes usually contain the source-path
;;; of the error location.
;;;
;;; Compiled code objects don't contain source paths, only the
;;; "toplevel-form-number" and the (sub-) "form-number". To get from
;;; the form-number to the source-path we need the entire toplevel-form
;;; (i.e. we have to read the source code). CMUCL has already some
;;; utilities to do this translation, but we use some extended
;;; versions, because we need more exact position info. Apparently
;;; Hemlock is happy with the position of the toplevel-form; we also
;;; need the position of subforms.
;;;
;;; We use a special readtable to get the positions of the subforms.
;;; The readtable stores the start and end position for each subform in
;;; hashtable for later retrieval.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;; Taken from slynk-cmucl.lisp, by Helmut Eller
(defpackage slynk-source-path-parser
(:use cl)
(:export
read-source-form
source-path-string-position
source-path-file-position
source-path-source-position
sexp-in-bounds-p
sexp-ref)
(:shadow ignore-errors))
(in-package slynk-source-path-parser)
;; Some test to ensure the required conformance
(let ((rt (copy-readtable nil)))
(assert (or (not (get-macro-character #\space rt))
(nth-value 1 (get-macro-character #\space rt))))
(assert (not (get-macro-character #\\ rt))))
(eval-when (:compile-toplevel)
(defmacro ignore-errors (&rest forms)
;;`(progn . ,forms) ; for debugging
`(cl:ignore-errors . ,forms)))
(defun make-sharpdot-reader (orig-sharpdot-reader)
(lambda (s c n)
;; We want things like M-. to work regardless of any #.-fu in
;; the source file that is to be visited. (For instance, when a
;; file contains #. forms referencing constants that do not
;; currently exist in the image.)
(ignore-errors (funcall orig-sharpdot-reader s c n))))
(defun make-source-recorder (fn source-map)
"Return a macro character function that does the same as FN, but
additionally stores the result together with the stream positions
before and after of calling FN in the hashtable SOURCE-MAP."
(lambda (stream char)
(let ((start (1- (file-position stream)))
(values (multiple-value-list (funcall fn stream char)))
(end (file-position stream)))
#+(or)
(format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%"
start values end (char-code char) char)
(when values
(destructuring-bind (&optional existing-start &rest existing-end)
(car (gethash (car values) source-map))
;; Some macros may return what a sub-call to another macro
;; produced, e.g. "#+(and) (a)" may end up saving (a) twice,
;; once from #\# and once from #\(. If the saved form
;; is a subform, don't save it again.
(unless (and existing-start existing-end
(<= start existing-start end)
(<= start existing-end end))
(push (cons start end) (gethash (car values) source-map)))))
(values-list values))))
(defun make-source-recording-readtable (readtable source-map)
(declare (type readtable readtable) (type hash-table source-map))
"Return a source position recording copy of READTABLE.
The source locations are stored in SOURCE-MAP."
(flet ((install-special-sharpdot-reader (rt)
(let ((fun (ignore-errors
(get-dispatch-macro-character #\# #\. rt))))
(when fun
(let ((wrapper (make-sharpdot-reader fun)))
(set-dispatch-macro-character #\# #\. wrapper rt)))))
(install-wrappers (rt)
(dotimes (code 128)
(let ((char (code-char code)))
(multiple-value-bind (fun nt) (get-macro-character char rt)
(when fun
(let ((wrapper (make-source-recorder fun source-map)))
(set-macro-character char wrapper nt rt))))))))
(let ((rt (copy-readtable readtable)))
(install-special-sharpdot-reader rt)
(install-wrappers rt)
rt)))
;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning.
;; Should be possible as we only need the right "list structure" and
;; not the right atoms.
(defun read-and-record-source-map (stream)
"Read the next object from STREAM.
Return the object together with a hashtable that maps
subexpressions of the object to stream positions."
(let* ((source-map (make-hash-table :test #'eq))
(*readtable* (make-source-recording-readtable *readtable* source-map))
(*read-suppress* nil)
(start (file-position stream))
(form (ignore-errors (read stream)))
(end (file-position stream)))
;; ensure that at least FORM is in the source-map
(unless (gethash form source-map)
(push (cons start end) (gethash form source-map)))
(values form source-map)))
(defun starts-with-p (string prefix)
(declare (type string string prefix))
(not (mismatch string prefix
:end1 (min (length string) (length prefix))
:test #'char-equal)))
(defun extract-package (line)
(declare (type string line))
(let ((name (cadr (read-from-string line))))
(find-package name)))
#+(or)
(progn
(assert (extract-package "(in-package cl)"))
(assert (extract-package "(cl:in-package cl)"))
(assert (extract-package "(in-package \"CL\")"))
(assert (extract-package "(in-package #:cl)")))
;; FIXME: do something cleaner than this.
(defun readtable-for-package (package)
;; KLUDGE: due to the load order we can't reference the slynk
;; package.
(funcall (slynk-backend:find-symbol2 "slynk::guess-buffer-readtable")
(string-upcase (package-name package))))
;; Search STREAM for a "(in-package ...)" form. Use that to derive
;; the values for *PACKAGE* and *READTABLE*.
;;
;; IDEA: move GUESS-READER-STATE to slynk.lisp so that all backends
;; use the same heuristic and to avoid the need to access
;; slynk::guess-buffer-readtable from here.
(defun guess-reader-state (stream)
(let* ((point (file-position stream))
(pkg *package*))
(file-position stream 0)
(loop for read-line = (read-line stream nil nil)
for line = (and read-line
(string-trim '(#\Space #\Tab #\Linefeed #\Page #\Return #\Rubout)
read-line))
do
(when (not line) (return))
(when (or (starts-with-p line "(in-package ")
(starts-with-p line "(cl:in-package "))
(let ((p (extract-package line)))
(when p (setf pkg p)))
(return)))
(file-position stream point)
(values (readtable-for-package pkg) pkg)))
(defun skip-whitespace (stream)
(peek-char t stream nil nil))
;; Skip over N toplevel forms.
(defun skip-toplevel-forms (n stream)
(let ((*read-suppress* t))
(dotimes (i n)
(read stream))
(skip-whitespace stream)))
(defun read-source-form (n stream)
"Read the Nth toplevel form number with source location recording.
Return the form and the source-map."
(multiple-value-bind (*readtable* *package*) (guess-reader-state stream)
(let (#+sbcl
(*features* (append *features*
(symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl)))))
(skip-toplevel-forms n stream)
(read-and-record-source-map stream))))
(defun source-path-stream-position (path stream)
"Search the source-path PATH in STREAM and return its position."
(check-source-path path)
(destructuring-bind (tlf-number . path) path
(multiple-value-bind (form source-map) (read-source-form tlf-number stream)
(source-path-source-position (cons 0 path) form source-map))))
(defun check-source-path (path)
(unless (and (consp path)
(every #'integerp path))
(error "The source-path ~S is not valid." path)))
(defun source-path-string-position (path string)
(with-input-from-string (s string)
(source-path-stream-position path s)))
(defun source-path-file-position (path filename)
;; We go this long way round, and don't directly operate on the file
;; stream because FILE-POSITION (used above) is not totally savy even
;; on file character streams; on SBCL, FILE-POSITION returns the binary
;; offset, and not the character offset---screwing up on Unicode.
(let ((toplevel-number (first path))
(buffer))
(with-open-file (file filename)
(skip-toplevel-forms (1+ toplevel-number) file)
(let ((endpos (file-position file)))
(setq buffer (make-array (list endpos) :element-type 'character
:initial-element #\Space))
(assert (file-position file 0))
(read-sequence buffer file :end endpos)))
(source-path-string-position path buffer)))
(defgeneric sexp-in-bounds-p (sexp i)
(:method ((list list) i)
(< i (loop for e on list
count t)))
(:method ((sexp t) i) nil))
(defgeneric sexp-ref (sexp i)
(:method ((s list) i) (elt s i)))
(defun source-path-source-position (path form source-map)
"Return the start position of PATH from FORM and SOURCE-MAP. All
subforms along the path are considered and the start and end position
of the deepest (i.e. smallest) possible form is returned."
;; compute all subforms along path
(let ((forms (loop for i in path
for f = form then (if (sexp-in-bounds-p f i)
(sexp-ref f i))
collect f)))
;; select the first subform present in source-map
(loop for form in (nreverse forms)
for ((start . end) . rest) = (gethash form source-map)
when (and start end (not rest))
return (return (values start end)))))
;;;; Source-file cache
;;;
;;; To robustly find source locations in CMUCL and SBCL it's useful to
;;; have the exact source code that the loaded code was compiled from.
;;; In this source we can accurately find the right location, and from
;;; that location we can extract a "snippet" of code to show what the
;;; definition looks like. Emacs can use this snippet in a best-match
;;; search to locate the right definition, which works well even if
;;; the buffer has been modified.
;;;
;;; The idea is that if a definition previously started with
;;; `(define-foo bar' then it probably still does.
;;;
;;; Whenever we see that the file on disk has the same
;;; `file-write-date' as a location we're looking for we cache the
;;; whole file inside Lisp. That way we will still have the matching
;;; version even if the file is later modified on disk. If the file is
;;; later recompiled and reloaded then we replace our cache entry.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
(defpackage slynk-source-file-cache
(:use cl slynk-backend)
(:import-from slynk-backend
defimplementation buffer-first-change)
(:export
get-source-code
source-cache-get ;FIXME: isn't it odd that both are exported?
*source-snippet-size*
read-snippet
read-snippet-from-string
))
(in-package slynk-source-file-cache)
(defvar *cache-sourcecode* t
"When true complete source files are cached.
The cache is used to keep known good copies of the source text which
correspond to the loaded code. Finding definitions is much more
reliable when the exact source is available, so we cache it in case it
gets edited on disk later.")
(defvar *source-file-cache* (make-hash-table :test 'equal)
"Cache of source file contents.
Maps from truename to source-cache-entry structure.")
(defstruct (source-cache-entry
(:conc-name source-cache-entry.)
(:constructor make-source-cache-entry (text date)))
text date)
(defimplementation buffer-first-change (filename)
"Load a file into the cache when the user modifies its buffer.
This is a win if the user then saves the file and tries to M-. into it."
(unless (source-cached-p filename)
(ignore-errors
(source-cache-get filename (file-write-date filename))))
nil)
(defun get-source-code (filename code-date)
"Return the source code for FILENAME as written on DATE in a string.
If the exact version cannot be found then return the current one from disk."
(or (source-cache-get filename code-date)
(read-file filename)))
(defun source-cache-get (filename date)
"Return the source code for FILENAME as written on DATE in a string.
Return NIL if the right version cannot be found."
(when *cache-sourcecode*
(let ((entry (gethash filename *source-file-cache*)))
(cond ((and entry (equal date (source-cache-entry.date entry)))
;; Cache hit.
(source-cache-entry.text entry))
((or (null entry)
(not (equal date (source-cache-entry.date entry))))
;; Cache miss.
(if (equal (file-write-date filename) date)
;; File on disk has the correct version.
(let ((source (read-file filename)))
(setf (gethash filename *source-file-cache*)
(make-source-cache-entry source date))
source)
nil))))))
(defun source-cached-p (filename)
"Is any version of FILENAME in the source cache?"
(if (gethash filename *source-file-cache*) t))
(defun read-file (filename)
"Return the entire contents of FILENAME as a string."
(with-open-file (s filename :direction :input
:external-format (or (guess-external-format filename)
(find-external-format "latin-1")
:default))
(let* ((string (make-string (file-length s)))
(length (read-sequence string s)))
(subseq string 0 length))))
;;;; Snippets
(defvar *source-snippet-size* 256
"Maximum number of characters in a snippet of source code.
Snippets at the beginning of definitions are used to tell Emacs what
the definitions looks like, so that it can accurately find them by
text search.")
(defun read-snippet (stream &optional position)
"Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM.
If POSITION is given, set the STREAM's file position first."
(when position
(file-position stream position))
#+sbcl (skip-comments-and-whitespace stream)
(read-upto-n-chars stream *source-snippet-size*))
(defun read-snippet-from-string (string &optional position)
(with-input-from-string (s string)
(read-snippet s position)))
(defun skip-comments-and-whitespace (stream)
(case (peek-char nil stream nil nil)
((#\Space #\Tab #\Newline #\Linefeed #\Page)
(read-char stream)
(skip-comments-and-whitespace stream))
(#\;
(read-line stream)
(skip-comments-and-whitespace stream))))
(defun read-upto-n-chars (stream n)
"Return a string of upto N chars from STREAM."
(let* ((string (make-string n))
(chars (read-sequence string stream)))
(subseq string 0 chars)))
;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
;;;
;;; slynk-rpc.lisp -- Pass remote calls and responses between lisp systems.
;;;
;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(defpackage #:slynk-rpc
(:use :cl)
(:export
#:read-message
#:read-packet
#:slynk-reader-error
#:slynk-reader-error.packet
#:slynk-reader-error.cause
#:write-message
#:*translating-swank-to-slynk*))
(in-package :slynk-rpc)
;;;;; Input
(define-condition slynk-reader-error (reader-error)
((packet :type string :initarg :packet
:reader slynk-reader-error.packet)
(cause :type reader-error :initarg :cause
:reader slynk-reader-error.cause)))
(defun read-message (stream package)
(let ((packet (read-packet stream)))
(handler-case (values (read-form packet package))
(reader-error (c)
(error 'slynk-reader-error
:packet packet :cause c)))))
(defun read-packet (stream)
(let* ((length (parse-header stream))
(octets (read-chunk stream length)))
(handler-case (slynk-backend:utf8-to-string octets)
(error (c)
(error 'slynk-reader-error
:packet (asciify octets)
:cause c)))))
(defun asciify (packet)
(with-output-to-string (*standard-output*)
(loop for code across (etypecase packet
(string (map 'vector #'char-code packet))
(vector packet))
do (cond ((<= code #x7f) (write-char (code-char code)))
(t (format t "\\x~x" code))))))
(defun parse-header (stream)
(parse-integer (map 'string #'code-char (read-chunk stream 6))
:radix 16))
(defun read-chunk (stream length)
(let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
(count (read-sequence buffer stream)))
(cond ((= count length)
buffer)
((zerop count)
(error 'end-of-file :stream stream))
(t
(error "Short read: length=~D count=~D" length count)))))
(defparameter *translating-swank-to-slynk* t
"Set to true to ensure SWANK*::SYMBOL is interned SLYNK*::SYMBOL.
Set by default to T to ensure that bootstrapping can occur from
clients sending strings like this on the wire.
(:EMACS-REX (SWANK:CONNECTION-INFO) NIL T 1)
*before* the slynk-retro.lisp contrib kicks in and renames SLYNK*
packages to SWANK*. After this happens, this variable is set to NIL,
since the translation is no longer necessary.
The user that is completely sure that Slynk will always be contacted
by SLY clients **without** the sly-retro.el contrib, can also set this
to NIL in her ~/.swankrc. Generally best left alone.")
(defun read-form (string package)
(with-standard-io-syntax
(let ((*package* package))
(if *translating-swank-to-slynk*
(with-input-from-string (*standard-input* string)
(translating-read))
(read-from-string string)))))
(defun maybe-convert-package-designator (string)
(let ((colon-pos (position #\: string))
(search (search "SWANK" string :test #'char-equal)))
(if (and search colon-pos)
(nstring-upcase (replace string "SLYNK"))
string)))
(defun translating-read ()
"Read a form that conforms to the protocol, otherwise signal an error."
(flet ((chomp ()
(loop for ch = (read-char nil t)
while (eq ch #\space)
finally (unread-char ch))))
(chomp)
(let ((c (read-char)))
(case c
(#\" (with-output-to-string (*standard-output*)
(loop for c = (read-char) do
(case c
(#\" (return))
(#\\ (write-char (read-char)))
(t (write-char c))))))
(#\(
(chomp)
(loop with dotread = nil
with retval = nil
for read = (read-char)
while (case read
(#\) nil)
(#\. (setq dotread t) t)
(t (progn (unread-char read) t)))
when (eq dotread 'should-error)
do (error 'reader-error :format-arguments "Too many things after dot")
when dotread
do (setq dotread 'should-error)
do (setq retval (nconc retval
(if dotread
(translating-read)
(list (translating-read)))))
(chomp)
finally (return retval)))
(#\' `(quote ,(translating-read)))
(t (let ((string (with-output-to-string (*standard-output*)
(loop for ch = c then (read-char nil nil) do
(case ch
((nil) (return))
(#\\ (write-char (read-char)))
((#\" #\( #\space #\)) (unread-char ch)(return))
(t (write-char ch)))))))
(read-from-string
(maybe-convert-package-designator string))))))))
;;;;; Output
(defun write-message (message package stream)
(let* ((string (prin1-to-string-for-emacs message package))
(octets (handler-case (slynk-backend:string-to-utf8 string)
(error (c) (encoding-error c string))))
(length (length octets)))
(write-header stream length)
(write-sequence octets stream)
(finish-output stream)))
;; FIXME: for now just tell emacs that we and an encoding problem.
(defun encoding-error (condition string)
(slynk-backend:string-to-utf8
(prin1-to-string-for-emacs
`(:reader-error
,(asciify string)
,(format nil "Error during string-to-utf8: ~a"
(or (ignore-errors (asciify (princ-to-string condition)))
(asciify (princ-to-string (type-of condition))))))
(find-package :cl))))
(defun write-header (stream length)
(declare (type (unsigned-byte 24) length))
;;(format *trace-output* "length: ~d (#x~x)~%" length length)
(loop for c across (format nil "~6,'0x" length)
do (write-byte (char-code c) stream)))
(defun switch-to-double-floats (x)
(typecase x
(double-float x)
(float (coerce x 'double-float))
(null x)
(list (loop for (x . cdr) on x
collect (switch-to-double-floats x) into result
until (atom cdr)
finally (return (append result (switch-to-double-floats cdr)))))
(t x)))
(defun prin1-to-string-for-emacs (object package)
(with-standard-io-syntax
(let ((*print-case* :downcase)
(*print-readably* nil)
(*print-pretty* nil)
(*package* package)
;; Emacs has only double floats.
(*read-default-float-format* 'double-float))
(prin1-to-string (switch-to-double-floats object)))))
#| TEST/DEMO:
(defparameter *transport*
(with-output-to-string (out)
(write-message '(:message (hello "world")) *package* out)
(write-message '(:return 5) *package* out)
(write-message '(:emacs-rex NIL) *package* out)))
*transport*
(with-input-from-string (in *transport*)
(loop while (peek-char T in NIL)
collect (read-message in *package*)))
|#
;;
;; SELECT-MATCH macro (and IN macro)
;;
;; Copyright 1990 Stephen Adams
;;
;; You are free to copy, distribute and make derivative works of this
;; source provided that this copyright notice is displayed near the
;; beginning of the file. No liability is accepted for the
;; correctness or performance of the code. If you modify the code
;; please indicate this fact both at the place of modification and in
;; this copyright message.
;;
;; Stephen Adams
;; Department of Electronics and Computer Science
;; University of Southampton
;; SO9 5NH, UK
;;
;; sra@ecs.soton.ac.uk
;;
;;
;; Synopsis:
;;
;; (select-match expression
;; (pattern action+)*)
;;
;; --- or ---
;;
;; (select-match expression
;; pattern => expression
;; pattern => expression
;; ...)
;;
;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
;; | symbol ;matches anything
;; | 'anything ;must be EQUAL
;; | (pattern = pattern) ;both patterns must match
;; | (#'function pattern) ;predicate test
;; | (pattern . pattern) ;cons cell
;;
;; Example
;;
;; (select-match item
;; (('if e1 e2 e3) 'if-then-else) ;(1)
;; ((#'oddp k) 'an-odd-integer) ;(2)
;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
;; (other 'anything-else)) ;(4)
;;
;; Notes
;;
;; . Each pattern is tested in turn. The first match is taken.
;;
;; . If no pattern matches, an error is signalled.
;;
;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
;; numbers, strings, characters, etc.) match things which are EQUAL.
;;
;; . Quoted patterns (which are CONSTANTP) are constants.
;;
;; . Symbols match anything. The symbol is bound to the matched item
;; for the execution of the actions.
;; For example, (SELECT-MATCH '(1 2 3)
;; (1 . X) => X)
;; returns (2 3) because X is bound to the cdr of the candidate.
;;
;; . The two pattern match (p1 = p2) can be used to name parts
;; of the matched structure. For example, (ALL = (HD . TL))
;; matches a cons cell. ALL is bound to the cons cell, HD to its car
;; and TL to its tail.
;;
;; . A predicate test applies the predicate to the item being matched.
;; If the predicate returns NIL then the match fails.
;; If it returns truth, then the nested pattern is matched. This is
;; often just a symbol like K in the example.
;;
;; . Care should be taken with the domain values for predicate matches.
;; If, in the above eg, item is not an integer, an error would occur
;; during the test. A safer pattern would be
;; (#'integerp (#'oddp k))
;; This would only test for oddness of the item was an integer.
;;
;; . A single symbol will match anything so it can be used as a default
;; case, like OTHER above.
;;
(defpackage :slynk-match
(:use :cl)
(:export #:match))
(in-package :slynk-match)
(defmacro match (expression &body patterns)
`(select-match ,expression ,@patterns))
(defmacro select-match (expression &rest patterns)
(let* ((do-let (not (atom expression)))
(key (if do-let (gensym) expression))
(cbody (expand-select-patterns key patterns))
(cform `(cond . ,cbody)))
(if do-let
`(let ((,key ,expression)) ,cform)
cform)))
(defun expand-select-patterns (key patterns)
(if (eq (second patterns) '=>)
(expand-select-patterns-style-2 key patterns)
(expand-select-patterns-style-1 key patterns)))
(defun expand-select-patterns-style-1 (key patterns)
(if (null patterns)
`((t (error "Case select pattern match failure on ~S" ,key)))
(let* ((pattern (caar patterns))
(actions (cdar patterns))
(rest (cdr patterns))
(test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`(,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(unless (eq test t)
(expand-select-patterns-style-1 key rest))))))
(defun expand-select-patterns-style-2 (key patterns)
(cond ((null patterns)
`((t (error "Case select pattern match failure on ~S" ,key))))
(t (when (or (< (length patterns) 3)
(not (eq (second patterns) '=>)))
(error "Illegal patterns: ~S" patterns))
(let* ((pattern (first patterns))
(actions (list (third patterns)))
(rest (cdddr patterns))
(test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`(,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(unless (eq test t)
(expand-select-patterns-style-2 key rest)))))))
(defun compile-select-test (key pattern)
(let ((tests (remove t (compile-select-tests key pattern))))
(cond
;; note AND does this anyway, but this allows us to tell if
;; the pattern will always match.
((null tests) t)
((= (length tests) 1) (car tests))
(t `(and . ,tests)))))
(defun compile-select-tests (key pattern)
(cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
((symbolp pattern) 'eq)
(t 'equal))
,key ,pattern)))
((symbolp pattern) '(t))
((select-double-match? pattern)
(append
(compile-select-tests key (first pattern))
(compile-select-tests key (third pattern))))
((select-predicate? pattern)
(append
`((,(second (first pattern)) ,key))
(compile-select-tests key (second pattern))))
((consp pattern)
(append
`((consp ,key))
(compile-select-tests (cs-car key) (car
pattern))
(compile-select-tests (cs-cdr key) (cdr
pattern))))
(t (error "Illegal select pattern: ~S" pattern))))
(defun compile-select-bindings (key pattern action)
(cond ((constantp pattern) '())
((symbolp pattern)
(if (select-in-tree pattern action)
`((,pattern ,key))
'()))
((select-double-match? pattern)
(append
(compile-select-bindings key (first pattern) action)
(compile-select-bindings key (third pattern) action)))
((select-predicate? pattern)
(compile-select-bindings key (second pattern) action))
((consp pattern)
(append
(compile-select-bindings (cs-car key) (car pattern)
action)
(compile-select-bindings (cs-cdr key) (cdr pattern)
action)))))
(defun select-in-tree (atom tree)
(or (eq atom tree)
(if (consp tree)
(or (select-in-tree atom (car tree))
(select-in-tree atom (cdr tree))))))
(defun select-double-match? (pattern)
;; (<pattern> = <pattern>)
(and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
(null (cdddr pattern))
(eq (second pattern) '=)))
(defun select-predicate? (pattern)
;; ((function <f>) <pattern>)
(and (consp pattern)
(consp (cdr pattern))
(null (cddr pattern))
(consp (first pattern))
(consp (cdr (first pattern)))
(null (cddr (first pattern)))
(eq (caar pattern) 'function)))
(defun cs-car (exp)
(cs-car/cdr 'car exp
'((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
(cdar . cadar) (cddr . caddr)
(caaar . caaaar) (caadr . caaadr) (cadar . caadar)
(caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
(cddar . caddar) (cdddr . cadddr))))
(defun cs-cdr (exp)
(cs-car/cdr 'cdr exp
'((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
(cdar . cddar) (cddr . cdddr)
(caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
(caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
(cddar . cdddar) (cdddr . cddddr))))
(defun cs-car/cdr (op exp table)
(if (and (consp exp) (= (length exp) 2))
(let ((replacement (assoc (car exp) table)))
(if replacement
`(,(cdr replacement) ,(second exp))
`(,op ,exp)))
`(,op ,exp)))
;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
;; (setf c2 '(select-match (car y)
;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
;; else))))
;; (setf c3 '(select-match (caddr y)
;; ((all = (x y)) (list x y all))
;; ((a '= b) (list 'assign a b))
;; ((#'oddp k) (1+ k)))))
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; slynk-loader.lisp --- Compile and load the Sly backend.
;;;
;;; Created 2003, James Bielman <jamesjb@jamesjb.com>
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;; If you want customize the source- or fasl-directory you can set
;; slynk-loader:*source-directory* resp. slynk-loader:*fasl-directory*
;; before loading this files.
;; E.g.:
;;
;; (load ".../slynk-loader.lisp")
;; (setq slynk-loader::*fasl-directory* "/tmp/fasl/")
;; (slynk-loader:init)
(cl:defpackage :slynk-loader
(:use :cl)
(:export #:init
#:dump-image
#:*source-directory*
#:*fasl-directory*
#:*load-path*))
(cl:in-package :slynk-loader)
(defvar *source-directory*
(make-pathname :name nil :type nil
:defaults (or *load-pathname* *default-pathname-defaults*))
"The directory where to look for the source.")
(defvar *load-path* (list *source-directory*)
"A list of directories to search for modules.")
(defparameter *sysdep-files*
#+cmu '(slynk-source-path-parser slynk-source-file-cache (backend cmucl))
#+scl '(slynk-source-path-parser slynk-source-file-cache (backend scl))
#+sbcl '(slynk-source-path-parser slynk-source-file-cache
(backend sbcl))
#+clozure '(metering (backend ccl))
#+lispworks '((backend lispworks))
#+allegro '((backend allegro))
#+clisp '(xref metering (backend clisp))
#+armedbear '((backend abcl))
#+cormanlisp '((backend corman))
#+ecl '(slynk-source-path-parser slynk-source-file-cache
(backend ecl))
#+clasp '(metering (backend clasp))
#+mkcl '((backend mkcl)))
(defparameter *implementation-features*
'(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
:armedbear :gcl :ecl :scl :mkcl :clasp))
(defparameter *os-features*
'(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
:unix))
(defparameter *architecture-features*
'(:powerpc :ppc :ppc64 :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
:sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 :aarch64
:pentium3 :pentium4
:mips :mipsel
:java-1.4 :java-1.5 :java-1.6 :java-1.7))
(defun q (s) (read-from-string s))
#+ecl
(defun ecl-version-string ()
(format nil "~A~@[-~A~]"
(lisp-implementation-version)
(when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)
(let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id"))))
(when (>= (length vcs-id) 8)
(subseq vcs-id 0 8))))))
#+clasp
(defun clasp-version-string ()
(format nil "~A~@[-~A~]"
(lisp-implementation-version)
(core:lisp-implementation-id)))
(defun lisp-version-string ()
#+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
(lisp-implementation-version))
#+(or cormanlisp scl mkcl) (lisp-implementation-version)
#+sbcl (format nil "~a~:[~;-no-threads~]"
(lisp-implementation-version)
#+sb-thread nil
#-sb-thread t)
#+lispworks (lisp-implementation-version)
#+allegro (format nil "~@{~a~}"
excl::*common-lisp-version-number*
(if (string= 'lisp "LISP") "A" "M") ; ANSI vs MoDeRn
(if (member :smp *features*) "s" "")
(if (member :64bit *features*) "-64bit" "")
(excl:ics-target-case
(:-ics "")
(:+ics "-ics")))
#+clisp (let ((s (lisp-implementation-version)))
(subseq s 0 (position #\space s)))
#+armedbear (lisp-implementation-version)
#+ecl (ecl-version-string) )
(defun unique-dir-name ()
"Return a name that can be used as a directory name that is
unique to a Lisp implementation, Lisp implementation version,
operating system, and hardware architecture."
(flet ((first-of (features)
(loop for f in features
when (find f *features*) return it))
(maybe-warn (value fstring &rest args)
(cond (value)
(t (apply #'warn fstring args)
"unknown"))))
(let ((lisp (maybe-warn (first-of *implementation-features*)
"No implementation feature found in ~a."
*implementation-features*))
(os (maybe-warn (first-of *os-features*)
"No os feature found in ~a." *os-features*))
(arch (maybe-warn (first-of *architecture-features*)
"No architecture feature found in ~a."
*architecture-features*))
(version (maybe-warn (lisp-version-string)
"Don't know how to get Lisp ~
implementation version.")))
(format nil "~(~@{~a~^-~}~)" lisp version os arch))))
(defun file-newer-p (new-file old-file)
"Returns true if NEW-FILE is newer than OLD-FILE."
(> (file-write-date new-file) (file-write-date old-file)))
(defun sly-version-string ()
"Return a string identifying the SLY version.
Return nil if nothing appropriate is available."
(let ((this-file #.(or *compile-file-truename* *load-truename*)))
(with-open-file (s (make-pathname :name "sly" :type "el"
:directory (butlast
(pathname-directory this-file)
1)
:defaults this-file))
(let ((seq (make-array 200 :element-type 'character :initial-element #\null)))
(read-sequence seq s :end 200)
(let* ((beg (search ";; Version:" seq))
(end (position #\NewLine seq :start beg))
(middle (position #\Space seq :from-end t :end end)))
(subseq seq (1+ middle) end))))))
(defun default-fasl-dir ()
(merge-pathnames
(make-pathname
:directory `(:relative ".sly" "fasl"
,@(if (sly-version-string) (list (sly-version-string)))
,(unique-dir-name)))
(let ((uhp (user-homedir-pathname)))
(make-pathname
:directory (or (pathname-directory uhp)
'(:absolute))
:defaults uhp))))
(defvar *fasl-directory* (default-fasl-dir)
"The directory where fasl files should be placed.")
(defun binary-pathname (src-pathname binary-dir)
"Return the pathname where SRC-PATHNAME's binary should be compiled."
(let ((cfp (compile-file-pathname src-pathname)))
(merge-pathnames (make-pathname :name (pathname-name cfp)
:type (pathname-type cfp))
binary-dir)))
(defun handle-slynk-load-error (condition context pathname)
(fresh-line *error-output*)
(pprint-logical-block (*error-output* () :per-line-prefix ";; ")
(format *error-output*
"~%Error ~A ~A:~% ~A~%"
context pathname condition)))
(defun compile-files (files fasl-dir load quiet)
"Compile each file in FILES if the source is newer than its
corresponding binary, or the file preceding it was recompiled.
If LOAD is true, load the fasl file."
(let ((needs-recompile nil)
(state :unknown))
(dolist (src files)
(let ((dest (binary-pathname src fasl-dir)))
(handler-bind
((error (lambda (c)
(ecase state
(:compile (handle-slynk-load-error c "compiling" src))
(:load (handle-slynk-load-error c "loading" dest))
(:unknown (handle-slynk-load-error c "???ing" src))))))
(when (or needs-recompile
(not (probe-file dest))
(file-newer-p src dest))
(ensure-directories-exist dest)
;; need to recompile SRC, so we'll need to recompile
;; everything after this too.
(setf needs-recompile t
state :compile)
(or (compile-file src :output-file dest :print nil
:verbose (not quiet))
;; An implementation may not necessarily signal a
;; condition itself when COMPILE-FILE fails (e.g. ECL)
(error "COMPILE-FILE returned NIL.")))
(when load
(setf state :load)
(load dest :verbose (not quiet))))))))
#+cormanlisp
(defun compile-files (files fasl-dir load quiet)
"Corman Lisp has trouble with compiled files."
(declare (ignore fasl-dir))
(when load
(dolist (file files)
(load file :verbose (not quiet)
(force-output)))))
(defun ensure-list (o)
(if (listp o) o (list o)))
(defun src-files (files src-dir)
"Return actual pathnames for each spec in FILES."
(mapcar (lambda (compound-name)
(let* ((directories (butlast compound-name))
(name (car (last compound-name))))
(make-pathname :name (string-downcase name) :type "lisp"
:directory (append (or (pathname-directory src-dir)
'(:relative))
(mapcar #'string-downcase directories))
:defaults src-dir)))
(mapcar #'ensure-list files)))
(defvar *slynk-files*
`(slynk-backend ,@*sysdep-files* #-armedbear slynk-gray slynk-match slynk-rpc
slynk slynk-completion slynk-apropos))
(defun load-slynk (&key (src-dir *source-directory*)
(fasl-dir *fasl-directory*)
quiet)
(compile-files (src-files *slynk-files* src-dir) fasl-dir t quiet))
(defun delete-stale-contrib-fasl-files (slynk-files contrib-files fasl-dir)
(let ((newest (reduce #'max (mapcar #'file-write-date slynk-files))))
(dolist (src contrib-files)
(let ((fasl (binary-pathname src fasl-dir)))
(when (and (probe-file fasl)
(<= (file-write-date fasl) newest))
(delete-file fasl))))))
(defun loadup ()
(load-slynk))
(defun setup ()
(funcall (q "slynk::init")))
(defun string-starts-with (string prefix)
(string-equal string prefix :end1 (min (length string) (length prefix))))
(defun list-slynk-packages ()
(remove-if-not (lambda (package)
(let ((name (package-name package)))
(and (string-not-equal name "slynk-loader")
(string-starts-with name "slynk"))))
(list-all-packages)))
(defun delete-packages (packages)
(dolist (package packages)
(flet ((handle-package-error (c)
(let ((pkgs (set-difference (package-used-by-list package)
packages)))
(when pkgs
(warn "deleting ~a which is used by ~{~a~^, ~}."
package pkgs))
(continue c))))
(handler-bind ((package-error #'handle-package-error))
(delete-package package)))))
(defun init (&key delete reload (setup t)
(quiet (not *load-verbose*))
load-contribs)
"Load SLYNK and initialize some global variables.
If DELETE is true, delete any existing SLYNK packages.
If RELOAD is true, reload SLYNK, even if the SLYNK package already exists.
If SETUP is true, load user init files and initialize some
global variabes in SLYNK."
(if load-contribs
(warn
"LOAD-CONTRIBS arg to SLYNK-LOADER:INIT is deprecated and useless"))
(when (and delete (find-package :slynk))
(delete-packages (list-slynk-packages))
(mapc #'delete-package '(:slynk :slynk-io-package :slynk-backend)))
(cond ((or (not (find-package :slynk)) reload)
(load-slynk :quiet quiet))
(t
(warn "Not reloading SLYNK. Package already exists.")))
(when setup
(setup)))
(defun dump-image (filename)
(init :setup nil)
(funcall (q "slynk-backend:save-image") filename))
;;;;;; Simple *require-module* function for asdf-loader.lisp.
(defun module-binary-dir (src-file)
(flet ((dir-components (path)
(cdr (pathname-directory path))))
(make-pathname :directory
(append
(pathname-directory *fasl-directory*)
(nthcdr (mismatch (dir-components *fasl-directory*)
(dir-components src-file)
:test #'equal)
(dir-components src-file))))))
(defun require-module (module)
(labels ((module () (string-upcase module))
(provided ()
(member (string-upcase (module)) *modules* :test #'string=)))
(unless (provided)
(let* ((src-file-name (substitute #\- #\/ (string-downcase module)))
(src-file
(some #'(lambda (dir)
(probe-file (make-pathname
:name src-file-name
:type "lisp"
:defaults dir)))
*load-path*)))
(assert src-file
nil
"Required module ~a but no source file ~a found in ~a" module
src-file-name
*load-path*)
(compile-files (list src-file)
(module-binary-dir src-file)
'load
nil)
(assert (provided)
nil
"Compiled and loaded ~a but required module ~s was not
provided" src-file module)))))
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; slynk-gray.lisp --- Gray stream based IO redirection.
;;;
;;; Created 2003
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(in-package slynk-backend)
#.(progn
(defvar *gray-stream-symbols*
'(fundamental-character-output-stream
stream-write-char
stream-write-string
stream-fresh-line
stream-force-output
stream-finish-output
fundamental-character-input-stream
stream-read-char
stream-peek-char
stream-read-line
stream-listen
stream-unread-char
stream-clear-input
stream-line-column
stream-read-char-no-hang))
nil)
(defpackage slynk-gray
(:use cl slynk-backend)
(:import-from #.(gray-package-name) . #.*gray-stream-symbols*)
(:export . #.*gray-stream-symbols*))
(in-package slynk-gray)
(defclass sly-output-stream (fundamental-character-output-stream)
((output-fn :initarg :output-fn)
(buffer :initform (make-string 8000))
(fill-pointer :initform 0)
(column :initform 0)
(lock :initform (make-lock :name "buffer write lock"))
(flush-thread :initarg :flush-thread
:initform nil
:accessor flush-thread)
(flush-scheduled :initarg :flush-scheduled
:initform nil
:accessor flush-scheduled)))
(defun maybe-schedule-flush (stream)
(when (and (flush-thread stream)
(not (flush-scheduled stream)))
(setf (flush-scheduled stream) t)
(send (flush-thread stream) t)))
(defmacro with-sly-output-stream (stream &body body)
`(with-slots (lock output-fn buffer fill-pointer column) ,stream
(call-with-lock-held lock (lambda () ,@body))))
(defmethod stream-write-char ((stream sly-output-stream) char)
(with-sly-output-stream stream
(setf (schar buffer fill-pointer) char)
(incf fill-pointer)
(incf column)
(when (char= #\newline char)
(setf column 0))
(if (= fill-pointer (length buffer))
(finish-output stream)
(maybe-schedule-flush stream)))
char)
(defmethod stream-write-string ((stream sly-output-stream) string
&optional start end)
(with-sly-output-stream stream
(let* ((start (or start 0))
(end (or end (length string)))
(len (length buffer))
(count (- end start))
(free (- len fill-pointer)))
(when (>= count free)
(stream-finish-output stream))
(cond ((< count len)
(replace buffer string :start1 fill-pointer
:start2 start :end2 end)
(incf fill-pointer count)
(maybe-schedule-flush stream))
(t
(funcall output-fn (subseq string start end))))
(let ((last-newline (position #\newline string :from-end t
:start start :end end)))
(setf column (if last-newline
(- end last-newline 1)
(+ column count))))))
string)
(defmethod stream-line-column ((stream sly-output-stream))
(with-sly-output-stream stream column))
(defmethod reset-stream-line-column ((stream sly-output-stream))
(with-sly-output-stream stream (setf column 0)))
#+sbcl
(defmethod reset-stream-line-column ((stream sb-sys:fd-stream))
(with-slots (sb-impl::output-column) stream
(setf sb-impl::output-column 0)))
#+cmucl
(defmethod reset-stream-line-column ((stream system:fd-stream))
(with-slots (lisp::char-pos) stream
(setf lisp::char-pos 0)))
(defmethod stream-finish-output ((stream sly-output-stream))
(with-sly-output-stream stream
(unless (zerop fill-pointer)
(funcall output-fn (subseq buffer 0 fill-pointer))
(setf fill-pointer 0))
(setf (flush-scheduled stream) nil))
nil)
#+(and sbcl sb-thread)
(defmethod stream-force-output :around ((stream sly-output-stream))
;; Workaround for deadlocks between the world-lock and auto-flush-thread
;; buffer write lock.
;;
;; Another alternative would be to grab the world-lock here, but that's less
;; future-proof, and could introduce other lock-ordering issues in the
;; future.
(handler-case
(sb-sys:with-deadline (:seconds 0.1)
(call-next-method))
(sb-sys:deadline-timeout ()
nil)))
(defmethod stream-force-output ((stream sly-output-stream))
(stream-finish-output stream))
(defmethod stream-fresh-line ((stream sly-output-stream))
(with-sly-output-stream stream
(cond ((zerop column) nil)
(t (terpri stream) t))))
(defclass sly-input-stream (fundamental-character-input-stream)
((input-fn :initarg :input-fn)
(buffer :initform "") (index :initform 0)
(lock :initform (make-lock :name "buffer read lock"))))
(defmethod stream-read-char ((s sly-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index input-fn) s
(when (= index (length buffer))
(let ((string (funcall input-fn)))
(cond ((zerop (length string))
(return-from stream-read-char :eof))
(t
(setf buffer string)
(setf index 0)))))
(assert (plusp (length buffer)))
(prog1 (aref buffer index) (incf index))))))
(defmethod stream-listen ((s sly-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(< index (length buffer))))))
(defmethod stream-unread-char ((s sly-input-stream) char)
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(decf index)
(cond ((eql (aref buffer index) char)
(setf (aref buffer index) char))
(t
(warn "stream-unread-char: ignoring ~S (expected ~S)"
char (aref buffer index)))))))
nil)
(defmethod stream-clear-input ((s sly-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(setf buffer ""
index 0))))
nil)
(defmethod stream-line-column ((s sly-input-stream))
nil)
(defmethod stream-read-char-no-hang ((s sly-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(when (< index (length buffer))
(prog1 (aref buffer index) (incf index)))))))
;;;
(defimplementation make-auto-flush-thread (stream)
(if (typep stream 'sly-output-stream)
(setf (flush-thread stream)
(spawn (lambda () (auto-flush-loop stream 0.08 t))
:name "auto-flush-thread"))
(spawn (lambda () (auto-flush-loop stream *auto-flush-interval*))
:name "auto-flush-thread")))
(defimplementation make-output-stream (write-string)
(make-instance 'sly-output-stream :output-fn write-string))
(defimplementation make-input-stream (read-string)
(make-instance 'sly-input-stream :input-fn read-string))
;;; slynk-flex-completion.lisp --- Common Lisp symbol completion routines
;;
;; Authors: João Távora, some parts derivative works of SLIME, by its
;; authors.
;;
(defpackage :slynk-completion
(:use #:cl #:slynk-api)
(:export
#:flex-completions
#:simple-completions
#:flex-matches))
;; for testing package-local nicknames
#+sbcl
(defpackage :slynk-completion-local-nicknames-test
(:use #:cl)
(:local-nicknames (#:api #:slynk-api)))
(in-package :slynk-completion)
;;; Simple completion
;;;
(defslyfun simple-completions (prefix package)
"Return a list of completions for the string PREFIX."
(let ((strings (all-simple-completions prefix package)))
(list strings (longest-common-prefix strings))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(import 'simple-completions :slynk)
(export 'simple-completions :slynk))
(defun all-simple-completions (prefix package)
(multiple-value-bind (name pname intern) (tokenize-symbol prefix)
(let* ((extern (and pname (not intern)))
(pkg (cond ((equal pname "") +keyword-package+)
((not pname) (guess-buffer-package package))
(t (guess-package pname))))
(test (lambda (sym) (prefix-match-p name (symbol-name sym))))
(syms (and pkg (matching-symbols pkg extern test)))
(strings (loop for sym in syms
for str = (unparse-symbol sym)
when (prefix-match-p name str) ; remove |Foo|
collect str)))
(format-completion-set strings intern pname))))
(defun matching-symbols (package external test)
(let ((test (if external
(lambda (s)
(and (symbol-external-p s package)
(funcall test s)))
test))
(result '()))
(do-symbols (s package)
(when (funcall test s)
(push s result)))
(remove-duplicates result)))
(defun unparse-symbol (symbol)
(let ((*print-case* (case (readtable-case *readtable*)
(:downcase :upcase)
(t :downcase))))
(unparse-name (symbol-name symbol))))
(defun prefix-match-p (prefix string)
"Return true if PREFIX is a prefix of STRING."
(not (mismatch prefix string :end2 (min (length string) (length prefix))
:test #'char-equal)))
(defun longest-common-prefix (strings)
"Return the longest string that is a common prefix of STRINGS."
(if (null strings)
""
(flet ((common-prefix (s1 s2)
(let ((diff-pos (mismatch s1 s2)))
(if diff-pos (subseq s1 0 diff-pos) s1))))
(reduce #'common-prefix strings))))
(defun format-completion-set (strings internal-p package-name)
"Format a set of completion strings.
Returns a list of completions with package qualifiers if needed."
(mapcar (lambda (string) (untokenize-symbol package-name internal-p string))
(sort strings #'string<)))
;;; Fancy "flex" completion
;;;
(defmacro collecting ((&rest collectors) &body body) ; lifted from uiop
"COLLECTORS should be a list of names for collections. A collector
defines a function that, when applied to an argument inside BODY, will
add its argument to the corresponding collection. Returns multiple values,
a list for each collection, in order.
E.g.,
\(collecting \(foo bar\)
\(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
\(foo \(first x\)\)
\(bar \(second x\)\)\)\)
Returns two values: \(A B C\) and \(1 2 3\)."
(let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
(initial-values (mapcar (constantly nil) collectors)))
`(let ,(mapcar #'list vars initial-values)
(flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
,@body
(values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
(defun to-chunks (string indexes)
"Return chunks of STRING in as specified by INDEXES."
;; (to-chunks "farfalhini" '(1 2 3 4)) => ((1 "arfa"))
;; (to-chunks "farfalhini" '(1 3 4)) => ((1 "a") (3 "fa"))
;; (to-chunks "farfalhini" '(1 2 3 4 5 7 8 9)) => ((1 "arfal") (7 "ini"))
;; (to-chunks "farfalhini" '(1 2 3 4 5 6 7 8 9)) => ((1 "arfalhini"))
(reverse (reduce (lambda (chunk-list number)
(let ((latest-chunk (car chunk-list)))
(if (and latest-chunk
(= (+
(length (second latest-chunk))
(first latest-chunk))
number))
(progn (setf (second latest-chunk)
(format nil "~a~c" (second latest-chunk)
(aref string number)))
chunk-list)
(cons (list number (format nil "~c" (aref string number)))
chunk-list))))
indexes
:initial-value nil)))
(defun readably-classify (sym)
(let* ((translations '((:fboundp . "fn")
(:class . "cla")
(:typespec . "type")
(:generic-function . "generic-fn")
(:macro . "macro")
(:special-operator . "special-op")
(:package . "pak")
(:boundp . "var")
(:constant . "constant")))
(classes (slynk::classify-symbol sym))
(classes (if (some (lambda (m) (member m classes)) '(:generic-function :macro))
(delete :fboundp classes)
classes))
(translated (mapcar (lambda (cla) (cdr (assoc cla translations)))
classes)))
(format nil "~{~a~^,~}" translated)))
(defparameter *flex-score-falloff* 1.5
"The larger the value, the more big index distances are penalized.")
(defparameter *more-qualified-matches* t
"If non-nil, \"foo\" more likely completes to \"bar:foo\".
Specifically this assigns a \"foo\" on \"bar:foo\" a
higher-than-usual score, as if the package qualifier \"bar\" was
shorter.")
(defun flex-score (string indexes pattern)
"Score the match of STRING as given by INDEXES.
INDEXES as calculated by FLEX-MATCHES."
(let* ((first-pattern-colon (and pattern
(position #\: pattern)))
(index-of-first-pattern-colon (and first-pattern-colon
(elt indexes first-pattern-colon)))
(first-string-colon)
(string-length (length string)))
(cond ((and first-pattern-colon
(plusp first-pattern-colon))
;; If the user included a colon (":") in the pattern, score
;; the pre-colon and post-colon parts separately and add
;; the resulting halves together. This tends to fare
;; slightly better when matching qualified symbols.
(let ((package-designator-score
(flex-score-1 index-of-first-pattern-colon
(subseq indexes 0 first-pattern-colon)))
(symbol-name-score
(flex-score-1 (- string-length
index-of-first-pattern-colon)
(mapcar (lambda (index)
(- index index-of-first-pattern-colon))
(subseq indexes (1+ first-pattern-colon))))))
(+ (/ package-designator-score 2)
(/ symbol-name-score 2))))
((and
*more-qualified-matches*
(setf first-string-colon (position #\: string))
(< first-string-colon
(car indexes)))
;; If the user did not include a colon, but the string
;; we're matching again does have that colon (we're
;; matching a qualified name), and the position of that
;; colon happens to be less than the first index, then act
;; as if the pre-colon part were actually half the size of
;; what it is. This also tends to promote qualified matches
;; meant on the symbol-name.
(let ((adjust (truncate (/ first-string-colon 2))))
(flex-score-1 (- string-length
adjust)
(mapcar (lambda (idx)
(- idx adjust))
indexes))))
(t
;; the default: score the whole pattern on the whole
;; string.
(flex-score-1 string-length indexes)))))
(defun flex-score-1 (string-length indexes)
"Does the real work of FLEX-SCORE.
Given that INDEXES is a list of integer position of characters in a
string of length STRING-LENGTH, say how well these characters
represent that STRING. There is a non-linear falloff with the
distances between the indexes, according to *FLEX-SCORE-FALLOFF*. If
that value is 2, for example, the indices '(0 1 2) on a 3-long
string of is a perfect (100% match,) while '(0 2) on that same
string is a 33% match and just '(1) is a 11% match."
(float
(/ (length indexes)
(* string-length
(+ 1 (reduce #'+
(loop for i from 0
for (a b) on `(,-1
,@indexes
,string-length)
while b
collect (expt (- b a 1) *flex-score-falloff*))))))))
(defun flex-matches (pattern string char-test)
"Return non-NIL if PATTERN flex-matches STRING.
In case of a match, return two values:
A list of non-negative integers which are the indexes of the
characters in PATTERN as found consecutively in STRING. This list
measures in length the number of characters in PATTERN.
A floating-point score. Higher scores for better matches."
(declare (optimize (speed 3) (safety 0))
(type simple-string string)
(type simple-string pattern)
(type function char-test))
(let* ((strlen (length string))
(indexes (loop for char across pattern
for from = 0 then (1+ pos)
for pos = (loop for i from from below strlen
when (funcall char-test
(aref string i) char)
return i)
unless pos
return nil
collect pos)))
(values indexes
(and indexes
(flex-score string indexes pattern)))))
(defun collect-if-matches (collector pattern string symbol)
"Make and collect a match with COLLECTOR if PATTERN matches STRING.
A match is a list (STRING SYMBOL INDEXES SCORE).
Return non-nil if match was collected, nil otherwise."
(multiple-value-bind (indexes score)
(flex-matches pattern string #'char=)
(when indexes
(funcall collector
(list string
symbol
indexes
score)))))
(defun sort-by-score (matches)
"Sort MATCHES by SCORE, highest score first.
Matches are produced by COLLECT-IF-MATCHES (which see)."
(sort matches #'> :key #'fourth))
(defun keywords-matching (pattern)
"Find keyword symbols flex-matching PATTERN.
Return an unsorted list of matches.
Matches are produced by COLLECT-IF-MATCHES (which see)."
(collecting (collect)
(and (char= (aref pattern 0) #\:)
(do-symbols (s +keyword-package+)
(collect-if-matches #'collect pattern (concatenate 'simple-string ":"
(symbol-name s))
s)))))
(defun accessible-matching (pattern package)
"Find symbols flex-matching PATTERN accessible without package-qualification.
Return an unsorted list of matches.
Matches are produced by COLLECT-IF-MATCHES (which see)."
(and (not (find #\: pattern))
(collecting (collect)
(let ((collected (make-hash-table)))
(do-symbols (s package)
;; XXX: since DO-SYMBOLS may visit a symbol more than
;; once. Read similar note apropos DO-ALL-SYMBOLS in
;; QUALIFIED-MATCHING for how we do it.
(collect-if-matches
(lambda (thing)
(unless (gethash s collected)
(setf (gethash s collected) t)
(funcall #'collect thing)))
pattern (symbol-name s) s))))))
(defun qualified-matching (pattern home-package)
"Find package-qualified symbols flex-matching PATTERN.
Return, as two values, a set of matches for external symbols,
package-qualified using one colon, and another one for internal
symbols, package-qualified using two colons.
The matches in the two sets are not guaranteed to be in their final
order, i.e. they are not sorted (except for the fact that
qualifications with shorter package nicknames are tried first).
Matches are produced by COLLECT-IF-MATCHES (which see)."
(let* ((first-colon (position #\: pattern))
(starts-with-colon (and first-colon (zerop first-colon)))
(two-colons (and first-colon (< (1+ first-colon) (length pattern))
(eq #\: (aref pattern (1+ first-colon))))))
(if (and starts-with-colon
(not two-colons))
(values nil nil)
(let* ((package-local-nicknames
(slynk-backend:package-local-nicknames home-package))
(package-local-nicknames-by-package
(let ((ret (make-hash-table)))
(loop for (short . full) in
package-local-nicknames
do (push short (gethash (find-package full)
ret)))
ret))
(nicknames-by-package (make-hash-table)))
(flet ((sorted-nicknames (package)
(or (gethash package nicknames-by-package)
(setf (gethash package nicknames-by-package)
(sort (append
(gethash package package-local-nicknames-by-package)
(package-nicknames package)
(list (package-name package)))
#'<
:key #'length)))))
(collecting (collect-external collect-internal)
(cond
(two-colons
(let ((collected (make-hash-table)))
(do-all-symbols (s)
(loop
with package = (symbol-package s)
for nickname in (and package ; gh#226
(sorted-nicknames package))
do (collect-if-matches
(lambda (thing)
;; XXX: since DO-ALL-SYMBOLS may visit
;; a symbol more than once, we want to
;; avoid double collections. But
;; instead of marking every traversed
;; symbol in a hash table, we mark just
;; those collected. We do pay an added
;; price of checking matching duplicate
;; symbols, but the much smaller hash
;; table pays off when benchmarked,
;; because the number of collections is
;; generally much smaller than the
;; total number of symbols.
(unless (gethash s collected)
(setf (gethash s collected) t)
(funcall #'collect-internal thing)))
pattern
(concatenate 'simple-string
nickname
"::"
(symbol-name s))
s)))))
(t
(loop
with use-list = (package-use-list home-package)
for package in (remove +keyword-package+ (list-all-packages))
for sorted-nicknames
= (and (not (eq package home-package))
(sorted-nicknames package))
do (when sorted-nicknames
(do-external-symbols (s package)
;;; XXX: This condition is slightly
;;; opinionated. It says, for example, that
;;; you never want to complete "c:del" to
;;; "cl:delete" or "common-lisp:delete" in
;;; packages that use :CL (a very common
;;; case).
(when (or first-colon
(not (member (symbol-package s) use-list)))
(loop for nickname in sorted-nicknames
do (collect-if-matches #'collect-external
pattern
(concatenate 'simple-string
nickname
":"
(symbol-name s))
s))))))))))))))
(defslyfun flex-completions (pattern package-name &key (limit 300))
"Compute \"flex\" completions for PATTERN given current PACKAGE-NAME.
Returns a list of (COMPLETIONS NIL). COMPLETIONS is a list of
\(STRING SCORE CHUNKS CLASSIFICATION-STRING)."
(when (plusp (length pattern))
(list (loop
with package = (guess-buffer-package package-name)
with upcasepat = (string-upcase pattern)
for (string symbol indexes score)
in
(loop with (external internal)
= (multiple-value-list (qualified-matching upcasepat package))
for e in (append (sort-by-score
(keywords-matching upcasepat))
(sort-by-score
(append (accessible-matching upcasepat package)
external))
(sort-by-score
internal))
for i upto limit
collect e)
collect
(list (if (every #'common-lisp:upper-case-p pattern)
(string-upcase string)
(string-downcase string))
score
(to-chunks string indexes)
(readably-classify symbol)))
nil)))
(provide :slynk/completion)
;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
;;;
;;; sly-backend.lisp --- SLY backend interface.
;;;
;;; Created by James Bielman in 2003. Released into the public domain.
;;;
;;;; Frontmatter
;;;
;;; This file defines the functions that must be implemented
;;; separately for each Lisp. Each is declared as a generic function
;;; for which slynk-<implementation>.lisp provides methods.
(defpackage slynk-backend
(:use cl)
(:export *debug-slynk-backend*
sly-db-condition
compiler-condition
original-condition
message
source-context
condition
severity
with-compilation-hooks
make-location
location
location-p
location-buffer
location-position
location-hints
position-p
position-pos
print-output-to-string
quit-lisp
references
unbound-slot-filler
declaration-arglist
type-specifier-arglist
with-struct
when-let
defimplementation
converting-errors-to-error-location
make-error-location
deinit-log-output
;; interrupt macro for the backend
*pending-sly-interrupts*
check-sly-interrupts
*interrupt-queued-handler*
;; inspector related symbols
emacs-inspect
label-value-line
label-value-line*
with-symbol
choose-symbol
boolean-to-feature-expression
;; package helper for backend
import-to-slynk-mop
import-slynk-mop-symbols
;;
definterface
defimplementation
;; auto-flush
auto-flush-loop
*auto-flush-interval*
find-symbol2
))
(defpackage slynk-mop
(:use)
(:export
;; classes
standard-generic-function
standard-slot-definition
standard-method
standard-class
eql-specializer
eql-specializer-object
;; standard-class readers
class-default-initargs
class-direct-default-initargs
class-direct-slots
class-direct-subclasses
class-direct-superclasses
class-finalized-p
class-name
class-precedence-list
class-prototype
class-slots
specializer-direct-methods
;; generic function readers
generic-function-argument-precedence-order
generic-function-declarations
generic-function-lambda-list
generic-function-methods
generic-function-method-class
generic-function-method-combination
generic-function-name
;; method readers
method-generic-function
method-function
method-lambda-list
method-specializers
method-qualifiers
;; slot readers
slot-definition-allocation
slot-definition-documentation
slot-definition-initargs
slot-definition-initform
slot-definition-initfunction
slot-definition-name
slot-definition-type
slot-definition-readers
slot-definition-writers
slot-boundp-using-class
slot-value-using-class
slot-makunbound-using-class
;; generic function protocol
compute-applicable-methods-using-classes
finalize-inheritance))
(in-package slynk-backend)
;;;; Metacode
(defparameter *debug-slynk-backend* nil
"If this is true, backends should not catch errors but enter the
debugger where appropriate. Also, they should not perform backtrace
magic but really show every frame including SLYNK related ones.")
(defparameter *interface-functions* '()
"The names of all interface functions.")
(defparameter *unimplemented-interfaces* '()
"List of interface functions that are not implemented.
DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
(defmacro definterface (name args documentation &rest default-body)
"Define an interface function for the backend to implement.
A function is defined with NAME, ARGS, and DOCUMENTATION. This
function first looks for a function to call in NAME's property list
that is indicated by 'IMPLEMENTATION; failing that, it looks for a
function indicated by 'DEFAULT. If neither is present, an error is
signaled.
If a DEFAULT-BODY is supplied, then a function with the same body and
ARGS will be added to NAME's property list as the property indicated
by 'DEFAULT.
Backends implement these functions using DEFIMPLEMENTATION."
(check-type documentation string "a documentation string")
(assert (every #'symbolp args) ()
"Complex lambda-list not supported: ~S ~S" name args)
(labels ((gen-default-impl ()
`(setf (get ',name 'default) (lambda ,args ,@default-body)))
(args-as-list (args)
(destructuring-bind (req opt key rest) (parse-lambda-list args)
`(,@req ,@opt
,@(loop for k in key append `(,(kw k) ,k))
,@(or rest '(())))))
(parse-lambda-list (args)
(parse args '(&optional &key &rest)
(make-array 4 :initial-element nil)))
(parse (args keywords vars)
(cond ((null args)
(reverse (map 'list #'reverse vars)))
((member (car args) keywords)
(parse (cdr args) (cdr (member (car args) keywords)) vars))
(t (push (car args) (aref vars (length keywords)))
(parse (cdr args) keywords vars))))
(kw (s) (intern (string s) :keyword)))
`(progn
(defun ,name ,args
,documentation
(let ((f (or (get ',name 'implementation)
(get ',name 'default))))
(cond (f (apply f ,@(args-as-list args)))
(t (error "~S not implemented" ',name)))))
(pushnew ',name *interface-functions*)
,(if (null default-body)
`(pushnew ',name *unimplemented-interfaces*)
(gen-default-impl))
(eval-when (:compile-toplevel :load-toplevel :execute)
(import ',name :slynk-backend)
(export ',name :slynk-backend))
',name)))
(defmacro defimplementation (name args &body body)
(assert (every #'symbolp args) ()
"Complex lambda-list not supported: ~S ~S" name args)
(let ((sym (find-symbol (symbol-name name) :slynk-backend)))
`(progn
(setf (get ',sym 'implementation)
;; For implicit BLOCK. FLET because of interplay w/ decls.
(flet ((,sym ,args ,@body)) #',sym))
(if (member ',sym *interface-functions*)
(setq *unimplemented-interfaces*
(remove ',sym *unimplemented-interfaces*))
(warn "DEFIMPLEMENTATION of undefined interface (~S)" ',sym))
',sym)))
(defun warn-unimplemented-interfaces ()
"Warn the user about unimplemented backend features.
The portable code calls this function at startup."
(let ((*print-pretty* t))
(warn "These Slynk interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
(list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
(defun find-symbol2 (name)
;; FIXME/TODO: Not a very good FIND-SYMBOL alternative, but works
;; for now and localized here so we can fix that some day (adding
;; error reporting for example).
(with-standard-io-syntax (read-from-string name)))
(defun import-to-slynk-mop (symbol-list)
(dolist (sym symbol-list)
(let* ((slynk-mop-sym (find-symbol (symbol-name sym) :slynk-mop)))
(when slynk-mop-sym
(unintern slynk-mop-sym :slynk-mop))
(import sym :slynk-mop)
(export sym :slynk-mop))))
(defun import-slynk-mop-symbols (package except)
"Import the mop symbols from PACKAGE to SLYNK-MOP.
EXCEPT is a list of symbol names which should be ignored."
(do-symbols (s :slynk-mop)
(unless (member s except :test #'string=)
(let ((real-symbol (find-symbol (string s) package)))
(assert real-symbol () "Symbol ~A not found in package ~A" s package)
(unintern s :slynk-mop)
(import real-symbol :slynk-mop)
(export real-symbol :slynk-mop)))))
(definterface gray-package-name ()
"Return a package-name that contains the Gray stream symbols.
This will be used like so:
(defpackage foo
(:import-from #.(gray-package-name) . #.*gray-stream-symbols*)")
;;;; Utilities
(defmacro with-struct ((conc-name &rest names) obj &body body)
"Like with-slots but works only for structs."
(check-type conc-name symbol)
(flet ((reader (slot)
(intern (concatenate 'string
(symbol-name conc-name)
(symbol-name slot))
(symbol-package conc-name))))
(let ((tmp (gensym "OO-")))
` (let ((,tmp ,obj))
(symbol-macrolet
,(loop for name in names collect
(typecase name
(symbol `(,name (,(reader name) ,tmp)))
(cons `(,(first name) (,(reader (second name)) ,tmp)))
(t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
,@body)))))
(defmacro when-let ((var value) &body body)
`(let ((,var ,value))
(when ,var ,@body)))
(defun boolean-to-feature-expression (value)
"Converts a boolean VALUE to a form suitable for testing with #+."
(if value
'(:and)
'(:or)))
(defun with-symbol (name package)
"Check if a symbol with a given NAME exists in PACKAGE and returns a
form suitable for testing with #+."
(boolean-to-feature-expression
(and (find-package package)
(find-symbol (string name) package))))
(defun choose-symbol (package name alt-package alt-name)
"If symbol package:name exists return that symbol, otherwise alt-package:alt-name.
Suitable for use with #."
(or (and (find-package package)
(find-symbol (string name) package))
(find-symbol (string alt-name) alt-package)))
;;;; UFT8
(deftype octet () '(unsigned-byte 8))
(deftype octets () '(simple-array octet (*)))
;; Helper function. Decode the next N bytes starting from INDEX.
;; Return the decoded char and the new index.
(defun utf8-decode-aux (buffer index limit byte0 n)
(declare (type octets buffer) (fixnum index limit byte0 n))
(if (< (- limit index) n)
(values nil index)
(do ((i 0 (1+ i))
(code byte0 (let ((byte (aref buffer (+ index i))))
(cond ((= (ldb (byte 2 6) byte) #b10)
(+ (ash code 6) (ldb (byte 6 0) byte)))
(t
#xFFFD))))) ;; Replacement_Character
((= i n)
(values (cond ((<= code #xff) (code-char code))
((<= #xd800 code #xdfff)
(code-char #xFFFD)) ;; Replacement_Character
((and (< code char-code-limit)
(code-char code)))
(t
(code-char #xFFFD))) ;; Replacement_Character
(+ index n))))))
;; Decode one character in BUFFER starting at INDEX.
;; Return 2 values: the character and the new index.
;; If there aren't enough bytes between INDEX and LIMIT return nil.
(defun utf8-decode (buffer index limit)
(declare (type octets buffer) (fixnum index limit))
(if (= index limit)
(values nil index)
(let ((b (aref buffer index)))
(if (<= b #x7f)
(values (code-char b) (1+ index))
(macrolet ((try (marker else)
(let* ((l (integer-length marker))
(n (- l 2)))
`(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker)
(utf8-decode-aux buffer (1+ index) limit
(ldb (byte ,(- 8 l) 0) b)
,n)
,else))))
(try #b110
(try #b1110
(try #b11110
(try #b111110
(try #b1111110
(error "Invalid encoding")))))))))))
;; Decode characters from BUFFER and write them to STRING.
;; Return 2 values: LASTINDEX and LASTSTART where
;; LASTINDEX is the last index in BUFFER that was not decoded
;; and LASTSTART is the last index in STRING not written.
(defun utf8-decode-into (buffer index limit string start end)
(declare (string string) (fixnum index limit start end) (type octets buffer))
(loop
(cond ((= start end)
(return (values index start)))
(t
(multiple-value-bind (c i) (utf8-decode buffer index limit)
(cond (c
(setf (aref string start) c)
(setq index i)
(setq start (1+ start)))
(t
(return (values index start)))))))))
(defun default-utf8-to-string (octets)
(let* ((limit (length octets))
(str (make-string limit)))
(multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit)
(if (= i limit)
(if (= limit s)
str
(adjust-array str s))
(loop
(let ((end (+ (length str) (- limit i))))
(setq str (adjust-array str end))
(multiple-value-bind (i2 s2)
(utf8-decode-into octets i limit str s end)
(cond ((= i2 limit)
(return (adjust-array str s2)))
(t
(setq i i2)
(setq s s2))))))))))
(defmacro utf8-encode-aux (code buffer start end n)
`(cond ((< (- ,end ,start) ,n)
,start)
(t
(setf (aref ,buffer ,start)
(dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code)
(byte ,(- 7 n) 0)
,(dpb 0 (byte 1 (- 7 n)) #xff)))
,@(loop for i from 0 upto (- n 2) collect
`(setf (aref ,buffer (+ ,start ,(- n 1 i)))
(dpb (ldb (byte 6 ,(* 6 i)) ,code)
(byte 6 0)
#b10111111)))
(+ ,start ,n))))
(defun %utf8-encode (code buffer start end)
(declare (type (unsigned-byte 31) code) (type octets buffer)
(type (and fixnum unsigned-byte) start end))
(cond ((<= code #x7f)
(cond ((< start end)
(setf (aref buffer start) code)
(1+ start))
(t start)))
((<= code #x7ff) (utf8-encode-aux code buffer start end 2))
((<= #xd800 code #xdfff)
(%utf8-encode (code-char #xFFFD) ;; Replacement_Character
buffer start end))
((<= code #xffff) (utf8-encode-aux code buffer start end 3))
((<= code #x1fffff) (utf8-encode-aux code buffer start end 4))
((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5))
(t (utf8-encode-aux code buffer start end 6))))
(defun utf8-encode (char buffer start end)
(declare (type character char) (type octets buffer)
(type (and fixnum unsigned-byte) start end))
(%utf8-encode (char-code char) buffer start end))
(defun utf8-encode-into (string start end buffer index limit)
(declare (string string) (type octets buffer) (fixnum start end index limit))
(loop
(cond ((= start end)
(return (values start index)))
((= index limit)
(return (values start index)))
(t
(let ((i2 (utf8-encode (char string start) buffer index limit)))
(cond ((= i2 index)
(return (values start index)))
(t
(setq index i2)
(incf start))))))))
(defun default-string-to-utf8 (string)
(let* ((len (length string))
(b (make-array len :element-type 'octet)))
(multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len)
(if (= s len)
b
(loop
(let ((limit (+ (length b) (- len s))))
(setq b (coerce (adjust-array b limit) 'octets))
(multiple-value-bind (s2 i2)
(utf8-encode-into string s len b i limit)
(cond ((= s2 len)
(return (coerce (adjust-array b i2) 'octets)))
(t
(setq i i2)
(setq s s2))))))))))
(definterface string-to-utf8 (string)
"Convert the string STRING to a (simple-array (unsigned-byte 8))"
(default-string-to-utf8 string))
(definterface utf8-to-string (octets)
"Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
(default-utf8-to-string octets))
;;; Codepoint length
;; we don't need this anymore.
(definterface codepoint-length (string)
"Return the number of codepoints in STRING.
With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
units, but other Lisps return the number of codepoints. The sly
protocol wants string lengths in terms of codepoints."
(length string))
;;;; TCP server
(definterface create-socket (host port &key backlog)
"Create a listening TCP socket on interface HOST and port PORT.
BACKLOG queue length for incoming connections.")
(definterface local-port (socket)
"Return the local port number of SOCKET.")
(definterface close-socket (socket)
"Close the socket SOCKET.")
(definterface accept-connection (socket &key external-format
buffering timeout)
"Accept a client connection on the listening socket SOCKET.
Return a stream for the new connection.
If EXTERNAL-FORMAT is nil return a binary stream
otherwise create a character stream.
BUFFERING can be one of:
nil ... no buffering
t ... enable buffering
:line ... enable buffering with automatic flushing on eol.")
(definterface add-sigio-handler (socket fn)
"Call FN whenever SOCKET is readable.")
(definterface remove-sigio-handlers (socket)
"Remove all sigio handlers for SOCKET.")
(definterface add-fd-handler (socket fn)
"Call FN when Lisp is waiting for input and SOCKET is readable.")
(definterface remove-fd-handlers (socket)
"Remove all fd-handlers for SOCKET.")
(definterface preferred-communication-style ()
"Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
nil)
(definterface set-stream-timeout (stream timeout)
"Set the 'stream 'timeout. The timeout is either the real number
specifying the timeout in seconds or 'nil for no timeout."
(declare (ignore stream timeout))
nil)
;;; Base condition for networking errors.
(define-condition network-error (simple-error) ())
(definterface emacs-connected ()
"Hook called when the first connection from Emacs is established.
Called from the INIT-FN of the socket server that accepts the
connection.
This is intended for setting up extra context, e.g. to discover
that the calling thread is the one that interacts with Emacs."
nil)
;;;; Unix signals
(defconstant +sigint+ 2)
(definterface getpid ()
"Return the (Unix) process ID of this superior Lisp.")
(definterface install-sigint-handler (function)
"Call FUNCTION on SIGINT (instead of invoking the debugger).
Return old signal handler."
(declare (ignore function))
nil)
(definterface call-with-user-break-handler (handler function)
"Install the break handler HANDLER while executing FUNCTION."
(let ((old-handler (install-sigint-handler handler)))
(unwind-protect (funcall function)
(install-sigint-handler old-handler))))
(definterface quit-lisp ()
"Exit the current lisp image.")
(definterface lisp-implementation-type-name ()
"Return a short name for the Lisp implementation."
(lisp-implementation-type))
(definterface lisp-implementation-program ()
"Return the argv[0] of the running Lisp process, or NIL."
(let ((file (car (command-line-args))))
(when (and file (probe-file file))
(namestring (truename file)))))
(definterface socket-fd (socket-stream)
"Return the file descriptor for SOCKET-STREAM.")
(definterface make-fd-stream (fd external-format)
"Create a character stream for the file descriptor FD.")
(definterface dup (fd)
"Duplicate a file descriptor.
If the syscall fails, signal a condition.
See dup(2).")
(definterface exec-image (image-file args)
"Replace the current process with a new process image.
The new image is created by loading the previously dumped
core file IMAGE-FILE.
ARGS is a list of strings passed as arguments to
the new image.
This is thin wrapper around exec(3).")
(definterface command-line-args ()
"Return a list of strings as passed by the OS."
nil)
;; pathnames are sooo useless
(definterface filename-to-pathname (filename)
"Return a pathname for FILENAME.
A filename in Emacs may for example contain asterisks which should not
be translated to wildcards."
(parse-namestring filename))
(definterface pathname-to-filename (pathname)
"Return the filename for PATHNAME."
(namestring pathname))
(definterface default-directory ()
"Return the default directory."
(directory-namestring (truename *default-pathname-defaults*)))
(definterface set-default-directory (directory)
"Set the default directory.
This is used to resolve filenames without directory component."
(setf *default-pathname-defaults* (truename (merge-pathnames directory)))
(default-directory))
(definterface call-with-syntax-hooks (fn)
"Call FN with hooks to handle special syntax."
(funcall fn))
(definterface default-readtable-alist ()
"Return a suitable initial value for SLYNK:*READTABLE-ALIST*."
'())
;;;; Packages
(definterface package-local-nicknames (package)
"Returns an alist of (local-nickname . actual-package) describing the
nicknames local to the designated package."
(declare (ignore package))
nil)
(definterface find-locally-nicknamed-package (name base-package)
"Return the package whose local nickname in BASE-PACKAGE matches NAME.
Return NIL if local nicknames are not implemented or if there is no
such package."
(cdr (assoc name (package-local-nicknames base-package) :test #'string-equal)))
;;;; Compilation
(definterface call-with-compilation-hooks (func)
"Call FUNC with hooks to record compiler conditions.")
(defmacro with-compilation-hooks ((&rest ignore) &body body)
"Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
(declare (ignore ignore))
`(call-with-compilation-hooks (lambda () (progn ,@body))))
(definterface slynk-compile-string (string &key buffer position filename
line column policy)
"Compile source from STRING.
During compilation, compiler conditions must be trapped and
resignalled as COMPILER-CONDITIONs.
If supplied, BUFFER and POSITION specify the source location in Emacs.
Additionally, if POSITION is supplied, it must be added to source
positions reported in compiler conditions.
If FILENAME is specified it may be used by certain implementations to
rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
source information.
If POLICY is supplied, and non-NIL, it may be used by certain
implementations to compile with optimization qualities of its
value.
If LINE and COLUMN are supplied, and non-NIL, they may be used by
certain implementations (presumably instead of POSITION) as the line
and column of the start of the string in FILENAME. Both LINE and
COLUMN are 1-based.
Should return T on successful compilation, NIL otherwise.
")
(definterface slynk-compile-file (input-file output-file load-p
external-format
&key policy)
"Compile INPUT-FILE signalling COMPILE-CONDITIONs.
If LOAD-P is true, load the file after compilation.
EXTERNAL-FORMAT is a value returned by find-external-format or
:default.
If POLICY is supplied, and non-NIL, it may be used by certain
implementations to compile with optimization qualities of its
value.
Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
like `compile-file'")
(deftype severity ()
'(member :error :read-error :warning :style-warning :note :redefinition))
;; Base condition type for compiler errors, warnings and notes.
(define-condition compiler-condition (condition)
((original-condition
;; The original condition thrown by the compiler if appropriate.
;; May be NIL if a compiler does not report using conditions.
:type (or null condition)
:initarg :original-condition
:accessor original-condition)
(severity :type severity
:initarg :severity
:accessor severity)
(message :initarg :message
:accessor message)
;; Macro expansion history etc. which may be helpful in some cases
;; but is often very verbose.
(source-context :initarg :source-context
:type (or null string)
:initform nil
:accessor source-context)
(references :initarg :references
:initform nil
:accessor references)
(location :initarg :location
:accessor location)))
(definterface find-external-format (coding-system)
"Return a \"external file format designator\" for CODING-SYSTEM.
CODING-SYSTEM is Emacs-style coding system name (a string),
e.g. \"latin-1-unix\"."
(if (equal coding-system "iso-latin-1-unix")
:default
nil))
(definterface guess-external-format (pathname)
"Detect the external format for the file with name pathname.
Return nil if the file contains no special markers."
;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
(with-open-file (s pathname :if-does-not-exist nil
:external-format (or (find-external-format "latin-1-unix")
:default))
(if s
(or (let* ((line (read-line s nil))
(p (search "-*-" line)))
(when p
(let* ((start (+ p (length "-*-")))
(end (search "-*-" line :start2 start)))
(when end
(%search-coding line start end)))))
(let* ((len (file-length s))
(buf (make-string (min len 3000))))
(file-position s (- len (length buf)))
(read-sequence buf s)
(let ((start (search "Local Variables:" buf :from-end t))
(end (search "End:" buf :from-end t)))
(and start end (< start end)
(%search-coding buf start end))))))))
(defun %search-coding (str start end)
(let ((p (search "coding:" str :start2 start :end2 end)))
(when p
(incf p (length "coding:"))
(loop while (and (< p end)
(member (aref str p) '(#\space #\tab)))
do (incf p))
(let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline #\;)))
str :start p)))
(find-external-format (subseq str p end))))))
;;;; Streams
(definterface make-output-stream (write-string)
"Return a new character output stream.
The stream calls WRITE-STRING when output is ready.")
(definterface make-input-stream (read-string)
"Return a new character input stream.
The stream calls READ-STRING when input is needed.")
(defvar *auto-flush-interval* 0.2)
(defun auto-flush-loop (stream interval &optional receive)
(loop
(when (not (and (open-stream-p stream)
(output-stream-p stream)))
(return nil))
(force-output stream)
(when receive
(receive-if #'identity))
(sleep interval)))
(definterface make-auto-flush-thread (stream)
"Make an auto-flush thread"
(spawn (lambda () (auto-flush-loop stream *auto-flush-interval* nil))
:name "auto-flush-thread"))
;;;; Documentation
(definterface arglist (name)
"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 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 SLYNK 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 variables))
(ignore '(&rest variables))
(ignorable '(&rest variables))
(special '(&rest variables))
(inline '(&rest function-names))
(notinline '(&rest function-names))
(declaration '(&rest names))
(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 variables))
((and (listp decl-identifier)
(typespec-p (first decl-identifier)))
'(&rest variables))
(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 SLYNK 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 type-specifier-p (symbol)
"Determine if SYMBOL is a type-specifier."
(or (documentation symbol 'type)
(not (eq (type-specifier-arglist symbol) :not-available))))
(definterface function-name (function)
"Return the name of the function object FUNCTION.
The result is either a symbol, a list, or NIL if no function name is
available."
(declare (ignore function))
nil)
(definterface valid-function-name-p (form)
"Is FORM syntactically valid to name a function?
If true, FBOUNDP should not signal a type-error for FORM."
(flet ((length=2 (list)
(and (not (null (cdr list))) (null (cddr list)))))
(or (symbolp form)
(and (consp form) (length=2 form)
(eq (first form) 'setf) (symbolp (second form))))))
(definterface macroexpand-all (form &optional env)
"Recursively expand all macros in FORM.
Return the resulting form.")
(definterface compiler-macroexpand-1 (form &optional env)
"Call the compiler-macro for form.
If FORM is a function call for which a compiler-macro has been
defined, invoke the expander function using *macroexpand-hook* and
return the results and T. Otherwise, return the original form and
NIL."
(let ((fun (and (consp form)
(valid-function-name-p (car form))
(compiler-macro-function (car form) env))))
(if fun
(let ((result (funcall *macroexpand-hook* fun form env)))
(values result (not (eq result form))))
(values form nil))))
(definterface compiler-macroexpand (form &optional env)
"Repetitively call `compiler-macroexpand-1'."
(labels ((frob (form expanded)
(multiple-value-bind (new-form newly-expanded)
(compiler-macroexpand-1 form env)
(if newly-expanded
(frob new-form t)
(values new-form expanded)))))
(frob form env)))
(definterface format-string-expand (control-string)
"Expand the format string CONTROL-STRING."
(macroexpand `(formatter ,control-string)))
(definterface describe-symbol-for-emacs (symbol)
"Return a property list describing SYMBOL.
The property list has an entry for each interesting aspect of the
symbol. The recognised keys are:
:VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
:TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
The value of each property is the corresponding documentation string,
or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys
not listed here (but sly-print-apropos in Emacs must know about
them).
Properties should be included if and only if they are applicable to
the symbol. For example, only (and all) fbound symbols should include
the :FUNCTION property.
Example:
\(describe-symbol-for-emacs 'vector)
=> (:CLASS :NOT-DOCUMENTED
:TYPE :NOT-DOCUMENTED
:FUNCTION \"Constructs a simple-vector from the given objects.\")")
(definterface describe-definition (name type)
"Describe the definition NAME of TYPE.
TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
Return a documentation string, or NIL if none is available.")
(definterface make-apropos-matcher (pattern symbol-name-fn
&optional
case-sensitive)
"Produce unary function that looks for PATTERN in symbol names.
SYMBOL-NAME-FN must be applied to symbol-names to produce the string
where PATTERN should be searched for. CASE-SENSITIVE indicates
case-sensitivity. On a positive match, the function returned must
return non-nil values, which may be pairs of indexes to highlight in
the symbol designation's string.")
;;;; Debugging
(definterface install-debugger-globally (function)
"Install FUNCTION as the debugger for all threads/processes. This
usually involves setting *DEBUGGER-HOOK* and, if the implementation
permits, hooking into BREAK as well."
(setq *debugger-hook* function))
(definterface call-with-debugging-environment (debugger-loop-fn)
"Call DEBUGGER-LOOP-FN in a suitable debugging environment.
This function is called recursively at each debug level to invoke the
debugger loop. The purpose is to setup any necessary environment for
other debugger callbacks that will be called within the debugger loop.
For example, this is a reasonable place to compute a backtrace, switch
to safe reader/printer settings, and so on.")
(definterface call-with-debugger-hook (hook fun)
"Call FUN and use HOOK as debugger hook. HOOK can be NIL.
HOOK should be called for both BREAK and INVOKE-DEBUGGER."
(let ((*debugger-hook* hook))
(funcall fun)))
(define-condition sly-db-condition (condition)
((original-condition
:initarg :original-condition
:accessor original-condition))
(:report (lambda (condition stream)
(format stream "Condition in debugger code~@[: ~A~]"
(original-condition condition))))
(:documentation
"Wrapper for conditions that should not be debugged.
When a condition arises from the internals of the debugger, it is not
desirable to debug it -- we'd risk entering an endless loop trying to
debug the debugger! Instead, such conditions can be reported to the
user without (re)entering the debugger by wrapping them as
`sly-db-condition's."))
;;; The following functions in this section are supposed to be called
;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
(definterface compute-backtrace (start end)
"Returns a backtrace of the condition currently being debugged,
that is an ordered list consisting of frames. ``Ordered list''
means that an integer I can be mapped back to the i-th frame of this
backtrace.
START and END are zero-based indices constraining the number of frames
returned. Frame zero is defined as the frame which invoked the
debugger. If END is nil, return the frames from START to the end of
the stack.")
(definterface print-frame (frame stream)
"Print frame to stream.")
(definterface frame-restartable-p (frame)
"Is the frame FRAME restartable?.
Return T if `restart-frame' can safely be called on the frame."
(declare (ignore frame))
nil)
(definterface frame-source-location (frame-number)
"Return the source location for the frame associated to FRAME-NUMBER.")
(definterface frame-catch-tags (frame-number)
"Return a list of catch tags for being printed in a debugger stack
frame."
(declare (ignore frame-number))
'())
(definterface frame-locals (frame-number)
"Return a list of ((&key NAME ID VALUE) ...) where each element of
the list represents a local variable in the stack frame associated to
FRAME-NUMBER.
NAME, a symbol; the name of the local variable.
ID, an integer; used as primary key for the local variable, unique
relatively to the frame under operation.
value, an object; the value of the local variable.")
(definterface frame-var-value (frame-number var-id)
"Return the value of the local variable associated to VAR-ID
relatively to the frame associated to FRAME-NUMBER.")
(definterface disassemble-frame (frame-number)
"Disassemble the code for the FRAME-NUMBER.
The output should be written to standard output.
FRAME-NUMBER is a non-negative integer.")
(definterface eval-in-frame (form frame-number)
"Evaluate a Lisp form in the lexical context of a stack frame
in the debugger.
FRAME-NUMBER must be a positive integer with 0 indicating the
frame which invoked the debugger.
The return value is the result of evaulating FORM in the
appropriate context.")
(definterface frame-package (frame-number)
"Return the package corresponding to the frame at FRAME-NUMBER.
Return nil if the backend can't figure it out."
(declare (ignore frame-number))
nil)
(definterface frame-arguments (frame-number)
"Return the arguments passed to frame at FRAME-NUMBER as a values list.
Default values of optional arguments not passed in by the user may or
may not be returned.")
(definterface return-from-frame (frame-number form)
"Unwind the stack to the frame FRAME-NUMBER and return the value(s)
produced by evaluating FORM in the frame context to its caller.
Execute any clean-up code from unwind-protect forms above the frame
during unwinding.
Return a string describing the error if it's not possible to return
from the frame.")
(definterface restart-frame (frame-number)
"Restart execution of the frame FRAME-NUMBER with the same arguments
as it was called originally.")
(definterface print-condition (condition stream)
"Print a condition for display in SLY-DB."
(princ condition stream))
(definterface condition-extras (condition)
"Return a list of extra for the debugger.
The allowed elements are of the form:
(:SHOW-FRAME-SOURCE frame-number)
(:REFERENCES &rest refs)
"
(declare (ignore condition))
'())
(definterface gdb-initial-commands ()
"List of gdb commands supposed to be executed first for the
ATTACH-GDB restart."
nil)
(definterface activate-stepping (frame-number)
"Prepare the frame FRAME-NUMBER for stepping.")
(definterface sly-db-break-on-return (frame-number)
"Set a breakpoint in the frame FRAME-NUMBER.")
(definterface sly-db-break-at-start (symbol)
"Set a breakpoint on the beginning of the function for SYMBOL.")
(definterface sly-db-stepper-condition-p (condition)
"Return true if SLY-DB was invoked due to a single-stepping condition,
false otherwise. "
(declare (ignore condition))
nil)
(definterface sly-db-step-into ()
"Step into the current single-stepper form.")
(definterface sly-db-step-next ()
"Step to the next form in the current function.")
(definterface sly-db-step-out ()
"Stop single-stepping temporarily, but resume it once the current function
returns.")
;;;; Definition finding
(defstruct (location (:type list)
(:constructor make-location
(buffer position &optional hints)))
(type :location)
buffer position
;; Hints is a property list optionally containing:
;; :snippet SOURCE-TEXT
;; This is a snippet of the actual source text at the start of
;; the definition, which could be used in a text search.
hints)
(defmacro converting-errors-to-error-location (&body body)
"Catches errors during BODY and converts them to an error location."
(let ((gblock (gensym "CONVERTING-ERRORS+")))
`(block ,gblock
(handler-bind ((error
#'(lambda (e)
(if *debug-slynk-backend*
nil ;decline
(return-from ,gblock
(make-error-location e))))))
,@body))))
(defun make-error-location (datum &rest args)
(cond ((typep datum 'condition)
`(:error ,(format nil "Error: ~A" datum)))
((symbolp datum)
`(:error ,(format nil "Error: ~A"
(apply #'make-condition datum args))))
(t
(assert (stringp datum))
`(:error ,(apply #'format nil datum args)))))
(definterface find-definitions (name)
"Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
NAME is a \"definition specifier\".
DSPEC is a \"definition specifier\" describing the
definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
\(DEFVAR FOO).
LOCATION is the source location for the definition.")
(definterface find-source-location (object)
"Returns the source location of OBJECT, or NIL.
That is the source location of the underlying datastructure of
OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
respective DEFSTRUCT definition, and so on."
;; This returns one source location and not a list of locations. It's
;; supposed to return the location of the DEFGENERIC definition on
;; #'SOME-GENERIC-FUNCTION.
(declare (ignore object))
(make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~
this implementation."))
(definterface buffer-first-change (filename)
"Called for effect the first time FILENAME's buffer is modified.
CMUCL/SBCL use this to cache the unmodified file and use the
unmodified text to improve the precision of source locations."
(declare (ignore filename))
nil)
;;;; XREF
(definterface who-calls (function-name)
"Return the call sites of FUNCTION-NAME (a symbol).
The results is a list ((DSPEC LOCATION) ...)."
(declare (ignore function-name))
:not-implemented)
(definterface calls-who (function-name)
"Return the list of functions called by FUNCTION-NAME (a symbol).
The results is a list ((DSPEC LOCATION) ...)."
(declare (ignore function-name))
:not-implemented)
(definterface who-references (variable-name)
"Return the locations where VARIABLE-NAME (a symbol) is referenced.
See WHO-CALLS for a description of the return value."
(declare (ignore variable-name))
:not-implemented)
(definterface who-binds (variable-name)
"Return the locations where VARIABLE-NAME (a symbol) is bound.
See WHO-CALLS for a description of the return value."
(declare (ignore variable-name))
:not-implemented)
(definterface who-sets (variable-name)
"Return the locations where VARIABLE-NAME (a symbol) is set.
See WHO-CALLS for a description of the return value."
(declare (ignore variable-name))
:not-implemented)
(definterface who-macroexpands (macro-name)
"Return the locations where MACRO-NAME (a symbol) is expanded.
See WHO-CALLS for a description of the return value."
(declare (ignore macro-name))
:not-implemented)
(definterface who-specializes (class-name)
"Return the locations where CLASS-NAME (a symbol) is specialized.
See WHO-CALLS for a description of the return value."
(declare (ignore class-name))
:not-implemented)
;;; Simpler variants.
(definterface list-callers (function-name)
"List the callers of FUNCTION-NAME.
This function is like WHO-CALLS except that it is expected to use
lower-level means. Whereas WHO-CALLS is usually implemented with
special compiler support, LIST-CALLERS is usually implemented by
groveling for constants in function objects throughout the heap.
The return value is as for WHO-CALLS.")
(definterface list-callees (function-name)
"List the functions called by FUNCTION-NAME.
See LIST-CALLERS for a description of the return value.")
;;;; Profiling
;;; The following functions define a minimal profiling interface.
(definterface profile (fname)
"Marks symbol FNAME for profiling.")
(definterface profiled-functions ()
"Returns a list of profiled functions.")
(definterface unprofile (fname)
"Marks symbol FNAME as not profiled.")
(definterface unprofile-all ()
"Marks all currently profiled functions as not profiled."
(dolist (f (profiled-functions))
(unprofile f)))
(definterface profile-report ()
"Prints profile report.")
(definterface profile-reset ()
"Resets profile counters.")
(definterface profile-package (package callers-p methods)
"Wrap profiling code around all functions in PACKAGE. If a function
is already profiled, then unprofile and reprofile (useful to notice
function redefinition.)
If CALLERS-P is T names have counts of the most common calling
functions recorded.
When called with arguments :METHODS T, profile all methods of all
generic functions having names in the given package. Generic functions
themselves, that is, their dispatch functions, are left alone.")
;;;; Trace
(definterface toggle-trace (spec)
"Toggle tracing of the function(s) given with SPEC.
SPEC can be:
(setf NAME) ; a setf function
(:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
(:defgeneric NAME) ; a generic function with all methods
(:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
(:labels TOPLEVEL LOCAL)
(:flet TOPLEVEL LOCAL) ")
;;;; Inspector
(defgeneric emacs-inspect (object)
(:documentation
"Explain to Emacs how to inspect OBJECT.
Returns a list specifying how to render the object for inspection.
Every element of the list must be either a string, which will be
inserted into the buffer as is, or a list of the form:
(:value object &optional format) - Render an inspectable
object. If format is provided it must be a string and will be
rendered in place of the value, otherwise use princ-to-string.
(:newline) - Render a \\n
(:action label lambda &key (refresh t)) - Render LABEL (a text
string) which when clicked will call LAMBDA. If REFRESH is
non-NIL the currently inspected object will be re-inspected
after calling the lambda.
"))
(defmethod emacs-inspect ((object t))
"Generic method for inspecting any kind of object.
Since we don't know how to deal with OBJECT we simply dump the
output of CL:DESCRIBE."
`("Type: " (:value ,(type-of object)) (:newline)
"Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
(:newline) (:newline)
,(with-output-to-string (desc) (describe object desc))))
(definterface eval-context (object)
"Return a list of bindings corresponding to OBJECT's slots."
(declare (ignore object))
'())
;;; Utilities for inspector methods.
;;;
(defun label-value-line (label value &key (newline t))
"Create a control list which prints \"LABEL: VALUE\" in the inspector.
If NEWLINE is non-NIL a `(:newline)' is added to the result."
(list* (princ-to-string label) ": " `(:value ,value)
(if newline '((:newline)) nil)))
(defmacro label-value-line* (&rest label-values)
` (append ,@(loop for (label value) in label-values
collect `(label-value-line ,label ,value))))
(definterface describe-primitive-type (object)
"Return a string describing the primitive type of object."
(declare (ignore object))
"N/A")
;;;; Multithreading
;;;
;;; The default implementations are sufficient for non-multiprocessing
;;; implementations.
(definterface initialize-multiprocessing (continuation)
"Initialize multiprocessing, if necessary and then invoke CONTINUATION.
Depending on the impleimentaion, this function may never return."
(funcall continuation))
(definterface spawn (fn &key name)
"Create a new thread to call FN.")
(definterface thread-id (thread)
"Return an Emacs-parsable object to identify THREAD.
Ids should be comparable with equal, i.e.:
(equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
thread)
(definterface find-thread (id)
"Return the thread for ID.
ID should be an id previously obtained with THREAD-ID.
Can return nil if the thread no longer exists."
(declare (ignore id))
(current-thread))
(definterface thread-name (thread)
"Return the name of THREAD.
Thread names are short strings meaningful to the user. They do not
have to be unique."
(declare (ignore thread))
"The One True Thread")
(definterface thread-status (thread)
"Return a string describing THREAD's state."
(declare (ignore thread))
"")
(definterface thread-attributes (thread)
"Return a plist of implementation-dependent attributes for THREAD"
(declare (ignore thread))
'())
(definterface current-thread ()
"Return the currently executing thread."
0)
(definterface all-threads ()
"Return a fresh list of all threads."
'())
(definterface thread-alive-p (thread)
"Test if THREAD is termintated."
(member thread (all-threads)))
(definterface interrupt-thread (thread fn)
"Cause THREAD to execute FN.")
(definterface kill-thread (thread)
"Terminate THREAD immediately.
Don't execute unwind-protected sections, don't raise conditions.
(Do not pass go, do not collect $200.)"
(declare (ignore thread))
nil)
(definterface send (thread object)
"Send OBJECT to thread THREAD."
(declare (ignore thread))
object)
(definterface receive (&optional timeout)
"Return the next message from current thread's mailbox."
(receive-if (constantly t) timeout))
(definterface receive-if (predicate &optional timeout)
"Return the first message satisfiying PREDICATE.")
(definterface wake-thread (thread)
"Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using
asynchronous interrupts."
(declare (ignore thread))
;; Doesn't have to implement this if RECEIVE-IF periodically calls
;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient
nil)
(definterface register-thread (name thread)
"Associate the thread THREAD with the symbol NAME.
The thread can then be retrieved with `find-registered'.
If THREAD is nil delete the association."
(declare (ignore name thread))
nil)
(definterface find-registered (name)
"Find the thread that was registered for the symbol NAME.
Return nil if the no thread was registred or if the tread is dead."
(declare (ignore name))
nil)
(definterface set-default-initial-binding (var form)
"Initialize special variable VAR by default with FORM.
Some implementations initialize certain variables in each newly
created thread. This function sets the form which is used to produce
the initial value."
(set var (eval form)))
;; List of delayed interrupts.
;; This should only have thread-local bindings, so no init form.
(defvar *pending-sly-interrupts*)
(defun check-sly-interrupts ()
"Execute pending interrupts if any.
This should be called periodically in operations which
can take a long time to complete.
Return a boolean indicating whether any interrupts was processed."
(when (and (boundp '*pending-sly-interrupts*)
*pending-sly-interrupts*)
(funcall (pop *pending-sly-interrupts*))
t))
(defvar *interrupt-queued-handler* nil
"Function to call on queued interrupts.
Interrupts get queued when an interrupt occurs while interrupt
handling is disabled.
Backends can use this function to abort slow operations.")
(definterface wait-for-input (streams &optional timeout)
"Wait for input on a list of streams. Return those that are ready.
STREAMS is a list of streams
TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
which are ready (or have reached end-of-file) without waiting.
If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
return nil.
Return :interrupt if an interrupt occurs while waiting."
(declare (ignore streams timeout))
;; Invoking the slime debugger will just endlessly loop.
(call-with-debugger-hook
nil
(lambda ()
(error
"~s not implemented. Check if ~s = ~s is supported by the implementation."
'wait-for-input
(slynk-backend:find-symbol2 "SLYNK:*COMMUNICATION-STYLE*")
(symbol-value
(slynk-backend:find-symbol2 "SLYNK:*COMMUNICATION-STYLE*"))))))
;;;; Locks
;; Please use locks only in slynk-gray.lisp. Locks are too low-level
;; for our taste.
(definterface make-lock (&key name)
"Make a lock for thread synchronization.
Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
but that thread may hold it more than once."
(declare (ignore name))
:null-lock)
(definterface call-with-lock-held (lock function)
"Call FUNCTION with LOCK held, queueing if necessary."
(declare (ignore lock)
(type function function))
(funcall function))
;;;; Weak datastructures
(definterface make-weak-key-hash-table (&rest args)
"Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
(apply #'make-hash-table args))
(definterface make-weak-value-hash-table (&rest args)
"Like MAKE-HASH-TABLE, but weak w.r.t. the values."
(apply #'make-hash-table args))
(definterface hash-table-weakness (hashtable)
"Return nil or one of :key :value :key-or-value :key-and-value"
(declare (ignore hashtable))
nil)
;;;; Floating point
(definterface float-nan-p (float)
"Return true if FLOAT is a NaN value (Not a Number)."
;; When the float type implements IEEE-754 floats, two NaN values
;; are never equal; when the implementation does not support NaN,
;; the predicate should return false. An implementation can
;; implement comparison with "unordered-signaling predicates", which
;; emit floating point exceptions.
(handler-case (not (= float float))
;; Comparisons never signal an exception other than the invalid
;; operation exception (5.11 Details of comparison predicates).
(floating-point-invalid-operation () t)))
(definterface float-infinity-p (float)
"Return true if FLOAT is positive or negative infinity."
(not (< most-negative-long-float
float
most-positive-long-float)))
;;;; Character names
(definterface character-completion-set (prefix matchp)
"Return a list of names of characters that match PREFIX."
;; Handle the standard and semi-standard characters.
(loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
"Linefeed" "Return" "Backspace")
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))
))
;;; Heap dumps
(definterface save-image (filename &optional restart-function)
"Save a heap image to the file FILENAME.
RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
(definterface background-save-image (filename &key restart-function
completion-function)
"Request saving a heap image to the file FILENAME.
RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
(defun deinit-log-output ()
;; Can't hang on to an fd-stream from a previous session.
(setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'slynk))
nil))
;;;; Wrapping
(definterface wrap (spec indicator &key before after replace)
"Intercept future calls to SPEC and surround them in callbacks.
INDICATOR is a symbol identifying a particular wrapping, and is used
to differentiate between multiple wrappings.
Implementations intercept calls to SPEC and call, in this order:
* the BEFORE callback, if it's provided, with a single argument set to
the list of arguments passed to the intercepted call;
* the original definition of SPEC recursively honouring any wrappings
previously established under different values of INDICATOR. If the
compatible function REPLACE is provided, call that instead.
* the AFTER callback, if it's provided, with a single set to the list
of values returned by the previous call, or, if that call exited
non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY.
The return value of implementation should be the
implementation-specific function object that SPEC describes, suitable
to be passed to the FIND-SOURCE-LOCATION interface."
(declare (ignore indicator))
(assert (symbolp spec) nil
"The default implementation for WRAP allows only simple names")
(assert (null (get spec 'sly-wrap)) nil
"The default implementation for WRAP allows a single wrapping")
(let* ((saved (symbol-function spec))
(replacement (lambda (&rest args)
(let (retlist completed)
(unwind-protect
(progn
(when before
(funcall before args))
(setq retlist (multiple-value-list
(apply (or replace
saved) args)))
(setq completed t)
(values-list retlist))
(when after
(funcall after (if completed
retlist
:exited-non-locally))))))))
(setf (get spec 'sly-wrap) (list saved replacement))
(setf (symbol-function spec) replacement)
saved))
(definterface unwrap (spec indicator)
"Remove from SPEC any wrappings tagged with INDICATOR."
(if (wrapped-p spec indicator)
(setf (symbol-function spec) (first (get spec 'sly-wrap)))
(cerror "All right, so I did"
"Hmmm, ~a is not correctly wrapped, you probably redefined it"
spec))
(setf (get spec 'sly-wrap) nil)
spec)
(definterface wrapped-p (spec indicator)
"Returns true if SPEC is wrapped with INDICATOR."
(declare (ignore indicator))
(and (symbolp spec)
(let ((prop-value (get spec 'sly-wrap)))
(cond ((and prop-value
(not (eq (second prop-value)
(symbol-function spec))))
(warn "~a appears to be incorrectly wrapped" spec)
nil)
(prop-value t)
(t nil)))))
(defpackage :slynk-apropos
(:use #:cl #:slynk-api)
(:export
#:apropos-list-for-emacs
#:*preferred-apropos-matcher*))
(in-package :slynk-apropos)
(defparameter *preferred-apropos-matcher* 'make-cl-ppcre-matcher
"Preferred matcher for apropos searches.
Value is a function of three arguments , PATTERN, CASE-SENSITIVE and
SYMBOL-NAME-FN that should return a function, called MATCHER of one
argument, a SYMBOL. MATCHER should return non-nil if PATTERN somehow
matches the result of applying SYMBOL-NAME-FN to SYMBOL, according to
CASE-SENSITIVE. The non-nil return value can be a list of integer or
a list of lists of integers.")
(defslyfun apropos-list-for-emacs (pattern &optional external-only
case-sensitive package)
"Make an apropos search for Emacs.
The result is a list of property lists."
(let ((package (if package
(or (parse-package package)
(error "No such package: ~S" package)))))
;; The MAPCAN will filter all uninteresting symbols, i.e. those
;; who cannot be meaningfully described.
;;
;; *BUFFER-PACKAGE* is exceptionally set so that the symbol
;; listing will only omit package qualifier iff the user specified
;; PACKAGE.
(let* ((*buffer-package* (or package
slynk::*slynk-io-package*))
(matcher (funcall *preferred-apropos-matcher*
pattern
case-sensitive))
(seen (make-hash-table))
result)
(do-all-symbols (sym)
(let ((external (symbol-external-p sym)))
(multiple-value-bind (bounds score)
(and
(symbol-package sym) ; see github#266
(funcall matcher
(if package
(string sym)
(concatenate 'string
(package-name (symbol-package sym))
(if external ":" "::")
(symbol-name sym)))))
(unless (gethash sym seen)
(when bounds
(unless (or (and external-only
(not external))
(and package
(not (eq package (symbol-package sym)))))
(push `(,sym :bounds ,bounds
,@(and score `(:flex-score ,score))
:external-p ,external)
result)))
(setf (gethash sym seen) t)))))
(loop for (symbol . extra)
in (sort result
(lambda (x y)
(let ((scorex (getf (cdr x) :flex-score))
(scorey (getf (cdr y) :flex-score)))
(if (and scorex scorey)
(> scorex scorey)
(present-symbol-before-p (car x) (car y))))))
for short = (briefly-describe-symbol-for-emacs
symbol (getf extra :external-p))
for score = (getf extra :flex-score)
when score
do (setf (getf extra :flex-score)
(format nil "~2$%"
(* 100 score)))
do (remf extra :external-p)
when short
collect (append short extra)))))
(defun briefly-describe-symbol-for-emacs (symbol external-p)
"Return a property list describing SYMBOL.
Like `describe-symbol-for-emacs' but with at most one line per item."
(flet ((first-line (string)
(let ((pos (position #\newline string)))
(if (null pos) string (subseq string 0 pos)))))
(let ((desc (map-if #'stringp #'first-line
(slynk-backend:describe-symbol-for-emacs symbol))))
(if desc
`(:designator ,(list (symbol-name symbol)
(let ((package (symbol-package symbol)))
(and package
(package-name package)))
external-p)
,@desc
,@(let ((arglist (and (fboundp symbol)
(slynk-backend:arglist symbol))))
(when (and arglist
(not (eq arglist :not-available)))
`(:arglist ,(princ-to-string arglist)))))))))
(defun present-symbol-before-p (x y)
"Return true if X belongs before Y in a printed summary of symbols.
Sorted alphabetically by package name and then symbol name, except
that symbols accessible in the current package go first."
(declare (type symbol x y))
(flet ((accessible (s)
;; Test breaks on NIL for package that does not inherit it
(eq (find-symbol (symbol-name s) *buffer-package*) s)))
(let ((ax (accessible x)) (ay (accessible y)))
(cond ((and ax ay) (string< (symbol-name x) (symbol-name y)))
(ax t)
(ay nil)
(t (let ((px (symbol-package x)) (py (symbol-package y)))
(if (eq px py)
(string< (symbol-name x) (symbol-name y))
(string< (package-name px) (package-name py)))))))))
(defun make-cl-ppcre-matcher (pattern case-sensitive)
(if (not (every #'alpha-char-p pattern))
(cond ((find-package :cl-ppcre)
(background-message "Using CL-PPCRE for apropos on regexp \"~a\"" pattern)
(let ((matcher (funcall (slynk-backend:find-symbol2 "cl-ppcre:create-scanner")
pattern
:case-insensitive-mode (not case-sensitive))))
(lambda (symbol-name)
(multiple-value-bind (beg end)
(funcall (slynk-backend:find-symbol2 "cl-ppcre:scan")
matcher
symbol-name)
(when beg `((,beg ,end)))))))
(t
(background-message "Using plain apropos. Load CL-PPCRE to enable regexps")
(make-plain-matcher pattern case-sensitive)))
(make-plain-matcher pattern case-sensitive)))
(defun make-plain-matcher (pattern case-sensitive)
(let ((chr= (if case-sensitive #'char= #'char-equal)))
(lambda (symbol-name)
(let ((beg (search pattern
symbol-name
:test chr=)))
(when beg
`((,beg ,(+ beg (length pattern)))))))))
(defun make-flex-matcher (pattern case-sensitive)
(if (zerop (length pattern))
(make-plain-matcher pattern case-sensitive)
(let ((chr= (if case-sensitive #'char= #'char-equal)))
(lambda (symbol-name)
(slynk-completion:flex-matches
pattern symbol-name chr=)))))
;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10.; -*-
;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
;;; ****************************************************************
;;; Metering System ************************************************
;;; ****************************************************************
;;;
;;; The Metering System is a portable Common Lisp code profiling tool.
;;; It gathers timing and consing statistics for specified functions
;;; while a program is running.
;;;
;;; The Metering System is a combination of
;;; o the Monitor package written by Chris McConnell
;;; o the Profile package written by Skef Wholey and Rob MacLachlan
;;; The two systems were merged and extended by Mark Kantrowitz.
;;;
;;; Address: Carnegie Mellon University
;;; School of Computer Science
;;; Pittsburgh, PA 15213
;;;
;;; This code is in the public domain and is distributed without warranty
;;; of any kind.
;;;
;;; This copy is from SLY, http://www.common-lisp.net/project/sly/
;;;
;;;
;;; ********************************
;;; Change Log *********************
;;; ********************************
;;;
;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages.
;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics
;;; with respect to nested calls. (Allows it to subtract
;;; total monitoring overhead for each function, not just
;;; the time spent monitoring the function itself.)
;;; 26-JUN-90 mk The table is now saved so that one may manipulate
;;; the data (sorting it, etc.) even after the original
;;; source of the data has been cleared.
;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2
;;; required-arguments functions for Lucid 3.0,
;;; Franz Allegro CL, and MACL 1.3.2.
;;; 25-JAN-91 mk Now uses fdefinition if available.
;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl.
;;; Much better solution for the fact that both call
;;; themselves :allegro.
;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded
;;; uncompiled.
;;; 5-JUL-91 mk When many unmonitored functions, print out number
;;; instead of whole list.
;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring
;;; doesn't work in MCL, but fixed so that timing
;;; statistics do.
;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with
;;; (and :ccl (not :lispworks)).
;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0.
;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1,
;;; Lucid 4.0, ibcl
;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible.
;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL.
;;; Purely to cut down on stale code (e.g. #+cltl2) in this
;;; version that is bundled with SLY.
;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL.
;;; 07-Aug-12 heller Break lines at 80 columns
;;;
;;; ********************************
;;; To Do **************************
;;; ********************************
;;;
;;; - Need get-cons for Allegro, AKCL.
;;; - Speed up monitoring code. Replace use of hash tables with an embedded
;;; offset in an array so that it will be faster than using gethash.
;;; (i.e., svref/closure reference is usually faster than gethash).
;;; - Beware of (get-internal-run-time) overflowing. Yikes!
;;; - Check robustness with respect to profiled functions.
;;; - Check logic of computing inclusive and exclusive time and consing.
;;; Especially wrt incf/setf comment below. Should be incf, so we
;;; sum recursive calls.
;;; - Add option to record caller statistics -- this would list who
;;; called which functions and how often.
;;; - switches to turn timing/CONSING statistics collection on/off.
;;; ********************************
;;; Notes **************************
;;; ********************************
;;;
;;; METERING has been tested (successfully) in the following lisps:
;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler
;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
;;; Macintosh Allegro Common Lisp (1.3.2)
;;; Macintosh Common Lisp (2.0)
;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1
;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0
;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1
;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1
;;; Lucid CL (Version 2.1 6-DEC-87)
;;; Lucid Common Lisp (3.0)
;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91)
;;; AKCL (1.86, June 30, 1987 or later)
;;; Ibuki Common Lisp (Version 2, release 01.027)
;;; CLISP (January 1994)
;;;
;;; METERING needs to be tested in the following lisps:
;;; Symbolics Common Lisp (8.0)
;;; KCL (June 3, 1987 or later)
;;; TI (Release 4.1 or later)
;;; Golden Common Lisp (3.1 IBM-PC)
;;; VAXLisp (2.0, 3.1)
;;; Procyon Common Lisp
;;; ****************************************************************
;;; Documentation **************************************************
;;; ****************************************************************
;;;
;;; This system runs in any valid Common Lisp. Four small
;;; implementation-dependent changes can be made to improve performance
;;; and prettiness. In the section labelled "Implementation Dependent
;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS,
;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation
;;; for the best results. If GET-CONS is not specified for your
;;; implementation, no consing information will be reported. The other
;;; functions will default to working forms, albeit inefficient, in
;;; non-CMU implementations. If you tailor these functions for a particular
;;; version of Common Lisp, we'd appreciate receiving the code.
;;;
;;; ****************************************************************
;;; Usage Notes ****************************************************
;;; ****************************************************************
;;;
;;; SUGGESTED USAGE:
;;;
;;; Start by monitoring big pieces of the program, then carefully choose
;;; which functions close to, but not in, the inner loop are to be
;;; monitored next. Don't monitor functions that are called by other
;;; monitored functions: you will only confuse yourself.
;;;
;;; If the per-call time reported is less than 1/10th of a second, then
;;; consider the clock resolution and profiling overhead before you believe
;;; the time. It may be that you will need to run your program many times
;;; in order to average out to a higher resolution.
;;;
;;; The easiest way to use this package is to load it and execute either
;;; (slynk-monitor:with-monitoring (names*) ()
;;; your-forms*)
;;; or
;;; (slynk-monitor:monitor-form your-form)
;;; The former allows you to specify which functions will be monitored; the
;;; latter monitors all functions in the current package. Both automatically
;;; produce a table of statistics. Other variants can be constructed from
;;; the monitoring primitives, which are described below, along with a
;;; fuller description of these two macros.
;;;
;;; For best results, compile this file before using.
;;;
;;;
;;; CLOCK RESOLUTION:
;;;
;;; Unless you are very lucky, the length of your machine's clock "tick" is
;;; probably much longer than the time it takes a simple function to run.
;;; For example, on the IBM RT, the clock resolution is 1/50th of a second.
;;; This means that if a function is only called a few times, then only the
;;; first couple of decimal places are really meaningful.
;;;
;;;
;;; MONITORING OVERHEAD:
;;;
;;; The added monitoring code takes time to run every time that the monitored
;;; function is called, which can disrupt the attempt to collect timing
;;; information. In order to avoid serious inflation of the times for functions
;;; that take little time to run, an estimate of the overhead due to monitoring
;;; is subtracted from the times reported for each function.
;;;
;;; Although this correction works fairly well, it is not totally accurate,
;;; resulting in times that become increasingly meaningless for functions
;;; with short runtimes. For example, subtracting the estimated overhead
;;; may result in negative times for some functions. This is only a concern
;;; when the estimated profiling overhead is many times larger than
;;; reported total CPU time.
;;;
;;; If you monitor functions that are called by monitored functions, in
;;; :inclusive mode the monitoring overhead for the inner function is
;;; subtracted from the CPU time for the outer function. [We do this by
;;; counting for each function not only the number of calls to *this*
;;; function, but also the number of monitored calls while it was running.]
;;; In :exclusive mode this is not necessary, since we subtract the
;;; monitoring time of inner functions, overhead & all.
;;;
;;; Otherwise, the estimated monitoring overhead is not represented in the
;;; reported total CPU time. The sum of total CPU time and the estimated
;;; monitoring overhead should be close to the total CPU time for the
;;; entire monitoring run (as determined by TIME).
;;;
;;; A timing overhead factor is computed at load time. This will be incorrect
;;; if the monitoring code is run in a different environment than this file
;;; was loaded in. For example, saving a core image on a high performance
;;; machine and running it on a low performance one will result in the use
;;; of an erroneously small overhead factor.
;;;
;;;
;;; If your times vary widely, possible causes are:
;;; - Garbage collection. Try turning it off, then running your code.
;;; Be warned that monitoring code will probably cons when it does
;;; (get-internal-run-time).
;;; - Swapping. If you have enough memory, execute your form once
;;; before monitoring so that it will be swapped into memory. Otherwise,
;;; get a bigger machine!
;;; - Resolution of internal-time-units-per-second. If this value is
;;; too low, then the timings become wild. You can try executing more
;;; of whatever your test is, but that will only work if some of your
;;; paths do not match the timer resolution.
;;; internal-time-units-per-second is so coarse -- on a Symbolics it is
;;; 977, in MACL it is 60.
;;;
;;;
;;; ****************************************************************
;;; Interface ******************************************************
;;; ****************************************************************
;;;
;;; WITH-MONITORING (&rest functions) [Macro]
;;; (&optional (nested :exclusive)
;;; (threshold 0.01)
;;; (key :percent-time))
;;; &body body
;;; The named functions will be set up for monitoring, the body forms executed,
;;; a table of results printed, and the functions unmonitored. The nested,
;;; threshold, and key arguments are passed to report-monitoring below.
;;;
;;; MONITOR-FORM form [Macro]
;;; &optional (nested :exclusive)
;;; (threshold 0.01)
;;; (key :percent-time)
;;; All functions in the current package are set up for monitoring while
;;; the form is executed, and automatically unmonitored after a table of
;;; results has been printed. The nested, threshold, and key arguments
;;; are passed to report-monitoring below.
;;;
;;; *MONITORED-FUNCTIONS* [Variable]
;;; This holds a list of all functions that are currently being monitored.
;;;
;;; MONITOR &rest names [Macro]
;;; The named functions will be set up for monitoring by augmenting
;;; their function definitions with code that gathers statistical information
;;; about code performance. As with the TRACE macro, the function names are
;;; not evaluated. Calls the function SLYNK-MONITOR::MONITORING-ENCAPSULATE on each
;;; function name. If no names are specified, returns a list of all
;;; monitored functions.
;;;
;;; If name is not a symbol, it is evaled to return the appropriate
;;; closure. This allows you to monitor closures stored anywhere like
;;; in a variable, array or structure. Most other monitoring packages
;;; can't handle this.
;;;
;;; MONITOR-ALL &optional (package *package*) [Function]
;;; Monitors all functions in the specified package, which defaults to
;;; the current package.
;;;
;;; UNMONITOR &rest names [Macro]
;;; Removes monitoring code from the named functions. If no names are
;;; specified, all currently monitored functions are unmonitored.
;;;
;;; RESET-MONITORING-INFO name [Function]
;;; Resets the monitoring statistics for the specified function.
;;;
;;; RESET-ALL-MONITORING [Function]
;;; Resets the monitoring statistics for all monitored functions.
;;;
;;; MONITORED name [Function]
;;; Predicate to test whether a function is monitored.
;;;
;;; REPORT-MONITORING &optional names [Function]
;;; (nested :exclusive)
;;; (threshold 0.01)
;;; (key :percent-time)
;;; Creates a table of monitoring information for the specified list
;;; of names, and displays the table using display-monitoring-results.
;;; If names is :all or nil, uses all currently monitored functions.
;;; Takes the following arguments:
;;; - NESTED specifies whether nested calls of monitored functions
;;; are included in the times for monitored functions.
;;; o If :inclusive, the per-function information is for the entire
;;; duration of the monitored function, including any calls to
;;; other monitored functions. If functions A and B are monitored,
;;; and A calls B, then the accumulated time and consing for A will
;;; include the time and consing of B. Note: if a function calls
;;; itself recursively, the time spent in the inner call(s) may
;;; be counted several times.
;;; o If :exclusive, the information excludes time attributed to
;;; calls to other monitored functions. This is the default.
;;; - THRESHOLD specifies that only functions which have been executed
;;; more than threshold percent of the time will be reported. Defaults
;;; to 1%. If a threshold of 0 is specified, all functions are listed,
;;; even those with 0 or negative running times (see note on overhead).
;;; - KEY specifies that the table be sorted by one of the following
;;; sort keys:
;;; :function alphabetically by function name
;;; :percent-time by percent of total execution time
;;; :percent-cons by percent of total consing
;;; :calls by number of times the function was called
;;; :time-per-call by average execution time per function
;;; :cons-per-call by average consing per function
;;; :time same as :percent-time
;;; :cons same as :percent-cons
;;;
;;; REPORT &key (names :all) [Function]
;;; (nested :exclusive)
;;; (threshold 0.01)
;;; (sort-key :percent-time)
;;; (ignore-no-calls nil)
;;;
;;; Same as REPORT-MONITORING but we use a nicer keyword interface.
;;;
;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function]
;;; (key :percent-time)
;;; Prints a table showing for each named function:
;;; - the total CPU time used in that function for all calls
;;; - the total number of bytes consed in that function for all calls
;;; - the total number of calls
;;; - the average amount of CPU time per call
;;; - the average amount of consing per call
;;; - the percent of total execution time spent executing that function
;;; - the percent of total consing spent consing in that function
;;; Summary totals of the CPU time, consing, and calls columns are printed.
;;; An estimate of the monitoring overhead is also printed. May be run
;;; even after unmonitoring all the functions, to play with the data.
;;;
;;; SAMPLE TABLE:
#|
Cons
% % Per Total Total
Function Time Cons Calls Sec/Call Call Time Cons
----------------------------------------------------------------------
FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0
GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0
GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0
FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0
----------------------------------------------------------------------
TOTAL: 1173 0.828950 0
Estimated total monitoring overhead: 0.88 seconds
|#
;;; ****************************************************************
;;; METERING *******************************************************
;;; ****************************************************************
;;; ********************************
;;; Warn people using the wrong Lisp
;;; ********************************
#-(or clisp openmcl clasp)
(warn "metering.lisp does not support your Lisp implementation!")
;;; ********************************
;;; Packages ***********************
;;; ********************************
;;; For CLtL2 compatible lisps
(defpackage "SLYNK-MONITOR" (:use "COMMON-LISP")
(:export "*MONITORED-FUNCTIONS*"
"MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM"
"WITH-MONITORING"
"RESET-MONITORING-INFO" "RESET-ALL-MONITORING"
"MONITORED"
"REPORT-MONITORING"
"DISPLAY-MONITORING-RESULTS"
"MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE"
"REPORT"))
(in-package "SLYNK-MONITOR")
;;; Warn user if they're loading the source instead of compiling it first.
(eval-when (eval)
(warn "This file should be compiled before loading for best results."))
;;; ********************************
;;; Version ************************
;;; ********************************
(defparameter *metering-version* "v2.1 25-JAN-94"
"Current version number/date for Metering.")
;;; ****************************************************************
;;; Implementation Dependent Definitions ***************************
;;; ****************************************************************
;;; ********************************
;;; Timing Functions ***************
;;; ********************************
;;; The get-time function is called to find the total number of ticks since
;;; the beginning of time. time-units-per-second allows us to convert units
;;; to seconds.
#-(or clasp clisp openmcl)
(eval-when (compile eval)
(warn
"You may want to supply implementation-specific get-time functions."))
(defconstant time-units-per-second internal-time-units-per-second)
#+(or clasp openmcl)
(progn
(deftype time-type () 'unsigned-byte)
(deftype consing-type () 'unsigned-byte))
(defmacro get-time ()
`(the time-type (get-internal-run-time)))
;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of
;;; milliseconds spent during GC. We could subtract this from
;;; the value returned by get-internal-run-time to eliminate
;;; the effect of GC on the timing values, but we prefer to let
;;; the user run without GC on. If the application is so big that
;;; it requires GC to complete, then the GC times are part of the
;;; cost of doing business, and will average out in the long run.
;;; If it seems really important to a user that GC times not be
;;; counted, then uncomment the following three lines and read-time
;;; conditionalize the definition of get-time above with #-:openmcl.
;#+openmcl
;(defmacro get-time ()
; `(the time-type (- (get-internal-run-time) (ccl:gctime))))
;;; ********************************
;;; Consing Functions **************
;;; ********************************
;;; The get-cons macro is called to find the total number of bytes
;;; consed since the beginning of time.
#+clisp
(defun get-cons ()
(multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
(sys::%%time)
(declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
(dpb space1 (byte 24 24) space2)))
;;; Macintosh Common Lisp 2.0
;;; Note that this includes bytes that were allocated during GC.
;;; We could subtract this out by advising GC like we did under
;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't
;;; run without GC, then the bytes consed during GC are a cost of
;;; running their program. Metering the code a few times will
;;; avoid the consing values being too lopsided. If a user really really
;;; wants to subtract out the consing during GC, replace the following
;;; two lines with the commented out code.
#+openmcl
(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
#+clasp
(defmacro get-cons ()
`(the consing-type (gctools::bytes-allocated)))
#-(or clasp clisp openmcl)
(progn
(eval-when (compile eval)
(warn "No consing will be reported unless a get-cons function is ~
defined."))
(defmacro get-cons () '(the consing-type 0)))
;; actually, neither `get-cons' nor `get-time' are used as is,
;; but only in the following macro `with-time/cons'
#-:clisp
(defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
(let ((start-cons (gensym "START-CONS-"))
(start-time (gensym "START-TIME-")))
`(let ((,start-time (get-time)) (,start-cons (get-cons)))
(declare (type time-type ,start-time)
(type consing-type ,start-cons))
(multiple-value-prog1 ,form
(let ((,delta-time (- (get-time) ,start-time))
(,delta-cons (- (get-cons) ,start-cons)))
,@post-process)))))
#+clisp
(progn
(defmacro delta4 (nv1 nv2 ov1 ov2 by)
`(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2))
(let ((del (find-symbol "DELTA4" "SYS")))
(when del (setf (fdefinition 'delta4) (fdefinition del))))
(if (< internal-time-units-per-second 1000000)
;; TIME_1: AMIGA, OS/2, UNIX_TIMES
(defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
`(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16))
;; TIME_2: other UNIX, WIN32
(defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
`(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second)
(- ,new-time2 ,old-time2))))
(defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2)
`(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24))
;; avoid consing: when the application conses a lot,
;; get-cons may return a bignum, so we really should not use it.
(defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
(let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-"))
(beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-"))
(beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-"))
(beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
(re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
`(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
,gc1 ,gc2 ,beg-cons1 ,beg-cons2)
(sys::%%time)
(declare (ignore ,re1 ,re2 ,gc1 ,gc2))
(multiple-value-prog1 ,form
(multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
,gc1 ,gc2 ,end-cons1 ,end-cons2)
(sys::%%time)
(declare (ignore ,re1 ,re2 ,gc1 ,gc2))
(let ((,delta-time (delta4-time ,end-time1 ,end-time2
,beg-time1 ,beg-time2))
(,delta-cons (delta4-cons ,end-cons1 ,end-cons2
,beg-cons1 ,beg-cons2)))
,@post-process)))))))
;;; ********************************
;;; Required Arguments *************
;;; ********************************
;;;
;;; Required (Fixed) vs Optional Args
;;;
;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
;;; number of required arguments, and use &rest to capture only non-required
;;; arguments. The function Required-Arguments returns two values: the first
;;; is the number of required arguments, and the second is T iff there are any
;;; non-required arguments (e.g. &optional, &rest, &key).
;;; Lucid, Allegro, and Macintosh Common Lisp
#+openmcl
(defun required-arguments (name)
(let* ((function (symbol-function name))
(args (ccl:arglist function))
(pos (position-if #'(lambda (x)
(and (symbolp x)
(let ((name (symbol-name x)))
(and (>= (length name) 1)
(char= (schar name 0)
#\&)))))
args)))
(if pos
(values pos t)
(values (length args) nil))))
#+clisp
(defun required-arguments (name)
(multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p)
(sys::function-signature name t)
(if name ; no error
(values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))
(values 0 t))))
#+clasp
(defun required-arguments (name)
(multiple-value-bind (arglist foundp)
(core:function-lambda-list name)
(if foundp
(let ((position-and
(position-if #'(lambda (x)
(and (symbolp x)
(let ((name (symbol-name x)))
(and (>= (length name) 1)
(char= (schar name 0)
#\&)))))
arglist)))
(if position-and
(values position-and t)
(values (length arglist) nil)))
(values 0 t))))
#-(or clasp clisp openmcl)
(progn
(eval-when (compile eval)
(warn
"You may want to add an implementation-specific ~
Required-Arguments function."))
(eval-when (load eval)
(defun required-arguments (name)
(declare (ignore name))
(values 0 t))))
#|
;;;Examples
(defun square (x) (* x x))
(defun square2 (x &optional y) (* x x y))
(defun test (x y &optional (z 3)) 3)
(defun test2 (x y &optional (z 3) &rest fred) 3)
(required-arguments 'square) => 1 nil
(required-arguments 'square2) => 1 t
(required-arguments 'test) => 2 t
(required-arguments 'test2) => 2 t
|#
;;; ****************************************************************
;;; Main METERING Code *********************************************
;;; ****************************************************************
;;; ********************************
;;; Global Variables ***************
;;; ********************************
(defvar *MONITOR-TIME-OVERHEAD* nil
"The amount of time an empty monitored function costs.")
(defvar *MONITOR-CONS-OVERHEAD* nil
"The amount of cons an empty monitored function costs.")
(defvar *TOTAL-TIME* 0
"Total amount of time monitored so far.")
(defvar *TOTAL-CONS* 0
"Total amount of consing monitored so far.")
(defvar *TOTAL-CALLS* 0
"Total number of calls monitored so far.")
(proclaim '(type time-type *total-time*))
(proclaim '(type consing-type *total-cons*))
(proclaim '(fixnum *total-calls*))
;;; ********************************
;;; Accessor Functions *************
;;; ********************************
;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables
;;; containing closures.
(defmacro PLACE-FUNCTION (function-place)
"Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
if it isn't a symbol, to allow monitoring of closures located in
variables/arrays/structures."
;; Note that (fboundp 'fdefinition) returns T even if fdefinition
;; is a macro, which is what we want.
(if (fboundp 'fdefinition)
`(if (fboundp ,function-place)
(fdefinition ,function-place)
(eval ,function-place))
`(if (symbolp ,function-place)
(symbol-function ,function-place)
(eval ,function-place))))
(defsetf PLACE-FUNCTION (function-place) (function)
"Set the function in FUNCTION-PLACE to FUNCTION."
(if (fboundp 'fdefinition)
;; If we're conforming to CLtL2, use fdefinition here.
`(if (fboundp ,function-place)
(setf (fdefinition ,function-place) ,function)
(eval '(setf ,function-place ',function)))
`(if (symbolp ,function-place)
(setf (symbol-function ,function-place) ,function)
(eval '(setf ,function-place ',function)))))
#|
;;; before using fdefinition
(defun PLACE-FUNCTION (function-place)
"Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
if it isn't a symbol, to allow monitoring of closures located in
variables/arrays/structures."
(if (symbolp function-place)
(symbol-function function-place)
(eval function-place)))
(defsetf PLACE-FUNCTION (function-place) (function)
"Set the function in FUNCTION-PLACE to FUNCTION."
`(if (symbolp ,function-place)
(setf (symbol-function ,function-place) ,function)
(eval '(setf ,function-place ',function))))
|#
(defun PLACE-FBOUNDP (function-place)
"Test to see if FUNCTION-PLACE is a function."
;; probably should be
#|(or (and (symbolp function-place)(fboundp function-place))
(functionp (place-function function-place)))|#
(if (symbolp function-place)
(fboundp function-place)
(functionp (place-function function-place))))
(defun PLACE-MACROP (function-place)
"Test to see if FUNCTION-PLACE is a macro."
(when (symbolp function-place)
(macro-function function-place)))
;;; ********************************
;;; Measurement Tables *************
;;; ********************************
(defvar *monitored-functions* nil
"List of monitored symbols.")
;;; We associate a METERING-FUNCTIONS structure with each monitored function
;;; name or other closure. This holds the functions that we call to manipulate
;;; the closure which implements the encapsulation.
;;;
(defstruct metering-functions
(name nil)
(old-definition nil :type function)
(new-definition nil :type function)
(read-metering nil :type function)
(reset-metering nil :type function))
;;; In general using hash tables in time-critical programs is a bad idea,
;;; because when one has to grow the table and rehash everything, the
;;; timing becomes grossly inaccurate. In this case it is not an issue
;;; because all inserting of entries in the hash table occurs before the
;;; timing commences. The only circumstance in which this could be a
;;; problem is if the lisp rehashes on the next reference to the table,
;;; instead of when the entry which forces a rehash was inserted.
;;;
;;; Note that a similar kind of problem can occur with GC, which is why
;;; one should turn off GC when monitoring code.
;;;
(defvar *monitor* (make-hash-table :test #'equal)
"Hash table in which METERING-FUNCTIONS structures are stored.")
(defun get-monitor-info (name)
(gethash name *monitor*))
(defsetf get-monitor-info (name) (info)
`(setf (gethash ,name *monitor*) ,info))
(defun MONITORED (function-place)
"Test to see if a FUNCTION-PLACE is monitored."
(and (place-fboundp function-place) ; this line necessary?
(get-monitor-info function-place)))
(defun reset-monitoring-info (name)
"Reset the monitoring info for the specified function."
(let ((finfo (get-monitor-info name)))
(when finfo
(funcall (metering-functions-reset-metering finfo)))))
(defun reset-all-monitoring ()
"Reset monitoring info for all functions."
(setq *total-time* 0
*total-cons* 0
*total-calls* 0)
(dolist (symbol *monitored-functions*)
(when (monitored symbol)
(reset-monitoring-info symbol))))
(defun monitor-info-values (name &optional (nested :exclusive) warn)
"Returns monitoring information values for the named function,
adjusted for overhead."
(let ((finfo (get-monitor-info name)))
(if finfo
(multiple-value-bind (inclusive-time inclusive-cons
exclusive-time exclusive-cons
calls nested-calls)
(funcall (metering-functions-read-metering finfo))
(unless (or (null warn)
(eq (place-function name)
(metering-functions-new-definition finfo)))
(warn "Funtion ~S has been redefined, so times may be inaccurate.~@
MONITOR it again to record calls to the new definition."
name))
(case nested
(:exclusive (values calls
nested-calls
(- exclusive-time
(* calls *monitor-time-overhead*))
(- exclusive-cons
(* calls *monitor-cons-overhead*))))
;; In :inclusive mode, subtract overhead for all the
;; called functions as well. Nested-calls includes the
;; calls of the function as well. [Necessary 'cause of
;; functions which call themselves recursively.]
(:inclusive (values calls
nested-calls
(- inclusive-time
(* nested-calls ;(+ calls)
*monitor-time-overhead*))
(- inclusive-cons
(* nested-calls ;(+ calls)
*monitor-cons-overhead*))))))
(values 0 0 0 0))))
;;; ********************************
;;; Encapsulate ********************
;;; ********************************
(eval-when (compile load eval)
;; Returns a lambda expression for a function that, when called with the
;; function name, will set up that function for metering.
;;
;; A function is monitored by replacing its definition with a closure
;; created by the following function. The closure records the monitoring
;; data, and updates the data with each call of the function.
;;
;; Other closures are used to read and reset the data.
(defun make-monitoring-encapsulation (min-args optionals-p)
(let (required-args)
(dotimes (i min-args) (push (gensym) required-args))
`(lambda (name)
(let ((inclusive-time 0)
(inclusive-cons 0)
(exclusive-time 0)
(exclusive-cons 0)
(calls 0)
(nested-calls 0)
(old-definition (place-function name)))
(declare (type time-type inclusive-time)
(type time-type exclusive-time)
(type consing-type inclusive-cons)
(type consing-type exclusive-cons)
(fixnum calls)
(fixnum nested-calls))
(pushnew name *monitored-functions*)
(setf (place-function name)
#'(lambda (,@required-args
,@(when optionals-p
`(&rest optional-args)))
(let ((prev-total-time *total-time*)
(prev-total-cons *total-cons*)
(prev-total-calls *total-calls*)
;; (old-time inclusive-time)
;; (old-cons inclusive-cons)
;; (old-nested-calls nested-calls)
)
(declare (type time-type prev-total-time)
(type consing-type prev-total-cons)
(fixnum prev-total-calls))
(with-time/cons (delta-time delta-cons)
;; form
,(if optionals-p
`(apply old-definition
,@required-args optional-args)
`(funcall old-definition ,@required-args))
;; post-processing:
;; Calls
(incf calls)
(incf *total-calls*)
;; nested-calls includes this call
(incf nested-calls (the fixnum
(- *total-calls*
prev-total-calls)))
;; (setf nested-calls (+ old-nested-calls
;; (- *total-calls*
;; prev-total-calls)))
;; Time
;; Problem with inclusive time is that it
;; currently doesn't add values from recursive
;; calls to the same function. Change the
;; setf to an incf to fix this?
(incf inclusive-time (the time-type delta-time))
;; (setf inclusive-time (+ delta-time old-time))
(incf exclusive-time (the time-type
(+ delta-time
(- prev-total-time
*total-time*))))
(setf *total-time* (the time-type
(+ delta-time
prev-total-time)))
;; Consing
(incf inclusive-cons (the consing-type delta-cons))
;; (setf inclusive-cons (+ delta-cons old-cons))
(incf exclusive-cons (the consing-type
(+ delta-cons
(- prev-total-cons
*total-cons*))))
(setf *total-cons*
(the consing-type
(+ delta-cons prev-total-cons)))))))
(setf (get-monitor-info name)
(make-metering-functions
:name name
:old-definition old-definition
:new-definition (place-function name)
:read-metering #'(lambda ()
(values inclusive-time
inclusive-cons
exclusive-time
exclusive-cons
calls
nested-calls))
:reset-metering #'(lambda ()
(setq inclusive-time 0
inclusive-cons 0
exclusive-time 0
exclusive-cons 0
calls 0
nested-calls 0)
t)))))))
);; End of EVAL-WHEN
;;; For efficiency reasons, we precompute the encapsulation functions
;;; for a variety of combinations of argument structures
;;; (min-args . optional-p). These are stored in the following hash table
;;; along with any new ones we encounter. Since we're now precomputing
;;; closure functions for common argument signatures, this eliminates
;;; the former need to call COMPILE for each monitored function.
(eval-when (compile eval)
(defconstant precomputed-encapsulations 8))
(defvar *existing-encapsulations* (make-hash-table :test #'equal))
(defun find-encapsulation (min-args optionals-p)
(or (gethash (cons min-args optionals-p) *existing-encapsulations*)
(setf (gethash (cons min-args optionals-p) *existing-encapsulations*)
(compile nil
(make-monitoring-encapsulation min-args optionals-p)))))
(macrolet ((frob ()
(let ((res ()))
(dotimes (i precomputed-encapsulations)
(push `(setf (gethash '(,i . nil) *existing-encapsulations*)
#',(make-monitoring-encapsulation i nil))
res)
(push `(setf (gethash '(,i . t) *existing-encapsulations*)
#',(make-monitoring-encapsulation i t))
res))
`(progn ,@res))))
(frob))
(defun monitoring-encapsulate (name &optional warn)
"Monitor the function Name. If already monitored, unmonitor first."
;; Saves the current definition of name and inserts a new function which
;; returns the result of evaluating body.
(cond ((not (place-fboundp name)) ; not a function
(when warn
(warn "Ignoring undefined function ~S." name)))
((place-macrop name) ; a macro
(when warn
(warn "Ignoring macro ~S." name)))
(t ; tis a function
(when (get-monitor-info name) ; monitored
(when warn
(warn "~S already monitored, so unmonitoring it first." name))
(monitoring-unencapsulate name))
(multiple-value-bind (min-args optionals-p)
(required-arguments name)
(funcall (find-encapsulation min-args optionals-p) name)))))
(defun monitoring-unencapsulate (name &optional warn)
"Removes monitoring encapsulation code from around Name."
(let ((finfo (get-monitor-info name)))
(when finfo ; monitored
(remprop name 'metering-functions)
(setq *monitored-functions*
(remove name *monitored-functions* :test #'equal))
(if (eq (place-function name)
(metering-functions-new-definition finfo))
(setf (place-function name)
(metering-functions-old-definition finfo))
(when warn
(warn "Preserving current definition of redefined function ~S."
name))))))
;;; ********************************
;;; Main Monitoring Functions ******
;;; ********************************
(defmacro MONITOR (&rest names)
"Monitor the named functions. As in TRACE, the names are not evaluated.
If a function is already monitored, then unmonitor and remonitor (useful
to notice function redefinition). If a name is undefined, give a warning
and ignore it. See also unmonitor, report-monitoring,
display-monitoring-results and reset-time."
`(progn
,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names)
*monitored-functions*))
(defmacro UNMONITOR (&rest names)
"Remove the monitoring on the named functions.
Names defaults to the list of all currently monitored functions."
`(dolist (name ,(if names `',names '*monitored-functions*) (values))
(monitoring-unencapsulate name)))
(defun MONITOR-ALL (&optional (package *package*))
"Monitor all functions in the specified package."
(let ((package (if (packagep package)
package
(find-package package))))
(do-symbols (symbol package)
(when (eq (symbol-package symbol) package)
(monitoring-encapsulate symbol)))))
(defmacro MONITOR-FORM (form
&optional (nested :exclusive) (threshold 0.01)
(key :percent-time))
"Monitor the execution of all functions in the current package
during the execution of FORM. All functions that are executed above
THRESHOLD % will be reported."
`(unwind-protect
(progn
(monitor-all)
(reset-all-monitoring)
(prog1
(time ,form)
(report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
(unmonitor)))
(defmacro WITH-MONITORING ((&rest functions)
(&optional (nested :exclusive)
(threshold 0.01)
(key :percent-time))
&body body)
"Monitor the specified functions during the execution of the body."
`(unwind-protect
(progn
(dolist (fun ',functions)
(monitoring-encapsulate fun))
(reset-all-monitoring)
,@body
(report-monitoring :all ,nested ,threshold ,key))
(unmonitor)))
;;; ********************************
;;; Overhead Calculations **********
;;; ********************************
(defconstant overhead-iterations 5000
"Number of iterations over which the timing overhead is averaged.")
;;; Perhaps this should return something to frustrate clever compilers.
(defun STUB-FUNCTION (x)
(declare (ignore x))
nil)
(proclaim '(notinline stub-function))
(defun SET-MONITOR-OVERHEAD ()
"Determines the average overhead of monitoring by monitoring the execution
of an empty function many times."
(setq *monitor-time-overhead* 0
*monitor-cons-overhead* 0)
(stub-function nil)
(monitor stub-function)
(reset-all-monitoring)
(let ((overhead-function (symbol-function 'stub-function)))
(dotimes (x overhead-iterations)
(funcall overhead-function overhead-function)))
; (dotimes (x overhead-iterations)
; (stub-function nil))
(let ((fiter (float overhead-iterations)))
(multiple-value-bind (calls nested-calls time cons)
(monitor-info-values 'stub-function)
(declare (ignore calls nested-calls))
(setq *monitor-time-overhead* (/ time fiter)
*monitor-cons-overhead* (/ cons fiter))))
(unmonitor stub-function))
(set-monitor-overhead)
;;; ********************************
;;; Report Data ********************
;;; ********************************
(defvar *monitor-results* nil
"A table of monitoring statistics is stored here.")
(defvar *no-calls* nil
"A list of monitored functions which weren't called.")
(defvar *estimated-total-overhead* 0)
;; (proclaim '(type time-type *estimated-total-overhead*))
(defstruct (monitoring-info
(:conc-name m-info-)
(:constructor make-monitoring-info
(name calls time cons
percent-time percent-cons
time-per-call cons-per-call)))
name
calls
time
cons
percent-time
percent-cons
time-per-call
cons-per-call)
(defun REPORT (&key (names :all)
(nested :exclusive)
(threshold 0.01)
(sort-key :percent-time)
(ignore-no-calls nil))
"Same as REPORT-MONITORING but with a nicer keyword interface"
(declare (type (member :function :percent-time :time :percent-cons
:cons :calls :time-per-call :cons-per-call)
sort-key)
(type (member :inclusive :exclusive) nested))
(report-monitoring names nested threshold sort-key ignore-no-calls))
(defun REPORT-MONITORING (&optional names
(nested :exclusive)
(threshold 0.01)
(key :percent-time)
ignore-no-calls)
"Report the current monitoring state.
The percentage of the total time spent executing unmonitored code
in each function (:exclusive mode), or total time (:inclusive mode)
will be printed together with the number of calls and
the unmonitored time per call. Functions that have been executed
below THRESHOLD % of the time will not be reported. To report on all
functions set NAMES to be either NIL or :ALL."
(when (or (null names) (eq names :all)) (setq names *monitored-functions*))
(let ((total-time 0)
(total-cons 0)
(total-calls 0))
;; Compute overall time and consing.
(dolist (name names)
(multiple-value-bind (calls nested-calls time cons)
(monitor-info-values name nested :warn)
(declare (ignore nested-calls))
(incf total-calls calls)
(incf total-time time)
(incf total-cons cons)))
;; Total overhead.
(setq *estimated-total-overhead*
(/ (* *monitor-time-overhead* total-calls)
time-units-per-second))
;; Assemble data for only the specified names (all monitored functions)
(if (zerop total-time)
(format *trace-output* "Not enough execution time to monitor.")
(progn
(setq *monitor-results* nil *no-calls* nil)
(dolist (name names)
(multiple-value-bind (calls nested-calls time cons)
(monitor-info-values name nested)
(declare (ignore nested-calls))
(when (minusp time) (setq time 0.0))
(when (minusp cons) (setq cons 0.0))
(if (zerop calls)
(push (if (symbolp name)
(symbol-name name)
(format nil "~S" name))
*no-calls*)
(push (make-monitoring-info
(format nil "~S" name) ; name
calls ; calls
(/ time (float time-units-per-second)) ; time in secs
(round cons) ; consing
(/ time (float total-time)) ; percent-time
(if (zerop total-cons) 0
(/ cons (float total-cons))) ; percent-cons
(/ (/ time (float calls)) ; time-per-call
time-units-per-second) ; sec/call
(round (/ cons (float calls)))) ; cons-per-call
*monitor-results*))))
(display-monitoring-results threshold key ignore-no-calls)))))
(defun display-monitoring-results (&optional (threshold 0.01)
(key :percent-time)
(ignore-no-calls t))
(let ((max-length 8) ; Function header size
(max-cons-length 8)
(total-time 0.0)
(total-consed 0)
(total-calls 0)
(total-percent-time 0)
(total-percent-cons 0))
(sort-results key)
(dolist (result *monitor-results*)
(when (or (zerop threshold)
(> (m-info-percent-time result) threshold))
(setq max-length
(max max-length
(length (m-info-name result))))
(setq max-cons-length
(max max-cons-length
(m-info-cons-per-call result)))))
(incf max-length 2)
(setf max-cons-length (+ 2 (ceiling (log max-cons-length 10))))
(format *trace-output*
"~%~%~
~VT ~VA~
~% ~VT % % ~VA ~
Total Total~
~%Function~VT Time Cons Calls Sec/Call ~VA ~
Time Cons~
~%~V,,,'-A"
max-length
max-cons-length "Cons"
max-length
max-cons-length "Per"
max-length
max-cons-length "Call"
(+ max-length 62 (max 0 (- max-cons-length 5))) "-")
(dolist (result *monitor-results*)
(when (or (zerop threshold)
(> (m-info-percent-time result) threshold))
(format *trace-output*
"~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D"
(m-info-name result)
max-length
(* 100 (m-info-percent-time result))
(* 100 (m-info-percent-cons result))
(m-info-calls result)
(m-info-time-per-call result)
max-cons-length
(m-info-cons-per-call result)
(m-info-time result)
(m-info-cons result))
(incf total-time (m-info-time result))
(incf total-consed (m-info-cons result))
(incf total-calls (m-info-calls result))
(incf total-percent-time (m-info-percent-time result))
(incf total-percent-cons (m-info-percent-cons result))))
(format *trace-output*
"~%~V,,,'-A~
~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~
~%Estimated monitoring overhead: ~5,2F seconds~
~%Estimated total monitoring overhead: ~5,2F seconds"
(+ max-length 62 (max 0 (- max-cons-length 5))) "-"
max-length
(* 100 total-percent-time)
(* 100 total-percent-cons)
total-calls
max-cons-length " "
total-time total-consed
(/ (* *monitor-time-overhead* total-calls)
time-units-per-second)
*estimated-total-overhead*)
(when (and (not ignore-no-calls) *no-calls*)
(setq *no-calls* (sort *no-calls* #'string<))
(let ((num-no-calls (length *no-calls*)))
(if (> num-no-calls 20)
(format *trace-output*
"~%~@(~r~) monitored functions were not called. ~
~%See the variable slynk-monitor::*no-calls* for a list."
num-no-calls)
(format *trace-output*
"~%The following monitored functions were not called:~
~%~{~<~%~:; ~A~>~}~%"
*no-calls*))))
(values)))
(defun sort-results (&optional (key :percent-time))
(setq *monitor-results*
(case key
(:function (sort *monitor-results* #'string>
:key #'m-info-name))
((:percent-time :time) (sort *monitor-results* #'>
:key #'m-info-time))
((:percent-cons :cons) (sort *monitor-results* #'>
:key #'m-info-cons))
(:calls (sort *monitor-results* #'>
:key #'m-info-calls))
(:time-per-call (sort *monitor-results* #'>
:key #'m-info-time-per-call))
(:cons-per-call (sort *monitor-results* #'>
:key #'m-info-cons-per-call)))))
;;; *END OF FILE*
;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
;;;
;;; Scieneer Common Lisp code for SLY.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(defpackage slynk-scl
(:use cl slynk-backend slynk-source-path-parser slynk-source-file-cache))
(in-package slynk-scl)
;;; slynk-mop
(import-slynk-mop-symbols :clos '(:slot-definition-documentation))
(defun slynk-mop:slot-definition-documentation (slot)
(documentation slot t))
;;;; TCP server
;;;
;;; SCL only supports the :spawn communication style.
;;;
(defimplementation preferred-communication-style ()
:spawn)
(defimplementation create-socket (host port &key backlog)
(let ((addr (resolve-hostname host)))
(ext:create-inet-listener port :stream :host addr :reuse-address t
:backlog (or backlog 5))))
(defimplementation local-port (socket)
(nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
(defimplementation close-socket (socket)
(ext:close-socket (socket-fd socket)))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(let ((buffering (or buffering :full))
(fd (socket-fd socket)))
(loop
(let ((ready (sys:wait-until-fd-usable fd :input timeout)))
(unless ready
(error "Timeout accepting connection on socket: ~S~%" socket)))
(let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
(when new-fd
(return (make-socket-io-stream new-fd external-format
(ecase buffering
((t) :full)
((nil) :none)
(:line :line)))))))))
(defimplementation set-stream-timeout (stream timeout)
(check-type timeout (or null real))
(if (fboundp 'ext::stream-timeout)
(setf (ext::stream-timeout stream) timeout)
(setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout)
timeout)))
;;;;; Sockets
(defun socket-fd (socket)
"Return the file descriptor for the socket represented by 'socket."
(etypecase socket
(fixnum socket)
(stream (sys:fd-stream-fd socket))))
(defun resolve-hostname (hostname)
"Return the IP address of 'hostname as an integer (in host byte-order)."
(let ((hostent (ext:lookup-host-entry hostname)))
(car (ext:host-entry-addr-list hostent))))
(defvar *external-format-to-coding-system*
'((:iso-8859-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")
(:euc-jp "euc-jp" "euc-jp-unix")))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
(defun make-socket-io-stream (fd external-format buffering)
"Create a new input/output fd-stream for 'fd."
(cond ((not external-format)
(sys:make-fd-stream fd :input t :output t :buffering buffering
:element-type '(unsigned-byte 8)))
(t
(let* ((stream (sys:make-fd-stream fd :input t :output t
:element-type 'base-char
:buffering buffering
:external-format external-format)))
;; Ignore character conversion errors. Without this the
;; communication channel is prone to lockup if a character
;; conversion error occurs.
(setf (lisp::character-conversion-stream-input-error-value stream)
#\?)
(setf (lisp::character-conversion-stream-output-error-value stream)
#\?)
stream))))
;;;; Stream handling
(defimplementation gray-package-name ()
"EXT")
;;;; Compilation Commands
(defvar *previous-compiler-condition* nil
"Used to detect duplicates.")
(defvar *previous-context* nil
"Previous compiler error context.")
(defvar *buffer-name* nil
"The name of the Emacs buffer we are compiling from.
Nil if we aren't compiling from a buffer.")
(defvar *buffer-start-position* nil)
(defvar *buffer-substring* nil)
(defimplementation call-with-compilation-hooks (function)
(let ((*previous-compiler-condition* nil)
(*previous-context* nil)
(*print-readably* nil))
(handler-bind ((c::compiler-error #'handle-notification-condition)
(c::style-warning #'handle-notification-condition)
(c::warning #'handle-notification-condition))
(funcall function))))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(ext:*ignore-extra-close-parentheses* nil))
(multiple-value-bind (output-file warnings-p failure-p)
(compile-file input-file
:output-file output-file
:external-format external-format)
(values output-file warnings-p
(or failure-p
(when load-p
;; Cache the latest source file for definition-finding.
(source-cache-get input-file
(file-write-date input-file))
(not (load output-file)))))))))
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore filename line column policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
(*buffer-substring* string))
(with-input-from-string (stream string)
(ext:compile-from-stream
stream
:source-info `(:emacs-buffer ,buffer
:emacs-buffer-offset ,position
:emacs-buffer-string ,string))))))
;;;;; Trapping notes
;;;
;;; We intercept conditions from the compiler and resignal them as
;;; `slynk:compiler-condition's.
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning."
(unless (eq condition *previous-compiler-condition*)
(let ((context (c::find-error-context nil)))
(setq *previous-compiler-condition* condition)
(setq *previous-context* context)
(signal-compiler-condition condition context))))
(defun signal-compiler-condition (condition context)
(signal 'compiler-condition
:original-condition condition
:severity (severity-for-emacs condition)
:message (brief-compiler-message-for-emacs condition)
:source-context (compiler-error-context context)
:location (if (read-error-p condition)
(read-error-location condition)
(compiler-note-location context))))
(defun severity-for-emacs (condition)
"Return the severity of 'condition."
(etypecase condition
((satisfies read-error-p) :read-error)
(c::compiler-error :error)
(c::style-warning :note)
(c::warning :warning)))
(defun read-error-p (condition)
(eq (type-of condition) 'c::compiler-read-error))
(defun brief-compiler-message-for-emacs (condition)
"Briefly describe a compiler error for Emacs.
When Emacs presents the message it already has the source popped up
and the source form highlighted. This makes much of the information in
the error-context redundant."
(princ-to-string condition))
(defun compiler-error-context (error-context)
"Describe a compiler error for Emacs including context information."
(declare (type (or c::compiler-error-context null) error-context))
(multiple-value-bind (enclosing source)
(if error-context
(values (c::compiler-error-context-enclosing-source error-context)
(c::compiler-error-context-source error-context)))
(if (and enclosing source)
(format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]"
enclosing source))))
(defun read-error-location (condition)
(let* ((finfo (car (c::source-info-current-file c::*source-info*)))
(file (c::file-info-name finfo))
(pos (c::compiler-read-error-position condition)))
(cond ((and (eq file :stream) *buffer-name*)
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position* pos)))
((and (pathnamep file) (not *buffer-name*))
(make-location (list :file (unix-truename file))
(list :position (1+ pos))))
(t (break)))))
(defun compiler-note-location (context)
"Derive the location of a complier message from its context.
Return a `location' record, or (:error <reason>) on failure."
(if (null context)
(note-error-location)
(let ((file (c::compiler-error-context-file-name context))
(source (c::compiler-error-context-original-source context))
(path
(reverse
(c::compiler-error-context-original-source-path context))))
(or (locate-compiler-note file source path)
(note-error-location)))))
(defun note-error-location ()
"Pseudo-location for notes that can't be located."
(list :error "No error location available."))
(defun locate-compiler-note (file source source-path)
(cond ((and (eq file :stream) *buffer-name*)
;; Compiling from a buffer
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position*
(source-path-string-position
source-path *buffer-substring*))))
((and (pathnamep file) (null *buffer-name*))
;; Compiling from a file
(make-location (list :file (unix-truename file))
(list :position (1+ (source-path-file-position
source-path file)))))
((and (eq file :lisp) (stringp source))
;; No location known, but we have the source form.
;; XXX How is this case triggered? -luke (16/May/2004)
;; This can happen if the compiler needs to expand a macro
;; but the macro-expander is not yet compiled. Calling the
;; (interpreted) macro-expander triggers IR1 conversion of
;; the lambda expression for the expander and invokes the
;; compiler recursively.
(make-location (list :source-form source)
(list :position 1)))))
(defun unix-truename (pathname)
(ext:unix-namestring (truename pathname)))
;;; TODO
(defimplementation who-calls (name) nil)
(defimplementation who-references (name) nil)
(defimplementation who-binds (name) nil)
(defimplementation who-sets (name) nil)
(defimplementation who-specializes (symbol) nil)
(defimplementation who-macroexpands (name) nil)
;;;; Find callers and callees
;;;
;;; Find callers and callees by looking at the constant pool of
;;; compiled code objects. We assume every fdefn object in the
;;; constant pool corresponds to a call to that function. A better
;;; strategy would be to use the disassembler to find actual
;;; call-sites.
(declaim (inline map-code-constants))
(defun map-code-constants (code fn)
"Call 'fn for each constant in 'code's constant pool."
(check-type code kernel:code-component)
(loop for i from vm:code-constants-offset below (kernel:get-header-data code)
do (funcall fn (kernel:code-header-ref code i))))
(defun function-callees (function)
"Return 'function's callees as a list of functions."
(let ((callees '()))
(map-code-constants
(vm::find-code-object function)
(lambda (obj)
(when (kernel:fdefn-p obj)
(push (kernel:fdefn-function obj) callees))))
callees))
(declaim (ext:maybe-inline map-allocated-code-components))
(defun map-allocated-code-components (spaces fn)
"Call FN for each allocated code component in one of 'spaces. FN
receives the object as argument. 'spaces should be a list of the
symbols :dynamic, :static, or :read-only."
(dolist (space spaces)
(declare (inline vm::map-allocated-objects)
(optimize (ext:inhibit-warnings 3)))
(vm::map-allocated-objects
(lambda (obj header size)
(declare (type fixnum size) (ignore size))
(when (= vm:code-header-type header)
(funcall fn obj)))
space)))
(declaim (ext:maybe-inline map-caller-code-components))
(defun map-caller-code-components (function spaces fn)
"Call 'fn for each code component with a fdefn for 'function in its
constant pool."
(let ((function (coerce function 'function)))
(declare (inline map-allocated-code-components))
(map-allocated-code-components
spaces
(lambda (obj)
(map-code-constants
obj
(lambda (constant)
(when (and (kernel:fdefn-p constant)
(eq (kernel:fdefn-function constant)
function))
(funcall fn obj))))))))
(defun function-callers (function &optional (spaces '(:read-only :static
:dynamic)))
"Return 'function's callers. The result is a list of code-objects."
(let ((referrers '()))
(declare (inline map-caller-code-components))
(map-caller-code-components function spaces
(lambda (code) (push code referrers)))
referrers))
(defun debug-info-definitions (debug-info)
"Return the defintions for a debug-info. This should only be used
for code-object without entry points, i.e., byte compiled
code (are theree others?)"
;; This mess has only been tested with #'ext::skip-whitespace, a
;; byte-compiled caller of #'read-char .
(check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
(let ((name (c::debug-info-name debug-info))
(source (c::debug-info-source debug-info)))
(destructuring-bind (first) source
(ecase (c::debug-source-from first)
(:file
(list (list name
(make-location
(list :file (unix-truename (c::debug-source-name first)))
(list :function-name (string name))))))))))
(defun valid-function-name-p (name)
(or (symbolp name) (and (consp name)
(eq (car name) 'setf)
(symbolp (cadr name))
(not (cddr name)))))
(defun code-component-entry-points (code)
"Return a list ((name location) ...) of function definitons for
the code omponent 'code."
(let ((names '()))
(do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
((not f))
(let ((name (kernel:%function-name f)))
(when (valid-function-name-p name)
(push (list name (function-location f)) names))))
names))
(defimplementation list-callers (symbol)
"Return a list ((name location) ...) of callers."
(let ((components (function-callers symbol))
(xrefs '()))
(dolist (code components)
(let* ((entry (kernel:%code-entry-points code))
(defs (if entry
(code-component-entry-points code)
;; byte compiled stuff
(debug-info-definitions
(kernel:%code-debug-info code)))))
(setq xrefs (nconc defs xrefs))))
xrefs))
(defimplementation list-callees (symbol)
(let ((fns (function-callees symbol)))
(mapcar (lambda (fn)
(list (kernel:%function-name fn)
(function-location fn)))
fns)))
;;;; Resolving source locations
;;;
;;; Our mission here is to "resolve" references to code locations into
;;; actual file/buffer names and character positions. The references
;;; we work from come out of the compiler's statically-generated debug
;;; information, such as `code-location''s and `debug-source''s. For
;;; more details, see the "Debugger Programmer's Interface" section of
;;; the SCL manual.
;;;
;;; The first step is usually to find the corresponding "source-path"
;;; for the location. Once we have the source-path we can pull up the
;;; source file and `READ' our way through to the right position. The
;;; main source-code groveling work is done in
;;; `slynk-source-path-parser.lisp'.
(defvar *debug-definition-finding* nil
"When true don't handle errors while looking for definitions.
This is useful when debugging the definition-finding code.")
(defmacro safe-definition-finding (&body body)
"Execute 'body and return the source-location it returns.
If an error occurs and `*debug-definition-finding*' is false, then
return an error pseudo-location.
The second return value is 'nil if no error occurs, otherwise it is the
condition object."
`(flet ((body () ,@body))
(if *debug-definition-finding*
(body)
(handler-case (values (progn ,@body) nil)
(error (c) (values (list :error (princ-to-string c)) c))))))
(defun code-location-source-location (code-location)
"Safe wrapper around `code-location-from-source-location'."
(safe-definition-finding
(source-location-from-code-location code-location)))
(defun source-location-from-code-location (code-location)
"Return the source location for 'code-location."
(let ((debug-fun (di:code-location-debug-function code-location)))
(when (di::bogus-debug-function-p debug-fun)
;; Those lousy cheapskates! They've put in a bogus debug source
;; because the code was compiled at a low debug setting.
(error "Bogus debug function: ~A" debug-fun)))
(let* ((debug-source (di:code-location-debug-source code-location))
(from (di:debug-source-from debug-source))
(name (di:debug-source-name debug-source)))
(ecase from
(:file
(location-in-file name code-location debug-source))
(:stream
(location-in-stream code-location debug-source))
(:lisp
;; The location comes from a form passed to `compile'.
;; The best we can do is return the form itself for printing.
(make-location
(list :source-form (with-output-to-string (*standard-output*)
(debug::print-code-location-source-form
code-location 100 t)))
(list :position 1))))))
(defun location-in-file (filename code-location debug-source)
"Resolve the source location for 'code-location in 'filename."
(let* ((code-date (di:debug-source-created debug-source))
(source-code (get-source-code filename code-date)))
(with-input-from-string (s source-code)
(make-location (list :file (unix-truename filename))
(list :position (1+ (code-location-stream-position
code-location s)))
`(:snippet ,(read-snippet s))))))
(defun location-in-stream (code-location debug-source)
"Resolve the source location for a 'code-location from a stream.
This only succeeds if the code was compiled from an Emacs buffer."
(unless (debug-source-info-from-emacs-buffer-p debug-source)
(error "The code is compiled from a non-SLY stream."))
(let* ((info (c::debug-source-info debug-source))
(string (getf info :emacs-buffer-string))
(position (code-location-string-offset
code-location
string)))
(make-location
(list :buffer (getf info :emacs-buffer))
(list :offset (getf info :emacs-buffer-offset) position)
(list :snippet (with-input-from-string (s string)
(file-position s position)
(read-snippet s))))))
;;;;; Function-name locations
;;;
(defun debug-info-function-name-location (debug-info)
"Return a function-name source-location for 'debug-info.
Function-name source-locations are a fallback for when precise
positions aren't available."
(with-struct (c::debug-info- (fname name) source) debug-info
(with-struct (c::debug-source- info from name) (car source)
(ecase from
(:file
(make-location (list :file (namestring (truename name)))
(list :function-name (string fname))))
(:stream
(assert (debug-source-info-from-emacs-buffer-p (car source)))
(make-location (list :buffer (getf info :emacs-buffer))
(list :function-name (string fname))))
(:lisp
(make-location (list :source-form (princ-to-string (aref name 0)))
(list :position 1)))))))
(defun debug-source-info-from-emacs-buffer-p (debug-source)
"Does the `info' slot of 'debug-source contain an Emacs buffer location?
This is true for functions that were compiled directly from buffers."
(info-from-emacs-buffer-p (c::debug-source-info debug-source)))
(defun info-from-emacs-buffer-p (info)
(and info
(consp info)
(eq :emacs-buffer (car info))))
;;;;; Groveling source-code for positions
(defun code-location-stream-position (code-location stream)
"Return the byte offset of 'code-location in 'stream. Extract the
toplevel-form-number and form-number from 'code-location and use that
to find the position of the corresponding form.
Finish with 'stream positioned at the start of the code location."
(let* ((location (debug::maybe-block-start-location code-location))
(tlf-offset (di:code-location-top-level-form-offset location))
(form-number (di:code-location-form-number location)))
(let ((pos (form-number-stream-position tlf-offset form-number stream)))
(file-position stream pos)
pos)))
(defun form-number-stream-position (tlf-number form-number stream)
"Return the starting character position of a form in 'stream.
'tlf-number is the top-level-form number.
'form-number is an index into a source-path table for the TLF."
(multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
(let* ((path-table (di:form-number-translations tlf 0))
(source-path
(if (<= (length path-table) form-number) ; source out of sync?
(list 0) ; should probably signal a condition
(reverse (cdr (aref path-table form-number))))))
(source-path-source-position source-path tlf position-map))))
(defun code-location-string-offset (code-location string)
"Return the byte offset of 'code-location in 'string.
See 'code-location-stream-position."
(with-input-from-string (s string)
(code-location-stream-position code-location s)))
;;;; Finding definitions
;;; There are a great many different types of definition for us to
;;; find. We search for definitions of every kind and return them in a
;;; list.
(defimplementation find-definitions (name)
(append (function-definitions name)
(setf-definitions name)
(variable-definitions name)
(class-definitions name)
(type-definitions name)
(compiler-macro-definitions name)
(source-transform-definitions name)
(function-info-definitions name)
(ir1-translator-definitions name)))
;;;;; Functions, macros, generic functions, methods
;;;
;;; We make extensive use of the compile-time debug information that
;;; SCL records, in particular "debug functions" and "code
;;; locations." Refer to the "Debugger Programmer's Interface" section
;;; of the SCL manual for more details.
(defun function-definitions (name)
"Return definitions for 'name in the \"function namespace\", i.e.,
regular functions, generic functions, methods and macros.
'name can any valid function name (e.g, (setf car))."
(let ((macro? (and (symbolp name) (macro-function name)))
(special? (and (symbolp name) (special-operator-p name)))
(function? (and (valid-function-name-p name)
(ext:info :function :definition name)
(if (symbolp name) (fboundp name) t))))
(cond (macro?
(list `((defmacro ,name)
,(function-location (macro-function name)))))
(special?
(list `((:special-operator ,name)
(:error ,(format nil "Special operator: ~S" name)))))
(function?
(let ((function (fdefinition name)))
(if (genericp function)
(generic-function-definitions name function)
(list (list `(function ,name)
(function-location function)))))))))
;;;;;; Ordinary (non-generic/macro/special) functions
;;;
;;; First we test if FUNCTION is a closure created by defstruct, and
;;; if so extract the defstruct-description (`dd') from the closure
;;; and find the constructor for the struct. Defstruct creates a
;;; defun for the default constructor and we use that as an
;;; approximation to the source location of the defstruct.
;;;
;;; For an ordinary function we return the source location of the
;;; first code-location we find.
;;;
(defun function-location (function)
"Return the source location for FUNCTION."
(cond ((struct-closure-p function)
(struct-closure-location function))
((c::byte-function-or-closure-p function)
(byte-function-location function))
(t
(compiled-function-location function))))
(defun compiled-function-location (function)
"Return the location of a regular compiled function."
(multiple-value-bind (code-location error)
(safe-definition-finding (function-first-code-location function))
(cond (error (list :error (princ-to-string error)))
(t (code-location-source-location code-location)))))
(defun function-first-code-location (function)
"Return the first code-location we can find for 'function."
(and (function-has-debug-function-p function)
(di:debug-function-start-location
(di:function-debug-function function))))
(defun function-has-debug-function-p (function)
(di:function-debug-function function))
(defun function-code-object= (closure function)
(and (eq (vm::find-code-object closure)
(vm::find-code-object function))
(not (eq closure function))))
(defun byte-function-location (fn)
"Return the location of the byte-compiled function 'fn."
(etypecase fn
((or c::hairy-byte-function c::simple-byte-function)
(let* ((component (c::byte-function-component fn))
(debug-info (kernel:%code-debug-info component)))
(debug-info-function-name-location debug-info)))
(c::byte-closure
(byte-function-location (c::byte-closure-function fn)))))
;;; Here we deal with structure accessors. Note that `dd' is a
;;; "defstruct descriptor" structure in SCL. A `dd' describes a
;;; `defstruct''d structure.
(defun struct-closure-p (function)
"Is 'function a closure created by defstruct?"
(or (function-code-object= function #'kernel::structure-slot-accessor)
(function-code-object= function #'kernel::structure-slot-setter)
(function-code-object= function #'kernel::%defstruct)))
(defun struct-closure-location (function)
"Return the location of the structure that 'function belongs to."
(assert (struct-closure-p function))
(safe-definition-finding
(dd-location (struct-closure-dd function))))
(defun struct-closure-dd (function)
"Return the defstruct-definition (dd) of FUNCTION."
(assert (= (kernel:get-type function) vm:closure-header-type))
(flet ((find-layout (function)
(sys:find-if-in-closure
(lambda (x)
(let ((value (if (di::indirect-value-cell-p x)
(c:value-cell-ref x)
x)))
(when (kernel::layout-p value)
(return-from find-layout value))))
function)))
(kernel:layout-info (find-layout function))))
(defun dd-location (dd)
"Return the location of a `defstruct'."
;; Find the location in a constructor.
(function-location (struct-constructor dd)))
(defun struct-constructor (dd)
"Return a constructor function from a defstruct definition.
Signal an error if no constructor can be found."
(let ((constructor (or (kernel:dd-default-constructor dd)
(car (kernel::dd-constructors dd)))))
(when (or (null constructor)
(and (consp constructor) (null (car constructor))))
(error "Cannot find structure's constructor: ~S"
(kernel::dd-name dd)))
(coerce (if (consp constructor) (first constructor) constructor)
'function)))
;;;;;; Generic functions and methods
(defun generic-function-definitions (name function)
"Return the definitions of a generic function and its methods."
(cons (list `(defgeneric ,name) (gf-location function))
(gf-method-definitions function)))
(defun gf-location (gf)
"Return the location of the generic function GF."
(definition-source-location gf (clos:generic-function-name gf)))
(defun gf-method-definitions (gf)
"Return the locations of all methods of the generic function GF."
(mapcar #'method-definition (clos:generic-function-methods gf)))
(defun method-definition (method)
(list (method-dspec method)
(method-location method)))
(defun method-dspec (method)
"Return a human-readable \"definition specifier\" for METHOD."
(let* ((gf (clos:method-generic-function method))
(name (clos:generic-function-name gf))
(specializers (clos:method-specializers method))
(qualifiers (clos:method-qualifiers method)))
`(method ,name ,@qualifiers ,specializers
#+nil (clos::unparse-specializers specializers))))
;; XXX maybe special case setters/getters
(defun method-location (method)
(function-location (clos:method-function method)))
(defun genericp (fn)
(typep fn 'generic-function))
;;;;;; Types and classes
(defun type-definitions (name)
"Return `deftype' locations for type NAME."
(maybe-make-definition (ext:info :type :expander name) 'deftype name))
(defun maybe-make-definition (function kind name)
"If FUNCTION is non-nil then return its definition location."
(if function
(list (list `(,kind ,name) (function-location function)))))
(defun class-definitions (name)
"Return the definition locations for the class called NAME."
(if (symbolp name)
(let ((class (find-class name nil)))
(etypecase class
(null '())
(structure-class
(list (list `(defstruct ,name)
(dd-location (find-dd name)))))
(standard-class
(list (list `(defclass ,name)
(class-location (find-class name)))))
((or built-in-class
kernel:funcallable-structure-class)
(list (list `(kernel::define-type-class ,name)
`(:error
,(format nil "No source info for ~A" name)))))))))
(defun class-location (class)
"Return the `defclass' location for CLASS."
(definition-source-location class (class-name class)))
(defun find-dd (name)
"Find the defstruct-definition by the name of its structure-class."
(let ((layout (ext:info :type :compiler-layout name)))
(if layout
(kernel:layout-info layout))))
(defun condition-class-location (class)
(let ((name (class-name class)))
`(:error ,(format nil "No location info for condition: ~A" name))))
(defun make-name-in-file-location (file string)
(multiple-value-bind (filename c)
(ignore-errors
(unix-truename (merge-pathnames (make-pathname :type "lisp")
file)))
(cond (filename (make-location `(:file ,filename)
`(:function-name ,(string string))))
(t (list :error (princ-to-string c))))))
(defun definition-source-location (object name)
`(:error ,(format nil "No source info for: ~A" object)))
(defun setf-definitions (name)
(let ((function (or (ext:info :setf :inverse name)
(ext:info :setf :expander name))))
(if function
(list (list `(setf ,name)
(function-location (coerce function 'function)))))))
(defun variable-location (symbol)
`(:error ,(format nil "No source info for variable ~S" symbol)))
(defun variable-definitions (name)
(if (symbolp name)
(multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
(if recorded-p
(list (list `(variable ,kind ,name)
(variable-location name)))))))
(defun compiler-macro-definitions (symbol)
(maybe-make-definition (compiler-macro-function symbol)
'define-compiler-macro
symbol))
(defun source-transform-definitions (name)
(maybe-make-definition (ext:info :function :source-transform name)
'c:def-source-transform
name))
(defun function-info-definitions (name)
(let ((info (ext:info :function :info name)))
(if info
(append (loop for transform in (c::function-info-transforms info)
collect (list `(c:deftransform ,name
,(c::type-specifier
(c::transform-type transform)))
(function-location (c::transform-function
transform))))
(maybe-make-definition (c::function-info-derive-type info)
'c::derive-type name)
(maybe-make-definition (c::function-info-optimizer info)
'c::optimizer name)
(maybe-make-definition (c::function-info-ltn-annotate info)
'c::ltn-annotate name)
(maybe-make-definition (c::function-info-ir2-convert info)
'c::ir2-convert name)
(loop for template in (c::function-info-templates info)
collect (list `(c::vop ,(c::template-name template))
(function-location
(c::vop-info-generator-function
template))))))))
(defun ir1-translator-definitions (name)
(maybe-make-definition (ext:info :function :ir1-convert name)
'c:def-ir1-translator name))
;;;; Documentation.
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (multiple-value-bind (kind recorded-p)
(ext:info variable kind symbol)
(declare (ignore kind))
(if (or (boundp symbol) recorded-p)
(doc 'variable))))
(when (fboundp symbol)
(maybe-push
(cond ((macro-function symbol) :macro)
((special-operator-p symbol) :special-operator)
((genericp (fdefinition symbol)) :generic-function)
(t :function))
(doc 'function)))
(maybe-push
:setf (if (or (ext:info setf inverse symbol)
(ext:info setf expander symbol))
(doc 'setf)))
(maybe-push
:type (if (ext:info type kind symbol)
(doc 'type)))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
(maybe-push
:alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
(doc 'alien-type)))
(maybe-push
:alien-struct (if (ext:info alien-type struct symbol)
(doc nil)))
(maybe-push
:alien-union (if (ext:info alien-type union symbol)
(doc nil)))
(maybe-push
:alien-enum (if (ext:info alien-type enum symbol)
(doc nil)))
result)))
(defimplementation describe-definition (symbol namespace)
(describe (ecase namespace
(:variable
symbol)
((:function :generic-function)
(symbol-function symbol))
(:setf
(or (ext:info setf inverse symbol)
(ext:info setf expander symbol)))
(:type
(kernel:values-specifier-type symbol))
(:class
(find-class symbol))
(:alien-struct
(ext:info :alien-type :struct symbol))
(:alien-union
(ext:info :alien-type :union symbol))
(:alien-enum
(ext:info :alien-type :enum symbol))
(:alien-type
(ecase (ext:info :alien-type :kind symbol)
(:primitive
(let ((alien::*values-type-okay* t))
(funcall (ext:info :alien-type :translator symbol)
(list symbol))))
((:defined)
(ext:info :alien-type :definition symbol))
(:unknown :unknown))))))
;;;;; Argument lists
(defimplementation arglist (fun)
(multiple-value-bind (args winp)
(ext:function-arglist fun)
(if winp args :not-available)))
(defimplementation function-name (function)
(cond ((eval:interpreted-function-p function)
(eval:interpreted-function-name function))
((typep function 'generic-function)
(clos:generic-function-name function))
((c::byte-function-or-closure-p function)
(c::byte-function-name function))
(t (kernel:%function-name (kernel:%function-self function)))))
;;; A harder case: an approximate arglist is derived from available
;;; debugging information.
(defun debug-function-arglist (debug-function)
"Derive the argument list of DEBUG-FUNCTION from debug info."
(let ((args (di::debug-function-lambda-list debug-function))
(required '())
(optional '())
(rest '())
(key '()))
;; collect the names of debug-vars
(dolist (arg args)
(etypecase arg
(di::debug-variable
(push (di::debug-variable-symbol arg) required))
((member :deleted)
(push ':deleted required))
(cons
(ecase (car arg)
(:keyword
(push (second arg) key))
(:optional
(push (debug-variable-symbol-or-deleted (second arg)) optional))
(:rest
(push (debug-variable-symbol-or-deleted (second arg)) rest))))))
;; intersperse lambda keywords as needed
(append (nreverse required)
(if optional (cons '&optional (nreverse optional)))
(if rest (cons '&rest (nreverse rest)))
(if key (cons '&key (nreverse key))))))
(defun debug-variable-symbol-or-deleted (var)
(etypecase var
(di:debug-variable
(di::debug-variable-symbol var))
((member :deleted)
'#:deleted)))
(defun symbol-debug-function-arglist (fname)
"Return FNAME's debug-function-arglist and %function-arglist.
A utility for debugging DEBUG-FUNCTION-ARGLIST."
(let ((fn (fdefinition fname)))
(values (debug-function-arglist (di::function-debug-function fn))
(kernel:%function-arglist (kernel:%function-self fn)))))
;;;; Miscellaneous.
(defimplementation macroexpand-all (form &optional env)
(declare (ignore env))
(macroexpand form))
(defimplementation set-default-directory (directory)
(setf (ext:default-directory) (namestring directory))
;; Setting *default-pathname-defaults* to an absolute directory
;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
(setf *default-pathname-defaults* (pathname (ext:default-directory)))
(default-directory))
(defimplementation default-directory ()
(namestring (ext:default-directory)))
(defimplementation pathname-to-filename (pathname)
(ext:unix-namestring pathname nil))
(defimplementation getpid ()
(unix:unix-getpid))
(defimplementation lisp-implementation-type-name ()
(if (eq ext:*case-mode* :upper) "scl" "scl-lower"))
(defimplementation quit-lisp ()
(ext:quit))
;;; source-path-{stream,file,string,etc}-position moved into
;;; slynk-source-path-parser
;;;; Debugging
(defvar *sly-db-stack-top*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* ((*sly-db-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
(debug:*stack-top-hint* nil)
(kernel:*current-level* 0))
(handler-bind ((di::unhandled-condition
(lambda (condition)
(error 'sly-db-condition
:original-condition condition))))
(funcall debugger-loop-fn))))
(defun frame-down (frame)
(handler-case (di:frame-down frame)
(di:no-debug-info () nil)))
(defun nth-frame (index)
(do ((frame *sly-db-stack-top* (frame-down frame))
(i index (1- i)))
((zerop i) frame)))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (frame-down f)
for i from start below end
while f collect f)))
(defimplementation print-frame (frame stream)
(let ((*standard-output* stream))
(handler-case
(debug::print-frame-call frame :verbosity 1 :number nil)
(error (e)
(ignore-errors (princ e stream))))))
(defimplementation frame-source-location (index)
(code-location-source-location (di:frame-code-location (nth-frame index))))
(defimplementation eval-in-frame (form index)
(di:eval-in-frame (nth-frame index) form))
(defun frame-debug-vars (frame)
"Return a vector of debug-variables in frame."
(di::debug-function-debug-variables (di:frame-debug-function frame)))
(defun debug-var-value (var frame location)
(let ((validity (di:debug-variable-validity var location)))
(ecase validity
(:valid (di:debug-variable-value var frame))
((:invalid :unknown) (make-symbol (string validity))))))
(defimplementation frame-locals (index)
(let* ((frame (nth-frame index))
(loc (di:frame-code-location frame))
(vars (frame-debug-vars frame)))
(loop for v across vars collect
(list :name (di:debug-variable-symbol v)
:id (di:debug-variable-id v)
:value (debug-var-value v frame loc)))))
(defimplementation frame-var-value (frame var)
(let* ((frame (nth-frame frame))
(dvar (aref (frame-debug-vars frame) var)))
(debug-var-value dvar frame (di:frame-code-location frame))))
(defimplementation frame-catch-tags (index)
(mapcar #'car (di:frame-catches (nth-frame index))))
(defimplementation return-from-frame (index form)
(let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame)
:debug-internals)))
(if sym
(let* ((frame (nth-frame index))
(probe (funcall sym frame)))
(cond (probe (throw (car probe) (eval-in-frame form index)))
(t (format nil "Cannot return from frame: ~S" frame))))
"return-from-frame is not implemented in this version of SCL.")))
(defimplementation activate-stepping (frame)
(set-step-breakpoints (nth-frame frame)))
(defimplementation sly-db-break-on-return (frame)
(break-on-return (nth-frame frame)))
;;; We set the breakpoint in the caller which might be a bit confusing.
;;;
(defun break-on-return (frame)
(let* ((caller (di:frame-down frame))
(cl (di:frame-code-location caller)))
(flet ((hook (frame bp)
(when (frame-pointer= frame caller)
(di:delete-breakpoint bp)
(signal-breakpoint bp frame))))
(let* ((info (ecase (di:code-location-kind cl)
((:single-value-return :unknown-return) nil)
(:known-return (debug-function-returns
(di:frame-debug-function frame)))))
(bp (di:make-breakpoint #'hook cl :kind :code-location
:info info)))
(di:activate-breakpoint bp)
`(:ok ,(format nil "Set breakpoint in ~A" caller))))))
(defun frame-pointer= (frame1 frame2)
"Return true if the frame pointers of FRAME1 and FRAME2 are the same."
(sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
;;; The PC in escaped frames at a single-return-value point is
;;; actually vm:single-value-return-byte-offset bytes after the
;;; position given in the debug info. Here we try to recognize such
;;; cases.
;;;
(defun next-code-locations (frame code-location)
"Like `debug::next-code-locations' but be careful in escaped frames."
(let ((next (debug::next-code-locations code-location)))
(flet ((adjust-pc ()
(let ((cl (di::copy-compiled-code-location code-location)))
(incf (di::compiled-code-location-pc cl)
vm:single-value-return-byte-offset)
cl)))
(cond ((and (di::compiled-frame-escaped frame)
(eq (di:code-location-kind code-location)
:single-value-return)
(= (length next) 1)
(di:code-location= (car next) (adjust-pc)))
(debug::next-code-locations (car next)))
(t
next)))))
(defun set-step-breakpoints (frame)
(let ((cl (di:frame-code-location frame)))
(when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
(error "Cannot step in elsewhere code"))
(let* ((debug::*bad-code-location-types*
(remove :call-site debug::*bad-code-location-types*))
(next (next-code-locations frame cl)))
(cond (next
(let ((steppoints '()))
(flet ((hook (bp-frame bp)
(signal-breakpoint bp bp-frame)
(mapc #'di:delete-breakpoint steppoints)))
(dolist (code-location next)
(let ((bp (di:make-breakpoint #'hook code-location
:kind :code-location)))
(di:activate-breakpoint bp)
(push bp steppoints))))))
(t
(break-on-return frame))))))
;; XXX the return values at return breakpoints should be passed to the
;; user hooks. debug-int.lisp should be changed to do this cleanly.
;;; The sigcontext and the PC for a breakpoint invocation are not
;;; passed to user hook functions, but we need them to extract return
;;; values. So we advice di::handle-breakpoint and bind the values to
;;; special variables.
;;;
(defvar *breakpoint-sigcontext*)
(defvar *breakpoint-pc*)
(defun sigcontext-object (sc index)
"Extract the lisp object in sigcontext SC at offset INDEX."
(kernel:make-lisp-obj (vm:ucontext-register sc index)))
(defun known-return-point-values (sigcontext sc-offsets)
(let ((fp (system:int-sap (vm:ucontext-register sigcontext
vm::cfp-offset))))
(system:without-gcing
(loop for sc-offset across sc-offsets
collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
;;; SCL returns the first few values in registers and the rest on
;;; the stack. In the multiple value case, the number of values is
;;; stored in a dedicated register. The values of the registers can be
;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
;;; of return conventions: :single-value-return, :unknown-return, and
;;; :known-return.
;;;
;;; The :single-value-return convention returns the value in a
;;; register without setting the nargs registers.
;;;
;;; The :unknown-return variant is used for multiple values. A
;;; :unknown-return point consists actually of 2 breakpoints: one for
;;; the single value case and one for the general case. The single
;;; value breakpoint comes vm:single-value-return-byte-offset after
;;; the multiple value breakpoint.
;;;
;;; The :known-return convention is used by local functions.
;;; :known-return is currently not supported because we don't know
;;; where the values are passed.
;;;
(defun breakpoint-values (breakpoint)
"Return the list of return values for a return point."
(flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
(let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
(alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext))))
(cl (di:breakpoint-what breakpoint)))
(ecase (di:code-location-kind cl)
(:single-value-return
(list (1st sc)))
(:known-return
(let ((info (di:breakpoint-info breakpoint)))
(if (vectorp info)
(known-return-point-values sc info)
(progn
;;(break)
(list "<<known-return convention not supported>>" info)))))
(:unknown-return
(let ((mv-return-pc (di::compiled-code-location-pc cl)))
(if (= mv-return-pc *breakpoint-pc*)
(mv-function-end-breakpoint-values sc)
(list (1st sc)))))))))
(defun mv-function-end-breakpoint-values (sigcontext)
(let ((sym (find-symbol
(symbol-name '#:function-end-breakpoint-values/standard)
:debug-internals)))
(cond (sym (funcall sym sigcontext))
(t (di::get-function-end-breakpoint-values sigcontext)))))
(defun debug-function-returns (debug-fun)
"Return the return style of DEBUG-FUN."
(let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
(c::compiled-debug-function-returns cdfun)))
(define-condition breakpoint (simple-condition)
((message :initarg :message :reader breakpoint.message)
(values :initarg :values :reader breakpoint.values))
(:report (lambda (c stream) (princ (breakpoint.message c) stream))))
#+nil
(defimplementation condition-extras ((c breakpoint))
;; simply pop up the source buffer
`((:short-frame-source 0)))
(defun signal-breakpoint (breakpoint frame)
"Signal a breakpoint condition for BREAKPOINT in FRAME.
Try to create a informative message."
(flet ((brk (values fstring &rest args)
(let ((msg (apply #'format nil fstring args))
(debug:*stack-top-hint* frame))
(break 'breakpoint :message msg :values values))))
(with-struct (di::breakpoint- kind what) breakpoint
(case kind
(:code-location
(case (di:code-location-kind what)
((:single-value-return :known-return :unknown-return)
(let ((values (breakpoint-values breakpoint)))
(brk values "Return value: ~{~S ~}" values)))
(t
#+(or)
(when (eq (di:code-location-kind what) :call-site)
(call-site-function breakpoint frame))
(brk nil "Breakpoint: ~S ~S"
(di:code-location-kind what)
(di::compiled-code-location-pc what)))))
(:function-start
(brk nil "Function start breakpoint"))
(t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
#+nil
(defimplementation sly-db-break-at-start (fname)
(let ((debug-fun (di:function-debug-function (coerce fname 'function))))
(cond ((not debug-fun)
`(:error ,(format nil "~S has no debug-function" fname)))
(t
(flet ((hook (frame bp &optional args cookie)
(declare (ignore args cookie))
(signal-breakpoint bp frame)))
(let ((bp (di:make-breakpoint #'hook debug-fun
:kind :function-start)))
(di:activate-breakpoint bp)
`(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
(defun frame-cfp (frame)
"Return the Control-Stack-Frame-Pointer for FRAME."
(etypecase frame
(di::compiled-frame (di::frame-pointer frame))
((or di::interpreted-frame null) -1)))
(defun frame-ip (frame)
"Return the (absolute) instruction pointer and the relative pc of FRAME."
(if (not frame)
-1
(let ((debug-fun (di::frame-debug-function frame)))
(etypecase debug-fun
(di::compiled-debug-function
(let* ((code-loc (di:frame-code-location frame))
(component (di::compiled-debug-function-component debug-fun))
(pc (di::compiled-code-location-pc code-loc))
(ip (sys:without-gcing
(sys:sap-int
(sys:sap+ (kernel:code-instructions component) pc)))))
(values ip pc)))
((or di::bogus-debug-function di::interpreted-debug-function)
-1)))))
(defun frame-registers (frame)
"Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
(let* ((cfp (frame-cfp frame))
(csp (frame-cfp (di::frame-up frame)))
(ip (frame-ip frame))
(ocfp (frame-cfp (di::frame-down frame)))
(lra (frame-ip (di::frame-down frame))))
(values csp cfp ip ocfp lra)))
(defun print-frame-registers (frame-number)
(let ((frame (di::frame-real-frame (nth-frame frame-number))))
(flet ((fixnum (p) (etypecase p
(integer p)
(sys:system-area-pointer (sys:sap-int p)))))
(apply #'format t "~
CSP = ~X
CFP = ~X
IP = ~X
OCFP = ~X
LRA = ~X~%" (mapcar #'fixnum
(multiple-value-list (frame-registers frame)))))))
(defimplementation disassemble-frame (frame-number)
"Return a string with the disassembly of frames code."
(print-frame-registers frame-number)
(terpri)
(let* ((frame (di::frame-real-frame (nth-frame frame-number)))
(debug-fun (di::frame-debug-function frame)))
(etypecase debug-fun
(di::compiled-debug-function
(let* ((component (di::compiled-debug-function-component debug-fun))
(fun (di:debug-function-function debug-fun)))
(if fun
(disassemble fun)
(disassem:disassemble-code-component component))))
(di::bogus-debug-function
(format t "~%[Disassembling bogus frames not implemented]")))))
;;;; Inspecting
(defconstant +lowtag-symbols+
'(vm:even-fixnum-type
vm:instance-pointer-type
vm:other-immediate-0-type
vm:list-pointer-type
vm:odd-fixnum-type
vm:function-pointer-type
vm:other-immediate-1-type
vm:other-pointer-type)
"Names of the constants that specify type tags.
The `symbol-value' of each element is a type tag.")
(defconstant +header-type-symbols+
(labels ((suffixp (suffix string)
(and (>= (length string) (length suffix))
(string= string suffix :start1 (- (length string)
(length suffix)))))
(header-type-symbol-p (x)
(and (suffixp (symbol-name '#:-type) (symbol-name x))
(not (member x +lowtag-symbols+))
(boundp x)
(typep (symbol-value x) 'fixnum))))
(remove-if-not #'header-type-symbol-p
(append (apropos-list (symbol-name '#:-type) :vm)
(apropos-list (symbol-name '#:-type) :bignum))))
"A list of names of the type codes in boxed objects.")
(defimplementation describe-primitive-type (object)
(with-output-to-string (*standard-output*)
(let* ((lowtag (kernel:get-lowtag object))
(lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
(format t "lowtag: ~A" lowtag-symbol)
(when (member lowtag (list vm:other-pointer-type
vm:function-pointer-type
vm:other-immediate-0-type
vm:other-immediate-1-type
))
(let* ((type (kernel:get-type object))
(type-symbol (find type +header-type-symbols+
:key #'symbol-value)))
(format t ", type: ~A" type-symbol))))))
(defmethod emacs-inspect ((o t))
(cond ((di::indirect-value-cell-p o)
`("Value: " (:value ,(c:value-cell-ref o))))
((alien::alien-value-p o)
(inspect-alien-value o))
(t
(scl-inspect o))))
(defun scl-inspect (o)
(destructuring-bind (text labeledp . parts)
(inspect::describe-parts o)
(list* (format nil "~A~%" text)
(if labeledp
(loop for (label . value) in parts
append (label-value-line label value))
(loop for value in parts for i from 0
append (label-value-line i value))))))
(defmethod emacs-inspect ((o function))
(let ((header (kernel:get-type o)))
(cond ((= header vm:function-header-type)
(list* (format nil "~A is a function.~%" o)
(append (label-value-line*
("Self" (kernel:%function-self o))
("Next" (kernel:%function-next o))
("Name" (kernel:%function-name o))
("Arglist" (kernel:%function-arglist o))
("Type" (kernel:%function-type o))
("Code" (kernel:function-code-header o)))
(list
(with-output-to-string (s)
(disassem:disassemble-function o :stream s))))))
((= header vm:closure-header-type)
(list* (format nil "~A is a closure.~%" o)
(append
(label-value-line "Function" (kernel:%closure-function o))
`("Environment:" (:newline))
(loop for i from 0 below (- (kernel:get-closure-length o)
(1- vm:closure-info-offset))
append (label-value-line
i (kernel:%closure-index-ref o i))))))
((eval::interpreted-function-p o)
(scl-inspect o))
(t
(call-next-method)))))
(defmethod emacs-inspect ((o kernel:code-component))
(append
(label-value-line*
("code-size" (kernel:%code-code-size o))
("entry-points" (kernel:%code-entry-points o))
("debug-info" (kernel:%code-debug-info o))
("trace-table-offset" (kernel:code-header-ref
o vm:code-trace-table-offset-slot)))
`("Constants:" (:newline))
(loop for i from vm:code-constants-offset
below (kernel:get-header-data o)
append (label-value-line i (kernel:code-header-ref o i)))
`("Code:" (:newline)
, (with-output-to-string (s)
(cond ((kernel:%code-debug-info o)
(disassem:disassemble-code-component o :stream s))
(t
(disassem:disassemble-memory
(disassem::align
(+ (logandc2 (kernel:get-lisp-obj-address o)
vm:lowtag-mask)
(* vm:code-constants-offset vm:word-bytes))
(ash 1 vm:lowtag-bits))
(ash (kernel:%code-code-size o) vm:word-shift)
:stream s)))))))
(defmethod emacs-inspect ((o kernel:fdefn))
(label-value-line*
("name" (kernel:fdefn-name o))
("function" (kernel:fdefn-function o))
("raw-addr" (sys:sap-ref-32
(sys:int-sap (kernel:get-lisp-obj-address o))
(* vm:fdefn-raw-addr-slot vm:word-bytes)))))
(defmethod emacs-inspect ((o array))
(cond ((kernel:array-header-p o)
(list* (format nil "~A is an array.~%" o)
(label-value-line*
(:header (describe-primitive-type o))
(:rank (array-rank o))
(:fill-pointer (kernel:%array-fill-pointer o))
(:fill-pointer-p (kernel:%array-fill-pointer-p o))
(:elements (kernel:%array-available-elements o))
(:data (kernel:%array-data-vector o))
(:displacement (kernel:%array-displacement o))
(:displaced-p (kernel:%array-displaced-p o))
(:dimensions (array-dimensions o)))))
(t
(list* (format nil "~A is an simple-array.~%" o)
(label-value-line*
(:header (describe-primitive-type o))
(:length (length o)))))))
(defmethod emacs-inspect ((o simple-vector))
(list* (format nil "~A is a vector.~%" o)
(append
(label-value-line*
(:header (describe-primitive-type o))
(:length (c::vector-length o)))
(unless (eq (array-element-type o) 'nil)
(loop for i below (length o)
append (label-value-line i (aref o i)))))))
(defun inspect-alien-record (alien)
(with-struct (alien::alien-value- sap type) alien
(with-struct (alien::alien-record-type- kind name fields) type
(append
(label-value-line*
(:sap sap)
(:kind kind)
(:name name))
(loop for field in fields
append (let ((slot (alien::alien-record-field-name field)))
(label-value-line slot (alien:slot alien slot))))))))
(defun inspect-alien-pointer (alien)
(with-struct (alien::alien-value- sap type) alien
(label-value-line*
(:sap sap)
(:type type)
(:to (alien::deref alien)))))
(defun inspect-alien-value (alien)
(typecase (alien::alien-value-type alien)
(alien::alien-record-type (inspect-alien-record alien))
(alien::alien-pointer-type (inspect-alien-pointer alien))
(t (scl-inspect alien))))
;;;; Profiling
(defimplementation profile (fname)
(eval `(profile:profile ,fname)))
(defimplementation unprofile (fname)
(eval `(profile:unprofile ,fname)))
(defimplementation unprofile-all ()
(eval `(profile:unprofile))
"All functions unprofiled.")
(defimplementation profile-report ()
(eval `(profile:report-time)))
(defimplementation profile-reset ()
(eval `(profile:reset-time))
"Reset profiling counters.")
(defimplementation profiled-functions ()
profile:*timed-functions*)
(defimplementation profile-package (package callers methods)
(profile:profile-all :package package
:callers-p callers
#+nil :methods #+nil methods))
;;;; Multiprocessing
(defimplementation spawn (fn &key name)
(thread:thread-create fn :name (or name "Anonymous")))
(defvar *thread-id-counter* 0)
(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter"))
(defimplementation thread-id (thread)
(thread:with-lock-held (*thread-id-counter-lock*)
(or (getf (thread:thread-plist thread) 'id)
(setf (getf (thread:thread-plist thread) 'id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(block find-thread
(thread:map-over-threads
#'(lambda (thread)
(when (eql (getf (thread:thread-plist thread) 'id) id)
(return-from find-thread thread))))))
(defimplementation thread-name (thread)
(princ-to-string (thread:thread-name thread)))
(defimplementation thread-status (thread)
(let ((dynamic-values (thread::thread-dynamic-values thread)))
(if (zerop dynamic-values) "Exited" "Running")))
(defimplementation make-lock (&key name)
(thread:make-lock name))
(defimplementation call-with-lock-held (lock function)
(declare (type function function))
(thread:with-lock-held (lock) (funcall function)))
(defimplementation current-thread ()
thread:*thread*)
(defimplementation all-threads ()
(let ((all-threads nil))
(thread:map-over-threads #'(lambda (thread) (push thread all-threads)))
all-threads))
(defimplementation interrupt-thread (thread fn)
(thread:thread-interrupt thread #'(lambda ()
(sys:with-interrupts
(funcall fn)))))
(defimplementation kill-thread (thread)
(thread:destroy-thread thread))
(defimplementation thread-alive-p (thread)
(not (zerop (thread::thread-dynamic-values thread))))
(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil))
(defstruct (mailbox)
(lock (thread:make-lock "Thread mailbox" :type :error-check
:interruptible nil)
:type thread:error-check-lock)
(queue '() :type list))
(defun mailbox (thread)
"Return 'thread's mailbox."
(sys:without-interrupts
(thread:with-lock-held (*mailbox-lock*)
(or (getf (thread:thread-plist thread) 'mailbox)
(setf (getf (thread:thread-plist thread) 'mailbox)
(make-mailbox))))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(lock (mailbox-lock mbox)))
(sys:without-interrupts
(thread:with-lock-held (lock "Mailbox Send")
(setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
(list message)))))
(mp:process-wakeup thread)))
#+nil
(defimplementation receive ()
(receive-if (constantly t)))
(defimplementation receive-if (test &optional timeout)
(let ((mbox (mailbox thread:*thread*)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(sys:without-interrupts
(mp:with-lock-held ((mailbox-lock mbox))
(let* ((q (mailbox-queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox-queue mbox)
(nconc (ldiff q tail) (cdr tail)))
(return (car tail))))))
(when (eq timeout t) (return (values nil t)))
(mp:process-wait-with-timeout
"Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
(defimplementation emacs-connected ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Trace implementations
;; In SCL, we have:
;; (trace <name>)
;; (trace (method <name> <qualifier>? (<specializer>+)))
;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
;; <name> can be a normal name or a (setf name)
(defun tracedp (spec)
(member spec (eval '(trace)) :test #'equal))
(defun toggle-trace-aux (spec &rest options)
(cond ((tracedp spec)
(eval `(untrace ,spec))
(format nil "~S is now untraced." spec))
(t
(eval `(trace ,spec ,@options))
(format nil "~S is now traced." spec))))
(defimplementation toggle-trace (spec)
(ecase (car spec)
((setf)
(toggle-trace-aux spec))
((:defgeneric)
(let ((name (second spec)))
(toggle-trace-aux name :methods name)))
((:defmethod)
nil)
((:call)
(destructuring-bind (caller callee) (cdr spec)
(toggle-trace-aux (process-fspec callee)
:wherein (list (process-fspec caller)))))))
(defun process-fspec (fspec)
(cond ((consp fspec)
(ecase (first fspec)
((:defun :defgeneric) (second fspec))
((:defmethod)
`(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
;; this isn't actually supported
((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
(t
fspec)))
;;; Weak datastructures
;;; Not implemented in SCL.
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak-p t args))
;;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; slynk-sbcl.lisp --- SLY backend for SBCL.
;;;
;;; Created 2003, Daniel Barlow <dan@metacircles.com>
;;;
;;; This code has been placed in the Public Domain. All warranties are
;;; disclaimed.
;;; Requires the SB-INTROSPECT contrib.
;;; Administrivia
(defpackage slynk-sbcl
(:use cl slynk-backend slynk-source-path-parser slynk-source-file-cache)
(:export
#:with-sbcl-version>=))
(in-package slynk-sbcl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-bsd-sockets)
(require 'sb-introspect)
(require 'sb-posix)
(require 'sb-cltl2))
(declaim (optimize (debug 2)
(sb-c::insert-step-conditions 0)
(sb-c::insert-debug-catch 0)))
;;; backwards compability tests
(eval-when (:compile-toplevel :load-toplevel :execute)
;; Generate a form suitable for testing for stepper support (0.9.17)
;; with #+.
(defun sbcl-with-new-stepper-p ()
(with-symbol 'enable-stepping 'sb-impl))
;; Ditto for weak hash-tables
(defun sbcl-with-weak-hash-tables ()
(with-symbol 'hash-table-weakness 'sb-ext))
;; And for xref support (1.0.1)
(defun sbcl-with-xref-p ()
(with-symbol 'who-calls 'sb-introspect))
;; ... for restart-frame support (1.0.2)
(defun sbcl-with-restart-frame ()
(with-symbol 'frame-has-debug-tag-p 'sb-debug))
;; ... for :setf :inverse info (1.1.17)
(defun sbcl-with-setf-inverse-meta-info ()
(boolean-to-feature-expression
;; going through FIND-SYMBOL since META-INFO was renamed from
;; TYPE-INFO in 1.2.10.
(let ((sym (find-symbol "META-INFO" "SB-C")))
(and sym
(fboundp sym)
(funcall sym :setf :inverse ()))))))
;;; slynk-mop
(import-slynk-mop-symbols :sb-mop '(:slot-definition-documentation))
(defun slynk-mop:slot-definition-documentation (slot)
(sb-pcl::documentation slot t))
;; stream support
(defimplementation gray-package-name ()
"SB-GRAY")
;; Pretty printer calls this, apparently
(defmethod sb-gray:stream-line-length
((s sb-gray:fundamental-character-input-stream))
nil)
;;; Connection info
(defimplementation lisp-implementation-type-name ()
"sbcl")
;; Declare return type explicitly to shut up STYLE-WARNINGS about
;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
(defimplementation getpid ()
(sb-posix:getpid))
;;; UTF8
(defimplementation string-to-utf8 (string)
(sb-ext:string-to-octets string :external-format '(:utf8 :replacement
#+sb-unicode #\Replacement_Character
#-sb-unicode #\? )))
(defimplementation utf8-to-string (octets)
(sb-ext:octets-to-string octets :external-format '(:utf8 :replacement
#+sb-unicode #\Replacement_Character
#-sb-unicode #\? )))
;;; TCP Server
(defimplementation preferred-communication-style ()
(cond
;; fixme: when SBCL/win32 gains better select() support, remove
;; this.
((member :sb-thread *features*) :spawn)
((member :win32 *features*) nil)
(t :fd-handler)))
(defun resolve-hostname (host)
"Returns valid IPv4 or IPv6 address for the host."
;; get all IPv4 and IPv6 addresses as a list
(let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
;; remove protocols for which we don't have an address
(addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
;; Return the first one or nil,
;; but actually, it shouln't return nil, because
;; get-host-by-name will signal NAME-SERVICE-ERROR condition
;; if there isn't any address for the host.
(first addresses)))
(defimplementation create-socket (host port &key backlog)
(let* ((host-ent (resolve-hostname host))
(socket (make-instance (cond #+#.(slynk-backend:with-symbol 'inet6-socket 'sb-bsd-sockets)
((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10)
'sb-bsd-sockets:inet6-socket)
(t
'sb-bsd-sockets:inet-socket))
:type :stream
:protocol :tcp)))
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
(sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port)
(sb-bsd-sockets:socket-listen socket (or backlog 5))
socket))
(defimplementation local-port (socket)
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
(defimplementation close-socket (socket)
(sb-sys:invalidate-descriptor (socket-fd socket))
(sb-bsd-sockets:socket-close socket))
(defimplementation accept-connection (socket &key
external-format
buffering timeout)
(declare (ignore timeout))
(make-socket-io-stream (accept socket) external-format
(ecase buffering
((t :full) :full)
((nil :none) :none)
((:line) :line))))
;; The SIGIO stuff should probably be removed as it's unlikey that
;; anybody uses it.
#-win32
(progn
(defimplementation install-sigint-handler (function)
(sb-sys:enable-interrupt sb-unix:sigint
(lambda (&rest args)
(declare (ignore args))
(sb-sys:invoke-interruption
(lambda ()
(sb-sys:with-interrupts
(funcall function)))))))
(defvar *sigio-handlers* '()
"List of (key . fn) pairs to be called on SIGIO.")
(defun sigio-handler (signal code scp)
(declare (ignore signal code scp))
(sb-sys:with-interrupts
(mapc (lambda (handler)
(funcall (the function (cdr handler))))
*sigio-handlers*)))
(defun set-sigio-handler ()
(sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler))
(defun enable-sigio-on-fd (fd)
(sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
(sb-posix::fcntl fd sb-posix::f-setown (getpid))
(values))
(defimplementation add-sigio-handler (socket fn)
(set-sigio-handler)
(let ((fd (socket-fd socket)))
(enable-sigio-on-fd fd)
(push (cons fd fn) *sigio-handlers*)))
(defimplementation remove-sigio-handlers (socket)
(let ((fd (socket-fd socket)))
(setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
(sb-sys:invalidate-descriptor fd))
(close socket)))
(defimplementation add-fd-handler (socket fun)
(let ((fd (socket-fd socket))
(handler nil))
(labels ((add ()
(setq handler (sb-sys:add-fd-handler fd :input #'run)))
(run (fd)
(sb-sys:remove-fd-handler handler) ; prevent recursion
(unwind-protect
(funcall fun)
(when (sb-unix:unix-fstat fd) ; still open?
(add)))))
(add))))
(defimplementation remove-fd-handlers (socket)
(sb-sys:invalidate-descriptor (socket-fd socket)))
(defimplementation socket-fd (socket)
(etypecase socket
(fixnum socket)
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
(file-stream (sb-sys:fd-stream-fd socket))))
(defimplementation command-line-args ()
sb-ext:*posix-argv*)
(defimplementation dup (fd)
(sb-posix:dup fd))
(defvar *wait-for-input-called*)
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(when (boundp '*wait-for-input-called*)
(setq *wait-for-input-called* t))
(let ((*wait-for-input-called* nil))
(loop
(let ((ready (remove-if-not #'input-ready-p streams)))
(when ready (return ready)))
(when (check-sly-interrupts)
(return :interrupt))
(when *wait-for-input-called*
(return :interrupt))
(when timeout
(return nil))
(sleep 0.1))))
(defun fd-stream-input-buffer-empty-p (stream)
(let ((buffer (sb-impl::fd-stream-ibuf stream)))
(or (not buffer)
(= (sb-impl::buffer-head buffer)
(sb-impl::buffer-tail buffer)))))
#-win32
(defun input-ready-p (stream)
(or (not (fd-stream-input-buffer-empty-p stream))
#+#.(slynk-backend:with-symbol 'fd-stream-fd-type 'sb-impl)
(eq :regular (sb-impl::fd-stream-fd-type stream))
(not (sb-impl::sysread-may-block-p stream))))
#+win32
(progn
(defun input-ready-p (stream)
(or (not (fd-stream-input-buffer-empty-p stream))
(handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
(sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
sb-win32:handle)
(sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
sb-alien:int
(event sb-win32:handle))
(defconstant +fd-read+ #.(ash 1 0))
(defconstant +fd-close+ #.(ash 1 5))
(sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
sb-alien:int
(fd sb-alien:int)
(handle sb-win32:handle)
(mask sb-alien:long))
(sb-alien:load-shared-object "kernel32.dll")
(sb-alien:define-alien-routine ("WaitForSingleObjectEx"
wait-for-single-object-ex)
sb-alien:int
(event sb-win32:handle)
(milliseconds sb-alien:long)
(alertable sb-alien:int))
;; see SB-WIN32:HANDLE-LISTEN
(defun handle-listen (handle)
(sb-alien:with-alien ((avail sb-win32:dword)
(buf (array char #.sb-win32::input-record-size)))
(unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
(sb-alien:alien-sap
(sb-alien:addr avail))
nil))
(return-from handle-listen (plusp avail)))
(unless (zerop (sb-win32:peek-console-input handle
(sb-alien:alien-sap buf)
sb-win32::input-record-size
(sb-alien:alien-sap
(sb-alien:addr avail))))
(return-from handle-listen (plusp avail))))
(let ((event (wsa-create-event)))
(wsa-event-select handle event (logior +fd-read+ +fd-close+))
(let ((val (wait-for-single-object-ex event 0 0)))
(wsa-close-event event)
(unless (= val -1)
(return-from handle-listen (zerop val)))))
nil)
)
(defvar *external-format-to-coding-system*
'((:iso-8859-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")
(:euc-jp "euc-jp" "euc-jp-unix")
(:us-ascii "us-ascii" "us-ascii-unix")))
;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general,
;; 2008-08-22.
(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
(defimplementation filename-to-pathname (filename)
(sb-ext:parse-native-namestring filename *physical-pathname-host*))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
(defimplementation set-default-directory (directory)
(let ((directory (truename (merge-pathnames directory))))
(sb-posix:chdir directory)
(setf *default-pathname-defaults* directory)
(default-directory)))
(defun make-socket-io-stream (socket external-format buffering)
(let ((args `(:output t
:input t
:element-type ,(if external-format
'character
'(unsigned-byte 8))
:buffering ,buffering
,@(cond ((and external-format (sb-int:featurep :sb-unicode))
`(:external-format ,external-format))
(t '()))
:serve-events ,(eq :fd-handler
(slynk-value '*communication-style* t))
;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
;; argument.
:allow-other-keys t)))
(apply #'sb-bsd-sockets:socket-make-stream socket args)))
(defun accept (socket)
"Like socket-accept, but retry on EAGAIN."
(loop (handler-case
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
;;;; Support for SBCL syntax
;;; SBCL's source code is riddled with #! reader macros. Also symbols
;;; containing `!' have special meaning. We have to work long and
;;; hard to be able to read the source. To deal with #! reader
;;; macros, we use a special readtable. The special symbols are
;;; converted by a condition handler.
(defun feature-in-list-p (feature list)
(etypecase feature
(symbol (member feature list :test #'eq))
(cons (flet ((subfeature-in-list-p (subfeature)
(feature-in-list-p subfeature list)))
;; Don't use ECASE since SBCL also has :host-feature,
;; don't need to handle it or anything else appearing in
;; the future or in erronous code.
(case (first feature)
(:or (some #'subfeature-in-list-p (rest feature)))
(:and (every #'subfeature-in-list-p (rest feature)))
(:not (destructuring-bind (e) (cdr feature)
(not (subfeature-in-list-p e)))))))))
(defun shebang-reader (stream sub-character infix-parameter)
(declare (ignore sub-character))
(when infix-parameter
(error "illegal read syntax: #~D!" infix-parameter))
(let ((next-char (read-char stream)))
(unless (find next-char "+-")
(error "illegal read syntax: #!~C" next-char))
;; When test is not satisfied
;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
;; would become "unless test is satisfied"..
(when (let* ((*package* (find-package "KEYWORD"))
(*read-suppress* nil)
(not-p (char= next-char #\-))
(feature (read stream)))
(if (feature-in-list-p feature *features*)
not-p
(not not-p)))
;; Read (and discard) a form from input.
(let ((*read-suppress* t))
(read stream t nil t))))
(values))
(defvar *shebang-readtable*
(let ((*readtable* (copy-readtable nil)))
(set-dispatch-macro-character #\# #\!
(lambda (s c n) (shebang-reader s c n))
*readtable*)
*readtable*))
(defun shebang-readtable ()
*shebang-readtable*)
(defun sbcl-package-p (package)
(let ((name (package-name package)))
(eql (mismatch "SB-" name) 3)))
(defun sbcl-source-file-p (filename)
(when filename
(loop for (nil pattern) in (logical-pathname-translations "SYS")
thereis (pathname-match-p filename pattern))))
(defun guess-readtable-for-filename (filename)
(if (sbcl-source-file-p filename)
(shebang-readtable)
*readtable*))
(defvar *debootstrap-packages* t)
(defun call-with-debootstrapping (fun)
(handler-bind ((sb-int:bootstrap-package-not-found
#'sb-int:debootstrap-package))
(funcall fun)))
(defmacro with-debootstrapping (&body body)
`(call-with-debootstrapping (lambda () ,@body)))
(defimplementation call-with-syntax-hooks (fn)
(cond ((and *debootstrap-packages*
(sbcl-package-p *package*))
(with-debootstrapping (funcall fn)))
(t
(funcall fn))))
(defimplementation default-readtable-alist ()
(let ((readtable (shebang-readtable)))
(loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
collect (cons (package-name p) readtable))))
;;; Packages
#+#.(slynk-backend:with-symbol 'package-local-nicknames 'sb-ext)
(defimplementation package-local-nicknames (package)
(sb-ext:package-local-nicknames package))
;;; Utilities
(defun slynk-value (name &optional errorp)
;; Easy way to refer to symbol values in SLYNK, which doesn't yet exist when
;; this is file is loaded.
(let ((symbol (find-symbol (string name) :slynk)))
(if (and symbol (or errorp (boundp symbol)))
(symbol-value symbol)
(when errorp
(error "~S does not exist in SLYNK." name)))))
(defun sbcl-version>= (&rest subversions)
#+#.(slynk-backend:with-symbol 'assert-version->= 'sb-ext)
(values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t))
#-#.(slynk-backend:with-symbol 'assert-version->= 'sb-ext)
nil)
(defmacro with-sbcl-version>= (&rest subversions)
`(if (sbcl-version>= ,@subversions)
'(:and) '(:or)))
#+#.(slynk-backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
(sb-introspect:function-lambda-list fname))
#-#.(slynk-backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
(sb-introspect:function-arglist fname))
(defimplementation function-name (f)
(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)))))
#+#.(slynk-backend:with-symbol 'deftype-lambda-list 'sb-introspect)
(defmethod type-specifier-arglist :around (typespec-operator)
(multiple-value-bind (arglist foundp)
(sb-introspect:deftype-lambda-list typespec-operator)
(if foundp arglist (call-next-method))))
(defimplementation type-specifier-p (symbol)
(or (sb-ext:valid-type-specifier-p symbol)
(not (eq (type-specifier-arglist symbol) :not-available))))
(defvar *buffer-name* nil)
(defvar *buffer-tmpfile* nil)
(defvar *buffer-offset*)
(defvar *buffer-substring* nil)
(defvar *previous-compiler-condition* nil
"Used to detect duplicates.")
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning.
This traps all compiler conditions at a lower-level than using
C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
craft our own error messages, which can omit a lot of redundant
information."
(unless (or (eq condition *previous-compiler-condition*))
;; First resignal warnings, so that outer handlers -- which may choose to
;; muffle this -- get a chance to run.
(when (typep condition 'warning)
(signal condition))
(setq *previous-compiler-condition* condition)
(signal-compiler-condition (real-condition condition)
(sb-c::find-error-context nil))))
(defun signal-compiler-condition (condition context)
(signal 'compiler-condition
:original-condition condition
:severity (etypecase condition
(sb-ext:compiler-note :note)
(sb-c:compiler-error :error)
(reader-error :read-error)
(error :error)
#+#.(slynk-backend:with-symbol early-deprecation-warning sb-ext)
(sb-ext::early-deprecation-warning :early-deprecation-warning)
#+#.(slynk-backend:with-symbol late-deprecation-warning sb-ext)
(sb-ext::late-deprecation-warning :late-deprecation-warning)
#+#.(slynk-backend:with-symbol final-deprecation-warning sb-ext)
(sb-ext::final-deprecation-warning :final-deprecation-warning)
#+#.(slynk-backend:with-symbol redefinition-warning
sb-kernel)
(sb-kernel:redefinition-warning
:redefinition)
(style-warning :style-warning)
(warning :warning))
:references (condition-references condition)
:message (brief-compiler-message-for-emacs condition)
:source-context (compiler-error-context context)
:location (compiler-note-location condition context)))
(defun real-condition (condition)
"Return the encapsulated condition or CONDITION itself."
(typecase condition
(sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
(t condition)))
(defun condition-references (condition)
(if (typep condition 'sb-int:reference-condition)
(externalize-reference
(sb-int:reference-condition-references condition))))
(defun compiler-note-location (condition context)
(flet ((bailout ()
(return-from compiler-note-location
(make-error-location "No error location available"))))
(cond (context
(locate-compiler-note
(sb-c::compiler-error-context-file-name context)
(compiler-source-path context)
(sb-c::compiler-error-context-original-source context)))
((typep condition 'reader-error)
(let* ((stream (stream-error-stream condition))
;; If STREAM is, for example, a STRING-INPUT-STREAM,
;; an error will be signaled since PATHNAME only
;; accepts a "stream associated with a file" which
;; is a complicated predicate and hard to test
;; portably.
(file (ignore-errors (pathname stream))))
(unless (and file (open-stream-p stream))
(bailout))
(if (compiling-from-buffer-p file)
;; The stream position for e.g. "comma not inside
;; backquote" is at the character following the
;; comma, :offset is 0-based, hence the 1-.
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-offset*
(1- (file-position stream))))
(progn
(assert (compiling-from-file-p file))
;; No 1- because :position is 1-based.
(make-location (list :file (namestring file))
(list :position (file-position stream)))))))
(t (bailout)))))
(defun compiling-from-buffer-p (filename)
(and *buffer-name*
;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
;; in LOCATE-COMPILER-NOTE, and allows handling nested
;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
;;
;; PROBE-FILE to handle tempfile directory being a symlink.
(pathnamep filename)
(let ((true1 (probe-file filename))
(true2 (probe-file *buffer-tmpfile*)))
(and true1 (equal true1 true2)))))
(defun compiling-from-file-p (filename)
(and (pathnamep filename)
(or (null *buffer-name*)
(null *buffer-tmpfile*)
(let ((true1 (probe-file filename))
(true2 (probe-file *buffer-tmpfile*)))
(not (and true1 (equal true1 true2)))))))
(defun compiling-from-generated-code-p (filename source)
(and (eq filename :lisp) (stringp source)))
(defun locate-compiler-note (file source-path source)
(cond ((compiling-from-buffer-p file)
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-offset*
(source-path-string-position
source-path *buffer-substring*))))
((compiling-from-file-p file)
(let ((position (source-path-file-position source-path file)))
(make-location (list :file (namestring file))
(list :position (and position
(1+ position))))))
((compiling-from-generated-code-p file source)
(make-location (list :source-form source)
(list :position 1)))
(t
(error "unhandled case in compiler note ~S ~S ~S"
file source-path source))))
(defun brief-compiler-message-for-emacs (condition)
"Briefly describe a compiler error for Emacs.
When Emacs presents the message it already has the source popped up
and the source form highlighted. This makes much of the information in
the error-context redundant."
(let ((sb-int:*print-condition-references* nil))
(princ-to-string condition)))
(defun compiler-error-context (error-context)
"Describe a compiler error for Emacs including context information."
(declare (type (or sb-c::compiler-error-context null) error-context))
(multiple-value-bind (enclosing source)
(if error-context
(values (sb-c::compiler-error-context-enclosing-source error-context)
(sb-c::compiler-error-context-source error-context)))
(and (or enclosing source)
(format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
enclosing source))))
(defun compiler-source-path (context)
"Return the source-path for the current compiler error.
Returns NIL if this cannot be determined by examining internal
compiler state."
(cond ((sb-c::node-p context)
(reverse
(sb-c::source-path-original-source
(sb-c::node-source-path context))))
((sb-c::compiler-error-context-p context)
(reverse
(sb-c::compiler-error-context-original-source-path context)))))
(defimplementation call-with-compilation-hooks (function)
(declare (type function function))
(handler-bind
;; N.B. Even though these handlers are called HANDLE-FOO they
;; actually decline, i.e. the signalling of the original
;; condition continues upward.
((sb-c:fatal-compiler-error #'handle-notification-condition)
(sb-c:compiler-error #'handle-notification-condition)
(sb-ext:compiler-note #'handle-notification-condition)
(error #'handle-notification-condition)
(warning #'handle-notification-condition))
(funcall function)))
;;; HACK: SBCL 1.2.12 shipped with a bug where
;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there
;;; were no policy restrictions in place. This workaround ensures the
;;; existence of at least one dummy restriction.
(handler-case (sb-ext:restrict-compiler-policy)
(error () (sb-ext:restrict-compiler-policy 'debug)))
(defun compiler-policy (qualities)
"Return compiler policy qualities present in the QUALITIES alist.
QUALITIES is an alist with (quality . value)"
#+#.(slynk-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
(loop with policy = (sb-ext:restrict-compiler-policy)
for (quality) in qualities
collect (cons quality
(or (cdr (assoc quality policy))
0))))
(defun (setf compiler-policy) (policy)
(declare (ignorable policy))
#+#.(slynk-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
(loop for (qual . value) in policy
do (sb-ext:restrict-compiler-policy qual value)))
(defmacro with-compiler-policy (policy &body body)
(let ((current-policy (gensym)))
`(let ((,current-policy (compiler-policy ,policy)))
(setf (compiler-policy) ,policy)
(unwind-protect (progn ,@body)
(setf (compiler-policy) ,current-policy)))))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(multiple-value-bind (output-file warnings-p failure-p)
(with-compiler-policy policy
(with-compilation-hooks ()
(compile-file input-file :output-file output-file
:external-format external-format)))
(values output-file warnings-p
(or failure-p
(when load-p
;; Cache the latest source file for definition-finding.
(source-cache-get input-file
(file-write-date input-file))
(not (load output-file)))))))
;;;; compile-string
;;; We copy the string to a temporary file in order to get adequate
;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
;;; which the previous approach using
;;; (compile nil `(lambda () ,(read-from-string string)))
;;; did not provide.
(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
sb-alien:c-string
(dir sb-alien:c-string)
(prefix sb-alien:c-string)))
(defun temp-file-name ()
"Return a temporary file name to compile strings into."
(tempnam nil "slime"))
(defvar *trap-load-time-warnings* t)
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore line column))
(let ((*buffer-name* buffer)
(*buffer-offset* position)
(*buffer-substring* string)
(*buffer-tmpfile* (temp-file-name)))
(labels ((load-it (filename)
(cond (*trap-load-time-warnings*
(with-compilation-hooks () (load filename)))
(t (load filename))))
(cf ()
(with-compiler-policy policy
(with-compilation-unit
(:source-plist (list :emacs-buffer buffer
:emacs-filename filename
:emacs-package (package-name *package*)
:emacs-position position
:emacs-string string)
:source-namestring filename
:allow-other-keys t)
(compile-file *buffer-tmpfile* :external-format :utf-8)))))
(with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
:external-format :utf-8)
(write-string string s))
(unwind-protect
(multiple-value-bind (output-file warningsp failurep)
(with-compilation-hooks () (cf))
(declare (ignore warningsp))
(when output-file
(load-it output-file))
(not failurep))
(ignore-errors
(delete-file *buffer-tmpfile*)
(delete-file (compile-file-pathname *buffer-tmpfile*)))))))
;;;; Definitions
(defparameter *definition-types*
'(:variable defvar
:constant defconstant
:type deftype
:symbol-macro define-symbol-macro
:macro defmacro
:compiler-macro define-compiler-macro
:function defun
:generic-function defgeneric
:method defmethod
:setf-expander define-setf-expander
:structure defstruct
:condition define-condition
:class defclass
:method-combination define-method-combination
:package defpackage
:transform :deftransform
:optimizer :defoptimizer
:vop :define-vop
:source-transform :define-source-transform
:ir1-convert :def-ir1-translator
:declaration declaim
:alien-type :define-alien-type)
"Map SB-INTROSPECT definition type names to SLY-friendly forms")
(defun definition-specifier (type)
"Return a pretty specifier for NAME representing a definition of type TYPE."
(getf *definition-types* type))
(defun make-dspec (type name source-location)
(list* (definition-specifier type)
name
(sb-introspect::definition-source-description source-location)))
(defimplementation find-definitions (name)
(loop for type in *definition-types* by #'cddr
for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
for filtered-defsrcs = (if (eq type :generic-function)
(remove :invalid defsrcs
:key #'categorize-definition-source)
defsrcs)
append (loop for defsrc in filtered-defsrcs collect
(list (make-dspec type name defsrc)
(converting-errors-to-error-location
(definition-source-for-emacs defsrc
type name))))))
(defimplementation find-source-location (obj)
(flet ((general-type-of (obj)
(typecase obj
(method :method)
(generic-function :generic-function)
(function :function)
(structure-class :structure-class)
(class :class)
(method-combination :method-combination)
(package :package)
(condition :condition)
(structure-object :structure-object)
(standard-object :standard-object)
(t :thing)))
(to-string (obj)
(typecase obj
;; Packages are possibly named entities.
(package (princ-to-string obj))
((or structure-object standard-object condition)
(with-output-to-string (s)
(print-unreadable-object (obj s :type t :identity t))))
(t (princ-to-string obj)))))
(converting-errors-to-error-location
(let ((defsrc (sb-introspect:find-definition-source obj)))
(definition-source-for-emacs defsrc
(general-type-of obj)
(to-string obj))))))
(defmacro with-definition-source ((&rest names) obj &body body)
"Like with-slots but works only for structs."
(flet ((reader (slot)
;; Use read-from-string instead of intern so that
;; conc-name can be a string such as ext:struct- and not
;; cause errors and not force interning ext::struct-
(read-from-string
(concatenate 'string "sb-introspect:definition-source-"
(string slot)))))
(let ((tmp (gensym "OO-")))
` (let ((,tmp ,obj))
(symbol-macrolet
,(loop for name in names collect
(typecase name
(symbol `(,name (,(reader name) ,tmp)))
(cons `(,(first name) (,(reader (second name)) ,tmp)))
(t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
,@body)))))
(defun categorize-definition-source (definition-source)
(with-definition-source (pathname form-path character-offset plist)
definition-source
(let ((file-p (and pathname (probe-file pathname)
(or form-path character-offset))))
(cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
((getf plist :emacs-buffer) :buffer)
(file-p :file)
(pathname :file-without-position)
(t :invalid)))))
#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun form-number-position (definition-source stream)
(let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source)))
(form-number (sb-introspect:definition-source-form-number definition-source)))
(multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
(let* ((path-table (sb-di::form-number-translations tlf 0))
(path (cond ((<= (length path-table) form-number)
(warn "inconsistent form-number-translations")
(list 0))
(t
(reverse (cdr (aref path-table form-number)))))))
(source-path-source-position path tlf pos-map)))))
#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun file-form-number-position (definition-source)
(let* ((code-date (sb-introspect:definition-source-file-write-date definition-source))
(filename (sb-introspect:definition-source-pathname definition-source))
(*readtable* (guess-readtable-for-filename filename))
(source-code (get-source-code filename code-date)))
(with-debootstrapping
(with-input-from-string (s source-code)
(form-number-position definition-source s)))))
#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun string-form-number-position (definition-source string)
(with-input-from-string (s string)
(form-number-position definition-source s)))
(defun definition-source-buffer-location (definition-source)
(with-definition-source (form-path character-offset plist) definition-source
(destructuring-bind (&key emacs-buffer emacs-position emacs-directory
emacs-string &allow-other-keys)
plist
(let ((*readtable* (guess-readtable-for-filename emacs-directory))
start
end)
(with-debootstrapping
(or
(and form-path
(or
#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect)
(setf (values start end)
(and (sb-introspect:definition-source-form-number definition-source)
(string-form-number-position definition-source emacs-string)))
(setf (values start end)
(source-path-string-position form-path emacs-string))))
(setf start character-offset
end most-positive-fixnum)))
(make-location
`(:buffer ,emacs-buffer)
`(:offset ,emacs-position ,start)
`(:snippet
,(subseq emacs-string
start
(min end (+ start *source-snippet-size*)))))))))
(defun definition-source-file-location (definition-source)
(with-definition-source (pathname form-path character-offset plist
file-write-date) definition-source
(let* ((namestring (namestring (translate-logical-pathname pathname)))
(pos (or (and form-path
(or
#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect)
(and (sb-introspect:definition-source-form-number definition-source)
(ignore-errors (file-form-number-position definition-source)))
(ignore-errors
(source-file-position namestring file-write-date
form-path))))
character-offset))
(snippet (source-hint-snippet namestring file-write-date pos)))
(make-location `(:file ,namestring)
;; /file positions/ in Common Lisp start from
;; 0, buffer positions in Emacs start from 1.
`(:position ,(1+ pos))
`(:snippet ,snippet)))))
(defun definition-source-buffer-and-file-location (definition-source)
(let ((buffer (definition-source-buffer-location definition-source))
(file (definition-source-file-location definition-source)))
(make-location (list :buffer-and-file
(cadr (location-buffer buffer))
(cadr (location-buffer file)))
(location-position buffer)
(location-hints buffer))))
(defun definition-source-for-emacs (definition-source type name)
(with-definition-source (pathname form-path character-offset plist
file-write-date)
definition-source
(ecase (categorize-definition-source definition-source)
(:buffer-and-file
(definition-source-buffer-and-file-location definition-source))
(:buffer
(definition-source-buffer-location definition-source))
(:file
(definition-source-file-location definition-source))
(:file-without-position
(make-location `(:file ,(namestring
(translate-logical-pathname pathname)))
'(:position 1)
(when (eql type :function)
`(:snippet ,(format nil "(defun ~a "
(symbol-name name))))))
(:invalid
(error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
meaningful information."
type name)))))
(defun source-file-position (filename write-date form-path)
(let ((source (get-source-code filename write-date))
(*readtable* (guess-readtable-for-filename filename)))
(with-debootstrapping
(source-path-string-position form-path source))))
(defun source-hint-snippet (filename write-date position)
(read-snippet-from-string (get-source-code filename write-date) position))
(defun function-source-location (function &optional name)
(declare (type function function))
(definition-source-for-emacs (sb-introspect:find-definition-source function)
:function
(or name (function-name function))))
(defun setf-expander (symbol)
(or
#+#.(slynk-sbcl::sbcl-with-setf-inverse-meta-info)
(sb-int:info :setf :inverse symbol)
(sb-int:info :setf :expander symbol)))
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result '()))
(flet ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (multiple-value-bind (kind recorded-p)
(sb-int:info :variable :kind symbol)
(declare (ignore kind))
(if (or (boundp symbol) recorded-p)
(doc 'variable))))
(when (fboundp symbol)
(maybe-push
(cond ((macro-function symbol) :macro)
((special-operator-p symbol) :special-operator)
((typep (fdefinition symbol) 'generic-function)
:generic-function)
(t :function))
(doc 'function)))
(maybe-push
:setf (and (setf-expander symbol)
(doc 'setf)))
(maybe-push
:type (if (sb-int:info :type :kind symbol)
(doc 'type)))
result)))
(defimplementation describe-definition (symbol type)
(case type
(:variable
(describe symbol))
(:function
(describe (symbol-function symbol)))
(:setf
(describe (setf-expander symbol)))
(:class
(describe (find-class symbol)))
(:type
(describe (sb-kernel:values-specifier-type symbol)))))
#+#.(slynk-sbcl::sbcl-with-xref-p)
(progn
(defmacro defxref (name &optional fn-name)
`(defimplementation ,name (what)
(sanitize-xrefs
(mapcar #'source-location-for-xref-data
(,(find-symbol (symbol-name (if fn-name
fn-name
name))
"SB-INTROSPECT")
what)))))
(defxref who-calls)
(defxref who-binds)
(defxref who-sets)
(defxref who-references)
(defxref who-macroexpands)
#+#.(slynk-backend:with-symbol 'who-specializes-directly 'sb-introspect)
(defxref who-specializes who-specializes-directly))
(defun source-location-for-xref-data (xref-data)
(destructuring-bind (name . defsrc) xref-data
(list name (converting-errors-to-error-location
(definition-source-for-emacs defsrc 'function name)))))
(defimplementation list-callers (symbol)
(let ((fn (fdefinition symbol)))
(sanitize-xrefs
(mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
(defimplementation list-callees (symbol)
(let ((fn (fdefinition symbol)))
(sanitize-xrefs
(mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
(defun sanitize-xrefs (xrefs)
(remove-duplicates
(remove-if (lambda (f)
(member f (ignored-xref-function-names)))
(loop for entry in xrefs
for name = (car entry)
collect (if (and (consp name)
(member (car name)
'(sb-pcl::fast-method
sb-pcl::slow-method
sb-pcl::method)))
(cons (cons 'defmethod (cdr name))
(cdr entry))
entry))
:key #'car)
:test (lambda (a b)
(and (eq (first a) (first b))
(equal (second a) (second b))))))
(defun ignored-xref-function-names ()
#-#.(slynk-sbcl::sbcl-with-new-stepper-p)
'(nil sb-c::step-form sb-c::step-values)
#+#.(slynk-sbcl::sbcl-with-new-stepper-p)
'(nil))
(defun function-dspec (fn)
"Describe where the function FN was defined.
Return a list of the form (NAME LOCATION)."
(let ((name (function-name fn)))
(list name (converting-errors-to-error-location
(function-source-location fn name)))))
;;; macroexpansion
(defimplementation macroexpand-all (form &optional env)
(sb-cltl2:macroexpand-all form env))
;;; Debugging
;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
;;; than just a hook into BREAK. In particular, it'll make
;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLY-DB rather
;;; than the native debugger. That should probably be considered a
;;; feature.
(defun make-invoke-debugger-hook (hook)
(when hook
#'(sb-int:named-lambda slynk-invoke-debugger-hook
(condition old-hook)
(if *debugger-hook*
nil ; decline, *DEBUGGER-HOOK* will be tried next.
(funcall hook condition old-hook)))))
(defun set-break-hook (hook)
(setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(defun call-with-break-hook (hook continuation)
(let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(funcall continuation)))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(set-break-hook function))
(defimplementation condition-extras (condition)
(cond #+#.(slynk-sbcl::sbcl-with-new-stepper-p)
((typep condition 'sb-impl::step-form-condition)
`((:show-frame-source 0)))
((typep condition 'sb-int:reference-condition)
(let ((refs (sb-int:reference-condition-references condition)))
(if refs
`((:references ,(externalize-reference refs))))))))
(defun externalize-reference (ref)
(etypecase ref
(null nil)
(cons (cons (externalize-reference (car ref))
(externalize-reference (cdr ref))))
((or string number) ref)
(symbol
(cond ((eq (symbol-package ref) (symbol-package :test))
ref)
(t (symbol-name ref))))))
(defvar *sly-db-stack-top*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(let ((*sly-db-stack-top*
(if (and (not *debug-slynk-backend*)
sb-debug:*stack-top-hint*)
#+#.(slynk-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
(sb-debug::resolve-stack-top-hint)
#-#.(slynk-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
sb-debug:*stack-top-hint*
(sb-di:top-frame)))
(sb-debug:*stack-top-hint* nil))
(handler-bind ((sb-di:debug-condition
(lambda (condition)
(signal 'sly-db-condition
:original-condition condition))))
(funcall debugger-loop-fn))))
#+#.(slynk-sbcl::sbcl-with-new-stepper-p)
(progn
(defimplementation activate-stepping (frame)
(declare (ignore frame))
(sb-impl::enable-stepping))
(defimplementation sly-db-stepper-condition-p (condition)
(typep condition 'sb-ext:step-form-condition))
(defimplementation sly-db-step-into ()
(invoke-restart 'sb-ext:step-into))
(defimplementation sly-db-step-next ()
(invoke-restart 'sb-ext:step-next))
(defimplementation sly-db-step-out ()
(invoke-restart 'sb-ext:step-out)))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
#+#.(slynk-sbcl::sbcl-with-new-stepper-p)
(sb-ext:*stepper-hook*
(lambda (condition)
(typecase condition
(sb-ext:step-form-condition
(let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
(sb-impl::invoke-debugger condition)))))))
(handler-bind (#+#.(slynk-sbcl::sbcl-with-new-stepper-p)
(sb-ext:step-condition #'sb-impl::invoke-stepper))
(call-with-break-hook hook fun))))
(defun nth-frame (index)
(do ((frame *sly-db-stack-top* (sb-di:frame-down frame))
(i index (1- i)))
((zerop i) frame)))
(defimplementation compute-backtrace (start end)
"Return a list of frames starting with frame number START and
continuing to frame number END or, if END is nil, the last frame on the
stack."
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (sb-di:frame-down f)
for i from start below end
while f collect f)))
(defimplementation print-frame (frame stream)
(sb-debug::print-frame-call frame stream
:allow-other-keys t
:emergency-best-effort t))
(defimplementation frame-restartable-p (frame)
#+#.(slynk-sbcl::sbcl-with-restart-frame)
(not (null (sb-debug:frame-has-debug-tag-p frame))))
(defimplementation frame-arguments (frame)
(multiple-value-bind (name args)
(sb-debug::frame-call (nth-frame frame))
(declare (ignore name))
(values-list args)))
;;;; Code-location -> source-location translation
;;; If debug-block info is avaibale, we determine the file position of
;;; the source-path for a code-location. If the code was compiled
;;; with C-c C-c, we have to search the position in the source string.
;;; If there's no debug-block info, we return the (less precise)
;;; source-location of the corresponding function.
(defun code-location-source-location (code-location)
(let* ((dsource (sb-di:code-location-debug-source code-location))
(plist (sb-c::debug-source-plist dsource))
(package (getf plist :emacs-package))
(*package* (or (and package
(find-package package))
*package*)))
(if (getf plist :emacs-buffer)
(emacs-buffer-source-location code-location plist)
#+#.(slynk-backend:with-symbol 'debug-source-from 'sb-di)
(ecase (sb-di:debug-source-from dsource)
(:file (file-source-location code-location))
(:lisp (lisp-source-location code-location)))
#-#.(slynk-backend:with-symbol 'debug-source-from 'sb-di)
(if (sb-di:debug-source-namestring dsource)
(file-source-location code-location)
(lisp-source-location code-location)))))
;;; FIXME: The naming policy of source-location functions is a bit
;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
;;; which returns the source location for a _code-location_.
;;;
;;; Maybe these should be named code-location-file-source-location,
;;; etc, turned into generic functions, or something. In the very
;;; least the names should indicate the main entry point vs. helper
;;; status.
(defun file-source-location (code-location)
(if (code-location-has-debug-block-info-p code-location)
(source-file-source-location code-location)
(fallback-source-location code-location)))
(defun fallback-source-location (code-location)
(let ((fun (code-location-debug-fun-fun code-location)))
(cond (fun (function-source-location fun))
(t (error "Cannot find source location for: ~A " code-location)))))
(defun lisp-source-location (code-location)
(let ((source (prin1-to-string
(sb-debug::code-location-source-form code-location 100)))
(condition (slynk-value '*slynk-debugger-condition*)))
(if (and (typep condition 'sb-impl::step-form-condition)
(search "SB-IMPL::WITH-STEPPING-ENABLED" source
:test #'char-equal)
(search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
;; The initial form is utterly uninteresting -- and almost
;; certainly right there in the REPL.
(make-error-location "Stepping...")
(make-location `(:source-form ,source) '(:position 1)))))
(defun emacs-buffer-source-location (code-location plist)
(if (code-location-has-debug-block-info-p code-location)
(destructuring-bind (&key emacs-buffer emacs-position emacs-string
&allow-other-keys)
plist
(let* ((pos (string-source-position code-location emacs-string))
(snipped (read-snippet-from-string emacs-string pos)))
(make-location `(:buffer ,emacs-buffer)
`(:offset ,emacs-position ,pos)
`(:snippet ,snipped))))
(fallback-source-location code-location)))
(defun source-file-source-location (code-location)
(let* ((code-date (code-location-debug-source-created code-location))
(filename (code-location-debug-source-name code-location))
(*readtable* (guess-readtable-for-filename filename))
(source-code (get-source-code filename code-date)))
(with-debootstrapping
(with-input-from-string (s source-code)
(let* ((pos (stream-source-position code-location s))
(snippet (read-snippet s pos)))
(make-location `(:file ,filename)
`(:position ,pos)
`(:snippet ,snippet)))))))
(defun code-location-debug-source-name (code-location)
(namestring (truename (#.(slynk-backend:choose-symbol
'sb-c 'debug-source-name
'sb-c 'debug-source-namestring)
(sb-di::code-location-debug-source code-location)))))
(defun code-location-debug-source-created (code-location)
(sb-c::debug-source-created
(sb-di::code-location-debug-source code-location)))
(defun code-location-debug-fun-fun (code-location)
(sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
(defun code-location-has-debug-block-info-p (code-location)
(handler-case
(progn (sb-di:code-location-debug-block code-location)
t)
(sb-di:no-debug-blocks () nil)))
(defun stream-source-position (code-location stream)
(let* ((cloc (sb-debug::maybe-block-start-location code-location))
(tlf-number (sb-di::code-location-toplevel-form-offset cloc))
(form-number (sb-di::code-location-form-number cloc)))
(multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
(let* ((path-table (sb-di::form-number-translations tlf 0))
(path (cond ((<= (length path-table) form-number)
(warn "inconsistent form-number-translations")
(list 0))
(t
(reverse (cdr (aref path-table form-number)))))))
(source-path-source-position path tlf pos-map)))))
(defun string-source-position (code-location string)
(with-input-from-string (s string)
(stream-source-position code-location s)))
;;; source-path-file-position and friends are in slynk-source-path-parser
(defimplementation frame-source-location (index)
(converting-errors-to-error-location
(code-location-source-location
(sb-di:frame-code-location (nth-frame index)))))
(defvar *keep-non-valid-locals* nil)
(defun frame-debug-vars (frame)
"Return a vector of debug-variables in frame."
(let* ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
(loc (sb-di:frame-code-location frame))
(vars (if *keep-non-valid-locals*
all-vars
(remove-if (lambda (var)
(ecase (sb-di:debug-var-validity var loc)
(:valid nil)
((:invalid :unknown) t)))
all-vars)))
more-context
more-count)
(values (when vars
(loop for v across vars
unless
(case (debug-var-info v)
(:more-context
(setf more-context (debug-var-value v frame loc))
t)
(:more-count
(setf more-count (debug-var-value v frame loc))
t))
collect v))
more-context more-count)))
(defun debug-var-value (var frame location)
(ecase (sb-di:debug-var-validity var location)
(:valid (sb-di:debug-var-value var frame))
((:invalid :unknown) ':<not-available>)))
(defun debug-var-info (var)
;; Introduced by SBCL 1.0.49.76.
(let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
(when (and s (fboundp s))
(funcall s var))))
(defimplementation frame-locals (index)
(let* ((frame (nth-frame index))
(loc (sb-di:frame-code-location frame)))
(multiple-value-bind (vars more-context more-count)
(frame-debug-vars frame)
(let ((locals
(loop for v in vars
collect
(list :name (sb-di:debug-var-symbol v)
:id (sb-di:debug-var-id v)
:value (debug-var-value v frame loc)))))
(if (and more-context more-count)
(append locals
(list
(list :name
;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
;; specially.
(or (find-symbol "MORE" :sb-debug) 'more)
:id 0
:value (multiple-value-list
(sb-c:%more-arg-values
more-context
0 more-count)))))
locals)))))
(defimplementation frame-var-value (frame var)
(let ((frame (nth-frame frame)))
(multiple-value-bind (vars more-context more-count)
(frame-debug-vars frame)
(let* ((loc (sb-di:frame-code-location frame))
(dvar (if (= var (length vars))
;; If VAR is out of bounds, it must be the fake var
;; we made up for &MORE.
(return-from frame-var-value
(multiple-value-list (sb-c:%more-arg-values
more-context
0 more-count)))
(nth var vars))))
(debug-var-value dvar frame loc)))))
(defimplementation frame-catch-tags (index)
(mapcar #'car (sb-di:frame-catches (nth-frame index))))
(defimplementation eval-in-frame (form index)
(let ((frame (nth-frame index)))
(funcall (the function
(sb-di:preprocess-for-eval form
(sb-di:frame-code-location frame)))
frame)))
(defimplementation frame-package (frame-number)
(let* ((frame (nth-frame frame-number))
(fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
(when fun
(let ((name (function-name fun)))
(typecase name
(null nil)
(symbol (symbol-package name))
((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))
#+#.(slynk-sbcl::sbcl-with-restart-frame)
(progn
(defimplementation return-from-frame (index form)
(let* ((frame (nth-frame index)))
(cond ((sb-debug:frame-has-debug-tag-p frame)
(let ((values (multiple-value-list (eval-in-frame form index))))
(sb-debug:unwind-to-frame-and-call frame
(lambda ()
(values-list values)))))
(t (format nil "Cannot return from frame: ~S" frame)))))
(defimplementation restart-frame (index)
(let ((frame (nth-frame index)))
(when (sb-debug:frame-has-debug-tag-p frame)
(multiple-value-bind (fname args) (sb-debug::frame-call frame)
(multiple-value-bind (fun arglist)
(if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
(values (fdefinition fname) args)
(values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
(sb-debug::frame-args-as-list frame)))
(when (functionp fun)
(sb-debug:unwind-to-frame-and-call
frame
(lambda ()
;; Ensure TCO.
(declare (optimize (debug 0)))
(apply fun arglist)))))))
(format nil "Cannot restart frame: ~S" frame))))
;; FIXME: this implementation doesn't unwind the stack before
;; re-invoking the function, but it's better than no implementation at
;; all.
#-#.(slynk-sbcl::sbcl-with-restart-frame)
(progn
(defun sb-debug-catch-tag-p (tag)
(and (symbolp tag)
(not (symbol-package tag))
(string= tag :sb-debug-catch-tag)))
(defimplementation return-from-frame (index form)
(let* ((frame (nth-frame index))
(probe (assoc-if #'sb-debug-catch-tag-p
(sb-di::frame-catches frame))))
(cond (probe (throw (car probe) (eval-in-frame form index)))
(t (format nil "Cannot return from frame: ~S" frame)))))
(defimplementation restart-frame (index)
(let ((frame (nth-frame index)))
(return-from-frame index (sb-debug::frame-call-as-list frame)))))
;;;;; reference-conditions
(defimplementation print-condition (condition stream)
(let ((sb-int:*print-condition-references* nil))
(princ condition stream)))
;;;; Profiling
(defimplementation profile (fname)
(when fname (eval `(sb-profile:profile ,fname))))
(defimplementation unprofile (fname)
(when fname (eval `(sb-profile:unprofile ,fname))))
(defimplementation unprofile-all ()
(sb-profile:unprofile)
"All functions unprofiled.")
(defimplementation profile-report ()
(sb-profile:report))
(defimplementation profile-reset ()
(sb-profile:reset)
"Reset profiling counters.")
(defimplementation profiled-functions ()
(sb-profile:profile))
(defimplementation profile-package (package callers methods)
(declare (ignore callers methods))
(eval `(sb-profile:profile ,(package-name (find-package package)))))
;;;; Inspector
(defmethod emacs-inspect ((o t))
(cond ((sb-di::indirect-value-cell-p o)
(label-value-line* (:value (sb-kernel:value-cell-ref o))))
(t
(multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
(list* (string-right-trim '(#\Newline) text)
'(:newline)
(if label
(loop for (l . v) in parts
append (label-value-line l v))
(loop for value in parts
for i from 0
append (label-value-line i value))))))))
(defmethod emacs-inspect ((o function))
(cond ((sb-kernel:simple-fun-p o)
(label-value-line*
(:name (sb-kernel:%simple-fun-name o))
(:arglist (sb-kernel:%simple-fun-arglist o))
(:type (sb-kernel:%simple-fun-type o))
(:code (sb-kernel:fun-code-header o))
(:documentation (documentation o t))))
((sb-kernel:closurep o)
(append
(label-value-line :function (sb-kernel:%closure-fun o))
`("Closed over values:" (:newline))
(loop for i below (1- (sb-kernel:get-closure-length o))
append (label-value-line
i (sb-kernel:%closure-index-ref o i)))))
(t (call-next-method o))))
(defmethod emacs-inspect ((o sb-kernel:code-component))
(append
(label-value-line*
(:code-size (sb-kernel:%code-code-size o))
(:debug-info (sb-kernel:%code-debug-info o)))
`("Constants:" (:newline))
(loop for i from sb-vm:code-constants-offset
below
(#.(slynk-backend:choose-symbol 'sb-kernel 'code-header-words
'sb-kernel 'get-header-data)
o)
append (label-value-line i (sb-kernel:code-header-ref o i)))
`("Code:" (:newline)
,(with-output-to-string (s)
(sb-disassem:disassemble-code-component o :stream s)))))
(defmethod emacs-inspect ((o sb-ext:weak-pointer))
(label-value-line*
(:value (sb-ext:weak-pointer-value o))))
(defmethod emacs-inspect ((o sb-kernel:fdefn))
(label-value-line*
(:name (sb-kernel:fdefn-name o))
(:function (sb-kernel:fdefn-fun o))))
(defmethod emacs-inspect :around ((o generic-function))
(append
(call-next-method)
(label-value-line*
(:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
(:initial-methods (sb-pcl::generic-function-initial-methods o))
)))
;;;; Multiprocessing
#+(and sb-thread
#.(slynk-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
(progn
(defvar *thread-id-counter* 0)
(defvar *thread-id-counter-lock*
(sb-thread:make-mutex :name "thread id counter lock"))
(defun next-thread-id ()
(sb-thread:with-mutex (*thread-id-counter-lock*)
(incf *thread-id-counter*)))
(defvar *thread-id-map* (make-hash-table))
;; This should be a thread -> id map but as weak keys are not
;; supported it is id -> map instead.
(defvar *thread-id-map-lock*
(sb-thread:make-mutex :name "thread id map lock"))
(defimplementation spawn (fn &key name)
(sb-thread:make-thread fn :name name))
(defimplementation thread-id (thread)
(block thread-id
(sb-thread:with-mutex (*thread-id-map-lock*)
(loop for id being the hash-key in *thread-id-map*
using (hash-value thread-pointer)
do
(let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
(cond ((null maybe-thread)
;; the value is gc'd, remove it manually
(remhash id *thread-id-map*))
((eq thread maybe-thread)
(return-from thread-id id)))))
;; lazy numbering
(let ((id (next-thread-id)))
(setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
id))))
(defimplementation find-thread (id)
(sb-thread:with-mutex (*thread-id-map-lock*)
(let ((thread-pointer (gethash id *thread-id-map*)))
(if thread-pointer
(let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
(if maybe-thread
maybe-thread
;; the value is gc'd, remove it manually
(progn
(remhash id *thread-id-map*)
nil)))
nil))))
(defimplementation thread-name (thread)
;; sometimes the name is not a string (e.g. NIL)
(princ-to-string (sb-thread:thread-name thread)))
(defimplementation thread-status (thread)
(if (sb-thread:thread-alive-p thread)
"Running"
"Stopped"))
(defimplementation make-lock (&key name)
(sb-thread:make-mutex :name name))
(defimplementation call-with-lock-held (lock function)
(declare (type function function))
(sb-thread:with-recursive-lock (lock) (funcall function)))
(defimplementation current-thread ()
sb-thread:*current-thread*)
(defimplementation all-threads ()
(sb-thread:list-all-threads))
(defimplementation interrupt-thread (thread fn)
(sb-thread:interrupt-thread thread fn))
(defimplementation kill-thread (thread)
(sb-thread:terminate-thread thread))
(defimplementation thread-alive-p (thread)
(sb-thread:thread-alive-p thread))
(defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
(defvar *mailboxes* (list))
(declaim (type list *mailboxes*))
(defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (sb-thread:make-mutex))
(waitqueue (sb-thread:make-waitqueue))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(sb-thread:with-mutex (*mailbox-lock*)
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation wake-thread (thread)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(sb-thread:with-recursive-lock (mutex)
(sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(sb-thread:with-mutex (mutex)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox))
(waitq (mailbox.waitqueue mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(sb-thread:with-mutex (mutex)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail))))
(when (eq timeout t) (return (values nil t)))
(sb-thread:condition-wait waitq mutex)))))
(let ((alist '())
(mutex (sb-thread:make-mutex :name "register-thread")))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(sb-thread:with-mutex (mutex)
(etypecase thread
(null
(setf alist (delete name alist :key #'car)))
(sb-thread:thread
(let ((probe (assoc name alist)))
(cond (probe (setf (cdr probe) thread))
(t (setf alist (acons name thread alist))))))))
nil)
(defimplementation find-registered (name)
(sb-thread:with-mutex (mutex)
(cdr (assoc name alist))))))
(defimplementation quit-lisp ()
#+#.(slynk-backend:with-symbol 'exit 'sb-ext)
(sb-ext:exit)
#-#.(slynk-backend:with-symbol 'exit 'sb-ext)
(progn
#+sb-thread
(dolist (thread (remove (current-thread) (all-threads)))
(ignore-errors (sb-thread:terminate-thread thread)))
(sb-ext:quit)))
;;Trace implementations
;;In SBCL, we have:
;; (trace <name>)
;; (trace :methods '<name>) ;to trace all methods of the gf <name>
;; (trace (method <name> <qualifier>? (<specializer>+)))
;; <name> can be a normal name or a (setf name)
(defun toggle-trace-aux (fspec &rest args)
(cond ((member fspec (eval '(trace)) :test #'equal)
(eval `(untrace ,fspec))
(format nil "~S is now untraced." fspec))
(t
(eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
(format nil "~S is now traced." fspec))))
(defun process-fspec (fspec)
(cond ((consp fspec)
(ecase (first fspec)
((:defun :defgeneric) (second fspec))
((:defmethod) `(method ,@(rest fspec)))
((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
(t
fspec)))
(defimplementation toggle-trace (spec)
(ecase (car spec)
((setf)
(toggle-trace-aux spec))
((:defmethod)
(toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
((:defgeneric)
(toggle-trace-aux (second spec) :methods t))
((:call)
(destructuring-bind (caller callee) (cdr spec)
(toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
;;; Weak datastructures
(defimplementation make-weak-key-hash-table (&rest args)
#+#.(slynk-sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table :weakness :key args)
#-#.(slynk-sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table args))
(defimplementation make-weak-value-hash-table (&rest args)
#+#.(slynk-sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table :weakness :value args)
#-#.(slynk-sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table args))
(defimplementation hash-table-weakness (hashtable)
#+#.(slynk-sbcl::sbcl-with-weak-hash-tables)
(sb-ext:hash-table-weakness hashtable))
;;; Floating point
(defimplementation float-nan-p (float)
(sb-ext:float-nan-p float))
(defimplementation float-infinity-p (float)
(sb-ext:float-infinity-p float))
#-win32
(defimplementation save-image (filename &optional restart-function)
(flet ((restart-sbcl ()
(sb-debug::enable-debugger)
(setf sb-impl::*descriptor-handlers* nil)
(funcall restart-function)))
(let ((pid (sb-posix:fork)))
(cond ((= pid 0)
(sb-debug::disable-debugger)
(apply #'sb-ext:save-lisp-and-die filename
(when restart-function
(list :toplevel #'restart-sbcl))))
(t
(multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
(assert (= pid rpid))
(assert (and (sb-posix:wifexited status)
(zerop (sb-posix:wexitstatus status))))))))))
#+unix
(progn
(sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
(program sb-alien:c-string)
(argv (* sb-alien:c-string)))
(defun execv (program args)
"Replace current executable with another one."
(let ((a-args (sb-alien:make-alien sb-alien:c-string
(+ 1 (length args)))))
(unwind-protect
(progn
(loop for index from 0 by 1
and item in (append args '(nil))
do (setf (sb-alien:deref a-args index)
item))
(when (minusp
(sys-execv program a-args))
(error "execv(3) returned.")))
(sb-alien:free-alien a-args))))
(defun runtime-pathname ()
#+#.(slynk-backend:with-symbol
'*runtime-pathname* 'sb-ext)
sb-ext:*runtime-pathname*
#-#.(slynk-backend:with-symbol
'*runtime-pathname* 'sb-ext)
(car sb-ext:*posix-argv*))
(defimplementation exec-image (image-file args)
(loop with fd-arg =
(loop for arg in args
and key = "" then arg
when (string-equal key "--slynk-fd")
return (parse-integer arg))
for my-fd from 3 to 1024
when (/= my-fd fd-arg)
do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
(let* ((self-string (pathname-to-filename (runtime-pathname))))
(execv
self-string
(apply 'list self-string "--core" image-file args)))))
(defimplementation make-fd-stream (fd external-format)
(sb-sys:make-fd-stream fd :input t :output t
:element-type 'character
:buffering :full
:dual-channel-p t
:external-format external-format))
#-win32
(defimplementation background-save-image (filename &key restart-function
completion-function)
(flet ((restart-sbcl ()
(sb-debug::enable-debugger)
(setf sb-impl::*descriptor-handlers* nil)
(funcall restart-function)))
(multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
(let ((pid (sb-posix:fork)))
(cond ((= pid 0)
(sb-posix:close pipe-in)
(sb-debug::disable-debugger)
(apply #'sb-ext:save-lisp-and-die filename
(when restart-function
(list :toplevel #'restart-sbcl))))
(t
(sb-posix:close pipe-out)
(sb-sys:add-fd-handler
pipe-in :input
(lambda (fd)
(sb-sys:invalidate-descriptor fd)
(sb-posix:close fd)
(multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
(assert (= pid rpid))
(assert (sb-posix:wifexited status))
(funcall completion-function
(zerop (sb-posix:wexitstatus status))))))))))))
(pushnew 'deinit-log-output sb-ext:*save-hooks*)
;;;; wrap interface implementation
(defimplementation wrap (spec indicator &key before after replace)
(when (wrapped-p spec indicator)
(warn "~a already wrapped with indicator ~a, unwrapping first"
spec indicator)
(sb-int:unencapsulate spec indicator))
(sb-int:encapsulate spec indicator
#-#.(slynk-backend:with-symbol 'arg-list 'sb-int)
(lambda (function &rest args)
(sbcl-wrap spec before after replace function args))
#+#.(slynk-backend:with-symbol 'arg-list 'sb-int)
(if (sbcl-version>= 1 1 16)
(lambda ()
(sbcl-wrap spec before after replace
(symbol-value 'sb-int:basic-definition)
(symbol-value 'sb-int:arg-list)))
`(sbcl-wrap ',spec ,before ,after ,replace
(symbol-value 'sb-int:basic-definition)
(symbol-value 'sb-int:arg-list))))
(symbol-function spec))
(defimplementation unwrap (spec indicator)
(sb-int:unencapsulate spec indicator))
(defimplementation wrapped-p (spec indicator)
(sb-int:encapsulated-p spec indicator))
(defun sbcl-wrap (spec before after replace function args)
(declare (ignore spec))
(let (retlist completed)
(unwind-protect
(progn
(when before
(funcall before args))
(setq retlist (multiple-value-list (if replace
(funcall replace
args)
(apply function args))))
(setq completed t)
(values-list retlist))
(when after
(funcall after (if completed retlist :exited-non-locally))))))
#+#.(slynk-backend:with-symbol 'comma-expr 'sb-impl)
(progn
(defmethod sexp-in-bounds-p ((s sb-impl::comma) i)
(sexp-in-bounds-p (sb-impl::comma-expr s) i))
(defmethod sexp-ref ((s sb-impl::comma) i)
(sexp-ref (sb-impl::comma-expr s) i)))
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; slynk-mkcl.lisp --- SLIME backend for MKCL.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;;; Administrivia
(defpackage slynk-mkcl
(:use cl slynk-backend))
(in-package slynk-mkcl)
;;(declaim (optimize (debug 3)))
(defvar *tmp*)
(defimplementation gray-package-name ()
'#:gray)
(eval-when (:compile-toplevel :load-toplevel)
(slynk-backend::import-slynk-mop-symbols :clos
;; '(:eql-specializer
;; :eql-specializer-object
;; :generic-function-declarations
;; :specializer-direct-methods
;; :compute-applicable-methods-using-classes)
nil
))
;;; UTF8
(defimplementation string-to-utf8 (string)
(mkcl:octets (si:utf-8 string)))
(defimplementation utf8-to-string (octets)
(string (si:utf-8 octets)))
;;;; TCP Server
(eval-when (:compile-toplevel :load-toplevel)
;; At compile-time we need access to the sb-bsd-sockets package for the
;; the following code to be read properly.
;; It is a bit a shame we have to load the entire module to get that.
(require 'sockets))
(defun resolve-hostname (name)
(car (sb-bsd-sockets:host-ent-addresses
(sb-bsd-sockets:get-host-by-name name))))
(defimplementation create-socket (host port &key backlog)
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
(sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
(sb-bsd-sockets:socket-listen socket (or backlog 5))
socket))
(defimplementation local-port (socket)
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
(defimplementation close-socket (socket)
(sb-bsd-sockets:socket-close socket))
(defun accept (socket)
"Like socket-accept, but retry on EINTR."
(loop (handler-case
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
(defimplementation accept-connection (socket
&key external-format
buffering timeout)
(declare (ignore timeout))
(sb-bsd-sockets:socket-make-stream (accept socket)
:output t ;; bogus
:input t ;; bogus
:buffering buffering ;; bogus
:element-type (if external-format
'character
'(unsigned-byte 8))
:external-format external-format
))
(defimplementation preferred-communication-style ()
:spawn
)
(defvar *external-format-to-coding-system*
'((:iso-8859-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")))
(defun external-format (coding-system)
(or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*))
(find coding-system (si:all-encodings) :test #'string-equal)))
(defimplementation find-external-format (coding-system)
#+unicode (external-format coding-system)
;; Without unicode support, MKCL uses the one-byte encoding of the
;; underlying OS, and will barf on anything except :DEFAULT. We
;; return NIL here for known multibyte encodings, so
;; SLYNK:CREATE-SERVER will barf.
#-unicode (let ((xf (external-format coding-system)))
(if (member xf '(:utf-8))
nil
:default)))
;;;; Unix signals
(defimplementation install-sigint-handler (handler)
(let ((old-handler (symbol-function 'si:terminal-interrupt)))
(setf (symbol-function 'si:terminal-interrupt)
(if (consp handler)
(car handler)
(lambda (&rest args)
(declare (ignore args))
(funcall handler)
(continue))))
(list old-handler)))
(defimplementation getpid ()
(mkcl:getpid))
(defimplementation set-default-directory (directory)
(mk-ext::chdir (namestring directory))
(default-directory))
(defimplementation default-directory ()
(namestring (mk-ext:getcwd)))
(defmacro progf (plist &rest forms)
`(let (_vars _vals)
(do ((p ,plist (cddr p)))
((endp p))
(push (car p) _vars)
(push (cadr p) _vals))
(progv _vars _vals ,@forms)
)
)
(defvar *inferior-lisp-sleeping-post* nil)
(defimplementation quit-lisp ()
;; restore original IO streams.
(progf (ignore-errors (eval
(slynk-backend:find-symbol2 "slynk::*saved-global-streams*")))
(when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*))
;;(mk-ext:quit :verbose t)
))
;;;; Compilation
(defvar *buffer-name* nil)
(defvar *buffer-start-position*)
(defvar *buffer-string*)
(defvar *compile-filename*)
(defun signal-compiler-condition (&rest args)
(signal (apply #'make-condition 'compiler-condition args)))
#|
(defun handle-compiler-warning (condition)
(signal-compiler-condition
:original-condition condition
:message (format nil "~A" condition)
:severity :warning
:location
(if *buffer-name*
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position* 0))
;; ;; compiler::*current-form*
;; (if compiler::*current-function*
;; (make-location (list :file *compile-filename*)
;; (list :function-name
;; (symbol-name
;; (slot-value compiler::*current-function*
;; 'compiler::name))))
(list :error "No location found.")
;; )
)))
|#
#|
(defun condition-location (condition)
(let ((file (compiler:compiler-message-file condition))
(position (compiler:compiler-message-file-position condition)))
(if (and position (not (minusp position)))
(if *buffer-name*
(make-buffer-location *buffer-name*
*buffer-start-position*
position)
(make-file-location file position))
(make-error-location "No location found."))))
|#
(defun condition-location (condition)
(if *buffer-name*
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position* 0))
;; ;; compiler::*current-form* ;
;; (if compiler::*current-function* ;
;; (make-location (list :file *compile-filename*) ;
;; (list :function-name ;
;; (symbol-name ;
;; (slot-value compiler::*current-function* ;
;; 'compiler::name)))) ;
(if (typep condition 'compiler::compiler-message)
(make-location (list :file (namestring (compiler:compiler-message-file condition)))
(list :end-position (compiler:compiler-message-file-end-position condition)))
(list :error "No location found."))
)
)
(defun handle-compiler-message (condition)
(unless (typep condition 'compiler::compiler-note)
(signal-compiler-condition
:original-condition condition
:message (princ-to-string condition)
:severity (etypecase condition
(compiler:compiler-fatal-error :error)
(compiler:compiler-error :error)
(error :error)
(style-warning :style-warning)
(warning :warning))
:location (condition-location condition))))
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((compiler:compiler-message #'handle-compiler-message))
(funcall function)))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(*compile-filename* input-file))
(handler-bind (#|
(compiler::compiler-note
#'(lambda (n)
(format t "~%slynk saw a compiler note: ~A~%" n) (finish-output) nil))
(compiler::compiler-warning
#'(lambda (w)
(format t "~%slynk saw a compiler warning: ~A~%" w) (finish-output) nil))
(compiler::compiler-error
#'(lambda (e)
(format t "~%slynk saw a compiler error: ~A~%" e) (finish-output) nil))
|#
)
(multiple-value-bind (output-truename warnings-p failure-p)
(compile-file input-file :output-file output-file :external-format external-format)
(values output-truename warnings-p
(or failure-p
(and load-p (not (load output-truename))))))))))
(defimplementation slynk-compile-string (string &key buffer position filename line column policy)
(declare (ignore filename line column policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
(*buffer-string* string))
(with-input-from-string (s string)
(when position (file-position position))
(compile-from-stream s)))))
(defun compile-from-stream (stream)
(let ((file (mkcl:mkstemp "TMP:MKCL-SLYNK-TMPXXXXXX"))
output-truename
warnings-p
failure-p
)
(with-open-file (s file :direction :output :if-exists :overwrite)
(do ((line (read-line stream nil) (read-line stream nil)))
((not line))
(write-line line s)))
(unwind-protect
(progn
(multiple-value-setq (output-truename warnings-p failure-p)
(compile-file file))
(and (not failure-p) (load output-truename)))
(when (probe-file file) (delete-file file))
(when (probe-file output-truename) (delete-file output-truename)))))
;;;; Documentation
(defun grovel-docstring-for-arglist (name type)
(flet ((compute-arglist-offset (docstring)
(when docstring
(let ((pos1 (search "Args: " docstring)))
(if pos1
(+ pos1 6)
(let ((pos2 (search "Syntax: " docstring)))
(when pos2
(+ pos2 8))))))))
(let* ((docstring (si::get-documentation name type))
(pos (compute-arglist-offset docstring)))
(if pos
(multiple-value-bind (arglist errorp)
(ignore-errors
(values (read-from-string docstring t nil :start pos)))
(if (or errorp (not (listp arglist)))
:not-available
arglist
))
:not-available ))))
(defimplementation arglist (name)
(cond ((and (symbolp name) (special-operator-p name))
(let ((arglist (grovel-docstring-for-arglist name 'function)))
(if (consp arglist) (cdr arglist) arglist)))
((and (symbolp name) (macro-function name))
(let ((arglist (grovel-docstring-for-arglist name 'function)))
(if (consp arglist) (cdr arglist) arglist)))
((or (functionp name) (fboundp name))
(multiple-value-bind (name fndef)
(if (functionp name)
(values (function-name name) name)
(values name (fdefinition name)))
(let ((fle (function-lambda-expression fndef)))
(case (car fle)
(si:lambda-block (caddr fle))
(t (typecase fndef
(generic-function (clos::generic-function-lambda-list fndef))
(compiled-function (grovel-docstring-for-arglist name 'function))
(function :not-available)))))))
(t :not-available)))
(defimplementation function-name (f)
(si:compiled-function-name f)
)
(eval-when (:compile-toplevel :load-toplevel)
;; At compile-time we need access to the walker package for the
;; the following code to be read properly.
;; It is a bit a shame we have to load the entire module to get that.
(require 'walker))
(defimplementation macroexpand-all (form &optional env)
(declare (ignore env))
(walker:macroexpand-all form))
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(dolist (type '(:VARIABLE :FUNCTION :CLASS))
(let ((doc (describe-definition symbol type)))
(when doc
(setf result (list* type doc result)))))
result))
(defimplementation describe-definition (name type)
(case type
(:variable (documentation name 'variable))
(:function (documentation name 'function))
(:class (documentation name 'class))
(t nil)))
;;; Debugging
(eval-when (:compile-toplevel :load-toplevel)
(import
'(si::*break-env*
si::*ihs-top*
si::*ihs-current*
si::*ihs-base*
si::*frs-base*
si::*frs-top*
si::*tpl-commands*
si::*tpl-level*
si::frs-top
si::ihs-top
si::ihs-fun
si::ihs-env
si::sch-frs-base
si::set-break-env
si::set-current-ihs
si::tpl-commands)))
(defvar *backtrace* '())
(defun in-slynk-package-p (x)
(and
(symbolp x)
(member (symbol-package x)
(list #.(find-package :slynk)
#.(find-package :slynk-backend)
#.(ignore-errors (find-package :slynk-mop))
#.(ignore-errors (find-package :slynk-loader))))
t))
(defun is-slynk-source-p (name)
(setf name (pathname name))
#+(or)
(pathname-match-p
name
(make-pathname :defaults slynk-loader::*source-directory*
:name (pathname-name name)
:type (pathname-type name)
:version (pathname-version name)))
nil)
(defun is-ignorable-fun-p (x)
(or
(in-slynk-package-p (frame-name x))
(multiple-value-bind (file position)
(ignore-errors (si::compiled-function-file (car x)))
(declare (ignore position))
(if file (is-slynk-source-p file)))))
(defmacro find-ihs-top (x)
(declare (ignore x))
'(si::ihs-top))
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(let* (;;(*tpl-commands* si::tpl-commands)
(*ihs-base* 0)
(*ihs-top* (find-ihs-top 'call-with-debugging-environment))
(*ihs-current* *ihs-top*)
(*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top))))
(*frs-top* (frs-top))
(*read-suppress* nil)
;;(*tpl-level* (1+ *tpl-level*))
(*backtrace* (loop for ihs from 0 below *ihs-top*
collect (list (si::ihs-fun ihs)
(si::ihs-env ihs)
nil))))
(declare (special *ihs-current*))
(loop for f from *frs-base* to *frs-top*
do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
(when (plusp i)
(let* ((x (elt *backtrace* i))
(name (si::frs-tag f)))
(unless (mkcl:fixnump name)
(push name (third x)))))))
(setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
(setf *tmp* *backtrace*)
(set-break-env)
(set-current-ihs)
(let ((*ihs-base* *ihs-top*))
(funcall debugger-loop-fn))))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
(*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
(funcall fun)))
(defimplementation compute-backtrace (start end)
(when (numberp end)
(setf end (min end (length *backtrace*))))
(loop for f in (subseq *backtrace* start end)
collect f))
(defimplementation format-sldb-condition (condition)
"Format a condition for display in SLDB."
;;(princ-to-string condition)
(format nil "~A~%In thread: ~S" condition mt:*thread*)
)
(defun frame-name (frame)
(let ((x (first frame)))
(if (symbolp x)
x
(function-name x))))
(defun function-position (fun)
(multiple-value-bind (file position)
(si::compiled-function-file fun)
(and file (make-location
`(:file ,(if (stringp file) file (namestring file)))
;;`(:position ,position)
`(:end-position , position)))))
(defun frame-function (frame)
(let* ((x (first frame))
fun position)
(etypecase x
(symbol (and (fboundp x)
(setf fun (fdefinition x)
position (function-position fun))))
(function (setf fun x position (function-position x))))
(values fun position)))
(defun frame-decode-env (frame)
(let ((functions '())
(blocks '())
(variables '()))
(setf frame (si::decode-ihs-env (second frame)))
(dolist (record frame)
(let* ((record0 (car record))
(record1 (cdr record)))
(cond ((or (symbolp record0) (stringp record0))
(setq variables (acons record0 record1 variables)))
((not (mkcl:fixnump record0))
(push record1 functions))
((symbolp record1)
(push record1 blocks))
(t
))))
(values functions blocks variables)))
(defimplementation print-frame (frame stream)
(let ((function (first frame)))
(let ((fname
;;; (cond ((symbolp function) function)
;;; ((si:instancep function) (slot-value function 'name))
;;; ((compiled-function-p function)
;;; (or (si::compiled-function-name function) 'lambda))
;;; (t :zombi))
(si::get-fname function)
))
(if (eq fname 'si::bytecode)
(format stream "~A [Evaluation of: ~S]"
fname (function-lambda-expression function))
(format stream "~A" fname)
)
(when (si::closurep function)
(format stream
", closure generated from ~A"
(si::get-fname (si:closure-producer function)))
)
)
)
)
(defimplementation frame-source-location (frame-number)
(nth-value 1 (frame-function (elt *backtrace* frame-number))))
(defimplementation frame-catch-tags (frame-number)
(third (elt *backtrace* frame-number)))
(defimplementation frame-locals (frame-number)
(loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
with i = 0
collect (list :name name :id (prog1 i (incf i)) :value value)))
(defimplementation frame-var-value (frame-number var-id)
(cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id)))
(defimplementation disassemble-frame (frame-number)
(let ((fun (frame-fun (elt *backtrace* frame-number))))
(disassemble fun)))
(defimplementation eval-in-frame (form frame-number)
(let ((env (second (elt *backtrace* frame-number))))
(si:eval-in-env form env)))
#|
(defimplementation gdb-initial-commands ()
;; These signals are used by the GC.
#+linux '("handle SIGPWR noprint nostop"
"handle SIGXCPU noprint nostop"))
(defimplementation command-line-args ()
(loop for n from 0 below (si:argc) collect (si:argv n)))
|#
;;;; Inspector
(defmethod emacs-inspect ((o t))
; ecl clos support leaves some to be desired
(cond
((streamp o)
(list*
(format nil "~S is an ordinary stream~%" o)
(append
(list
"Open for "
(cond
((ignore-errors (interactive-stream-p o)) "Interactive")
((and (input-stream-p o) (output-stream-p o)) "Input and output")
((input-stream-p o) "Input")
((output-stream-p o) "Output"))
`(:newline) `(:newline))
(label-value-line*
("Element type" (stream-element-type o))
("External format" (stream-external-format o)))
(ignore-errors (label-value-line*
("Broadcast streams" (broadcast-stream-streams o))))
(ignore-errors (label-value-line*
("Concatenated streams" (concatenated-stream-streams o))))
(ignore-errors (label-value-line*
("Echo input stream" (echo-stream-input-stream o))))
(ignore-errors (label-value-line*
("Echo output stream" (echo-stream-output-stream o))))
(ignore-errors (label-value-line*
("Output String" (get-output-stream-string o))))
(ignore-errors (label-value-line*
("Synonym symbol" (synonym-stream-symbol o))))
(ignore-errors (label-value-line*
("Input stream" (two-way-stream-input-stream o))))
(ignore-errors (label-value-line*
("Output stream" (two-way-stream-output-stream o)))))))
((si:instancep o) ;;t
(let* ((cl (si:instance-class o))
(slots (clos::class-slots cl)))
(list* (format nil "~S is an instance of class ~A~%"
o (clos::class-name cl))
(loop for x in slots append
(let* ((name (clos::slot-definition-name x))
(value (if (slot-boundp o name)
(clos::slot-value o name)
"Unbound"
)))
(list
(format nil "~S: " name)
`(:value ,value)
`(:newline)))))))
(t (list (format nil "~A" o)))))
;;;; Definitions
(defimplementation find-definitions (name)
(if (fboundp name)
(let ((tmp (find-source-location (symbol-function name))))
`(((defun ,name) ,tmp)))))
(defimplementation find-source-location (obj)
(setf *tmp* obj)
(or
(typecase obj
(function
(multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj))
(if (and file pos)
(make-location
`(:file ,(if (stringp file) file (namestring file)))
`(:end-position ,pos) ;; `(:position ,pos)
`(:snippet
,(with-open-file (s file)
(file-position s pos)
(skip-comments-and-whitespace s)
(read-snippet s))))))))
`(:error (format nil "Source definition of ~S not found" obj))))
;;;; Profiling
(eval-when (:compile-toplevel :load-toplevel)
;; At compile-time we need access to the profile package for the
;; the following code to be read properly.
;; It is a bit a shame we have to load the entire module to get that.
(require 'profile))
(defimplementation profile (fname)
(when fname (eval `(profile:profile ,fname))))
(defimplementation unprofile (fname)
(when fname (eval `(profile:unprofile ,fname))))
(defimplementation unprofile-all ()
(profile:unprofile-all)
"All functions unprofiled.")
(defimplementation profile-report ()
(profile:report))
(defimplementation profile-reset ()
(profile:reset)
"Reset profiling counters.")
(defimplementation profiled-functions ()
(profile:profile))
(defimplementation profile-package (package callers methods)
(declare (ignore callers methods))
(eval `(profile:profile ,(package-name (find-package package)))))
;;;; Threads
(defvar *thread-id-counter* 0)
(defvar *thread-id-counter-lock*
(mt:make-lock :name "thread id counter lock"))
(defun next-thread-id ()
(mt:with-lock (*thread-id-counter-lock*)
(incf *thread-id-counter*))
)
(defparameter *thread-id-map* (make-hash-table))
(defparameter *id-thread-map* (make-hash-table))
(defvar *thread-id-map-lock*
(mt:make-lock :name "thread id map lock"))
(defparameter +default-thread-local-variables+
'(*macroexpand-hook*
*default-pathname-defaults*
*readtable*
*random-state*
*compile-print*
*compile-verbose*
*load-print*
*load-verbose*
*print-array*
*print-base*
*print-case*
*print-circle*
*print-escape*
*print-gensym*
*print-length*
*print-level*
*print-lines*
*print-miser-width*
*print-pprint-dispatch*
*print-pretty*
*print-radix*
*print-readably*
*print-right-margin*
*read-base*
*read-default-float-format*
*read-eval*
*read-suppress*
))
(defun thread-local-default-bindings ()
(let (local)
(dolist (var +default-thread-local-variables+ local)
(setq local (acons var (symbol-value var) local))
)))
;; mkcl doesn't have weak pointers
(defimplementation spawn (fn &key name initial-bindings)
(let* ((local-defaults (thread-local-default-bindings))
(thread
;;(mt:make-thread :name name)
(mt:make-thread :name name
:initial-bindings (nconc initial-bindings
local-defaults))
)
(id (next-thread-id)))
(mt:with-lock (*thread-id-map-lock*)
(setf (gethash id *thread-id-map*) thread)
(setf (gethash thread *id-thread-map*) id))
(mt:thread-preset
thread
#'(lambda ()
(unwind-protect
(progn
;;(format t "~&Starting thread: ~S.~%" name) (finish-output)
(mt:thread-detach nil)
(funcall fn))
(progn
;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output)
(mt:with-lock (*thread-id-map-lock*)
(remhash thread *id-thread-map*)
(remhash id *thread-id-map*))
;;(format t "~&Finished thread: ~S~%" name) (finish-output)
))))
(mt:thread-enable thread)
(mt:thread-yield)
thread
))
(defimplementation thread-id (thread)
(block thread-id
(mt:with-lock (*thread-id-map-lock*)
(or (gethash thread *id-thread-map*)
(let ((id (next-thread-id)))
(setf (gethash id *thread-id-map*) thread)
(setf (gethash thread *id-thread-map*) id)
id)))))
(defimplementation find-thread (id)
(mt:with-lock (*thread-id-map-lock*)
(gethash id *thread-id-map*)))
(defimplementation thread-name (thread)
(mt:thread-name thread))
(defimplementation thread-status (thread)
(if (mt:thread-active-p thread)
"RUNNING"
"STOPPED"))
(defimplementation make-lock (&key name)
(mt:make-lock :name name :recursive t))
(defimplementation call-with-lock-held (lock function)
(declare (type function function))
(mt:with-lock (lock) (funcall function)))
(defimplementation current-thread ()
mt:*thread*)
(defimplementation all-threads ()
(mt:all-threads))
(defimplementation interrupt-thread (thread fn)
(mt:interrupt-thread thread fn))
(defimplementation kill-thread (thread)
(mt:interrupt-thread thread #'mt:terminate-thread)
)
(defimplementation thread-alive-p (thread)
(mt:thread-active-p thread))
(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock"))
(defvar *mailboxes* (list))
(declaim (type list *mailboxes*))
(defstruct (mailbox (:conc-name mailbox.))
thread
locked-by
(mutex (mt:make-lock :name "thread mailbox"))
(semaphore (mt:make-semaphore))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(mt:with-lock (*mailbox-lock*)
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation send (thread message)
(handler-case
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
;; (mt:interrupt-thread
;; thread
;; (lambda ()
;; (mt:with-lock (mutex)
;; (setf (mailbox.queue mbox)
;; (nconc (mailbox.queue mbox) (list message))))))
;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%"
;; mt:*thread* thread message) (finish-output)
(mt:with-lock (mutex)
(setf (mailbox.locked-by mbox) mt:*thread*)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
;;(format t "*") (finish-output)
(handler-case
(mt:semaphore-signal (mailbox.semaphore mbox))
(condition (condition)
(format t "Something went bad with semaphore-signal ~A" condition) (finish-output)
;;(break)
))
(setf (mailbox.locked-by mbox) nil)
)
;;(format t "+") (finish-output)
)
(condition (condition)
(format t "~&Error in send: ~S~%" condition) (finish-output))
)
)
;; (defimplementation receive ()
;; (block got-mail
;; (let* ((mbox (mailbox mt:*thread*))
;; (mutex (mailbox.mutex mbox)))
;; (loop
;; (mt:with-lock (mutex)
;; (if (mailbox.queue mbox)
;; (return-from got-mail (pop (mailbox.queue mbox)))))
;; ;;interrupt-thread will halt this if it takes longer than 1sec
;; (sleep 1)))))
(defimplementation receive-if (test &optional timeout)
(handler-case
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox))
got-one)
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
;;(format t "~&: ~S~%" mt:*thread*) (finish-output)
(handler-case
(setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2))
(condition (condition)
(format t "~&In (slynk-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition)
(finish-output)
nil
)
)
(mt:with-lock (mutex)
(setf (mailbox.locked-by mbox) mt:*thread*)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(setf (mailbox.locked-by mbox) nil)
;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail))
(return (car tail))))
(setf (mailbox.locked-by mbox) nil)
)
;;(format t "/ ~S~%" mt:*thread*) (finish-output)
(when (eq timeout t) (return (values nil t)))
;; (unless got-one
;; (format t "~&In (slynk-mkcl) receive-if: semaphore-wait timed out!~%"))
)
)
(condition (condition)
(format t "~&Error in (slynk-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output)
nil
)
)
)
(defmethod stream-finish-output ((stream stream))
(finish-output stream))
;;
;;#+windows
(defimplementation doze-in-repl ()
(setq *inferior-lisp-sleeping-post* (mt:make-semaphore))
;;(loop (sleep 1))
(mt:semaphore-wait *inferior-lisp-sleeping-post*)
(mk-ext:quit :verbose t)
)
;;; -*- indent-tabs-mode: nil -*-
;;;
;;; slynk-lispworks.lisp --- LispWorks specific code for SLIME.
;;;
;;; Created 2003, Helmut Eller
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(defpackage slynk-lispworks
(:use cl slynk-backend))
(in-package slynk-lispworks)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "comm"))
(defimplementation gray-package-name ()
"STREAM")
(import-slynk-mop-symbols :clos '(:slot-definition-documentation
:slot-boundp-using-class
:slot-value-using-class
:slot-makunbound-using-class
:eql-specializer
:eql-specializer-object
:compute-applicable-methods-using-classes))
(defun slynk-mop:slot-definition-documentation (slot)
(documentation slot t))
(defun slynk-mop:slot-boundp-using-class (class object slotd)
(clos:slot-boundp-using-class class object
(clos:slot-definition-name slotd)))
(defun slynk-mop:slot-value-using-class (class object slotd)
(clos:slot-value-using-class class object
(clos:slot-definition-name slotd)))
(defun (setf slynk-mop:slot-value-using-class) (value class object slotd)
(setf (clos:slot-value-using-class class object
(clos:slot-definition-name slotd))
value))
(defun slynk-mop:slot-makunbound-using-class (class object slotd)
(clos:slot-makunbound-using-class class object
(clos:slot-definition-name slotd)))
(defun slynk-mop:compute-applicable-methods-using-classes (gf classes)
(clos::compute-applicable-methods-from-classes gf classes))
;; lispworks doesn't have the eql-specializer class, it represents
;; them as a list of `(EQL ,OBJECT)
(deftype slynk-mop:eql-specializer () 'cons)
(defun slynk-mop:eql-specializer-object (eql-spec)
(second eql-spec))
(eval-when (:compile-toplevel :execute :load-toplevel)
(defvar *original-defimplementation* (macro-function 'defimplementation))
(defmacro defimplementation (&whole whole name args &body body
&environment env)
(declare (ignore args body))
`(progn
(dspec:record-definition '(defun ,name) (dspec:location)
:check-redefinition-p nil)
,(funcall *original-defimplementation* whole env))))
;;; UTF8
(defimplementation string-to-utf8 (string)
(ef:encode-lisp-string string '(:utf-8 :eol-style :lf)))
(defimplementation utf8-to-string (octets)
(ef:decode-external-string octets '(:utf-8 :eol-style :lf)))
;;; TCP server
(defimplementation preferred-communication-style ()
:spawn)
(defun socket-fd (socket)
(etypecase socket
(fixnum socket)
(comm:socket-stream (comm:socket-stream-socket socket))))
(defimplementation create-socket (host port &key backlog)
(multiple-value-bind (socket where errno)
#-(or lispworks4.1 (and macosx lispworks4.3))
(comm::create-tcp-socket-for-service port :address host
:backlog (or backlog 5))
#+(or lispworks4.1 (and macosx lispworks4.3))
(comm::create-tcp-socket-for-service port)
(cond (socket socket)
(t (error 'network-error
:format-control "~A failed: ~A (~D)"
:format-arguments (list where
(list #+unix (lw:get-unix-error errno))
errno))))))
(defimplementation local-port (socket)
(nth-value 1 (comm:get-socket-address (socket-fd socket))))
(defimplementation close-socket (socket)
(comm::close-socket (socket-fd socket)))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering))
(let* ((fd (comm::get-fd-from-socket socket)))
(assert (/= fd -1))
(cond ((not external-format)
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type '(unsigned-byte 8)))
(t
(assert (valid-external-format-p external-format))
(ecase (first external-format)
((:latin-1 :ascii)
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type 'base-char))
(:utf-8
(make-flexi-stream
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type '(unsigned-byte 8))
external-format)))))))
(defun make-flexi-stream (stream external-format)
(unless (member :flexi-streams *features*)
(error "Cannot use external format ~A~
without having installed flexi-streams in the inferior-lisp."
external-format))
(funcall (slynk-backend:find-symbol2 "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
stream
:external-format
(apply (slynk-backend:find-symbol2
"FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
external-format)))
;;; Coding Systems
(defun valid-external-format-p (external-format)
(member external-format *external-format-to-coding-system*
:test #'equal :key #'car))
(defvar *external-format-to-coding-system*
'(((:latin-1 :eol-style :lf)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1")
;;((:utf-8) "utf-8")
((:utf-8 :eol-style :lf) "utf-8-unix")
;;((:euc-jp) "euc-jp")
((:euc-jp :eol-style :lf) "euc-jp-unix")
;;((:ascii) "us-ascii")
((:ascii :eol-style :lf) "us-ascii-unix")))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
;;; Unix signals
(defun sigint-handler ()
(with-simple-restart (continue "Continue from SIGINT handler.")
(invoke-debugger "SIGINT")))
(defun make-sigint-handler (process)
(lambda (&rest args)
(declare (ignore args))
(mp:process-interrupt process #'sigint-handler)))
(defun set-sigint-handler ()
;; Set SIGINT handler on Slynk request handler thread.
#-win32
(sys::set-signal-handler sys::unix-sigint
(make-sigint-handler mp:*current-process*)))
#-win32
(defimplementation install-sigint-handler (handler)
(sys::set-signal-handler sys::unix-sigint
(let ((self mp:*current-process*))
(lambda (&rest args)
(declare (ignore args))
(mp:process-interrupt self handler)))))
(defimplementation getpid ()
#+win32 (win32:get-current-process-id)
#-win32 (system::getpid))
(defimplementation lisp-implementation-type-name ()
"lispworks")
(defimplementation set-default-directory (directory)
(namestring (hcl:change-directory directory)))
;;;; Documentation
(defun map-list (function list)
"Map over proper and not proper lists."
(loop for (car . cdr) on list
collect (funcall function car) into result
when (null cdr) return result
when (atom cdr) return (nconc result (funcall function cdr))))
(defun replace-strings-with-symbols (tree)
(map-list
(lambda (x)
(typecase x
(list
(replace-strings-with-symbols x))
(symbol
x)
(string
(intern x))
(t
(intern (write-to-string x)))))
tree))
(defimplementation arglist (symbol-or-function)
(let ((arglist (lw:function-lambda-list symbol-or-function)))
(etypecase arglist
((member :dont-know)
:not-available)
(list
(replace-strings-with-symbols arglist)))))
(defimplementation function-name (function)
(nth-value 2 (function-lambda-expression function)))
(defimplementation macroexpand-all (form &optional env)
(declare (ignore env))
(walker:walk-form form))
(defun generic-function-p (object)
(typep object 'generic-function))
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result '()))
(labels ((first-line (string)
(let ((pos (position #\newline string)))
(if (null pos) string (subseq string 0 pos))))
(doc (kind &optional (sym symbol))
(let ((string (or (documentation sym kind))))
(if string
(first-line string)
:not-documented)))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (when (boundp symbol)
(doc 'variable)))
(maybe-push
:generic-function (if (and (fboundp symbol)
(generic-function-p (fdefinition symbol)))
(doc 'function)))
(maybe-push
:function (if (and (fboundp symbol)
(not (generic-function-p (fdefinition symbol))))
(doc 'function)))
(maybe-push
:setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
(if (fboundp setf-name)
(doc 'setf))))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
result)))
(defimplementation describe-definition (symbol type)
(ecase type
(:variable (describe-symbol symbol))
(:class (describe (find-class symbol)))
((:function :generic-function) (describe-function symbol))
(:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
(defun describe-function (symbol)
(cond ((fboundp symbol)
(format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
symbol
(lispworks:function-lambda-list symbol)
(documentation symbol 'function))
(describe (fdefinition symbol)))
(t (format t "~S is not fbound" symbol))))
(defun describe-symbol (sym)
(format t "~A is a symbol in package ~A." sym (symbol-package sym))
(when (boundp sym)
(format t "~%~%Value: ~A" (symbol-value sym)))
(let ((doc (documentation sym 'variable)))
(when doc
(format t "~%~%Variable documentation:~%~A" doc)))
(when (fboundp sym)
(describe-function sym)))
(defimplementation type-specifier-p (symbol)
(or (ignore-errors
(subtypep nil symbol))
(not (eq (type-specifier-arglist symbol) :not-available))))
;;; Debugging
(defclass sly-env (env:environment)
((debugger-hook :initarg :debugger-hoook)))
(defun sly-env (hook io-bindings)
(make-instance 'sly-env :name "SLY Environment"
:io-bindings io-bindings
:debugger-hoook hook))
(defmethod env-internals:environment-display-notifier
((env sly-env) &key restarts condition)
(declare (ignore restarts condition))
(funcall (slynk-sym :slynk-debugger-hook) condition *debugger-hook*)
;; nil
)
(defmethod env-internals:environment-display-debugger ((env sly-env))
*debug-io*)
(defmethod env-internals:confirm-p ((e sly-env) &optional msg &rest args)
(apply (slynk-sym :y-or-n-p-in-emacs) msg args))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook))
(env:with-environment ((sly-env hook '()))
(funcall fun))))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setf (env:environment) (sly-env function '())))
(defvar *sly-db-top-frame*)
(defun interesting-frame-p (frame)
(cond ((or (dbg::call-frame-p frame)
(dbg::derived-call-frame-p frame)
(dbg::foreign-frame-p frame)
(dbg::interpreted-call-frame-p frame))
t)
((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
(t nil)))
(defun nth-next-frame (frame n)
"Unwind FRAME N times."
(do ((frame frame (dbg::frame-next frame))
(i n (if (interesting-frame-p frame) (1- i) i)))
((or (not frame)
(and (interesting-frame-p frame) (zerop i)))
frame)))
(defun nth-frame (index)
(nth-next-frame *sly-db-top-frame* index))
(defun find-top-frame ()
"Return the most suitable top-frame for the debugger."
(flet ((find-named-frame (name)
(do ((frame (dbg::debugger-stack-current-frame
dbg::*debugger-stack*)
(nth-next-frame frame 1)))
((or (null frame) ; no frame found!
(and (dbg::call-frame-p frame)
(eq (dbg::call-frame-function-name frame)
name)))
(nth-next-frame frame 1)))))
(or (find-named-frame 'invoke-debugger)
(find-named-frame (slynk-sym :safe-backtrace))
;; if we can't find a likely top frame, take any old frame
;; at the top
(dbg::debugger-stack-current-frame dbg::*debugger-stack*))))
(defimplementation call-with-debugging-environment (fn)
(dbg::with-debugger-stack ()
(let ((*sly-db-top-frame* (find-top-frame)))
(funcall fn))))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum))
(backtrace '()))
(do ((frame (nth-frame start) (dbg::frame-next frame))
(i start))
((or (not frame) (= i end)) (nreverse backtrace))
(when (interesting-frame-p frame)
(incf i)
(push frame backtrace)))))
(defun frame-actual-args (frame)
(let ((*break-on-signals* nil)
(kind nil))
(loop for arg in (dbg::call-frame-arglist frame)
if (eq kind '&rest)
nconc (handler-case
(dbg::dbg-eval arg frame)
(error (e) (list (format nil "<~A>" arg))))
and do (loop-finish)
else
if (member arg '(&rest &optional &key))
do (setq kind arg)
else
nconc
(handler-case
(nconc (and (eq kind '&key)
(list (cond ((symbolp arg)
(intern (symbol-name arg) :keyword))
((and (consp arg) (symbolp (car arg)))
(intern (symbol-name (car arg))
:keyword))
(t (caar arg)))))
(list (dbg::dbg-eval
(cond ((symbolp arg) arg)
((and (consp arg) (symbolp (car arg)))
(car arg))
(t (cadar arg)))
frame)))
(error (e) (list (format nil "<~A>" arg)))))))
(defimplementation print-frame (frame stream)
(cond ((dbg::call-frame-p frame)
(prin1 (cons (dbg::call-frame-function-name frame)
(frame-actual-args frame))
stream))
(t (princ frame stream))))
(defun frame-vars (frame)
(first (dbg::frame-locals-format-list frame #'list 75 0)))
(defimplementation frame-locals (n)
(let ((frame (nth-frame n)))
(if (dbg::call-frame-p frame)
(mapcar (lambda (var)
(destructuring-bind (name value symbol location) var
(declare (ignore name location))
(list :name symbol :id 0
:value value)))
(frame-vars frame)))))
(defimplementation frame-var-value (frame var)
(let ((frame (nth-frame frame)))
(destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
(declare (ignore _n _s _l))
value)))
(defimplementation frame-source-location (frame)
(let ((frame (nth-frame frame))
(callee (if (plusp frame) (nth-frame (1- frame)))))
(if (dbg::call-frame-p frame)
(let ((dspec (dbg::call-frame-function-name frame))
(cname (and (dbg::call-frame-p callee)
(dbg::call-frame-function-name callee)))
(path (and (dbg::call-frame-p frame)
(dbg::call-frame-edit-path frame))))
(if dspec
(frame-location dspec cname path))))))
(defimplementation eval-in-frame (form frame-number)
(let ((frame (nth-frame frame-number)))
(dbg::dbg-eval form frame)))
(defun function-name-package (name)
(typecase name
(null nil)
(symbol (symbol-package name))
((cons (eql hcl:subfunction))
(destructuring-bind (name parent) (cdr name)
(declare (ignore name))
(function-name-package parent)))
((cons (eql lw:top-level-form)) nil)
(t nil)))
(defimplementation frame-package (frame-number)
(let ((frame (nth-frame frame-number)))
(if (dbg::call-frame-p frame)
(function-name-package (dbg::call-frame-function-name frame)))))
(defimplementation return-from-frame (frame-number form)
(let* ((frame (nth-frame frame-number))
(return-frame (dbg::find-frame-for-return frame)))
(dbg::dbg-return-from-call-frame frame form return-frame
dbg::*debugger-stack*)))
(defimplementation restart-frame (frame-number)
(let ((frame (nth-frame frame-number)))
(dbg::restart-frame frame :same-args t)))
(defimplementation disassemble-frame (frame-number)
(let* ((frame (nth-frame frame-number)))
(when (dbg::call-frame-p frame)
(let ((function (dbg::get-call-frame-function frame)))
(disassemble function)))))
;;; Definition finding
(defun frame-location (dspec callee-name edit-path)
(let ((infos (dspec:find-dspec-locations dspec)))
(cond (infos
(destructuring-bind ((rdspec location) &rest _) infos
(declare (ignore _))
(let ((name (and callee-name (symbolp callee-name)
(string callee-name)))
(path (edit-path-to-cmucl-source-path edit-path)))
(make-dspec-location rdspec location
`(:call-site ,name :edit-path ,path)))))
(t
(list :error (format nil "Source location not available for: ~S"
dspec))))))
;; dbg::call-frame-edit-path is not documented but lets assume the
;; binary representation of the integer EDIT-PATH should be
;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the
;; same as cadadddr. Something is odd with the highest bit.
(defun edit-path-to-cmucl-source-path (edit-path)
(and edit-path
(cons 0
(let ((n -1))
(loop for i from (1- (integer-length edit-path)) downto 0
if (logbitp i edit-path) do (incf n)
else collect (prog1 n (setq n 0)))))))
;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
(defimplementation find-definitions (name)
(let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
(loop for (dspec location) in locations
collect (list dspec (make-dspec-location dspec location)))))
;;; Compilation
(defmacro with-slynk-compilation-unit ((location &rest options) &body body)
(lw:rebinding (location)
`(let ((compiler::*error-database* '()))
(with-compilation-unit ,options
(multiple-value-prog1 (progn ,@body)
(signal-error-data-base compiler::*error-database*
,location)
(signal-undefined-functions compiler::*unknown-functions*
,location))))))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-slynk-compilation-unit (input-file)
(compile-file input-file
:output-file output-file
:load load-p
:external-format external-format)))
(defvar *within-call-with-compilation-hooks* nil
"Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
(defvar *undefined-functions-hash* nil
"Hash table to map info about undefined functions to pathnames.")
(lw:defadvice (compile-file compile-file-and-collect-notes :around)
(pathname &rest rest)
(multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
(when *within-call-with-compilation-hooks*
(maphash (lambda (unfun dspecs)
(dolist (dspec dspecs)
(let ((unfun-info (list unfun dspec)))
(unless (gethash unfun-info *undefined-functions-hash*)
(setf (gethash unfun-info *undefined-functions-hash*)
pathname)))))
compiler::*unknown-functions*))))
(defimplementation call-with-compilation-hooks (function)
(let ((compiler::*error-database* '())
(*undefined-functions-hash* (make-hash-table :test 'equal))
(*within-call-with-compilation-hooks* t))
(with-compilation-unit ()
(prog1 (funcall function)
(signal-error-data-base compiler::*error-database*)
(signal-undefined-functions compiler::*unknown-functions*)))))
(defun map-error-database (database fn)
(loop for (filename . defs) in database do
(loop for (dspec . conditions) in defs do
(dolist (c conditions)
(multiple-value-bind (condition path)
(if (consp c) (values (car c) (cdr c)) (values c nil))
(funcall fn filename dspec condition path))))))
(defun lispworks-severity (condition)
(cond ((not condition) :warning)
(t (etypecase condition
#-(or lispworks4 lispworks5)
(conditions:compiler-note :note)
(error :error)
(style-warning :warning)
(warning :warning)))))
(defun signal-compiler-condition (message location condition)
(check-type message string)
(signal
(make-instance 'compiler-condition :message message
:severity (lispworks-severity condition)
:location location
:original-condition condition)))
(defvar *temp-file-format* '(:utf-8 :eol-style :lf))
(defun compile-from-temp-file (string filename)
(unwind-protect
(progn
(with-open-file (s filename :direction :output
:if-exists :supersede
:external-format *temp-file-format*)
(write-string string s)
(finish-output s))
(multiple-value-bind (binary-filename warnings? failure?)
(compile-file filename :load t
:external-format *temp-file-format*)
(declare (ignore warnings?))
(when binary-filename
(delete-file binary-filename))
(not failure?)))
(delete-file filename)))
(defun dspec-function-name-position (dspec fallback)
(etypecase dspec
(cons (let ((name (dspec:dspec-primary-name dspec)))
(typecase name
((or symbol string)
(list :function-name (string name)))
(t fallback))))
(null fallback)
(symbol (list :function-name (string dspec)))))
(defmacro with-fairly-standard-io-syntax (&body body)
"Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
(let ((package (gensym))
(readtable (gensym)))
`(let ((,package *package*)
(,readtable *readtable*))
(with-standard-io-syntax
(let ((*package* ,package)
(*readtable* ,readtable))
,@body)))))
(defun skip-comments (stream)
(let ((pos0 (file-position stream)))
(cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
'(()))
(file-position stream (1- (file-position stream))))
(t (file-position stream pos0)))))
#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
(defun dspec-stream-position (stream dspec)
(with-fairly-standard-io-syntax
(loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
(form (read stream nil '#1=#:eof)))
(when (eq form '#1#)
(return nil))
(labels ((check-dspec (form)
(when (consp form)
(let ((operator (car form)))
(case operator
((progn)
(mapcar #'check-dspec
(cdr form)))
((eval-when locally macrolet symbol-macrolet)
(mapcar #'check-dspec
(cddr form)))
((in-package)
(let ((package (find-package (second form))))
(when package
(setq *package* package))))
(otherwise
(let ((form-dspec (dspec:parse-form-dspec form)))
(when (dspec:dspec-equal dspec form-dspec)
(return pos)))))))))
(check-dspec form))))))
(defun dspec-file-position (file dspec)
(let* ((*compile-file-pathname* (pathname file))
(*compile-file-truename* (truename *compile-file-pathname*))
(*load-pathname* *compile-file-pathname*)
(*load-truename* *compile-file-truename*))
(with-open-file (stream file)
(let ((pos
#-(or lispworks4.1 lispworks4.2)
(ignore-errors (dspec-stream-position stream dspec))))
(if pos
(list :position (1+ pos))
(dspec-function-name-position dspec `(:position 1)))))))
(defun emacs-buffer-location-p (location)
(and (consp location)
(eq (car location) :emacs-buffer)))
(defun make-dspec-location (dspec location &optional hints)
(etypecase location
((or pathname string)
(multiple-value-bind (file err)
(ignore-errors (namestring (truename location)))
(if err
(list :error (princ-to-string err))
(make-location `(:file ,file)
(dspec-file-position file dspec)
hints))))
(symbol
`(:error ,(format nil "Cannot resolve location: ~S" location)))
((satisfies emacs-buffer-location-p)
(destructuring-bind (_ buffer offset) location
(declare (ignore _))
(make-location `(:buffer ,buffer)
(dspec-function-name-position dspec `(:offset ,offset 0))
hints)))))
(defun make-dspec-progenitor-location (dspec location edit-path)
(let ((canon-dspec (dspec:canonicalize-dspec dspec)))
(make-dspec-location
(if canon-dspec
(if (dspec:local-dspec-p canon-dspec)
(dspec:dspec-progenitor canon-dspec)
canon-dspec)
nil)
location
(if edit-path
(list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
(defun signal-error-data-base (database &optional location)
(map-error-database
database
(lambda (filename dspec condition edit-path)
(signal-compiler-condition
(format nil "~A" condition)
(make-dspec-progenitor-location dspec (or location filename) edit-path)
condition))))
(defun unmangle-unfun (symbol)
"Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
function names like \(SETF GET)."
(cond ((sys::setf-symbol-p symbol)
(sys::setf-pair-from-underlying-name symbol))
(t symbol)))
(defun signal-undefined-functions (htab &optional filename)
(maphash (lambda (unfun dspecs)
(dolist (dspec dspecs)
(signal-compiler-condition
(format nil "Undefined function ~A" (unmangle-unfun unfun))
(make-dspec-progenitor-location
dspec
(or filename
(gethash (list unfun dspec) *undefined-functions-hash*))
nil)
nil)))
htab))
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore filename line column policy))
(assert buffer)
(assert position)
(let* ((location (list :emacs-buffer buffer position))
(tmpname (hcl:make-temp-file nil "lisp")))
(with-slynk-compilation-unit (location)
(compile-from-temp-file
(with-output-to-string (s)
(let ((*print-radix* t))
(print `(eval-when (:compile-toplevel)
(setq dspec::*location* (list ,@location)))
s))
(write-string string s))
tmpname))))
;;; xref
(defmacro defxref (name function)
`(defimplementation ,name (name)
(xref-results (,function name))))
(defxref who-calls hcl:who-calls)
(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
(defxref calls-who hcl:calls-who)
(defxref list-callers list-callers-internal)
(defxref list-callees list-callees-internal)
(defun list-callers-internal (name)
(let ((callers (make-array 100
:fill-pointer 0
:adjustable t)))
(hcl:sweep-all-objects
#'(lambda (object)
(when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
#+Harlequin-Unix-Lisp (sys:callablep object)
#-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp)
(sys:compiled-code-p object)
(system::find-constant$funcallable name object))
(vector-push-extend object callers))))
;; Delay dspec:object-dspec until after sweep-all-objects
;; to reduce allocation problems.
(loop for object across callers
collect (if (symbolp object)
(list 'function object)
(or (dspec:object-dspec object) object)))))
(defun list-callees-internal (name)
(let ((callees '()))
(system::find-constant$funcallable
'junk name
:test #'(lambda (junk constant)
(declare (ignore junk))
(when (and (symbolp constant)
(fboundp constant))
(pushnew (list 'function constant) callees :test 'equal))
;; Return nil so we iterate over all constants.
nil))
callees))
;; only for lispworks 4.2 and above
#-lispworks4.1
(progn
(defxref who-references hcl:who-references)
(defxref who-binds hcl:who-binds)
(defxref who-sets hcl:who-sets))
(defimplementation who-specializes (classname)
(let ((class (find-class classname nil)))
(when class
(let ((methods (clos:class-direct-methods class)))
(xref-results (mapcar #'dspec:object-dspec methods))))))
(defun xref-results (dspecs)
(flet ((frob-locs (dspec locs)
(cond (locs
(loop for (name loc) in locs
collect (list name (make-dspec-location name loc))))
(t `((,dspec (:error "Source location not available")))))))
(loop for dspec in dspecs
append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
;;; Inspector
(defmethod emacs-inspect ((o t))
(lispworks-inspect o))
(defmethod emacs-inspect ((o function))
(lispworks-inspect o))
;; FIXME: slot-boundp-using-class in LW works with names so we can't
;; use our method in slynk.lisp.
(defmethod emacs-inspect ((o standard-object))
(lispworks-inspect o))
(defun lispworks-inspect (o)
(multiple-value-bind (names values _getter _setter type)
(lw:get-inspector-values o nil)
(declare (ignore _getter _setter))
(append
(label-value-line "Type" type)
(loop for name in names
for value in values
append (label-value-line name value)))))
;;; Miscellaneous
(defimplementation quit-lisp ()
(lispworks:quit))
;;; Tracing
(defun parse-fspec (fspec)
"Return a dspec for FSPEC."
(ecase (car fspec)
((:defmethod) `(method ,(cdr fspec)))))
(defun tracedp (dspec)
(member dspec (eval '(trace)) :test #'equal))
(defun toggle-trace-aux (dspec)
(cond ((tracedp dspec)
(eval `(untrace ,dspec))
(format nil "~S is now untraced." dspec))
(t
(eval `(trace (,dspec)))
(format nil "~S is now traced." dspec))))
(defimplementation toggle-trace (fspec)
(toggle-trace-aux (parse-fspec fspec)))
;;; Multithreading
(defimplementation initialize-multiprocessing (continuation)
(cond ((not mp::*multiprocessing*)
(push (list "Initialize SLY" '() continuation)
mp:*initial-processes*)
(mp:initialize-multiprocessing))
(t (funcall continuation))))
(defimplementation spawn (fn &key name)
(mp:process-run-function name () fn))
(defvar *id-lock* (mp:make-lock))
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
(mp:with-lock (*id-lock*)
(or (getf (mp:process-plist thread) 'id)
(setf (getf (mp:process-plist thread) 'id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id (mp:list-all-processes)
:key (lambda (p) (getf (mp:process-plist p) 'id))))
(defimplementation thread-name (thread)
(mp:process-name thread))
(defimplementation thread-status (thread)
(format nil "~A ~D"
(mp:process-whostate thread)
(mp:process-priority thread)))
(defimplementation make-lock (&key name)
(mp:make-lock :name name))
(defimplementation call-with-lock-held (lock function)
(mp:with-lock (lock) (funcall function)))
(defimplementation current-thread ()
mp:*current-process*)
(defimplementation all-threads ()
(mp:list-all-processes))
(defimplementation interrupt-thread (thread fn)
(mp:process-interrupt thread fn))
(defimplementation kill-thread (thread)
(mp:process-kill thread))
(defimplementation thread-alive-p (thread)
(mp:process-alive-p thread))
(defstruct (mailbox (:conc-name mailbox.))
(mutex (mp:make-lock :name "thread mailbox"))
(queue '() :type list))
(defvar *mailbox-lock* (mp:make-lock))
(defun mailbox (thread)
(mp:with-lock (*mailbox-lock*)
(or (getf (mp:process-plist thread) 'mailbox)
(setf (getf (mp:process-plist thread) 'mailbox)
(make-mailbox)))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox mp:*current-process*))
(lock (mailbox.mutex mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(mp:with-lock (lock "receive-if/try")
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail)))))
(when (eq timeout t) (return (values nil t)))
(mp:process-wait-with-timeout
"receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(mp:with-lock ((mailbox.mutex mbox))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
(let ((alist '())
(lock (mp:make-lock :name "register-thread")))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(mp:with-lock (lock)
(etypecase thread
(null
(setf alist (delete name alist :key #'car)))
(mp:process
(let ((probe (assoc name alist)))
(cond (probe (setf (cdr probe) thread))
(t (setf alist (acons name thread alist))))))))
nil)
(defimplementation find-registered (name)
(mp:with-lock (lock)
(cdr (assoc name alist)))))
(defimplementation set-default-initial-binding (var form)
(setq mp:*process-initial-bindings*
(acons var `(eval (quote ,form))
mp:*process-initial-bindings* )))
(defimplementation thread-attributes (thread)
(list :priority (mp:process-priority thread)
:idle (mp:process-idle-time thread)))
;;; Some intergration with the lispworks environment
(defun slynk-sym (name) (find-symbol (string name) :slynk))
;;;; Weak hashtables
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak-kind :key args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weak-kind :value args))
;;;; Packages
#+#.(slynk-backend:with-symbol 'package-local-nicknames 'hcl)
(defimplementation package-local-nicknames (package)
(hcl:package-local-nicknames package))
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; slynk-ecl.lisp --- SLY backend for ECL.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;;; Administrivia
(defpackage slynk-ecl
(:use cl slynk-backend))
(in-package slynk-ecl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ecl-version ()
(let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
(if version
(symbol-value version)
0)))
(when (< (ecl-version) 100301)
(error "~&IMPORTANT:~% ~
The version of ECL you're using (~A) is too old.~% ~
Please upgrade to at least 10.3.1.~% ~
Sorry for the inconvenience.~%~%"
(lisp-implementation-version))))
;; Hard dependencies.
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sockets))
;; Soft dependencies.
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (probe-file "sys:profile.fas")
(require :profile)
(pushnew :profile *features*))
(when (probe-file "sys:serve-event.fas")
(require :serve-event)
(pushnew :serve-event *features*)))
(declaim (optimize (debug 3)))
;;; Slynk-mop
(eval-when (:compile-toplevel :load-toplevel :execute)
(import-slynk-mop-symbols
:clos
(and (< (ecl-version) 121201)
`(:eql-specializer
:eql-specializer-object
:generic-function-declarations
:specializer-direct-methods
,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
'(:compute-applicable-methods-using-classes))))))
(defimplementation gray-package-name ()
"GRAY")
;;;; UTF8
;;; Convert the string STRING to a (simple-array (unsigned-byte 8)).
;;;
;;; string-to-utf8 (string)
;;; Convert the (simple-array (unsigned-byte 8)) OCTETS to a string.
;;;
;;; utf8-to-string (octets)
;;;; TCP Server
(defun resolve-hostname (name)
(car (sb-bsd-sockets:host-ent-addresses
(sb-bsd-sockets:get-host-by-name name))))
(defimplementation create-socket (host port &key backlog)
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
(sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
(sb-bsd-sockets:socket-listen socket (or backlog 5))
socket))
(defimplementation local-port (socket)
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
(defimplementation close-socket (socket)
(sb-bsd-sockets:socket-close socket))
(defun accept (socket)
"Like socket-accept, but retry on EAGAIN."
(loop (handler-case
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
(defimplementation accept-connection (socket
&key external-format
buffering timeout)
(declare (ignore timeout))
(sb-bsd-sockets:socket-make-stream (accept socket)
:output t
:input t
:buffering (ecase buffering
((t) :full)
((nil) :none)
(:line :line))
:element-type (if external-format
'character
'(unsigned-byte 8))
:external-format external-format))
;;; Call FN whenever SOCKET is readable.
;;;
;;; add-sigio-handler (socket fn)
;;; Remove all sigio handlers for SOCKET.
;;;
;;; remove-sigio-handlers (socket)
;;; Call FN when Lisp is waiting for input and SOCKET is readable.
;;;
;;; add-fd-handler (socket fn)
;;; Remove all fd-handlers for SOCKET.
;;;
;;; remove-fd-handlers (socket)
(defimplementation preferred-communication-style ()
(cond
((member :threads *features*) :spawn)
((member :windows *features*) nil)
(t #|:fd-handler|# nil)))
;;; Set the 'stream 'timeout. The timeout is either the real number
;;; specifying the timeout in seconds or 'nil for no timeout.
;;;
;;; set-stream-timeout (stream timeout)
;;; Hook called when the first connection from Emacs is established.
;;; Called from the INIT-FN of the socket server that accepts the
;;; connection.
;;;
;;; This is intended for setting up extra context, e.g. to discover
;;; that the calling thread is the one that interacts with Emacs.
;;;
;;; emacs-connected ()
;;;; Unix Integration
(defimplementation getpid ()
(si:getpid))
;;; Call FUNCTION on SIGINT (instead of invoking the debugger).
;;; Return old signal handler.
;;;
;;; install-sigint-handler (function)
;;; XXX!
;;; If ECL is built with thread support, it'll spawn a helper thread
;;; executing the SIGINT handler. We do not want to BREAK into that
;;; helper but into the main thread, though. This is coupled with the
;;; current choice of NIL as communication-style in so far as ECL's
;;; main-thread is also the Sly's REPL thread.
(defun make-interrupt-handler (real-handler)
#+threads
(let ((main-thread (find 'si:top-level (mp:all-processes)
:key #'mp:process-name)))
#'(lambda (&rest args)
(declare (ignore args))
(mp:interrupt-process main-thread real-handler)))
#-threads
#'(lambda (&rest args)
(declare (ignore args))
(funcall real-handler)))
(defimplementation call-with-user-break-handler (real-handler function)
(let ((old-handler #'si:terminal-interrupt))
(setf (symbol-function 'si:terminal-interrupt)
(make-interrupt-handler real-handler))
(unwind-protect (funcall function)
(setf (symbol-function 'si:terminal-interrupt) old-handler))))
(defimplementation quit-lisp ()
(ext:quit))
;;; Default implementation is fine.
;;;
;;; lisp-implementation-type-name
;;; lisp-implementation-program
(defimplementation socket-fd (socket)
(etypecase socket
(fixnum socket)
(two-way-stream (socket-fd (two-way-stream-input-stream socket)))
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
(file-stream (si:file-stream-fd socket))))
;;; Create a character stream for the file descriptor FD. This
;;; interface implementation requires either `ffi:c-inline' or has to
;;; wait for the exported interface.
;;;
;;; make-fd-stream (socket-stream)
;;; Duplicate a file descriptor. If the syscall fails, signal a
;;; condition. See dup(2). This interface requiers `ffi:c-inline' or
;;; has to wait for the exported interface.
;;;
;;; dup (fd)
;;; Does not apply to ECL which doesn't dump images.
;;;
;;; exec-image (image-file args)
(defimplementation command-line-args ()
(ext:command-args))
;;;; pathnames
;;; Return a pathname for FILENAME.
;;; A filename in Emacs may for example contain asterisks which should not
;;; be translated to wildcards.
;;;
;;; filename-to-pathname (filename)
;;; Return the filename for PATHNAME.
;;;
;;; pathname-to-filename (pathname)
(defimplementation default-directory ()
(namestring (ext:getcwd)))
(defimplementation set-default-directory (directory)
(ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
(default-directory))
;;; Call FN with hooks to handle special syntax. Can we use it for
;;; `ffi:c-inline' to be handled as C/C++ code?
;;;
;;; call-with-syntax-hooks
;;; Return a suitable initial value for SLYNK:*READTABLE-ALIST*.
;;;
;;; default-readtable-alist
;;;; Packages
#+package-local-nicknames
(defimplementation package-local-nicknames (package)
(ext:package-local-nicknames package))
;;;; Compilation
(defvar *buffer-name* nil)
(defvar *buffer-start-position*)
(defun signal-compiler-condition (&rest args)
(apply #'signal 'compiler-condition args))
#-ecl-bytecmp
(defun handle-compiler-message (condition)
;; ECL emits lots of noise in compiler-notes, like "Invoking
;; external command".
(unless (typep condition 'c::compiler-note)
(signal-compiler-condition
:original-condition condition
:message (princ-to-string condition)
:severity (etypecase condition
(c:compiler-fatal-error :error)
(c:compiler-error :error)
(error :error)
(style-warning :style-warning)
(warning :warning))
:location (condition-location condition))))
#-ecl-bytecmp
(defun condition-location (condition)
(let ((file (c:compiler-message-file condition))
(position (c:compiler-message-file-position condition)))
(if (and position (not (minusp position)))
(if *buffer-name*
(make-buffer-location *buffer-name*
*buffer-start-position*
position)
(make-file-location file position))
(make-error-location "No location found."))))
(defimplementation call-with-compilation-hooks (function)
#+ecl-bytecmp
(funcall function)
#-ecl-bytecmp
(handler-bind ((c:compiler-message #'handle-compiler-message))
(funcall function)))
(defvar *tmpfile-map* (make-hash-table :test #'equal))
(defun note-buffer-tmpfile (tmp-file buffer-name)
;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
(let ((tmp-namestring (namestring (truename tmp-file))))
(setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
tmp-namestring))
(defun tmpfile-to-buffer (tmp-file)
(gethash tmp-file *tmpfile-map*))
(defimplementation slynk-compile-string
(string &key buffer position filename line column policy)
(declare (ignore line column policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer) ; for compilation hooks
(*buffer-start-position* position))
(let ((tmp-file (si:mkstemp "TMP:ecl-slynk-tmpfile-"))
(fasl-file)
(warnings-p)
(failure-p))
(unwind-protect
(with-open-file (tmp-stream tmp-file :direction :output
:if-exists :supersede)
(write-string string tmp-stream)
(finish-output tmp-stream)
(multiple-value-setq (fasl-file warnings-p failure-p)
(compile-file tmp-file
:load t
:source-truename (or filename
(note-buffer-tmpfile tmp-file buffer))
:source-offset (1- position))))
(when (probe-file tmp-file)
(delete-file tmp-file))
(when fasl-file
(delete-file fasl-file)))
(not failure-p)))))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-compilation-hooks ()
(compile-file input-file :output-file output-file
:load load-p
:external-format external-format)))
(defvar *external-format-to-coding-system*
'((:latin-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")))
(defun external-format (coding-system)
(or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*))
(find coding-system (ext:all-encodings) :test #'string-equal)))
(defimplementation find-external-format (coding-system)
#+unicode (external-format coding-system)
;; Without unicode support, ECL uses the one-byte encoding of the
;; underlying OS, and will barf on anything except :DEFAULT. We
;; return NIL here for known multibyte encodings, so
;; SLYNK:CREATE-SERVER will barf.
#-unicode (let ((xf (external-format coding-system)))
(if (member xf '(:utf-8))
nil
:default)))
;;; Default implementation is fine
;;;
;;; guess-external-format
;;;; Streams
;;; Implemented in `gray'
;;;
;;; make-output-stream
;;; make-input-stream
;;;; Documentation
(defimplementation arglist (name)
(multiple-value-bind (arglist foundp)
(ext:function-lambda-list name)
(if foundp arglist :not-available)))
(defimplementation type-specifier-p (symbol)
(or (subtypep nil symbol)
(not (eq (type-specifier-arglist symbol) :not-available))))
(defimplementation function-name (f)
(typecase f
(generic-function (clos:generic-function-name f))
(function (si:compiled-function-name f))))
;;; Default implementation is fine (CL).
;;;
;;; valid-function-name-p (form)
#+walker
(defimplementation macroexpand-all (form &optional env)
(walker:macroexpand-all form env))
;;; Default implementation is fine.
;;;
;;; compiler-macroexpand-1
;;; compiler-macroexpand
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((frob (type boundp)
(when (funcall boundp symbol)
(let ((doc (describe-definition symbol type)))
(setf result (list* type doc result))))))
(frob :VARIABLE #'boundp)
(frob :FUNCTION #'fboundp)
(frob :CLASS (lambda (x) (find-class x nil))))
result))
(defimplementation describe-definition (name type)
(case type
(:variable (documentation name 'variable))
(:function (documentation name 'function))
(:class (documentation name 'class))
(t nil)))
;;;; Debugging
(eval-when (:compile-toplevel :load-toplevel :execute)
(import
'(si::*break-env*
si::*ihs-top*
si::*ihs-current*
si::*ihs-base*
si::*frs-base*
si::*frs-top*
si::*tpl-commands*
si::*tpl-level*
si::frs-top
si::ihs-top
si::ihs-fun
si::ihs-env
si::sch-frs-base
si::set-break-env
si::set-current-ihs
si::tpl-commands)))
(defun make-invoke-debugger-hook (hook)
(when hook
#'(lambda (condition old-hook)
;; Regard *debugger-hook* if set by user.
(if *debugger-hook*
nil ; decline, *DEBUGGER-HOOK* will be tried next.
(funcall hook condition old-hook)))))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
(ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(funcall fun)))
(defvar *backtrace* '())
;;; Commented out; it's not clear this is a good way of doing it. In
;;; particular because it makes errors stemming from this file harder
;;; to debug, and given the "young" age of ECL's slynk backend, that's
;;; a bad idea.
;;;
;;; Also before thinking whether to uncomment this consider that SLY
;;; might not be loaded with slynk-loader.lisp at all.
;; (defun in-slynk-package-p (x)
;; (and
;; (symbolp x)
;; (member (symbol-package x)
;; (list #.(find-package :slynk)
;; #.(find-package :slynk-backend)
;; #.(ignore-errors (find-package :slynk-mop))
;; #.(ignore-errors (find-package :slynk-loader))))
;; t))
;; (defun is-slynk-source-p (name)
;; (setf name (pathname name))
;; (pathname-match-p
;; name
;; (make-pathname :defaults slynk-loader::*source-directory*
;; :name (pathname-name name)
;; :type (pathname-type name)
;; :version (pathname-version name))))
;; (defun is-ignorable-fun-p (x)
;; (or
;; (in-slynk-package-p (frame-name x))
;; (multiple-value-bind (file position)
;; (ignore-errors (si::bc-file (car x)))
;; (declare (ignore position))
;; (if file (is-slynk-source-p file)))))
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(let* ((*ihs-top* (ihs-top))
(*ihs-current* *ihs-top*)
(*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
(*frs-top* (frs-top))
(*tpl-level* (1+ *tpl-level*))
(*backtrace* (loop for ihs from 0 below *ihs-top*
collect (list (si::ihs-fun ihs)
(si::ihs-env ihs)
nil))))
(declare (special *ihs-current*))
(loop for f from *frs-base* until *frs-top*
do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
(when (plusp i)
(let* ((x (elt *backtrace* i))
(name (si::frs-tag f)))
(unless (si::fixnump name)
(push name (third x)))))))
;; (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
(setf *backtrace* (nreverse *backtrace*))
(set-break-env)
(set-current-ihs)
(let ((*ihs-base* *ihs-top*))
(funcall debugger-loop-fn))))
(defimplementation compute-backtrace (start end)
(subseq *backtrace* start
(and (numberp end)
(min end (length *backtrace*)))))
(defun frame-name (frame)
(let ((x (first frame)))
(if (symbolp x)
x
(function-name x))))
(defun function-position (fun)
(multiple-value-bind (file position)
(si::bc-file fun)
(when file
(make-file-location file position))))
(defun frame-function (frame)
(let* ((x (first frame))
fun position)
(etypecase x
(symbol (and (fboundp x)
(setf fun (fdefinition x)
position (function-position fun))))
(function (setf fun x position (function-position x))))
(values fun position)))
(defun frame-decode-env (frame)
(let ((functions '())
(blocks '())
(variables '()))
(setf frame (si::decode-ihs-env (second frame)))
(dolist (record (remove-if-not #'consp frame))
(let* ((record0 (car record))
(record1 (cdr record)))
(cond ((or (symbolp record0) (stringp record0))
(setq variables (acons record0 record1 variables)))
((not (si::fixnump record0))
(push record1 functions))
((symbolp record1)
(push record1 blocks))
(t
))))
(values functions blocks variables)))
(defimplementation print-frame (frame stream)
(format stream "~A" (first frame)))
;;; Is the frame FRAME restartable?.
;;; Return T if `restart-frame' can safely be called on the frame.
;;;
;;; frame-restartable-p (frame)
(defimplementation frame-source-location (frame-number)
(let ((frame (elt *backtrace* frame-number)))
(or (nth-value 1 (frame-function frame))
(make-error-location "Unknown source location for ~A." (car frame)))))
(defimplementation frame-catch-tags (frame-number)
(third (elt *backtrace* frame-number)))
(defimplementation frame-locals (frame-number)
(loop for (name . value) in (nth-value 2 (frame-decode-env
(elt *backtrace* frame-number)))
collect (list :name name :id 0 :value value)))
(defimplementation frame-var-value (frame-number var-number)
(destructuring-bind (name . value)
(elt
(nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
var-number)
(declare (ignore name))
value))
(defimplementation disassemble-frame (frame-number)
(let ((fun (frame-function (elt *backtrace* frame-number))))
(disassemble fun)))
(defimplementation eval-in-frame (form frame-number)
(let ((env (second (elt *backtrace* frame-number))))
(si:eval-with-env form env)))
;;; frame-package
;;; frame-call
;;; return-from-frame
;;; restart-frame
;;; print-condition
;;; condition-extras
(defimplementation gdb-initial-commands ()
;; These signals are used by the GC.
#+linux '("handle SIGPWR noprint nostop"
"handle SIGXCPU noprint nostop"))
;;; active-stepping
;;; sldb-break-on-return
;;; sldb-break-at-start
;;; sldb-stepper-condition-p
;;; sldb-setp-into
;;; sldb-step-next
;;; sldb-step-out
;;;; Definition finding
(defvar +TAGS+ (namestring
(merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
(defun make-file-location (file file-position)
;; File positions in CL start at 0, but Emacs' buffer positions
;; start at 1. We specify (:ALIGN T) because the positions comming
;; from ECL point at right after the toplevel form appearing before
;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
(make-location `(:file ,(namestring (translate-logical-pathname file)))
`(:position ,(1+ file-position))
`(:align t)))
(defun make-buffer-location (buffer-name start-position &optional (offset 0))
(make-location `(:buffer ,buffer-name)
`(:offset ,start-position ,offset)
`(:align t)))
(defun make-TAGS-location (&rest tags)
(make-location `(:etags-file ,+TAGS+)
`(:tag ,@tags)))
(defimplementation find-definitions (name)
(let ((annotations (ext:get-annotation name 'si::location :all)))
(cond (annotations
(loop for annotation in annotations
collect (destructuring-bind (dspec file . pos) annotation
`(,dspec ,(make-file-location file pos)))))
(t
(mapcan #'(lambda (type) (find-definitions-by-type name type))
(classify-definition-name name))))))
(defun classify-definition-name (name)
(let ((types '()))
(when (fboundp name)
(cond ((special-operator-p name)
(push :special-operator types))
((macro-function name)
(push :macro types))
((typep (fdefinition name) 'generic-function)
(push :generic-function types))
((si:mangle-name name t)
(push :c-function types))
(t
(push :lisp-function types))))
(when (boundp name)
(cond ((constantp name)
(push :constant types))
(t
(push :global-variable types))))
types))
(defun find-definitions-by-type (name type)
(ecase type
(:lisp-function
(when-let (loc (source-location (fdefinition name)))
(list `((defun ,name) ,loc))))
(:c-function
(when-let (loc (source-location (fdefinition name)))
(list `((c-source ,name) ,loc))))
(:generic-function
(loop for method in (clos:generic-function-methods (fdefinition name))
for specs = (clos:method-specializers method)
for loc = (source-location method)
when loc
collect `((defmethod ,name ,specs) ,loc)))
(:macro
(when-let (loc (source-location (macro-function name)))
(list `((defmacro ,name) ,loc))))
(:constant
(when-let (loc (source-location name))
(list `((defconstant ,name) ,loc))))
(:global-variable
(when-let (loc (source-location name))
(list `((defvar ,name) ,loc))))
(:special-operator)))
;;; FIXME: There ought to be a better way.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun c-function-name-p (name)
(and (symbolp name) (si:mangle-name name t) t))
(defun c-function-p (object)
(and (functionp object)
(let ((fn-name (function-name object)))
(and fn-name (c-function-name-p fn-name))))))
(deftype c-function ()
`(satisfies c-function-p))
(defun assert-source-directory ()
(unless (probe-file #P"SRC:")
(error "ECL's source directory ~A does not exist. ~
You can specify a different location via the environment ~
variable `ECLSRCDIR'."
(namestring (translate-logical-pathname #P"SYS:")))))
(defun assert-TAGS-file ()
(unless (probe-file +TAGS+)
(error "No TAGS file ~A found. It should have been installed with ECL."
+TAGS+)))
(defun package-names (package)
(cons (package-name package) (package-nicknames package)))
(defun source-location (object)
(converting-errors-to-error-location
(typecase object
(c-function
(assert-source-directory)
(assert-TAGS-file)
(let ((lisp-name (function-name object)))
(assert lisp-name)
(multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
(assert flag)
;; In ECL's code base sometimes the mangled name is used
;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
;; @EXT::SYMBOL is used. We cannot predict here, so we just
;; provide several candidates.
(apply #'make-TAGS-location
c-name
(loop with s = (symbol-name lisp-name)
for p in (package-names (symbol-package lisp-name))
collect (format nil "~A::~A" p s)
collect (format nil "~(~A::~A~)" p s))))))
(function
(multiple-value-bind (file pos) (ext:compiled-function-file object)
(cond ((not file)
(return-from source-location nil))
((tmpfile-to-buffer file)
(make-buffer-location (tmpfile-to-buffer file) pos))
(t
(assert (probe-file file))
(assert (not (minusp pos)))
(make-file-location file pos)))))
(method
;; FIXME: This will always return NIL at the moment; ECL does not
;; store debug information for methods yet.
(source-location (clos:method-function object)))
((member nil t)
(multiple-value-bind (flag c-name) (si:mangle-name object)
(assert flag)
(make-TAGS-location c-name))))))
(defimplementation find-source-location (object)
(or (source-location object)
(make-error-location "Source definition of ~S not found." object)))
;;; buffer-first-change
;;;; XREF
;;; who-calls
;;; calls-who
;;; who-references
;;; who-binds
;;; who-sets
;;; who-macroexpands
;;; who-specializes
;;; list-callers
;;; list-callees
;;;; Profiling
;;; XXX: use monitor.lisp (ccl,clisp)
#+profile
(progn
(defimplementation profile (fname)
(when fname (eval `(profile:profile ,fname))))
(defimplementation unprofile (fname)
(when fname (eval `(profile:unprofile ,fname))))
(defimplementation unprofile-all ()
(profile:unprofile-all)
"All functions unprofiled.")
(defimplementation profile-report ()
(profile:report))
(defimplementation profile-reset ()
(profile:reset)
"Reset profiling counters.")
(defimplementation profiled-functions ()
(profile:profile))
(defimplementation profile-package (package callers methods)
(declare (ignore callers methods))
(eval `(profile:profile ,(package-name (find-package package)))))
) ; #+profile (progn ...
;;;; Trace
;;; Toggle tracing of the function(s) given with SPEC.
;;; SPEC can be:
;;; (setf NAME) ; a setf function
;;; (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
;;; (:defgeneric NAME) ; a generic function with all methods
;;; (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
;;; (:labels TOPLEVEL LOCAL)
;;; (:flet TOPLEVEL LOCAL)
;;;
;;; toggle-trace (spec)
;;;; Inspector
;;; FIXME: Would be nice if it was possible to inspect objects
;;; implemented in C.
;;; Return a list of bindings corresponding to OBJECT's slots.
;;; eval-context (object)
;;; Return a string describing the primitive type of object.
;;; describe-primitive-type (object)
;;;; Multithreading
;;; Not needed in ECL
;;;
;;; initialize-multiprocessing
#+threads
(progn
(defvar *thread-id-counter* 0)
(defparameter *thread-id-map* (make-hash-table))
(defvar *thread-id-map-lock*
(mp:make-lock :name "thread id map lock"))
(defimplementation spawn (fn &key name)
(mp:process-run-function name fn))
(defimplementation thread-id (target-thread)
(block thread-id
(mp:with-lock (*thread-id-map-lock*)
;; Does TARGET-THREAD have an id already?
(maphash (lambda (id thread-pointer)
(let ((thread (si:weak-pointer-value thread-pointer)))
(cond ((not thread)
(remhash id *thread-id-map*))
((eq thread target-thread)
(return-from thread-id id)))))
*thread-id-map*)
;; TARGET-THREAD not found in *THREAD-ID-MAP*
(let ((id (incf *thread-id-counter*))
(thread-pointer (si:make-weak-pointer target-thread)))
(setf (gethash id *thread-id-map*) thread-pointer)
id))))
(defimplementation find-thread (id)
(mp:with-lock (*thread-id-map-lock*)
(let* ((thread-ptr (gethash id *thread-id-map*))
(thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
(unless thread
(remhash id *thread-id-map*))
thread)))
(defimplementation thread-name (thread)
(mp:process-name thread))
(defimplementation thread-status (thread)
(if (mp:process-active-p thread)
"RUNNING"
"STOPPED"))
;; thread-attributes
(defimplementation current-thread ()
mp:*current-process*)
(defimplementation all-threads ()
(mp:all-processes))
(defimplementation thread-alive-p (thread)
(mp:process-active-p thread))
(defimplementation interrupt-thread (thread fn)
(mp:interrupt-process thread fn))
(defimplementation kill-thread (thread)
(mp:process-kill thread))
(defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
(defvar *mailboxes* (list))
(declaim (type list *mailboxes*))
(defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (mp:make-lock))
(cvar (mp:make-condition-variable))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(mp:with-lock (*mailbox-lock*)
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(mp:with-lock (mutex)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
;; receive
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(mp:with-lock (mutex)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail))))
(when (eq timeout t) (return (values nil t)))
(mp:condition-variable-wait (mailbox.cvar mbox) mutex)))))
;; Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using
;; asynchronous interrupts.
;;
;; Doesn't have to implement this if RECEIVE-IF periodically calls
;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient.
;;
;; wake-thread (thread)
;; Copied from sbcl.lisp and adjusted to ECL.
(let ((alist '())
(mutex (mp:make-lock :name "register-thread")))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(mp:with-lock (mutex)
(etypecase thread
(null
(setf alist (delete name alist :key #'car)))
(mp:process
(let ((probe (assoc name alist)))
(cond (probe (setf (cdr probe) thread))
(t (setf alist (acons name thread alist))))))))
nil)
(defimplementation find-registered (name)
(mp:with-lock (mutex)
(cdr (assoc name alist)))))
;; Not needed in ECL (?).
;;
;; set-default-initial-binding (var form)
) ; #+threads
;;; Instead of busy waiting with communication-style NIL, use select()
;;; on the sockets' streams.
#+serve-event
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(flet ((poll-streams (streams timeout)
(let* ((serve-event::*descriptor-handlers*
(copy-list serve-event::*descriptor-handlers*))
(active-fds '())
(fd-stream-alist
(loop for s in streams
for fd = (socket-fd s)
collect (cons fd s)
do (serve-event:add-fd-handler fd :input
#'(lambda (fd)
(push fd active-fds))))))
(serve-event:serve-event timeout)
(loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))))
(loop
(cond ((check-slime-interrupts) (return :interrupt))
(timeout (return (poll-streams streams 0)))
(t
(when-let (ready (poll-streams streams 0.2))
(return ready)))))))
#-serve-event
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(loop
(cond ((check-slime-interrupts) (return :interrupt))
(timeout (return (remove-if-not #'listen streams)))
(t
(let ((ready (remove-if-not #'listen streams)))
(if ready (return ready))
(sleep 0.1))))))
;;;; Locks
#+threads
(defimplementation make-lock (&key name)
(mp:make-lock :name name :recursive t))
(defimplementation call-with-lock-held (lock function)
(declare (type function function))
(mp:with-lock (lock) (funcall function)))
;;;; Weak datastructures
;;; XXX: this should work but causes SLIME REPL hang at some point of time. May
;;; be ECL or SLIME bug - disabling for now.
#+(and ecl-weak-hash (or))
(progn
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weakness :key args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weakness :value args))
(defimplementation hash-table-weakness (hashtable)
(ext:hash-table-weakness hashtable)))
;;;; Character names
;;; Default implementation is fine.
;;;
;;; character-completion-set (prefix matchp)
;;;; Heap dumps
;;; Doesn't apply to ECL.
;;;
;;; save-image (filename &optional restart-function)
;;; background-save-image (filename &key restart-function completion-function)
;;;; Wrapping
;;; Intercept future calls to SPEC and surround them in callbacks.
;;; Very much similar to so-called advices for normal functions.
;;;
;;; wrap (spec indicator &key before after replace)
;;; unwrap (spec indicator)
;;; wrapped-p (spec indicator)
;;;
;;; slynk-corman.lisp --- Corman Lisp specific code for SLY.
;;;
;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
;;;
;;; License
;;; =======
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the author be held liable for any damages
;;; arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any purpose,
;;; including commercial applications, and to alter it and redistribute
;;; it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;; not claim that you wrote the original software. If you use this
;;; software in a product, an acknowledgment in the product documentation
;;; would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;; not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source
;;; distribution.
;;;
;;; Notes
;;; =====
;;; You will need CCL 2.51, and you will *definitely* need to patch
;;; CCL with the patches at
;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLY
;;; will blow up in your face. You should also follow the
;;; instructions on http://www.grumblesmurf.org/lisp/corman-sly.
;;;
;;; The only communication style currently supported is NIL.
;;;
;;; Starting CCL inside emacs (with M-x sly) seems to work for me
;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
;;; (sometimes it works, other times it hangs on start or hangs when
;;; initializing WinSock) - starting CCL externally and using M-x
;;; sly-connect always works fine.
;;;
;;; Sometimes CCL gets confused and starts giving you random memory
;;; access violation errors on startup; if this happens, try redumping
;;; your image.
;;;
;;; What works
;;; ==========
;;; * Basic editing and evaluation
;;; * Arglist display
;;; * Compilation
;;; * Loading files
;;; * apropos/describe
;;; * Debugger
;;; * Inspector
;;;
;;; TODO
;;; ====
;;; * More debugger functionality (missing bits: restart-frame,
;;; return-from-frame, disassemble-frame, activate-stepping,
;;; toggle-trace)
;;; * XREF
;;; * Profiling
;;; * More sophisticated communication styles than NIL
;;;
(in-package :slynk-backend)
;;; Pull in various needed bits
(require :composite-streams)
(require :sockets)
(require :winbase)
(require :lp)
(use-package :gs)
;; MOP stuff
(defclass slynk-mop:standard-slot-definition ()
()
(:documentation
"Dummy class created so that slynk.lisp will compile and load."))
(defun named-by-gensym-p (c)
(null (symbol-package (class-name c))))
(deftype slynk-mop:eql-specializer ()
'(satisfies named-by-gensym-p))
(defun slynk-mop:eql-specializer-object (specializer)
(with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
(loop (multiple-value-bind (more key value)
(next-entry)
(unless more (return nil))
(when (eq specializer value)
(return key))))))
(defun slynk-mop:class-finalized-p (class)
(declare (ignore class))
t)
(defun slynk-mop:class-prototype (class)
(make-instance class))
(defun slynk-mop:specializer-direct-methods (obj)
(declare (ignore obj))
nil)
(defun slynk-mop:generic-function-argument-precedence-order (gf)
(generic-function-lambda-list gf))
(defun slynk-mop:generic-function-method-combination (gf)
(declare (ignore gf))
:standard)
(defun slynk-mop:generic-function-declarations (gf)
(declare (ignore gf))
nil)
(defun slynk-mop:slot-definition-documentation (slot)
(declare (ignore slot))
(getf slot :documentation nil))
(defun slynk-mop:slot-definition-type (slot)
(declare (ignore slot))
t)
(import-slynk-mop-symbols :cl '(;; classes
:standard-slot-definition
:eql-specializer
:eql-specializer-object
;; standard class readers
:class-default-initargs
:class-direct-default-initargs
:class-finalized-p
:class-prototype
:specializer-direct-methods
;; gf readers
:generic-function-argument-precedence-order
:generic-function-declarations
:generic-function-method-combination
;; method readers
;; slot readers
:slot-definition-documentation
:slot-definition-type))
;;;; slynk implementations
;;; Debugger
(defvar *stack-trace* nil)
(defvar *frame-trace* nil)
(defstruct frame
name function address debug-info variables)
(defimplementation call-with-debugging-environment (fn)
(let* ((real-stack-trace (cl::stack-trace))
(*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
:key #'car)))
(*frame-trace*
(let* ((db::*debug-level* (1+ db::*debug-level*))
(db::*debug-frame-pointer* (db::stash-ebp
(ct:create-foreign-ptr)))
(db::*debug-max-level* (length real-stack-trace))
(db::*debug-min-level* 1))
(cdr (member #'cl:invoke-debugger
(cons
(make-frame :function nil)
(loop for i from db::*debug-min-level*
upto db::*debug-max-level*
until (eq (db::get-frame-function i)
cl::*top-level*)
collect
(make-frame
:function (db::get-frame-function i)
:address (db::get-frame-address i))))
:key #'frame-function)))))
(funcall fn)))
(defimplementation compute-backtrace (start end)
(loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
collect f))
(defimplementation print-frame (frame stream)
(format stream "~S" frame))
(defun get-frame-debug-info (frame)
(or (frame-debug-info frame)
(setf (frame-debug-info frame)
(db::prepare-frame-debug-info (frame-function frame)
(frame-address frame)))))
(defimplementation frame-locals (frame-number)
(let* ((frame (elt *frame-trace* frame-number))
(info (get-frame-debug-info frame)))
(let ((var-list
(loop for i from 4 below (length info) by 2
collect `(list :name ',(svref info i) :id 0
:value (db::debug-filter ,(svref info i))))))
(let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
(setf (frame-variables frame) vars)))))
(defimplementation eval-in-frame (form frame-number)
(let ((frame (elt *frame-trace* frame-number)))
(let ((cl::*compiler-environment* (get-frame-debug-info frame)))
(eval form))))
(defimplementation frame-var-value (frame-number var)
(let ((vars (frame-variables (elt *frame-trace* frame-number))))
(when vars
(second (elt vars var)))))
(defimplementation frame-source-location (frame-number)
(fspec-location (frame-function (elt *frame-trace* frame-number))))
(defun break (&optional (format-control "Break") &rest format-arguments)
(with-simple-restart (continue "Return from BREAK.")
(let ();(*debugger-hook* nil))
(let ((condition
(make-condition 'simple-condition
:format-control format-control
:format-arguments format-arguments)))
;;(format *debug-io* ";;; User break: ~A~%" condition)
(invoke-debugger condition))))
nil)
;;; Socket communication
(defimplementation create-socket (host port &key backlog)
(sockets:start-sockets)
(sockets:make-server-socket :host host :port port))
(defimplementation local-port (socket)
(sockets:socket-port socket))
(defimplementation close-socket (socket)
(close socket))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering timeout external-format))
(sockets:make-socket-stream (sockets:accept-socket socket)))
;;; Misc
(defimplementation preferred-communication-style ()
nil)
(defimplementation getpid ()
ccl:*current-process-id*)
(defimplementation lisp-implementation-type-name ()
"cormanlisp")
(defimplementation quit-lisp ()
(sockets:stop-sockets)
(win32:exitprocess 0))
(defimplementation set-default-directory (directory)
(setf (ccl:current-directory) directory)
(directory-namestring (setf *default-pathname-defaults*
(truename (merge-pathnames directory)))))
(defimplementation default-directory ()
(directory-namestring (ccl:current-directory)))
(defimplementation macroexpand-all (form &optional env)
(declare (ignore env))
(ccl:macroexpand-all form))
;;; Documentation
(defun fspec-location (fspec)
(when (symbolp fspec)
(setq fspec (symbol-function fspec)))
(let ((file (ccl::function-source-file fspec)))
(if file
(handler-case
(let ((truename (truename
(merge-pathnames file
ccl:*cormanlisp-directory*))))
(make-location (list :file (namestring truename))
(if (ccl::function-source-line fspec)
(list :line
(1+ (ccl::function-source-line fspec)))
(list :function-name
(princ-to-string
(function-name fspec))))))
(error (c) (list :error (princ-to-string c))))
(list :error (format nil "No source information available for ~S"
fspec)))))
(defimplementation find-definitions (name)
(list (list name (fspec-location name))))
(defimplementation arglist (name)
(handler-case
(cond ((and (symbolp name)
(macro-function name))
(ccl::macro-lambda-list (symbol-function name)))
(t
(when (symbolp name)
(setq name (symbol-function name)))
(if (eq (class-of name) cl::the-class-standard-gf)
(generic-function-lambda-list name)
(ccl:function-lambda-list name))))
(error () :not-available)))
(defimplementation function-name (fn)
(handler-case (getf (cl::function-info-list fn) 'cl::function-name)
(error () nil)))
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind &optional (sym symbol))
(or (documentation sym kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (when (boundp symbol)
(doc 'variable)))
(maybe-push
:function (if (fboundp symbol)
(doc 'function)))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
result)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(:class
(describe (find-class symbol)))))
;;; Compiler
(defvar *buffer-name* nil)
(defvar *buffer-position*)
(defvar *buffer-string*)
(defvar *compile-filename* nil)
;; FIXME
(defimplementation call-with-compilation-hooks (FN)
(handler-bind ((error (lambda (c)
(signal 'compiler-condition
:original-condition c
:severity :warning
:message (format nil "~A" c)
:location
(cond (*buffer-name*
(make-location
(list :buffer *buffer-name*)
(list :offset *buffer-position* 0)))
(*compile-filename*
(make-location
(list :file *compile-filename*)
(list :position 1)))
(t
(list :error "No location")))))))
(funcall fn)))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore external-format policy))
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(*compile-filename* input-file))
(multiple-value-bind (output-file warnings? failure?)
(compile-file input-file :output-file output-file)
(values output-file warnings?
(or failure? (and load-p (load output-file))))))))
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore filename line column policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-position* position)
(*buffer-string* string))
(funcall (compile nil (read-from-string
(format nil "(~S () ~A)" 'lambda string))))
t)))
;;;; Inspecting
;; Hack to make slynk.lisp load, at least
(defclass file-stream ())
(defun comma-separated (list &optional (callback (lambda (v)
`(:value ,v))))
(butlast (loop for e in list
collect (funcall callback e)
collect ", ")))
(defmethod emacs-inspect ((class standard-class))
`("Name: "
(:value ,(class-name class))
(:newline)
"Super classes: "
,@(comma-separated (slynk-mop:class-direct-superclasses class))
(:newline)
"Direct Slots: "
,@(comma-separated
(slynk-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot
,(princ-to-string
(slynk-mop:slot-definition-name slot)))))
(:newline)
"Effective Slots: "
,@(if (slynk-mop:class-finalized-p class)
(comma-separated
(slynk-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string
(slynk-mop:slot-definition-name slot)))))
'("#<N/A (class not finalized)>"))
(:newline)
,@(when (documentation class t)
`("Documentation:" (:newline) ,(documentation class t) (:newline)))
"Sub classes: "
,@(comma-separated (slynk-mop:class-direct-subclasses class)
(lambda (sub)
`(:value ,sub ,(princ-to-string (class-name sub)))))
(:newline)
"Precedence List: "
,@(if (slynk-mop:class-finalized-p class)
(comma-separated
(slynk-mop:class-precedence-list class)
(lambda (class)
`(:value ,class
,(princ-to-string (class-name class)))))
'("#<N/A (class not finalized)>"))
(:newline)))
(defmethod emacs-inspect ((slot cons))
;; Inspects slot definitions
(if (eq (car slot) :name)
`("Name: " (:value ,(slynk-mop:slot-definition-name slot))
(:newline)
,@(when (slynk-mop:slot-definition-documentation slot)
`("Documentation:"
(:newline)
(:value
,(slynk-mop:slot-definition-documentation slot))
(:newline)))
"Init args: " (:value
,(slynk-mop:slot-definition-initargs slot))
(:newline)
"Init form: "
,(if (slynk-mop:slot-definition-initfunction slot)
`(:value ,(slynk-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: "
(:value ,(slynk-mop:slot-definition-initfunction slot))
(:newline))
(call-next-method)))
(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
(list* (if (wild-pathname-p pathname)
"A wild pathname."
"A pathname.")
'(:newline)
(append (label-value-line*
("Namestring" (namestring pathname))
("Host" (pathname-host pathname))
("Device" (pathname-device pathname))
("Directory" (pathname-directory pathname))
("Name" (pathname-name pathname))
("Type" (pathname-type pathname))
("Version" (pathname-version pathname)))
(unless (or (wild-pathname-p pathname)
(not (probe-file pathname)))
(label-value-line "Truename" (truename pathname))))))
(defmethod emacs-inspect ((o t))
(cond ((cl::structurep o) (inspect-structure o))
(t (call-next-method))))
(defun inspect-structure (o)
(let* ((template (cl::uref o 1))
(num-slots (cl::struct-template-num-slots template)))
(cond ((symbolp template)
(loop for i below num-slots
append (label-value-line i (cl::uref o (+ 2 i)))))
(t
(loop for i below num-slots
append (label-value-line (elt template (+ 6 (* i 5)))
(cl::uref o (+ 2 i))))))))
;;; Threads
(require 'threads)
(defstruct (mailbox (:conc-name mailbox.))
thread
(lock (make-instance 'threads:critical-section))
(queue '() :type list))
(defvar *mailbox-lock* (make-instance 'threads:critical-section))
(defvar *mailboxes* (list))
(defmacro with-lock (lock &body body)
`(threads:with-synchronization (threads:cs ,lock)
,@body))
(defimplementation spawn (fun &key name)
(declare (ignore name))
(th:create-thread
(lambda ()
(handler-bind ((serious-condition #'invoke-debugger))
(unwind-protect (funcall fun)
(with-lock *mailbox-lock*
(setq *mailboxes* (remove cormanlisp:*current-thread-id*
*mailboxes* :key #'mailbox.thread))))))))
(defimplementation thread-id (thread)
thread)
(defimplementation find-thread (thread)
(if (thread-alive-p thread)
thread))
(defimplementation thread-alive-p (thread)
(if (threads:thread-handle thread) t nil))
(defimplementation current-thread ()
cormanlisp:*current-thread-id*)
;; XXX implement it
(defimplementation all-threads ()
'())
;; XXX something here is broken
(defimplementation kill-thread (thread)
(threads:terminate-thread thread 'killed))
(defun mailbox (thread)
(with-lock *mailbox-lock*
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(with-lock (mailbox.lock mbox)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
(defimplementation receive ()
(let ((mbox (mailbox cormanlisp:*current-thread-id*)))
(loop
(with-lock (mailbox.lock mbox)
(when (mailbox.queue mbox)
(return (pop (mailbox.queue mbox)))))
(sleep 0.1))))
;;; This is probably not good, but it WFM
(in-package :common-lisp)
(defvar *old-documentation* #'documentation)
(defun documentation (thing &optional (type 'function))
(if (symbolp thing)
(funcall *old-documentation* thing type)
(values)))
(defmethod print-object ((restart restart) stream)
(if (or *print-escape*
*print-readably*)
(print-unreadable-object (restart stream :type t :identity t)
(princ (restart-name restart) stream))
(when (functionp (restart-report-function restart))
(funcall (restart-report-function restart) stream))))
;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
;;;
;;; License: Public Domain
;;;
;;;; Introduction
;;;
;;; This is the CMUCL implementation of the `slynk-backend' package.
(defpackage slynk-cmucl
(:use cl slynk-backend slynk-source-path-parser slynk-source-file-cache
fwrappers))
(in-package slynk-cmucl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((min-version #x20c))
(assert (>= c:byte-fasl-file-version min-version)
() "This file requires CMUCL version ~x or newer" min-version))
(require 'gray-streams))
(import-slynk-mop-symbols :pcl '(:slot-definition-documentation))
(defun slynk-mop:slot-definition-documentation (slot)
(documentation slot t))
;;; UTF8
(locally (declare (optimize (ext:inhibit-warnings 3)))
;; Compile and load the utf8 format, if not already loaded.
(stream::find-external-format :utf-8))
(defimplementation string-to-utf8 (string)
(let ((ef (load-time-value (stream::find-external-format :utf-8) t)))
(stream:string-to-octets string :external-format ef)))
(defimplementation utf8-to-string (octets)
(let ((ef (load-time-value (stream::find-external-format :utf-8) t)))
(stream:octets-to-string octets :external-format ef)))
;;;; TCP server
;;;
;;; In CMUCL we support all communication styles. By default we use
;;; `:SIGIO' because it is the most responsive, but it's somewhat
;;; dangerous: CMUCL is not in general "signal safe", and you don't
;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
;;; `:SPAWN' are reasonable alternatives.
(defimplementation preferred-communication-style ()
:sigio)
#-(or darwin mips)
(defimplementation create-socket (host port &key backlog)
(let* ((addr (resolve-hostname host))
(addr (if (not (find-symbol "SOCKET-ERROR" :ext))
(ext:htonl addr)
addr)))
(ext:create-inet-listener port :stream :reuse-address t :host addr
:backlog (or backlog 5))))
;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix.
#+(or darwin mips)
(defimplementation create-socket (host port &key backlog)
(declare (ignore host))
(ext:create-inet-listener port :stream :reuse-address t))
(defimplementation local-port (socket)
(nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
(defimplementation close-socket (socket)
(let ((fd (socket-fd socket)))
(sys:invalidate-descriptor fd)
(ext:close-socket fd)))
(defimplementation accept-connection (socket &key
external-format buffering timeout)
(declare (ignore timeout))
(make-socket-io-stream (ext:accept-tcp-connection socket)
(ecase buffering
((t) :full)
(:line :line)
((nil) :none))
external-format))
;;;;; Sockets
(defimplementation socket-fd (socket)
"Return the filedescriptor for the socket represented by SOCKET."
(etypecase socket
(fixnum socket)
(sys:fd-stream (sys:fd-stream-fd socket))))
(defun resolve-hostname (hostname)
"Return the IP address of HOSTNAME as an integer (in host byte-order)."
(let ((hostent (ext:lookup-host-entry hostname)))
(car (ext:host-entry-addr-list hostent))))
(defvar *external-format-to-coding-system*
'((:iso-8859-1 "iso-latin-1-unix")
#+unicode
(:utf-8 "utf-8-unix")))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
(defun make-socket-io-stream (fd buffering external-format)
"Create a new input/output fd-stream for FD."
(cond (external-format
(sys:make-fd-stream fd :input t :output t
:element-type 'character
:buffering buffering
:external-format external-format))
(t
(sys:make-fd-stream fd :input t :output t
:element-type '(unsigned-byte 8)
:buffering buffering))))
(defimplementation make-fd-stream (fd external-format)
(make-socket-io-stream fd :full external-format))
(defimplementation dup (fd)
(multiple-value-bind (clone error) (unix:unix-dup fd)
(unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error)))
clone))
(defimplementation command-line-args ()
ext:*command-line-strings*)
(defimplementation exec-image (image-file args)
(multiple-value-bind (ok error)
(unix:unix-execve (car (command-line-args))
(list* (car (command-line-args))
"-core" image-file
"-noinit"
args))
(error "~a" (unix:get-unix-error-msg error))
ok))
;;;;; Signal-driven I/O
(defimplementation install-sigint-handler (function)
(sys:enable-interrupt :sigint (lambda (signal code scp)
(declare (ignore signal code scp))
(funcall function))))
(defvar *sigio-handlers* '()
"List of (key . function) pairs.
All functions are called on SIGIO, and the key is used for removing
specific functions.")
(defun reset-sigio-handlers () (setq *sigio-handlers* '()))
;; All file handlers are invalid afer reload.
(pushnew 'reset-sigio-handlers ext:*after-save-initializations*)
(defun set-sigio-handler ()
(sys:enable-interrupt :sigio (lambda (signal code scp)
(sigio-handler signal code scp))))
(defun sigio-handler (signal code scp)
(declare (ignore signal code scp))
(mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
(defun fcntl (fd command arg)
"fcntl(2) - manipulate a file descriptor."
(multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
(cond (ok)
(t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
(defimplementation add-sigio-handler (socket fn)
(set-sigio-handler)
(let ((fd (socket-fd socket)))
(fcntl fd unix:f-setown (unix:unix-getpid))
(let ((old-flags (fcntl fd unix:f-getfl 0)))
(fcntl fd unix:f-setfl (logior old-flags unix:fasync)))
(assert (not (assoc fd *sigio-handlers*)))
(push (cons fd fn) *sigio-handlers*)))
(defimplementation remove-sigio-handlers (socket)
(let ((fd (socket-fd socket)))
(when (assoc fd *sigio-handlers*)
(setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
(let ((old-flags (fcntl fd unix:f-getfl 0)))
(fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync)))
(sys:invalidate-descriptor fd))
(assert (not (assoc fd *sigio-handlers*)))
(when (null *sigio-handlers*)
(sys:default-interrupt :sigio))))
;;;;; SERVE-EVENT
(defimplementation add-fd-handler (socket fn)
(let ((fd (socket-fd socket)))
(sys:add-fd-handler fd :input (lambda (_) _ (funcall fn)))))
(defimplementation remove-fd-handlers (socket)
(sys:invalidate-descriptor (socket-fd socket)))
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(loop
(let ((ready (remove-if-not #'listen streams)))
(when ready (return ready)))
(when timeout (return nil))
(multiple-value-bind (in out) (make-pipe)
(let* ((f (constantly t))
(handlers (loop for s in (cons in (mapcar #'to-fd-stream streams))
collect (add-one-shot-handler s f))))
(unwind-protect
(let ((*interrupt-queued-handler* (lambda ()
(write-char #\! out))))
(when (check-sly-interrupts) (return :interrupt))
(sys:serve-event))
(mapc #'sys:remove-fd-handler handlers)
(close in)
(close out))))))
(defun to-fd-stream (stream)
(etypecase stream
(sys:fd-stream stream)
(synonym-stream
(to-fd-stream
(symbol-value (synonym-stream-symbol stream))))
(two-way-stream
(to-fd-stream (two-way-stream-input-stream stream)))))
(defun add-one-shot-handler (stream function)
(let (handler)
(setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input
(lambda (fd)
(declare (ignore fd))
(sys:remove-fd-handler handler)
(funcall function stream))))))
(defun make-pipe ()
(multiple-value-bind (in out) (unix:unix-pipe)
(values (sys:make-fd-stream in :input t :buffering :none)
(sys:make-fd-stream out :output t :buffering :none))))
;;;; Stream handling
(defimplementation gray-package-name ()
"EXT")
;;;; Compilation Commands
(defvar *previous-compiler-condition* nil
"Used to detect duplicates.")
(defvar *previous-context* nil
"Previous compiler error context.")
(defvar *buffer-name* nil
"The name of the Emacs buffer we are compiling from.
NIL if we aren't compiling from a buffer.")
(defvar *buffer-start-position* nil)
(defvar *buffer-substring* nil)
(defimplementation call-with-compilation-hooks (function)
(let ((*previous-compiler-condition* nil)
(*previous-context* nil)
(*print-readably* nil))
(handler-bind ((c::compiler-error #'handle-notification-condition)
(c::style-warning #'handle-notification-condition)
(c::warning #'handle-notification-condition))
(funcall function))))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(clear-xref-info input-file)
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(ext:*ignore-extra-close-parentheses* nil))
(multiple-value-bind (output-file warnings-p failure-p)
(compile-file input-file :output-file output-file
:external-format external-format)
(values output-file warnings-p
(or failure-p
(when load-p
;; Cache the latest source file for definition-finding.
(source-cache-get input-file
(file-write-date input-file))
(not (load output-file)))))))))
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore filename line column policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
(*buffer-substring* string)
(source-info (list :emacs-buffer buffer
:emacs-buffer-offset position
:emacs-buffer-string string)))
(with-input-from-string (stream string)
(let ((failurep (ext:compile-from-stream stream :source-info
source-info)))
(not failurep))))))
;;;;; Trapping notes
;;;
;;; We intercept conditions from the compiler and resignal them as
;;; `SLYNK:COMPILER-CONDITION's.
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning."
(unless (eq condition *previous-compiler-condition*)
(let ((context (c::find-error-context nil)))
(setq *previous-compiler-condition* condition)
(setq *previous-context* context)
(signal-compiler-condition condition context))))
(defun signal-compiler-condition (condition context)
(signal 'compiler-condition
:original-condition condition
:severity (severity-for-emacs condition)
:message (compiler-condition-message condition)
:source-context (compiler-error-context context)
:location (if (read-error-p condition)
(read-error-location condition)
(compiler-note-location context))))
(defun severity-for-emacs (condition)
"Return the severity of CONDITION."
(etypecase condition
((satisfies read-error-p) :read-error)
(c::compiler-error :error)
(c::style-warning :note)
(c::warning :warning)))
(defun read-error-p (condition)
(eq (type-of condition) 'c::compiler-read-error))
(defun compiler-condition-message (condition)
"Briefly describe a compiler error for Emacs.
When Emacs presents the message it already has the source popped up
and the source form highlighted. This makes much of the information in
the error-context redundant."
(princ-to-string condition))
(defun compiler-error-context (error-context)
"Describe context information for Emacs."
(declare (type (or c::compiler-error-context null) error-context))
(multiple-value-bind (enclosing source)
(if error-context
(values (c::compiler-error-context-enclosing-source error-context)
(c::compiler-error-context-source error-context)))
(if (or enclosing source)
(format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~
~@[==>~{~&~A~}~]"
enclosing source))))
(defun read-error-location (condition)
(let* ((finfo (car (c::source-info-current-file c::*source-info*)))
(file (c::file-info-name finfo))
(pos (c::compiler-read-error-position condition)))
(cond ((and (eq file :stream) *buffer-name*)
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position* pos)))
((and (pathnamep file) (not *buffer-name*))
(make-location (list :file (unix-truename file))
(list :position (1+ pos))))
(t (break)))))
(defun compiler-note-location (context)
"Derive the location of a complier message from its context.
Return a `location' record, or (:error REASON) on failure."
(if (null context)
(note-error-location)
(with-struct (c::compiler-error-context- file-name
original-source
original-source-path) context
(or (locate-compiler-note file-name original-source
(reverse original-source-path))
(note-error-location)))))
(defun note-error-location ()
"Pseudo-location for notes that can't be located."
(cond (*compile-file-truename*
(make-location (list :file (unix-truename *compile-file-truename*))
(list :eof)))
(*buffer-name*
(make-location (list :buffer *buffer-name*)
(list :position *buffer-start-position*)))
(t (list :error "No error location available."))))
(defun locate-compiler-note (file source source-path)
(cond ((and (eq file :stream) *buffer-name*)
;; Compiling from a buffer
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position*
(source-path-string-position
source-path *buffer-substring*))))
((and (pathnamep file) (null *buffer-name*))
;; Compiling from a file
(make-location (list :file (unix-truename file))
(list :position (1+ (source-path-file-position
source-path file)))))
((and (eq file :lisp) (stringp source))
;; No location known, but we have the source form.
;; XXX How is this case triggered? -luke (16/May/2004)
;; This can happen if the compiler needs to expand a macro
;; but the macro-expander is not yet compiled. Calling the
;; (interpreted) macro-expander triggers IR1 conversion of
;; the lambda expression for the expander and invokes the
;; compiler recursively.
(make-location (list :source-form source)
(list :position 1)))))
(defun unix-truename (pathname)
(ext:unix-namestring (truename pathname)))
;;;; XREF
;;;
;;; Cross-reference support is based on the standard CMUCL `XREF'
;;; package. This package has some caveats: XREF information is
;;; recorded during compilation and not preserved in fasl files, and
;;; XREF recording is disabled by default. Redefining functions can
;;; also cause duplicate references to accumulate, but
;;; `slynk-compile-file' will automatically clear out any old records
;;; from the same filename.
;;;
;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
;;; clear out the XREF database call `xref:init-xref-database'.
(defmacro defxref (name function)
`(defimplementation ,name (name)
(xref-results (,function name))))
(defxref who-calls xref:who-calls)
(defxref who-references xref:who-references)
(defxref who-binds xref:who-binds)
(defxref who-sets xref:who-sets)
;;; More types of XREF information were added since 18e:
;;;
(defxref who-macroexpands xref:who-macroexpands)
;; XXX
(defimplementation who-specializes (symbol)
(let* ((methods (xref::who-specializes (find-class symbol)))
(locations (mapcar #'method-location methods)))
(mapcar #'list methods locations)))
(defun xref-results (contexts)
(mapcar (lambda (xref)
(list (xref:xref-context-name xref)
(resolve-xref-location xref)))
contexts))
(defun resolve-xref-location (xref)
(let ((name (xref:xref-context-name xref))
(file (xref:xref-context-file xref))
(source-path (xref:xref-context-source-path xref)))
(cond ((and file source-path)
(let ((position (source-path-file-position source-path file)))
(make-location (list :file (unix-truename file))
(list :position (1+ position)))))
(file
(make-location (list :file (unix-truename file))
(list :function-name (string name))))
(t
`(:error ,(format nil "Unknown source location: ~S ~S ~S "
name file source-path))))))
(defun clear-xref-info (namestring)
"Clear XREF notes pertaining to NAMESTRING.
This is a workaround for a CMUCL bug: XREF records are cumulative."
(when c:*record-xref-info*
(let ((filename (truename namestring)))
(dolist (db (list xref::*who-calls*
xref::*who-is-called*
xref::*who-macroexpands*
xref::*who-references*
xref::*who-binds*
xref::*who-sets*))
(maphash (lambda (target contexts)
;; XXX update during traversal?
(setf (gethash target db)
(delete filename contexts
:key #'xref:xref-context-file
:test #'equalp)))
db)))))
;;;; Find callers and callees
;;;
;;; Find callers and callees by looking at the constant pool of
;;; compiled code objects. We assume every fdefn object in the
;;; constant pool corresponds to a call to that function. A better
;;; strategy would be to use the disassembler to find actual
;;; call-sites.
(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t))
(map-cpool (code fun)
(declare (type kernel:code-component code) (type function fun))
(loop for i from vm:code-constants-offset
below (kernel:get-header-data code)
do (funcall fun (kernel:code-header-ref code i))))
(callees (fun)
(let ((callees (make-stack)))
(map-cpool (vm::find-code-object fun)
(lambda (o)
(when (kernel:fdefn-p o)
(vector-push-extend (kernel:fdefn-function o)
callees))))
(coerce callees 'list)))
(callers (fun)
(declare (function fun))
(let ((callers (make-stack)))
(ext:gc :full t)
;; scan :dynamic first to avoid the need for even more gcing
(dolist (space '(:dynamic :read-only :static))
(vm::map-allocated-objects
(lambda (obj header size)
(declare (type fixnum header) (ignore size))
(when (= vm:code-header-type header)
(map-cpool obj
(lambda (c)
(when (and (kernel:fdefn-p c)
(eq (kernel:fdefn-function c) fun))
(vector-push-extend obj callers))))))
space)
(ext:gc))
(coerce callers 'list)))
(entry-points (code)
(loop for entry = (kernel:%code-entry-points code)
then (kernel::%function-next entry)
while entry
collect entry))
(guess-main-entry-point (entry-points)
(or (find-if (lambda (fun)
(ext:valid-function-name-p
(kernel:%function-name fun)))
entry-points)
(car entry-points)))
(fun-dspec (fun)
(list (kernel:%function-name fun) (function-location fun)))
(code-dspec (code)
(let ((eps (entry-points code))
(di (kernel:%code-debug-info code)))
(cond (eps (fun-dspec (guess-main-entry-point eps)))
(di (list (c::debug-info-name di)
(debug-info-function-name-location di)))
(t (list (princ-to-string code)
`(:error "No src-loc available")))))))
(declare (inline map-cpool))
(defimplementation list-callers (symbol)
(mapcar #'code-dspec (callers (coerce symbol 'function) )))
(defimplementation list-callees (symbol)
(mapcar #'fun-dspec (callees symbol))))
(defun test-list-callers (count)
(let ((funsyms '()))
(do-all-symbols (s)
(when (and (fboundp s)
(functionp (symbol-function s))
(not (macro-function s))
(not (special-operator-p s)))
(push s funsyms)))
(let ((len (length funsyms)))
(dotimes (i count)
(let ((sym (nth (random len) funsyms)))
(format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym))))))))
;; (test-list-callers 100)
;;;; Resolving source locations
;;;
;;; Our mission here is to "resolve" references to code locations into
;;; actual file/buffer names and character positions. The references
;;; we work from come out of the compiler's statically-generated debug
;;; information, such as `code-location''s and `debug-source''s. For
;;; more details, see the "Debugger Programmer's Interface" section of
;;; the CMUCL manual.
;;;
;;; The first step is usually to find the corresponding "source-path"
;;; for the location. Once we have the source-path we can pull up the
;;; source file and `READ' our way through to the right position. The
;;; main source-code groveling work is done in
;;; `slynk-source-path-parser.lisp'.
(defvar *debug-definition-finding* nil
"When true don't handle errors while looking for definitions.
This is useful when debugging the definition-finding code.")
(defmacro safe-definition-finding (&body body)
"Execute BODY and return the source-location it returns.
If an error occurs and `*debug-definition-finding*' is false, then
return an error pseudo-location.
The second return value is NIL if no error occurs, otherwise it is the
condition object."
`(flet ((body () ,@body))
(if *debug-definition-finding*
(body)
(handler-case (values (progn ,@body) nil)
(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'."
(safe-definition-finding
(source-location-from-code-location code-location)))
(defun source-location-from-code-location (code-location)
"Return the source location for CODE-LOCATION."
(let ((debug-fun (di:code-location-debug-function code-location)))
(when (di::bogus-debug-function-p debug-fun)
;; Those lousy cheapskates! They've put in a bogus debug source
;; because the code was compiled at a low debug setting.
(error "Bogus debug function: ~A" debug-fun)))
(let* ((debug-source (di:code-location-debug-source code-location))
(from (di:debug-source-from debug-source))
(name (di:debug-source-name debug-source)))
(ecase from
(:file
(location-in-file name code-location debug-source))
(:stream
(location-in-stream code-location debug-source))
(:lisp
;; The location comes from a form passed to `compile'.
;; The best we can do is return the form itself for printing.
(make-location
(list :source-form (with-output-to-string (*standard-output*)
(debug::print-code-location-source-form
code-location 100 t)))
(list :position 1))))))
(defun location-in-file (filename code-location debug-source)
"Resolve the source location for CODE-LOCATION in FILENAME."
(let* ((code-date (di:debug-source-created debug-source))
(root-number (di:debug-source-root-number debug-source))
(source-code (get-source-code filename code-date)))
(with-input-from-string (s source-code)
(make-location (list :file (unix-truename filename))
(list :position (1+ (code-location-stream-position
code-location s root-number)))
`(:snippet ,(read-snippet s))))))
(defun location-in-stream (code-location debug-source)
"Resolve the source location for a CODE-LOCATION from a stream.
This only succeeds if the code was compiled from an Emacs buffer."
(unless (debug-source-info-from-emacs-buffer-p debug-source)
(error "The code is compiled from a non-SLY stream."))
(let* ((info (c::debug-source-info debug-source))
(string (getf info :emacs-buffer-string))
(position (code-location-string-offset
code-location
string)))
(make-location
(list :buffer (getf info :emacs-buffer))
(list :offset (getf info :emacs-buffer-offset) position)
(list :snippet (with-input-from-string (s string)
(file-position s position)
(read-snippet s))))))
;;;;; Function-name locations
;;;
(defun debug-info-function-name-location (debug-info)
"Return a function-name source-location for DEBUG-INFO.
Function-name source-locations are a fallback for when precise
positions aren't available."
(with-struct (c::debug-info- (fname name) source) debug-info
(with-struct (c::debug-source- info from name) (car source)
(ecase from
(:file
(make-location (list :file (namestring (truename name)))
(list :function-name (string fname))))
(:stream
(assert (debug-source-info-from-emacs-buffer-p (car source)))
(make-location (list :buffer (getf info :emacs-buffer))
(list :function-name (string fname))))
(:lisp
(make-location (list :source-form (princ-to-string (aref name 0)))
(list :position 1)))))))
(defun debug-source-info-from-emacs-buffer-p (debug-source)
"Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
This is true for functions that were compiled directly from buffers."
(info-from-emacs-buffer-p (c::debug-source-info debug-source)))
(defun info-from-emacs-buffer-p (info)
(and info
(consp info)
(eq :emacs-buffer (car info))))
;;;;; Groveling source-code for positions
(defun code-location-stream-position (code-location stream root)
"Return the byte offset of CODE-LOCATION in STREAM. Extract the
toplevel-form-number and form-number from CODE-LOCATION and use that
to find the position of the corresponding form.
Finish with STREAM positioned at the start of the code location."
(let* ((location (debug::maybe-block-start-location code-location))
(tlf-offset (- (di:code-location-top-level-form-offset location)
root))
(form-number (di:code-location-form-number location)))
(let ((pos (form-number-stream-position tlf-offset form-number stream)))
(file-position stream pos)
pos)))
(defun form-number-stream-position (tlf-number form-number stream)
"Return the starting character position of a form in STREAM.
TLF-NUMBER is the top-level-form number.
FORM-NUMBER is an index into a source-path table for the TLF."
(multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
(let* ((path-table (di:form-number-translations tlf 0))
(source-path
(if (<= (length path-table) form-number) ; source out of sync?
(list 0) ; should probably signal a condition
(reverse (cdr (aref path-table form-number))))))
(source-path-source-position source-path tlf position-map))))
(defun code-location-string-offset (code-location string)
"Return the byte offset of CODE-LOCATION in STRING.
See CODE-LOCATION-STREAM-POSITION."
(with-input-from-string (s string)
(code-location-stream-position code-location s 0)))
;;;; Finding definitions
;;; There are a great many different types of definition for us to
;;; find. We search for definitions of every kind and return them in a
;;; list.
(defimplementation find-definitions (name)
(append (function-definitions name)
(setf-definitions name)
(variable-definitions name)
(class-definitions name)
(type-definitions name)
(compiler-macro-definitions name)
(source-transform-definitions name)
(function-info-definitions name)
(ir1-translator-definitions name)
(template-definitions name)
(primitive-definitions name)
(vm-support-routine-definitions name)
))
;;;;; Functions, macros, generic functions, methods
;;;
;;; We make extensive use of the compile-time debug information that
;;; CMUCL records, in particular "debug functions" and "code
;;; locations." Refer to the "Debugger Programmer's Interface" section
;;; of the CMUCL manual for more details.
(defun function-definitions (name)
"Return definitions for NAME in the \"function namespace\", i.e.,
regular functions, generic functions, methods and macros.
NAME can any valid function name (e.g, (setf car))."
(let ((macro? (and (symbolp name) (macro-function name)))
(function? (and (ext:valid-function-name-p name)
(ext:info :function :definition name)
(if (symbolp name) (fboundp name) t))))
(cond (macro?
(list `((defmacro ,name)
,(function-location (macro-function name)))))
(function?
(let ((function (fdefinition name)))
(if (genericp function)
(gf-definitions name function)
(list (list `(function ,name)
(function-location function)))))))))
;;;;;; Ordinary (non-generic/macro/special) functions
;;;
;;; First we test if FUNCTION is a closure created by defstruct, and
;;; if so extract the defstruct-description (`dd') from the closure
;;; and find the constructor for the struct. Defstruct creates a
;;; defun for the default constructor and we use that as an
;;; approximation to the source location of the defstruct.
;;;
;;; For an ordinary function we return the source location of the
;;; first code-location we find.
;;;
(defun function-location (function)
"Return the source location for FUNCTION."
(cond ((struct-closure-p function)
(struct-closure-location function))
((c::byte-function-or-closure-p function)
(byte-function-location function))
(t
(compiled-function-location function))))
(defun compiled-function-location (function)
"Return the location of a regular compiled function."
(multiple-value-bind (code-location error)
(safe-definition-finding (function-first-code-location function))
(cond (error (list :error (princ-to-string error)))
(t (code-location-source-location code-location)))))
(defun function-first-code-location (function)
"Return the first code-location we can find for FUNCTION."
(and (function-has-debug-function-p function)
(di:debug-function-start-location
(di:function-debug-function function))))
(defun function-has-debug-function-p (function)
(di:function-debug-function function))
(defun function-code-object= (closure function)
(and (eq (vm::find-code-object closure)
(vm::find-code-object function))
(not (eq closure function))))
(defun byte-function-location (fun)
"Return the location of the byte-compiled function FUN."
(etypecase fun
((or c::hairy-byte-function c::simple-byte-function)
(let* ((di (kernel:%code-debug-info (c::byte-function-component fun))))
(if di
(debug-info-function-name-location di)
`(:error
,(format nil "Byte-function without debug-info: ~a" fun)))))
(c::byte-closure
(byte-function-location (c::byte-closure-function fun)))))
;;; Here we deal with structure accessors. Note that `dd' is a
;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
;;; `defstruct''d structure.
(defun struct-closure-p (function)
"Is FUNCTION a closure created by defstruct?"
(or (function-code-object= function #'kernel::structure-slot-accessor)
(function-code-object= function #'kernel::structure-slot-setter)
(function-code-object= function #'kernel::%defstruct)))
(defun struct-closure-location (function)
"Return the location of the structure that FUNCTION belongs to."
(assert (struct-closure-p function))
(safe-definition-finding
(dd-location (struct-closure-dd function))))
(defun struct-closure-dd (function)
"Return the defstruct-definition (dd) of FUNCTION."
(assert (= (kernel:get-type function) vm:closure-header-type))
(flet ((find-layout (function)
(sys:find-if-in-closure
(lambda (x)
(let ((value (if (di::indirect-value-cell-p x)
(c:value-cell-ref x)
x)))
(when (kernel::layout-p value)
(return-from find-layout value))))
function)))
(kernel:layout-info (find-layout function))))
(defun dd-location (dd)
"Return the location of a `defstruct'."
(let ((ctor (struct-constructor dd)))
(cond (ctor
(function-location (coerce ctor 'function)))
(t
(let ((name (kernel:dd-name dd)))
(multiple-value-bind (location foundp)
(ext:info :source-location :defvar name)
(cond (foundp
(resolve-source-location location))
(t
(error "No location for defstruct: ~S" name)))))))))
(defun struct-constructor (dd)
"Return the name of the constructor from a defstruct definition."
(let* ((constructor (or (kernel:dd-default-constructor dd)
(car (kernel::dd-constructors dd)))))
(if (consp constructor) (car constructor) constructor)))
;;;;;; Generic functions and methods
(defun gf-definitions (name function)
"Return the definitions of a generic function and its methods."
(cons (list `(defgeneric ,name) (gf-location function))
(gf-method-definitions function)))
(defun gf-location (gf)
"Return the location of the generic function GF."
(definition-source-location gf (pcl::generic-function-name gf)))
(defun gf-method-definitions (gf)
"Return the locations of all methods of the generic function GF."
(mapcar #'method-definition (pcl::generic-function-methods gf)))
(defun method-definition (method)
(list (method-dspec method)
(method-location method)))
(defun method-dspec (method)
"Return a human-readable \"definition specifier\" for METHOD."
(let* ((gf (pcl:method-generic-function method))
(name (pcl:generic-function-name gf))
(specializers (pcl:method-specializers method))
(qualifiers (pcl:method-qualifiers method)))
`(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
(defun method-location (method)
(typecase method
(pcl::standard-accessor-method
(definition-source-location
(cond ((pcl::definition-source method)
method)
(t
(pcl::slot-definition-class
(pcl::accessor-method-slot-definition method))))
(pcl::accessor-method-slot-name method)))
(t
(function-location (or (pcl::method-fast-function method)
(pcl:method-function method))))))
(defun genericp (fn)
(typep fn 'generic-function))
;;;;;; Types and classes
(defun type-definitions (name)
"Return `deftype' locations for type NAME."
(maybe-make-definition (ext:info :type :expander name) 'deftype name))
(defun maybe-make-definition (function kind name)
"If FUNCTION is non-nil then return its definition location."
(if function
(list (list `(,kind ,name) (function-location function)))))
(defun class-definitions (name)
"Return the definition locations for the class called NAME."
(if (symbolp name)
(let ((class (kernel::find-class name nil)))
(etypecase class
(null '())
(kernel::structure-class
(list (list `(defstruct ,name) (dd-location (find-dd name)))))
#+(or)
(conditions::condition-class
(list (list `(define-condition ,name)
(condition-class-location class))))
(kernel::standard-class
(list (list `(defclass ,name)
(pcl-class-location (find-class name)))))
((or kernel::built-in-class
conditions::condition-class
kernel:funcallable-structure-class)
(list (list `(class ,name) (class-location class))))))))
(defun pcl-class-location (class)
"Return the `defclass' location for CLASS."
(definition-source-location class (pcl:class-name class)))
;; FIXME: eval used for backward compatibility.
(defun class-location (class)
(declare (type kernel::class class))
(let ((name (kernel:%class-name class)))
(multiple-value-bind (loc found?)
(let ((x (ignore-errors
(multiple-value-list
(eval `(ext:info :source-location :class ',name))))))
(values-list x))
(cond (found? (resolve-source-location loc))
(`(:error
,(format nil "No location recorded for class: ~S" name)))))))
(defun find-dd (name)
"Find the defstruct-definition by the name of its structure-class."
(let ((layout (ext:info :type :compiler-layout name)))
(if layout
(kernel:layout-info layout))))
(defun condition-class-location (class)
(let ((slots (conditions::condition-class-slots class))
(name (conditions::condition-class-name class)))
(cond ((null slots)
`(:error ,(format nil "No location info for condition: ~A" name)))
(t
;; Find the class via one of its slot-reader methods.
(let* ((slot (first slots))
(gf (fdefinition
(first (conditions::condition-slot-readers slot)))))
(method-location
(first
(pcl:compute-applicable-methods-using-classes
gf (list (find-class name))))))))))
(defun make-name-in-file-location (file string)
(multiple-value-bind (filename c)
(ignore-errors
(unix-truename (merge-pathnames (make-pathname :type "lisp")
file)))
(cond (filename (make-location `(:file ,filename)
`(:function-name ,(string string))))
(t (list :error (princ-to-string c))))))
(defun source-location-form-numbers (location)
(c::decode-form-numbers (c::form-numbers-form-numbers location)))
(defun source-location-tlf-number (location)
(nth-value 0 (source-location-form-numbers location)))
(defun source-location-form-number (location)
(nth-value 1 (source-location-form-numbers location)))
(defun resolve-file-source-location (location)
(let ((filename (c::file-source-location-pathname location))
(tlf-number (source-location-tlf-number location))
(form-number (source-location-form-number location)))
(with-open-file (s filename)
(let ((pos (form-number-stream-position tlf-number form-number s)))
(make-location `(:file ,(unix-truename filename))
`(:position ,(1+ pos)))))))
(defun resolve-stream-source-location (location)
(let ((info (c::stream-source-location-user-info location))
(tlf-number (source-location-tlf-number location))
(form-number (source-location-form-number location)))
;; XXX duplication in frame-source-location
(assert (info-from-emacs-buffer-p info))
(destructuring-bind (&key emacs-buffer emacs-buffer-string
emacs-buffer-offset) info
(with-input-from-string (s emacs-buffer-string)
(let ((pos (form-number-stream-position tlf-number form-number s)))
(make-location `(:buffer ,emacs-buffer)
`(:offset ,emacs-buffer-offset ,pos)))))))
;; XXX predicates for 18e backward compatibilty. Remove them when
;; we're 19a only.
(defun file-source-location-p (object)
(when (fboundp 'c::file-source-location-p)
(c::file-source-location-p object)))
(defun stream-source-location-p (object)
(when (fboundp 'c::stream-source-location-p)
(c::stream-source-location-p object)))
(defun source-location-p (object)
(or (file-source-location-p object)
(stream-source-location-p object)))
(defun resolve-source-location (location)
(etypecase location
((satisfies file-source-location-p)
(resolve-file-source-location location))
((satisfies stream-source-location-p)
(resolve-stream-source-location location))))
(defun definition-source-location (object name)
(let ((source (pcl::definition-source object)))
(etypecase source
(null
`(:error ,(format nil "No source info for: ~A" object)))
((satisfies source-location-p)
(resolve-source-location source))
(pathname
(make-name-in-file-location source name))
(cons
(destructuring-bind ((dg name) pathname) source
(declare (ignore dg))
(etypecase pathname
(pathname (make-name-in-file-location pathname (string name)))
(null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
(defun setf-definitions (name)
(let ((f (or (ext:info :setf :inverse name)
(ext:info :setf :expander name)
(and (symbolp name)
(fboundp `(setf ,name))
(fdefinition `(setf ,name))))))
(if f
`(((setf ,name) ,(function-location (cond ((functionp f) f)
((macro-function f))
((fdefinition f)))))))))
(defun variable-location (symbol)
(multiple-value-bind (location foundp)
;; XXX for 18e compatibilty. rewrite this when we drop 18e
;; support.
(ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
(if (and foundp location)
(resolve-source-location location)
`(:error ,(format nil "No source info for variable ~S" symbol)))))
(defun variable-definitions (name)
(if (symbolp name)
(multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
(if recorded-p
(list (list `(variable ,kind ,name)
(variable-location name)))))))
(defun compiler-macro-definitions (symbol)
(maybe-make-definition (compiler-macro-function symbol)
'define-compiler-macro
symbol))
(defun source-transform-definitions (name)
(maybe-make-definition (ext:info :function :source-transform name)
'c:def-source-transform
name))
(defun function-info-definitions (name)
(let ((info (ext:info :function :info name)))
(if info
(append (loop for transform in (c::function-info-transforms info)
collect (list `(c:deftransform ,name
,(c::type-specifier
(c::transform-type transform)))
(function-location (c::transform-function
transform))))
(maybe-make-definition (c::function-info-derive-type info)
'c::derive-type name)
(maybe-make-definition (c::function-info-optimizer info)
'c::optimizer name)
(maybe-make-definition (c::function-info-ltn-annotate info)
'c::ltn-annotate name)
(maybe-make-definition (c::function-info-ir2-convert info)
'c::ir2-convert name)
(loop for template in (c::function-info-templates info)
collect (list `(,(type-of template)
,(c::template-name template))
(function-location
(c::vop-info-generator-function
template))))))))
(defun ir1-translator-definitions (name)
(maybe-make-definition (ext:info :function :ir1-convert name)
'c:def-ir1-translator name))
(defun template-definitions (name)
(let* ((templates (c::backend-template-names c::*backend*))
(template (gethash name templates)))
(etypecase template
(null)
(c::vop-info
(maybe-make-definition (c::vop-info-generator-function template)
(type-of template) name)))))
;; for cases like: (%primitive NAME ...)
(defun primitive-definitions (name)
(let ((csym (find-symbol (string name) 'c)))
(and csym
(not (eq csym name))
(template-definitions csym))))
(defun vm-support-routine-definitions (name)
(let ((sr (c::backend-support-routines c::*backend*))
(name (find-symbol (string name) 'c)))
(and name
(slot-exists-p sr name)
(maybe-make-definition (slot-value sr name)
(find-symbol (string 'vm-support-routine) 'c)
name))))
;;;; Documentation.
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (multiple-value-bind (kind recorded-p)
(ext:info variable kind symbol)
(declare (ignore kind))
(if (or (boundp symbol) recorded-p)
(doc 'variable))))
(when (fboundp symbol)
(maybe-push
(cond ((macro-function symbol) :macro)
((special-operator-p symbol) :special-operator)
((genericp (fdefinition symbol)) :generic-function)
(t :function))
(doc 'function)))
(maybe-push
:setf (if (or (ext:info setf inverse symbol)
(ext:info setf expander symbol))
(doc 'setf)))
(maybe-push
:type (if (ext:info type kind symbol)
(doc 'type)))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
(maybe-push
:alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
(doc 'alien-type)))
(maybe-push
:alien-struct (if (ext:info alien-type struct symbol)
(doc nil)))
(maybe-push
:alien-union (if (ext:info alien-type union symbol)
(doc nil)))
(maybe-push
:alien-enum (if (ext:info alien-type enum symbol)
(doc nil)))
result)))
(defimplementation describe-definition (symbol namespace)
(describe (ecase namespace
(:variable
symbol)
((:function :generic-function)
(symbol-function symbol))
(:setf
(or (ext:info setf inverse symbol)
(ext:info setf expander symbol)))
(:type
(kernel:values-specifier-type symbol))
(:class
(find-class symbol))
(:alien-struct
(ext:info :alien-type :struct symbol))
(:alien-union
(ext:info :alien-type :union symbol))
(:alien-enum
(ext:info :alien-type :enum symbol))
(:alien-type
(ecase (ext:info :alien-type :kind symbol)
(:primitive
(let ((alien::*values-type-okay* t))
(funcall (ext:info :alien-type :translator symbol)
(list symbol))))
((:defined)
(ext:info :alien-type :definition symbol))
(:unknown :unkown))))))
;;;;; Argument lists
(defimplementation arglist (fun)
(etypecase fun
(function (function-arglist fun))
(symbol (function-arglist (or (macro-function fun)
(symbol-function fun))))))
(defun function-arglist (fun)
(let ((arglist
(cond ((eval:interpreted-function-p fun)
(eval:interpreted-function-arglist fun))
((pcl::generic-function-p fun)
(pcl:generic-function-lambda-list fun))
((c::byte-function-or-closure-p fun)
(byte-code-function-arglist fun))
((kernel:%function-arglist (kernel:%function-self fun))
(handler-case (read-arglist fun)
(error () :not-available)))
;; this should work both for compiled-debug-function
;; and for interpreted-debug-function
(t
(handler-case (debug-function-arglist
(di::function-debug-function fun))
(di:unhandled-condition () :not-available))))))
(check-type arglist (or list (member :not-available)))
arglist))
(defimplementation function-name (function)
(cond ((eval:interpreted-function-p function)
(eval:interpreted-function-name function))
((pcl::generic-function-p function)
(pcl::generic-function-name function))
((c::byte-function-or-closure-p function)
(c::byte-function-name function))
(t (kernel:%function-name (kernel:%function-self function)))))
;;; A simple case: the arglist is available as a string that we can
;;; `read'.
(defun read-arglist (fn)
"Parse the arglist-string of the function object FN."
(let ((string (kernel:%function-arglist
(kernel:%function-self fn)))
(package (find-package
(c::compiled-debug-info-package
(kernel:%code-debug-info
(vm::find-code-object fn))))))
(with-standard-io-syntax
(let ((*package* (or package *package*)))
(read-from-string string)))))
;;; A harder case: an approximate arglist is derived from available
;;; debugging information.
(defun debug-function-arglist (debug-function)
"Derive the argument list of DEBUG-FUNCTION from debug info."
(let ((args (di::debug-function-lambda-list debug-function))
(required '())
(optional '())
(rest '())
(key '()))
;; collect the names of debug-vars
(dolist (arg args)
(etypecase arg
(di::debug-variable
(push (di::debug-variable-symbol arg) required))
((member :deleted)
(push ':deleted required))
(cons
(ecase (car arg)
(:keyword
(push (second arg) key))
(:optional
(push (debug-variable-symbol-or-deleted (second arg)) optional))
(:rest
(push (debug-variable-symbol-or-deleted (second arg)) rest))))))
;; intersperse lambda keywords as needed
(append (nreverse required)
(if optional (cons '&optional (nreverse optional)))
(if rest (cons '&rest (nreverse rest)))
(if key (cons '&key (nreverse key))))))
(defun debug-variable-symbol-or-deleted (var)
(etypecase var
(di:debug-variable
(di::debug-variable-symbol var))
((member :deleted)
'#:deleted)))
(defun symbol-debug-function-arglist (fname)
"Return FNAME's debug-function-arglist and %function-arglist.
A utility for debugging DEBUG-FUNCTION-ARGLIST."
(let ((fn (fdefinition fname)))
(values (debug-function-arglist (di::function-debug-function fn))
(kernel:%function-arglist (kernel:%function-self fn)))))
;;; Deriving arglists for byte-compiled functions:
;;;
(defun byte-code-function-arglist (fn)
;; There doesn't seem to be much arglist information around for
;; byte-code functions. Use the arg-count and return something like
;; (arg0 arg1 ...)
(etypecase fn
(c::simple-byte-function
(loop for i from 0 below (c::simple-byte-function-num-args fn)
collect (make-arg-symbol i)))
(c::hairy-byte-function
(hairy-byte-function-arglist fn))
(c::byte-closure
(byte-code-function-arglist (c::byte-closure-function fn)))))
(defun make-arg-symbol (i)
(make-symbol (format nil "~A~D" (string 'arg) i)))
;;; A "hairy" byte-function is one that takes a variable number of
;;; arguments. `hairy-byte-function' is a type from the bytecode
;;; interpreter.
;;;
(defun hairy-byte-function-arglist (fn)
(let ((counter -1))
(flet ((next-arg () (make-arg-symbol (incf counter))))
(with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
keywords-p keywords) fn
(let ((arglist '())
(optional (- max-args min-args)))
;; XXX isn't there a better way to write this?
;; (Looks fine to me. -luke)
(dotimes (i min-args)
(push (next-arg) arglist))
(when (plusp optional)
(push '&optional arglist)
(dotimes (i optional)
(push (next-arg) arglist)))
(when rest-arg-p
(push '&rest arglist)
(push (next-arg) arglist))
(when keywords-p
(push '&key arglist)
(loop for (key _ __) in keywords
do (push key arglist))
(when (eq keywords-p :allow-others)
(push '&allow-other-keys arglist)))
(nreverse arglist))))))
;;;; Miscellaneous.
(defimplementation macroexpand-all (form &optional env)
(walker:macroexpand-all form env))
(defimplementation compiler-macroexpand-1 (form &optional env)
(ext:compiler-macroexpand-1 form env))
(defimplementation compiler-macroexpand (form &optional env)
(ext:compiler-macroexpand form env))
(defimplementation set-default-directory (directory)
(setf (ext:default-directory) (namestring directory))
;; Setting *default-pathname-defaults* to an absolute directory
;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
(setf *default-pathname-defaults* (pathname (ext:default-directory)))
(default-directory))
(defimplementation default-directory ()
(namestring (ext:default-directory)))
(defimplementation getpid ()
(unix:unix-getpid))
(defimplementation lisp-implementation-type-name ()
"cmucl")
(defimplementation quit-lisp ()
(ext::quit))
;;; source-path-{stream,file,string,etc}-position moved into
;;; slynk-source-path-parser
;;;; Debugging
(defvar *sly-db-stack-top*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(unix:unix-sigsetmask 0)
(let* ((*sly-db-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
(debug:*stack-top-hint* nil)
(kernel:*current-level* 0))
(handler-bind ((di::unhandled-condition
(lambda (condition)
(error 'sly-db-condition
:original-condition condition))))
(unwind-protect
(progn
#+(or)(sys:scrub-control-stack)
(funcall debugger-loop-fn))
#+(or)(sys:scrub-control-stack)
))))
(defun frame-down (frame)
(handler-case (di:frame-down frame)
(di:no-debug-info () nil)))
(defun nth-frame (index)
(do ((frame *sly-db-stack-top* (frame-down frame))
(i index (1- i)))
((zerop i) frame)))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (frame-down f)
for i from start below end
while f collect f)))
(defimplementation print-frame (frame stream)
(let ((*standard-output* stream))
(handler-case
(debug::print-frame-call frame :verbosity 1 :number nil)
(error (e)
(ignore-errors (princ e stream))))))
(defimplementation frame-source-location (index)
(let ((frame (nth-frame index)))
(cond ((foreign-frame-p frame) (foreign-frame-source-location frame))
((code-location-source-location (di:frame-code-location frame))))))
(defimplementation eval-in-frame (form index)
(di:eval-in-frame (nth-frame index) form))
(defun frame-debug-vars (frame)
"Return a vector of debug-variables in frame."
(let ((loc (di:frame-code-location frame)))
(remove-if
(lambda (v)
(not (eq (di:debug-variable-validity v loc) :valid)))
(di::debug-function-debug-variables (di:frame-debug-function frame)))))
(defun debug-var-value (var frame)
(let* ((loc (di:frame-code-location frame))
(validity (di:debug-variable-validity var loc)))
(ecase validity
(:valid (di:debug-variable-value var frame))
((:invalid :unknown) (make-symbol (string validity))))))
(defimplementation frame-locals (index)
(let ((frame (nth-frame index)))
(loop for v across (frame-debug-vars frame)
collect (list :name (di:debug-variable-symbol v)
:id (di:debug-variable-id v)
:value (debug-var-value v frame)))))
(defimplementation frame-var-value (frame var)
(let* ((frame (nth-frame frame))
(dvar (aref (frame-debug-vars frame) var)))
(debug-var-value dvar frame)))
(defimplementation frame-catch-tags (index)
(mapcar #'car (di:frame-catches (nth-frame index))))
(defimplementation frame-package (frame-number)
(let* ((frame (nth-frame frame-number))
(dbg-fun (di:frame-debug-function frame)))
(typecase dbg-fun
(di::compiled-debug-function
(let* ((comp (di::compiled-debug-function-component dbg-fun))
(dbg-info (kernel:%code-debug-info comp)))
(typecase dbg-info
(c::compiled-debug-info
(find-package (c::compiled-debug-info-package dbg-info)))))))))
(defimplementation return-from-frame (index form)
(let ((sym (find-symbol (string 'find-debug-tag-for-frame)
:debug-internals)))
(if sym
(let* ((frame (nth-frame index))
(probe (funcall sym frame)))
(cond (probe (throw (car probe) (eval-in-frame form index)))
(t (format nil "Cannot return from frame: ~S" frame))))
"return-from-frame is not implemented in this version of CMUCL.")))
(defimplementation activate-stepping (frame)
(set-step-breakpoints (nth-frame frame)))
(defimplementation sly-db-break-on-return (frame)
(break-on-return (nth-frame frame)))
;;; We set the breakpoint in the caller which might be a bit confusing.
;;;
(defun break-on-return (frame)
(let* ((caller (di:frame-down frame))
(cl (di:frame-code-location caller)))
(flet ((hook (frame bp)
(when (frame-pointer= frame caller)
(di:delete-breakpoint bp)
(signal-breakpoint bp frame))))
(let* ((info (ecase (di:code-location-kind cl)
((:single-value-return :unknown-return) nil)
(:known-return (debug-function-returns
(di:frame-debug-function frame)))))
(bp (di:make-breakpoint #'hook cl :kind :code-location
:info info)))
(di:activate-breakpoint bp)
`(:ok ,(format nil "Set breakpoint in ~A" caller))))))
(defun frame-pointer= (frame1 frame2)
"Return true if the frame pointers of FRAME1 and FRAME2 are the same."
(sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
;;; The PC in escaped frames at a single-return-value point is
;;; actually vm:single-value-return-byte-offset bytes after the
;;; position given in the debug info. Here we try to recognize such
;;; cases.
;;;
(defun next-code-locations (frame code-location)
"Like `debug::next-code-locations' but be careful in escaped frames."
(let ((next (debug::next-code-locations code-location)))
(flet ((adjust-pc ()
(let ((cl (di::copy-compiled-code-location code-location)))
(incf (di::compiled-code-location-pc cl)
vm:single-value-return-byte-offset)
cl)))
(cond ((and (di::compiled-frame-escaped frame)
(eq (di:code-location-kind code-location)
:single-value-return)
(= (length next) 1)
(di:code-location= (car next) (adjust-pc)))
(debug::next-code-locations (car next)))
(t
next)))))
(defun set-step-breakpoints (frame)
(let ((cl (di:frame-code-location frame)))
(when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
(error "Cannot step in elsewhere code"))
(let* ((debug::*bad-code-location-types*
(remove :call-site debug::*bad-code-location-types*))
(next (next-code-locations frame cl)))
(cond (next
(let ((steppoints '()))
(flet ((hook (bp-frame bp)
(signal-breakpoint bp bp-frame)
(mapc #'di:delete-breakpoint steppoints)))
(dolist (code-location next)
(let ((bp (di:make-breakpoint #'hook code-location
:kind :code-location)))
(di:activate-breakpoint bp)
(push bp steppoints))))))
(t
(break-on-return frame))))))
;; XXX the return values at return breakpoints should be passed to the
;; user hooks. debug-int.lisp should be changed to do this cleanly.
;;; The sigcontext and the PC for a breakpoint invocation are not
;;; passed to user hook functions, but we need them to extract return
;;; values. So we advice di::handle-breakpoint and bind the values to
;;; special variables.
;;;
(defvar *breakpoint-sigcontext*)
(defvar *breakpoint-pc*)
(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext)
(let ((*breakpoint-sigcontext* sigcontext)
(*breakpoint-pc* offset))
(call-next-function)))
(set-fwrappers 'di::handle-breakpoint '())
(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext)
(defun sigcontext-object (sc index)
"Extract the lisp object in sigcontext SC at offset INDEX."
(kernel:make-lisp-obj (vm:sigcontext-register sc index)))
(defun known-return-point-values (sigcontext sc-offsets)
(let ((fp (system:int-sap (vm:sigcontext-register sigcontext
vm::cfp-offset))))
(system:without-gcing
(loop for sc-offset across sc-offsets
collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
;;; CMUCL returns the first few values in registers and the rest on
;;; the stack. In the multiple value case, the number of values is
;;; stored in a dedicated register. The values of the registers can be
;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
;;; of return conventions: :single-value-return, :unknown-return, and
;;; :known-return.
;;;
;;; The :single-value-return convention returns the value in a
;;; register without setting the nargs registers.
;;;
;;; The :unknown-return variant is used for multiple values. A
;;; :unknown-return point consists actually of 2 breakpoints: one for
;;; the single value case and one for the general case. The single
;;; value breakpoint comes vm:single-value-return-byte-offset after
;;; the multiple value breakpoint.
;;;
;;; The :known-return convention is used by local functions.
;;; :known-return is currently not supported because we don't know
;;; where the values are passed.
;;;
(defun breakpoint-values (breakpoint)
"Return the list of return values for a return point."
(flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
(let ((sc (locally (declare (optimize (speed 0)))
(alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext))))
(cl (di:breakpoint-what breakpoint)))
(ecase (di:code-location-kind cl)
(:single-value-return
(list (1st sc)))
(:known-return
(let ((info (di:breakpoint-info breakpoint)))
(if (vectorp info)
(known-return-point-values sc info)
(progn
;;(break)
(list "<<known-return convention not supported>>" info)))))
(:unknown-return
(let ((mv-return-pc (di::compiled-code-location-pc cl)))
(if (= mv-return-pc *breakpoint-pc*)
(mv-function-end-breakpoint-values sc)
(list (1st sc)))))))))
;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in
;; newer versions of CMUCL (after ~March 2005).
(defun mv-function-end-breakpoint-values (sigcontext)
(let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
(cond (sym (funcall sym sigcontext))
(t (funcall 'di::get-function-end-breakpoint-values sigcontext)))))
(defun debug-function-returns (debug-fun)
"Return the return style of DEBUG-FUN."
(let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
(c::compiled-debug-function-returns cdfun)))
(define-condition breakpoint (simple-condition)
((message :initarg :message :reader breakpoint.message)
(values :initarg :values :reader breakpoint.values))
(:report (lambda (c stream) (princ (breakpoint.message c) stream))))
(defimplementation condition-extras (condition)
(typecase condition
(breakpoint
;; pop up the source buffer
`((:show-frame-source 0)))
(t '())))
(defun signal-breakpoint (breakpoint frame)
"Signal a breakpoint condition for BREAKPOINT in FRAME.
Try to create a informative message."
(flet ((brk (values fstring &rest args)
(let ((msg (apply #'format nil fstring args))
(debug:*stack-top-hint* frame))
(break 'breakpoint :message msg :values values))))
(with-struct (di::breakpoint- kind what) breakpoint
(case kind
(:code-location
(case (di:code-location-kind what)
((:single-value-return :known-return :unknown-return)
(let ((values (breakpoint-values breakpoint)))
(brk values "Return value: ~{~S ~}" values)))
(t
#+(or)
(when (eq (di:code-location-kind what) :call-site)
(call-site-function breakpoint frame))
(brk nil "Breakpoint: ~S ~S"
(di:code-location-kind what)
(di::compiled-code-location-pc what)))))
(:function-start
(brk nil "Function start breakpoint"))
(t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
(defimplementation sly-db-break-at-start (fname)
(let ((debug-fun (di:function-debug-function (coerce fname 'function))))
(cond ((not debug-fun)
`(:error ,(format nil "~S has no debug-function" fname)))
(t
(flet ((hook (frame bp &optional args cookie)
(declare (ignore args cookie))
(signal-breakpoint bp frame)))
(let ((bp (di:make-breakpoint #'hook debug-fun
:kind :function-start)))
(di:activate-breakpoint bp)
`(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
(defun frame-cfp (frame)
"Return the Control-Stack-Frame-Pointer for FRAME."
(etypecase frame
(di::compiled-frame (di::frame-pointer frame))
((or di::interpreted-frame null) -1)))
(defun frame-ip (frame)
"Return the (absolute) instruction pointer and the relative pc of FRAME."
(if (not frame)
-1
(let ((debug-fun (di::frame-debug-function frame)))
(etypecase debug-fun
(di::compiled-debug-function
(let* ((code-loc (di:frame-code-location frame))
(component (di::compiled-debug-function-component debug-fun))
(pc (di::compiled-code-location-pc code-loc))
(ip (sys:without-gcing
(sys:sap-int
(sys:sap+ (kernel:code-instructions component) pc)))))
(values ip pc)))
(di::interpreted-debug-function -1)
(di::bogus-debug-function
#-x86
(let* ((real (di::frame-real-frame (di::frame-up frame)))
(fp (di::frame-pointer real)))
;;#+(or)
(progn
(format *debug-io* "Frame-real-frame = ~S~%" real)
(format *debug-io* "fp = ~S~%" fp)
(format *debug-io* "lra = ~S~%"
(kernel:stack-ref fp vm::lra-save-offset)))
(values
(sys:int-sap
(- (kernel:get-lisp-obj-address
(kernel:stack-ref fp vm::lra-save-offset))
(- (ash vm:function-code-offset vm:word-shift)
vm:function-pointer-type)))
0))
#+x86
(let ((fp (di::frame-pointer (di:frame-up frame))))
(multiple-value-bind (ra ofp) (di::x86-call-context fp)
(declare (ignore ofp))
(values ra 0))))))))
(defun frame-registers (frame)
"Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
(let* ((cfp (frame-cfp frame))
(csp (frame-cfp (di::frame-up frame)))
(ip (frame-ip frame))
(ocfp (frame-cfp (di::frame-down frame)))
(lra (frame-ip (di::frame-down frame))))
(values csp cfp ip ocfp lra)))
(defun print-frame-registers (frame-number)
(let ((frame (di::frame-real-frame (nth-frame frame-number))))
(flet ((fixnum (p) (etypecase p
(integer p)
(sys:system-area-pointer (sys:sap-int p)))))
(apply #'format t "~
~8X Stack Pointer
~8X Frame Pointer
~8X Instruction Pointer
~8X Saved Frame Pointer
~8X Saved Instruction Pointer~%" (mapcar #'fixnum
(multiple-value-list (frame-registers frame)))))))
(defvar *gdb-program-name*
(ext:enumerate-search-list (p "path:gdb")
(when (probe-file p)
(return p))))
(defimplementation disassemble-frame (frame-number)
(print-frame-registers frame-number)
(terpri)
(let* ((frame (di::frame-real-frame (nth-frame frame-number)))
(debug-fun (di::frame-debug-function frame)))
(etypecase debug-fun
(di::compiled-debug-function
(let* ((component (di::compiled-debug-function-component debug-fun))
(fun (di:debug-function-function debug-fun)))
(if fun
(disassemble fun)
(disassem:disassemble-code-component component))))
(di::bogus-debug-function
(cond ((probe-file *gdb-program-name*)
(let ((ip (sys:sap-int (frame-ip frame))))
(princ (gdb-command "disas 0x~x" ip))))
(t
(format t "~%[Disassembling bogus frames not implemented]")))))))
(defmacro with-temporary-file ((stream filename) &body body)
`(call/temporary-file (lambda (,stream ,filename) . ,body)))
(defun call/temporary-file (fun)
(let ((name (system::pick-temporary-file-name)))
(unwind-protect
(with-open-file (stream name :direction :output :if-exists :supersede)
(funcall fun stream name))
(delete-file name))))
(defun gdb-command (format-string &rest args)
(let ((str (gdb-exec (format nil
"interpreter-exec mi2 \"attach ~d\"~%~
interpreter-exec console ~s~%detach"
(getpid)
(apply #'format nil format-string args))))
(prompt (format nil
#-(and darwin x86) "~%^done~%(gdb) ~%"
#+(and darwin x86)
"~%^done,thread-id=\"1\"~%(gdb) ~%")))
(subseq str (+ (or (search prompt str) 0) (length prompt)))))
(defun gdb-exec (cmd)
(with-temporary-file (file filename)
(write-string cmd file)
(force-output file)
(let* ((output (make-string-output-stream))
;; gdb on sparc needs to know the executable to find the
;; symbols. Without this, gdb can't disassemble anything.
;; NOTE: We assume that the first entry in
;; lisp::*cmucl-lib* is the bin directory where lisp is
;; located. If this is not true, we'll have to do
;; something better to find the lisp executable.
(lisp-path
#+sparc
(list
(namestring
(probe-file
(merge-pathnames "lisp" (car (lisp::parse-unix-search-path
lisp::*cmucl-lib*))))))
#-sparc
nil)
(proc (ext:run-program *gdb-program-name*
`(,@lisp-path "-batch" "-x" ,filename)
:wait t
:output output)))
(assert (eq (ext:process-status proc) :exited))
(assert (eq (ext:process-exit-code proc) 0))
(get-output-stream-string output))))
(defun foreign-frame-p (frame)
#-x86
(let ((ip (frame-ip frame)))
(and (sys:system-area-pointer-p ip)
(typep (di::frame-debug-function frame) 'di::bogus-debug-function)))
#+x86
(let ((ip (frame-ip frame)))
(and (sys:system-area-pointer-p ip)
(multiple-value-bind (pc code)
(di::compute-lra-data-from-pc ip)
(declare (ignore pc))
(not code)))))
(defun foreign-frame-source-location (frame)
(let ((ip (sys:sap-int (frame-ip frame))))
(cond ((probe-file *gdb-program-name*)
(parse-gdb-line-info (gdb-command "info line *0x~x" ip)))
(t `(:error "no srcloc available for ~a" frame)))))
;; The output of gdb looks like:
;; Line 215 of "../../src/lisp/x86-assem.S"
;; starts at address 0x805318c <Ldone+11>
;; and ends at 0x805318e <Ldone+13>.
;; The ../../ are fixed up with the "target:" search list which might
;; be wrong sometimes.
(defun parse-gdb-line-info (string)
(with-input-from-string (*standard-input* string)
(let ((w1 (read-word)))
(cond ((equal w1 "Line")
(let ((line (read-word)))
(assert (equal (read-word) "of"))
(let* ((file (read-from-string (read-word)))
(pathname
(or (probe-file file)
(probe-file (format nil "target:lisp/~a" file))
file)))
(make-location (list :file (unix-truename pathname))
(list :line (parse-integer line))))))
(t
`(:error ,string))))))
(defun read-word (&optional (stream *standard-input*))
(peek-char t stream)
(concatenate 'string (loop until (whitespacep (peek-char nil stream))
collect (read-char stream))))
(defun whitespacep (char)
(member char '(#\space #\newline)))
;;;; Inspecting
(defconstant +lowtag-symbols+
'(vm:even-fixnum-type
vm:function-pointer-type
vm:other-immediate-0-type
vm:list-pointer-type
vm:odd-fixnum-type
vm:instance-pointer-type
vm:other-immediate-1-type
vm:other-pointer-type)
"Names of the constants that specify type tags.
The `symbol-value' of each element is a type tag.")
(defconstant +header-type-symbols+
(labels ((suffixp (suffix string)
(and (>= (length string) (length suffix))
(string= string suffix :start1 (- (length string)
(length suffix)))))
(header-type-symbol-p (x)
(and (suffixp "-TYPE" (symbol-name x))
(not (member x +lowtag-symbols+))
(boundp x)
(typep (symbol-value x) 'fixnum))))
(remove-if-not #'header-type-symbol-p
(append (apropos-list "-TYPE" "VM")
(apropos-list "-TYPE" "BIGNUM"))))
"A list of names of the type codes in boxed objects.")
(defimplementation describe-primitive-type (object)
(with-output-to-string (*standard-output*)
(let* ((lowtag (kernel:get-lowtag object))
(lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
(format t "lowtag: ~A" lowtag-symbol)
(when (member lowtag (list vm:other-pointer-type
vm:function-pointer-type
vm:other-immediate-0-type
vm:other-immediate-1-type
))
(let* ((type (kernel:get-type object))
(type-symbol (find type +header-type-symbols+
:key #'symbol-value)))
(format t ", type: ~A" type-symbol))))))
(defmethod emacs-inspect ((o t))
(cond ((di::indirect-value-cell-p o)
`("Value: " (:value ,(c:value-cell-ref o))))
((alien::alien-value-p o)
(inspect-alien-value o))
(t
(cmucl-inspect o))))
(defun cmucl-inspect (o)
(destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
(list* (format nil "~A~%" text)
(if labeledp
(loop for (label . value) in parts
append (label-value-line label value))
(loop for value in parts for i from 0
append (label-value-line i value))))))
(defmethod emacs-inspect ((o function))
(let ((header (kernel:get-type o)))
(cond ((= header vm:function-header-type)
(append (label-value-line*
("Self" (kernel:%function-self o))
("Next" (kernel:%function-next o))
("Name" (kernel:%function-name o))
("Arglist" (kernel:%function-arglist o))
("Type" (kernel:%function-type o))
("Code" (kernel:function-code-header o)))
(list
(with-output-to-string (s)
(disassem:disassemble-function o :stream s)))))
((= header vm:closure-header-type)
(list* (format nil "~A is a closure.~%" o)
(append
(label-value-line "Function" (kernel:%closure-function o))
`("Environment:" (:newline))
(loop for i from 0 below (1- (kernel:get-closure-length o))
append (label-value-line
i (kernel:%closure-index-ref o i))))))
((eval::interpreted-function-p o)
(cmucl-inspect o))
(t
(call-next-method)))))
(defmethod emacs-inspect ((o kernel:funcallable-instance))
(append (label-value-line*
(:function (kernel:%funcallable-instance-function o))
(:lexenv (kernel:%funcallable-instance-lexenv o))
(:layout (kernel:%funcallable-instance-layout o)))
(cmucl-inspect o)))
(defmethod emacs-inspect ((o kernel:code-component))
(append
(label-value-line*
("code-size" (kernel:%code-code-size o))
("entry-points" (kernel:%code-entry-points o))
("debug-info" (kernel:%code-debug-info o))
("trace-table-offset" (kernel:code-header-ref
o vm:code-trace-table-offset-slot)))
`("Constants:" (:newline))
(loop for i from vm:code-constants-offset
below (kernel:get-header-data o)
append (label-value-line i (kernel:code-header-ref o i)))
`("Code:"
(:newline)
, (with-output-to-string (*standard-output*)
(cond ((c::compiled-debug-info-p (kernel:%code-debug-info o))
(disassem:disassemble-code-component o))
((or
(c::debug-info-p (kernel:%code-debug-info o))
(consp (kernel:code-header-ref
o vm:code-trace-table-offset-slot)))
(c:disassem-byte-component o))
(t
(disassem:disassemble-memory
(disassem::align
(+ (logandc2 (kernel:get-lisp-obj-address o)
vm:lowtag-mask)
(* vm:code-constants-offset vm:word-bytes))
(ash 1 vm:lowtag-bits))
(ash (kernel:%code-code-size o) vm:word-shift))))))))
(defmethod emacs-inspect ((o kernel:fdefn))
(label-value-line*
("name" (kernel:fdefn-name o))
("function" (kernel:fdefn-function o))
("raw-addr" (sys:sap-ref-32
(sys:int-sap (kernel:get-lisp-obj-address o))
(* vm:fdefn-raw-addr-slot vm:word-bytes)))))
#+(or)
(defmethod emacs-inspect ((o array))
(if (typep o 'simple-array)
(call-next-method)
(label-value-line*
(:header (describe-primitive-type o))
(:rank (array-rank o))
(:fill-pointer (kernel:%array-fill-pointer o))
(:fill-pointer-p (kernel:%array-fill-pointer-p o))
(:elements (kernel:%array-available-elements o))
(:data (kernel:%array-data-vector o))
(:displacement (kernel:%array-displacement o))
(:displaced-p (kernel:%array-displaced-p o))
(:dimensions (array-dimensions o)))))
(defmethod emacs-inspect ((o simple-vector))
(append
(label-value-line*
(:header (describe-primitive-type o))
(:length (c::vector-length o)))
(loop for i below (length o)
append (label-value-line i (aref o i)))))
(defun inspect-alien-record (alien)
(with-struct (alien::alien-value- sap type) alien
(with-struct (alien::alien-record-type- kind name fields) type
(append
(label-value-line*
(:sap sap)
(:kind kind)
(:name name))
(loop for field in fields
append (let ((slot (alien::alien-record-field-name field)))
(declare (optimize (speed 0)))
(label-value-line slot (alien:slot alien slot))))))))
(defun inspect-alien-pointer (alien)
(with-struct (alien::alien-value- sap type) alien
(label-value-line*
(:sap sap)
(:type type)
(:to (alien::deref alien)))))
(defun inspect-alien-value (alien)
(typecase (alien::alien-value-type alien)
(alien::alien-record-type (inspect-alien-record alien))
(alien::alien-pointer-type (inspect-alien-pointer alien))
(t (cmucl-inspect alien))))
(defimplementation eval-context (obj)
(cond ((typep (class-of obj) 'structure-class)
(let* ((dd (kernel:layout-info (kernel:layout-of obj)))
(slots (kernel:dd-slots dd)))
(list* (cons '*package*
(symbol-package (if slots
(kernel:dsd-name (car slots))
(kernel:dd-name dd))))
(loop for slot in slots collect
(cons (kernel:dsd-name slot)
(funcall (kernel:dsd-accessor slot) obj))))))))
;;;; Profiling
(defimplementation profile (fname)
(eval `(profile:profile ,fname)))
(defimplementation unprofile (fname)
(eval `(profile:unprofile ,fname)))
(defimplementation unprofile-all ()
(eval `(profile:unprofile))
"All functions unprofiled.")
(defimplementation profile-report ()
(eval `(profile:report-time)))
(defimplementation profile-reset ()
(eval `(profile:reset-time))
"Reset profiling counters.")
(defimplementation profiled-functions ()
profile:*timed-functions*)
(defimplementation profile-package (package callers methods)
(profile:profile-all :package package
:callers-p callers
:methods methods))
;;;; Multiprocessing
#+mp
(progn
(defimplementation initialize-multiprocessing (continuation)
(mp::init-multi-processing)
(mp:make-process continuation :name "slynk")
;; Threads magic: this never returns! But top-level becomes
;; available again.
(unless mp::*idle-process*
(mp::startup-idle-and-top-level-loops)))
(defimplementation spawn (fn &key name)
(mp:make-process fn :name (or name "Anonymous")))
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
(or (getf (mp:process-property-list thread) 'id)
(setf (getf (mp:process-property-list thread) 'id)
(incf *thread-id-counter*))))
(defimplementation find-thread (id)
(find id (all-threads)
:key (lambda (p) (getf (mp:process-property-list p) 'id))))
(defimplementation thread-name (thread)
(mp:process-name thread))
(defimplementation thread-status (thread)
(mp:process-whostate thread))
(defimplementation current-thread ()
mp:*current-process*)
(defimplementation all-threads ()
(copy-list mp:*all-processes*))
(defimplementation interrupt-thread (thread fn)
(mp:process-interrupt thread fn))
(defimplementation kill-thread (thread)
(mp:destroy-process thread))
(defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
(defstruct (mailbox (:conc-name mailbox.))
(mutex (mp:make-lock "process mailbox"))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(mp:with-lock-held (*mailbox-lock*)
(or (getf (mp:process-property-list thread) 'mailbox)
(setf (getf (mp:process-property-list thread) 'mailbox)
(make-mailbox)))))
(defimplementation send (thread message)
(check-sly-interrupts)
(let* ((mbox (mailbox thread)))
(mp:with-lock-held ((mailbox.mutex mbox))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
(defimplementation receive-if (test &optional timeout)
(let ((mbox (mailbox mp:*current-process*)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(mp:with-lock-held ((mailbox.mutex mbox))
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox)
(nconc (ldiff q tail) (cdr tail)))
(return (car tail)))))
(when (eq timeout t) (return (values nil t)))
(mp:process-wait-with-timeout
"receive-if" 0.5
(lambda () (some test (mailbox.queue mbox)))))))
) ;; #+mp
;;;; GC hooks
;;;
;;; Display GC messages in the echo area to avoid cluttering the
;;; normal output.
;;;
;; this should probably not be here, but where else?
(defun background-message (message)
(funcall (find-symbol (string :background-message) :slynk)
message))
(defun print-bytes (nbytes &optional stream)
"Print the number NBYTES to STREAM in KB, MB, or GB units."
(let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb))))
(multiple-value-bind (power name)
(loop for ((p1 n1) (p2 n2)) on names
while n2 do
(when (<= (expt 2 p1) nbytes (1- (expt 2 p2)))
(return (values p1 n1))))
(cond (name
(format stream "~,1F ~A" (/ nbytes (expt 2 power)) name))
(t
(format stream "~:D bytes" nbytes))))))
(defconstant gc-generations 6)
#+gencgc
(defun generation-stats ()
"Return a string describing the size distribution among the generations."
(let* ((alloc (loop for i below gc-generations
collect (lisp::gencgc-stats i)))
(sum (coerce (reduce #'+ alloc) 'float)))
(format nil "~{~3F~^/~}"
(mapcar (lambda (size) (/ size sum))
alloc))))
(defvar *gc-start-time* 0)
(defun pre-gc-hook (bytes-in-use)
(setq *gc-start-time* (get-internal-real-time))
(let ((msg (format nil "[Commencing GC with ~A in use.]"
(print-bytes bytes-in-use))))
(background-message msg)))
(defun post-gc-hook (bytes-retained bytes-freed trigger)
(declare (ignore trigger))
(let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*)
internal-time-units-per-second))
(msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]"
(print-bytes bytes-freed)
(print-bytes bytes-retained)
#+gencgc(generation-stats)
#-gencgc""
seconds)))
(background-message msg)))
(defun install-gc-hooks ()
(setq ext:*gc-notify-before* #'pre-gc-hook)
(setq ext:*gc-notify-after* #'post-gc-hook))
(defun remove-gc-hooks ()
(setq ext:*gc-notify-before* #'lisp::default-gc-notify-before)
(setq ext:*gc-notify-after* #'lisp::default-gc-notify-after))
(defvar *install-gc-hooks* t
"If non-nil install GC hooks")
(defimplementation emacs-connected ()
(when *install-gc-hooks*
(install-gc-hooks)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Trace implementations
;;In CMUCL, we have:
;; (trace <name>)
;; (trace (method <name> <qualifier>? (<specializer>+)))
;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
;; <name> can be a normal name or a (setf name)
(defun tracedp (spec)
(member spec (eval '(trace)) :test #'equal))
(defun toggle-trace-aux (spec &rest options)
(cond ((tracedp spec)
(eval `(untrace ,spec))
(format nil "~S is now untraced." spec))
(t
(eval `(trace ,spec ,@options))
(format nil "~S is now traced." spec))))
(defimplementation toggle-trace (spec)
(ecase (car spec)
((setf)
(toggle-trace-aux spec))
((:defgeneric)
(let ((name (second spec)))
(toggle-trace-aux name :methods name)))
((:defmethod)
(cond ((fboundp `(method ,@(cdr spec)))
(toggle-trace-aux `(method ,(cdr spec))))
;; Man, is this ugly
((fboundp `(pcl::fast-method ,@(cdr spec)))
(toggle-trace-aux `(pcl::fast-method ,@(cdr spec))))
(t
(error 'undefined-function :name (cdr spec)))))
((:call)
(destructuring-bind (caller callee) (cdr spec)
(toggle-trace-aux (process-fspec callee)
:wherein (list (process-fspec caller)))))
;; doesn't work properly
;; ((:labels :flet) (toggle-trace-aux (process-fspec spec)))
))
(defun process-fspec (fspec)
(cond ((consp fspec)
(ecase (first fspec)
((:defun :defgeneric) (second fspec))
((:defmethod)
`(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec))))
((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec))))))
(t
fspec)))
;;; Weak datastructures
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak-p t args))
;;; Save image
(defimplementation save-image (filename &optional restart-function)
(multiple-value-bind (pid error) (unix:unix-fork)
(when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error)))
(cond ((= pid 0)
(apply #'ext:save-lisp
filename
(if restart-function
`(:init-function ,restart-function))))
(t
(let ((status (waitpid pid)))
(destructuring-bind (&key exited? status &allow-other-keys) status
(assert (and exited? (equal status 0)) ()
"Invalid exit status: ~a" status)))))))
(defun waitpid (pid)
(alien:with-alien ((status c-call:int))
(let ((code (alien:alien-funcall
(alien:extern-alien
waitpid (alien:function c-call:int c-call:int
(* c-call:int) c-call:int))
pid (alien:addr status) 0)))
(cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg)))
(t (assert (= code pid))
(decode-wait-status status))))))
(defun decode-wait-status (status)
(let ((output (with-output-to-string (s)
(call-program (list (process-status-program)
(format nil "~d" status))
:output s))))
(read-from-string output)))
(defun call-program (args &key output)
(destructuring-bind (program &rest args) args
(let ((process (ext:run-program program args :output output)))
(when (not program) (error "fork failed"))
(unless (and (eq (ext:process-status process) :exited)
(= (ext:process-exit-code process) 0))
(error "Non-zero exit status")))))
(defvar *process-status-program* nil)
(defun process-status-program ()
(or *process-status-program*
(setq *process-status-program*
(compile-process-status-program))))
(defun compile-process-status-program ()
(let ((infile (system::pick-temporary-file-name
"/tmp/process-status~d~c.c")))
(with-open-file (stream infile :direction :output :if-exists :supersede)
(format stream "
#include <stdio.h>
#include <stdlib.h>
#include <sys/types.h>
#include <sys/wait.h>
#include <assert.h>
#define FLAG(value) (value ? \"t\" : \"nil\")
int main (int argc, char** argv) {
assert (argc == 2);
{
char* endptr = NULL;
char* arg = argv[1];
long int status = strtol (arg, &endptr, 10);
assert (endptr != arg && *endptr == '\\0');
printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\"
\" :stopped? %s :stopsig %d)\\n\",
FLAG(WIFEXITED(status)), WEXITSTATUS(status),
FLAG(WIFSIGNALED(status)), WTERMSIG(status),
FLAG(WCOREDUMP(status)),
FLAG(WIFSTOPPED(status)), WSTOPSIG(status));
fflush (NULL);
return 0;
}
}
")
(finish-output stream))
(let* ((outfile (system::pick-temporary-file-name))
(args (list "cc" "-o" outfile infile)))
(warn "Running cc: ~{~a ~}~%" args)
(call-program args :output t)
(delete-file infile)
outfile)))
;; FIXME: lisp:unicode-complete introduced in version 20d.
#+#.(slynk-backend:with-symbol 'unicode-complete 'lisp)
(defun match-semi-standard (prefix matchp)
;; Handle the CMUCL's short character names.
(loop for name in lisp::char-name-alist
when (funcall matchp prefix (car name))
collect (car name)))
#+#.(slynk-backend:with-symbol 'unicode-complete 'lisp)
(defimplementation character-completion-set (prefix matchp)
(let ((names (lisp::unicode-complete prefix)))
;; Match prefix against semistandard names. If there's a match,
;; add it to our list of matches.
(let ((semi-standard (match-semi-standard prefix matchp)))
(when semi-standard
(setf names (append semi-standard names))))
(setf names (mapcar #'string-capitalize names))
(loop for n in names
when (funcall matchp prefix n)
collect n)))
(defimplementation codepoint-length (string)
"Return the number of code points in the string. The string MUST be
a valid UTF-16 string."
(do ((len (length string))
(index 0 (1+ index))
(count 0 (1+ count)))
((>= index len)
count)
(multiple-value-bind (codepoint wide)
(lisp:codepoint string index)
(declare (ignore codepoint))
(when wide (incf index)))))
;;;; -*- indent-tabs-mode: nil -*-
;;;; SLYNK support for CLISP.
;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License as
;;;; published by the Free Software Foundation; either version 2 of
;;;; the License, or (at your option) any later version.
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; You should have received a copy of the GNU General Public
;;;; License along with this program; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;;;; MA 02111-1307, USA.
;;; This is work in progress, but it's already usable. Many things
;;; are adapted from other slynk-*.lisp, in particular from
;;; slynk-allegro (I don't use allegro at all, but it's the shortest
;;; one and I found Helmut Eller's code there enlightening).
;;; This code will work better with recent versions of CLISP (say, the
;;; last release or CVS HEAD) while it may not work at all with older
;;; versions. It is reasonable to expect it to work on platforms with
;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
;;; systems, but also on Win32. This backend uses the portable xref
;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
;;; are conveniently included in SLY.
;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
(defpackage slynk-clisp
(:use cl slynk-backend))
(in-package slynk-clisp)
(eval-when (:compile-toplevel)
(unless (string< "2.44" (lisp-implementation-version))
(error "Need at least CLISP version 2.44")))
(defimplementation gray-package-name ()
"GRAY")
;;;; if this lisp has the complete CLOS then we use it, otherwise we
;;;; build up a "fake" slynk-mop and then override the methods in the
;;;; inspector.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *have-mop*
(and (find-package :clos)
(eql :external
(nth-value 1 (find-symbol (string ':standard-slot-definition)
:clos))))
"True in those CLISP images which have a complete MOP implementation."))
#+#.(cl:if slynk-clisp::*have-mop* '(cl:and) '(cl:or))
(progn
(import-slynk-mop-symbols :clos '(:slot-definition-documentation))
(defun slynk-mop:slot-definition-documentation (slot)
(clos::slot-definition-documentation slot)))
#-#.(cl:if slynk-clisp::*have-mop* '(and) '(or))
(defclass slynk-mop:standard-slot-definition ()
()
(:documentation
"Dummy class created so that slynk.lisp will compile and load."))
(let ((getpid (or (find-symbol "PROCESS-ID" :system)
;; old name prior to 2005-03-01, clisp <= 2.33.2
(find-symbol "PROGRAM-ID" :system)
#+win32 ; integrated into the above since 2005-02-24
(and (find-package :win32) ; optional modules/win32
(find-symbol "GetCurrentProcessId" :win32)))))
(defimplementation getpid () ; a required interface
(cond
(getpid (funcall getpid))
#+win32 ((ext:getenv "PID")) ; where does that come from?
(t -1))))
(defimplementation call-with-user-break-handler (handler function)
(handler-bind ((system::simple-interrupt-condition
(lambda (c)
(declare (ignore c))
(funcall handler)
(when (find-restart 'socket-status)
(invoke-restart (find-restart 'socket-status)))
(continue))))
(funcall function)))
(defimplementation lisp-implementation-type-name ()
"clisp")
(defimplementation set-default-directory (directory)
(setf (ext:default-directory) directory)
(namestring (setf *default-pathname-defaults* (ext:default-directory))))
(defimplementation filename-to-pathname (string)
(cond ((member :cygwin *features*)
(parse-cygwin-filename string))
(t (parse-namestring string))))
(defun parse-cygwin-filename (string)
(multiple-value-bind (match _ drive absolute)
(regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
(declare (ignore _))
(assert (and match (if drive absolute t)) ()
"Invalid filename syntax: ~a" string)
(let* ((sans-prefix (subseq string (regexp:match-end match)))
(path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
(path (loop for name in path collect
(cond ((equal name "..") ':back)
(t name))))
(directoryp (or (equal string "")
(find (aref string (1- (length string))) "\\/"))))
(multiple-value-bind (file type)
(cond ((and (not directoryp) (last path))
(let* ((file (car (last path)))
(pos (position #\. file :from-end t)))
(cond ((and pos (> pos 0))
(values (subseq file 0 pos)
(subseq file (1+ pos))))
(t file)))))
(make-pathname :host nil
:device nil
:directory (cons
(if absolute :absolute :relative)
(let ((path (if directoryp
path
(butlast path))))
(if drive
(cons
(regexp:match-string string drive)
path)
path)))
:name file
:type type)))))
;;;; UTF
(defimplementation string-to-utf8 (string)
(let ((enc (load-time-value
(ext:make-encoding :charset "utf-8" :line-terminator :unix)
t)))
(ext:convert-string-to-bytes string enc)))
(defimplementation utf8-to-string (octets)
(let ((enc (load-time-value
(ext:make-encoding :charset "utf-8" :line-terminator :unix)
t)))
(ext:convert-string-from-bytes octets enc)))
;;;; TCP Server
(defimplementation create-socket (host port &key backlog)
(socket:socket-server port :interface host :backlog (or backlog 5)))
(defimplementation local-port (socket)
(socket:socket-server-port socket))
(defimplementation close-socket (socket)
(socket:socket-server-close socket))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering timeout))
(socket:socket-accept socket
:buffered buffering ;; XXX may not work if t
:element-type (if external-format
'character
'(unsigned-byte 8))
:external-format (or external-format :default)))
#-win32
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
(loop
(cond ((check-sly-interrupts) (return :interrupt))
(timeout
(socket:socket-status streams 0 0)
(return (loop for (s nil . x) in streams
if x collect s)))
(t
(with-simple-restart (socket-status "Return from socket-status.")
(socket:socket-status streams 0 500000))
(let ((ready (loop for (s nil . x) in streams
if x collect s)))
(when ready (return ready))))))))
#+win32
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(loop
(cond ((check-sly-interrupts) (return :interrupt))
(t
(let ((ready (remove-if-not #'input-available-p streams)))
(when ready (return ready)))
(when timeout (return nil))
(sleep 0.1)))))
#+win32
;; Some facts to remember (for the next time we need to debug this):
;; - interactive-sream-p returns t for socket-streams
;; - listen returns nil for socket-streams
;; - (type-of <socket-stream>) is 'stream
;; - (type-of *terminal-io*) is 'two-way-stream
;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
;; - calling socket:socket-status on non sockets signals an error,
;; but seems to mess up something internally.
;; - calling read-char-no-hang on sockets does not signal an error,
;; but seems to mess up something internally.
(defun input-available-p (stream)
(case (stream-element-type stream)
(character
(let ((c (read-char-no-hang stream nil nil)))
(cond ((not c)
nil)
(t
(unread-char c stream)
t))))
(t
(eq (socket:socket-status (cons stream :input) 0 0)
:input))))
;;;; Coding systems
(defvar *external-format-to-coding-system*
'(((:charset "iso-8859-1" :line-terminator :unix)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
((:charset "iso-8859-1")
"latin-1" "iso-latin-1" "iso-8859-1")
((:charset "utf-8") "utf-8")
((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
((:charset "euc-jp") "euc-jp")
((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
((:charset "us-ascii") "us-ascii")
((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
(defimplementation find-external-format (coding-system)
(let ((args (car (rassoc-if (lambda (x)
(member coding-system x :test #'equal))
*external-format-to-coding-system*))))
(and args (apply #'ext:make-encoding args))))
;;;; Slynk functions
(defimplementation arglist (fname)
(block nil
(or (ignore-errors
(let ((exp (function-lambda-expression fname)))
(and exp (return (second exp)))))
(ignore-errors
(return (ext:arglist fname)))
:not-available)))
(defimplementation macroexpand-all (form &optional env)
(declare (ignore env))
(ext:expand-form form))
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result ()))
(flet ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push :variable (when (boundp symbol) (doc 'variable)))
(when (fboundp symbol)
(maybe-push
;; Report WHEN etc. as macros, even though they may be
;; implemented as special operators.
(if (macro-function symbol) :macro
(typecase (fdefinition symbol)
(generic-function :generic-function)
(function :function)
;; (type-of 'progn) -> ext:special-operator
(t :special-operator)))
(doc 'function)))
(when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
(get symbol 'system::setf-expander)); defsetf
(maybe-push :setf (doc 'setf)))
(when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
(get symbol 'system::defstruct-description)
(get symbol 'system::deftype-expander))
(maybe-push :type (doc 'type))) ; even for 'structure
(when (find-class symbol nil)
(maybe-push :class (doc 'type)))
;; Let this code work compiled in images without FFI
(let ((types (load-time-value
(and (find-package "FFI")
(symbol-value
(find-symbol "*C-TYPE-TABLE*" "FFI"))))))
;; Use ffi::*c-type-table* so as not to suffer the overhead of
;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
;; which are not FFI type names.
(when (and types (nth-value 1 (gethash symbol types)))
;; Maybe use (case (head (ffi:deparse-c-type)))
;; to distinguish struct and union types?
(maybe-push :alien-type :not-documented)))
result)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable (describe symbol))
(:macro (describe (macro-function symbol)))
(:function (describe (symbol-function symbol)))
(:class (describe (find-class symbol)))))
(defimplementation type-specifier-p (symbol)
(or (ignore-errors
(subtypep nil symbol))
(not (eq (type-specifier-arglist symbol) :not-available))))
(defun fspec-pathname (spec)
(let ((path spec)
type
lines)
(when (consp path)
(psetq type (car path)
path (cadr path)
lines (cddr path)))
(when (and path
(member (pathname-type path)
custom:*compiled-file-types* :test #'equal))
(setq path
(loop for suffix in custom:*source-file-types*
thereis (probe-file (make-pathname :defaults path
:type suffix)))))
(values path type lines)))
(defun fspec-location (name fspec)
(multiple-value-bind (file type lines)
(fspec-pathname fspec)
(list (if type (list name type) name)
(cond (file
(multiple-value-bind (truename c)
(ignore-errors (truename file))
(cond (truename
(make-location
(list :file (namestring truename))
(if (consp lines)
(list* :line lines)
(list :function-name (string name)))
(when (consp type)
(list :snippet (format nil "~A" type)))))
(t (list :error (princ-to-string c))))))
(t (list :error
(format nil "No source information available for: ~S"
fspec)))))))
(defimplementation find-definitions (name)
(mapcar #'(lambda (e) (fspec-location name e))
(documentation name 'sys::file)))
(defun trim-whitespace (string)
(string-trim #(#\newline #\space #\tab) string))
(defvar *sly-db-backtrace*)
(defun sly-db-backtrace ()
"Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
(let* ((modes '((:all-stack-elements 1)
(:all-frames 2)
(:only-lexical-frames 3)
(:only-eval-and-apply-frames 4)
(:only-apply-frames 5)))
(mode (cadr (assoc :all-stack-elements modes))))
(do ((frames '())
(last nil frame)
(frame (sys::the-frame)
(sys::frame-up 1 frame mode)))
((eq frame last) (nreverse frames))
(unless (boring-frame-p frame)
(push frame frames)))))
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* (;;(sys::*break-count* (1+ sys::*break-count*))
;;(sys::*driver* debugger-loop-fn)
;;(sys::*fasoutput-stream* nil)
(*sly-db-backtrace*
(let* ((f (sys::the-frame))
(bt (sly-db-backtrace))
(rest (member f bt)))
(if rest (nthcdr 8 rest) bt))))
(funcall debugger-loop-fn)))
(defun nth-frame (index)
(nth index *sly-db-backtrace*))
(defun boring-frame-p (frame)
(member (frame-type frame) '(stack-value bind-var bind-env
compiled-tagbody compiled-block)))
(defun frame-to-string (frame)
(with-output-to-string (s)
(sys::describe-frame s frame)))
(defun frame-type (frame)
;; FIXME: should bind *print-length* etc. to small values.
(frame-string-type (frame-to-string frame)))
;; FIXME: they changed the layout in 2.44 and not all patterns have
;; been updated.
(defvar *frame-prefixes*
'(("\\[[0-9]\\+\\] frame binding variables" bind-var)
("<1> #<compiled-function" compiled-fun)
("<1> #<system-function" sys-fun)
("<1> #<special-operator" special-op)
("EVAL frame" eval)
("APPLY frame" apply)
("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
("\\[[0-9]\\+\\] compiled block frame" compiled-block)
("block frame" block)
("nested block frame" block)
("tagbody frame" tagbody)
("nested tagbody frame" tagbody)
("catch frame" catch)
("handler frame" handler)
("unwind-protect frame" unwind-protect)
("driver frame" driver)
("\\[[0-9]\\+\\] frame binding environments" bind-env)
("CALLBACK frame" callback)
("- " stack-value)
("<1> " fun)
("<2> " 2nd-frame)
))
(defun frame-string-type (string)
(cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
*frame-prefixes*)))
(defimplementation compute-backtrace (start end)
(let* ((bt *sly-db-backtrace*)
(len (length bt)))
(loop for f in (subseq bt start (min (or end len) len))
collect f)))
(defimplementation print-frame (frame stream)
(let* ((str (frame-to-string frame)))
(write-string (extract-frame-line str)
stream)))
(defun extract-frame-line (frame-string)
(let ((s frame-string))
(trim-whitespace
(case (frame-string-type s)
((eval special-op)
(string-match "EVAL frame .*for form \\(.*\\)" s 1))
(apply
(string-match "APPLY frame for call \\(.*\\)" s 1))
((compiled-fun sys-fun fun)
(extract-function-name s))
(t s)))))
(defun extract-function-name (string)
(let ((1st (car (split-frame-string string))))
(or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
1st
1)
(string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
1st)))
(defun split-frame-string (string)
(let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
(mapcar #'car *frame-prefixes*))))
(loop for pos = 0 then (1+ (regexp:match-start match))
for match = (regexp:match rx string :start pos)
if match collect (subseq string pos (regexp:match-start match))
else collect (subseq string pos)
while match)))
(defun string-match (pattern string n)
(let* ((match (nth-value n (regexp:match pattern string))))
(if match (regexp:match-string string match))))
(defimplementation eval-in-frame (form frame-number)
(sys::eval-at (nth-frame frame-number) form))
(defimplementation frame-locals (frame-number)
(let ((frame (nth-frame frame-number)))
(loop for i below (%frame-count-vars frame)
collect (list :name (%frame-var-name frame i)
:value (%frame-var-value frame i)
:id 0))))
(defimplementation frame-var-value (frame var)
(%frame-var-value (nth-frame frame) var))
;;; Interpreter-Variablen-Environment has the shape
;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
(defun %frame-count-vars (frame)
(cond ((sys::eval-frame-p frame)
(do ((venv (frame-venv frame) (next-venv venv))
(count 0 (+ count (/ (1- (length venv)) 2))))
((not venv) count)))
((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
(length (%parse-stack-values frame)))
(t 0)))
(defun %frame-var-name (frame i)
(cond ((sys::eval-frame-p frame)
(nth-value 0 (venv-ref (frame-venv frame) i)))
(t (format nil "~D" i))))
(defun %frame-var-value (frame i)
(cond ((sys::eval-frame-p frame)
(let ((name (venv-ref (frame-venv frame) i)))
(multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
(if c
(format-sly-db-condition c)
v))))
((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
(let ((str (nth i (%parse-stack-values frame))))
(trim-whitespace (subseq str 2))))
(t (break "Not implemented"))))
(defun frame-venv (frame)
(let ((env (sys::eval-at frame '(sys::the-environment))))
(svref env 0)))
(defun next-venv (venv) (svref venv (1- (length venv))))
(defun venv-ref (env i)
"Reference the Ith binding in ENV.
Return two values: NAME and VALUE"
(let ((idx (* i 2)))
(if (< idx (1- (length env)))
(values (svref env idx) (svref env (1+ idx)))
(venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
(defun %parse-stack-values (frame)
(labels ((next (fp) (sys::frame-down 1 fp 1))
(parse (fp accu)
(let ((str (frame-to-string fp)))
(cond ((is-prefix-p "- " str)
(parse (next fp) (cons str accu)))
((is-prefix-p "<1> " str)
;;(when (eq (frame-type frame) 'compiled-fun)
;; (pop accu))
(dolist (str (cdr (split-frame-string str)))
(when (is-prefix-p "- " str)
(push str accu)))
(nreverse accu))
(t (parse (next fp) accu))))))
(parse (next frame) '())))
(defun is-prefix-p (regexp string)
(if (regexp:match (concatenate 'string "^" regexp) string) t))
(defimplementation return-from-frame (index form)
(sys::return-from-eval-frame (nth-frame index) form))
(defimplementation restart-frame (index)
(sys::redo-eval-frame (nth-frame index)))
(defimplementation frame-source-location (index)
`(:error
,(format nil "frame-source-location not implemented. (frame: ~A)"
(nth-frame index))))
;;;; Profiling
(defimplementation profile (fname)
(eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
slynk-monitor:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(slynk-monitor:unmonitor))
(defimplementation profile-report ()
(slynk-monitor:report-monitoring))
(defimplementation profile-reset ()
(slynk-monitor:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(slynk-monitor:monitor-all package))
;;;; Handle compiler conditions (find out location of error etc.)
(defmacro compile-file-frobbing-notes ((&rest args) &body body)
"Pass ARGS to COMPILE-FILE, send the compiler notes to
*STANDARD-INPUT* and frob them in BODY."
`(let ((*error-output* (make-string-output-stream))
(*compile-verbose* t))
(multiple-value-prog1
(compile-file ,@args)
(handler-case
(with-input-from-string
(*standard-input* (get-output-stream-string *error-output*))
,@body)
(sys::simple-end-of-file () nil)))))
(defvar *orig-c-warn* (symbol-function 'system::c-warn))
(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
(defvar *orig-c-error* (symbol-function 'system::c-error))
(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
(defmacro dynamic-flet (names-functions &body body)
"(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
Execute BODY with NAME's function slot set to FUNCTION."
`(ext:letf* ,(loop for (name function) in names-functions
collect `((symbol-function ',name) ,function))
,@body))
(defvar *buffer-name* nil)
(defvar *buffer-offset*)
(defun compiler-note-location ()
"Return the current compiler location."
(let ((lineno1 sys::*compile-file-lineno1*)
(lineno2 sys::*compile-file-lineno2*)
(file sys::*compile-file-truename*))
(cond ((and file lineno1 lineno2)
(make-location (list ':file (namestring file))
(list ':line lineno1)))
(*buffer-name*
(make-location (list ':buffer *buffer-name*)
(list ':offset *buffer-offset* 0)))
(t
(list :error "No error location available")))))
(defun signal-compiler-warning (cstring args severity orig-fn)
(signal 'compiler-condition
:severity severity
:message (apply #'format nil cstring args)
:location (compiler-note-location))
(apply orig-fn cstring args))
(defun c-warn (cstring &rest args)
(signal-compiler-warning cstring args :warning *orig-c-warn*))
(defun c-style-warn (cstring &rest args)
(dynamic-flet ((sys::c-warn *orig-c-warn*))
(signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
(defun c-error (&rest args)
(signal 'compiler-condition
:severity :error
:message (apply #'format nil
(if (= (length args) 3)
(cdr args)
args))
:location (compiler-note-location))
(apply *orig-c-error* args))
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((warning #'handle-notification-condition))
(dynamic-flet ((system::c-warn #'c-warn)
(system::c-style-warn #'c-style-warn)
(system::c-error #'c-error))
(funcall function))))
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning."
(signal 'compiler-condition
:original-condition condition
:severity :warning
:message (princ-to-string condition)
:location (compiler-note-location)))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-compilation-hooks ()
(with-compilation-unit ()
(multiple-value-bind (fasl-file warningsp failurep)
(compile-file input-file
:output-file output-file
:external-format external-format)
(values fasl-file warningsp
(or failurep
(and load-p
(not (load fasl-file)))))))))
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore filename line column policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-offset* position))
(funcall (compile nil (read-from-string
(format nil "(~S () ~A)" 'lambda string))))
t)))
;;;; Portable XREF from the CMU AI repository.
(setq pxref::*handle-package-forms* '(cl:in-package))
(defmacro defxref (name function)
`(defimplementation ,name (name)
(xref-results (,function name))))
(defxref who-calls pxref:list-callers)
(defxref who-references pxref:list-readers)
(defxref who-binds pxref:list-setters)
(defxref who-sets pxref:list-setters)
(defxref list-callers pxref:list-callers)
(defxref list-callees pxref:list-callees)
(defun xref-results (symbols)
(let ((xrefs '()))
(dolist (symbol symbols)
(push (fspec-location symbol symbol) xrefs))
xrefs))
(when (find-package :slynk-loader)
(setf (symbol-function (intern "USER-INIT-FILE" :slynk-loader))
(lambda ()
(let ((home (user-homedir-pathname)))
(and (ext:probe-directory home)
(probe-file (format nil "~A/.slynk.lisp"
(namestring (truename home)))))))))
;;; Don't set *debugger-hook* to nil on break.
(ext:without-package-lock ()
(defun break (&optional (format-string "Break") &rest args)
(if (not sys::*use-clcs*)
(progn
(terpri *error-output*)
(apply #'format *error-output*
(concatenate 'string "*** - " format-string)
args)
(funcall ext:*break-driver* t))
(let ((condition
(make-condition 'simple-condition
:format-control format-string
:format-arguments args))
;;(*debugger-hook* nil)
;; Issue 91
)
(ext:with-restarts
((continue
:report (lambda (stream)
(format stream (sys::text "Return from ~S loop")
'break))
()))
(with-condition-restarts condition (list (find-restart 'continue))
(invoke-debugger condition)))))
nil))
;;;; Inspecting
(defmethod emacs-inspect ((o t))
(let* ((*print-array* nil) (*print-pretty* t)
(*print-circle* t) (*print-escape* t)
(*print-lines* custom:*inspect-print-lines*)
(*print-level* custom:*inspect-print-level*)
(*print-length* custom:*inspect-print-length*)
(sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
(tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
(*package* tmp-pack)
(sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
(let ((inspection (sys::inspect-backend o)))
(append (list
(format nil "~S~% ~A~{~%~A~}~%" o
(sys::insp-title inspection)
(sys::insp-blurb inspection)))
(loop with count = (sys::insp-num-slots inspection)
for i below count
append (multiple-value-bind (value name)
(funcall (sys::insp-nth-slot inspection)
i)
`((:value ,name) " = " (:value ,value)
(:newline))))))))
(defimplementation quit-lisp ()
#+lisp=cl (ext:quit)
#-lisp=cl (lisp:quit))
(defimplementation preferred-communication-style ()
nil)
;;; FIXME
;;;
;;; Clisp 2.48 added experimental support for threads. Basically, you
;;; can use :SPAWN now, BUT:
;;;
;;; - there are problems with GC, and threads stuffed into weak
;;; hash-tables as is the case for *THREAD-PLIST-TABLE*.
;;;
;;; See test case at
;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429
;;;
;;; Even though said to be fixed, it's not:
;;;
;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
;;;
;;; - The DYNAMIC-FLET above is an implementation technique that's
;;; probably not sustainable in light of threads. This got to be
;;; rewritten.
;;;
;;; TCR (2009-07-30)
#+#.(cl:if (cl:find-package "MP") '(:and) '(:or))
(progn
(defimplementation spawn (fn &key name)
(mp:make-thread fn :name name))
(defvar *thread-plist-table-lock*
(mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
(defvar *thread-plist-table* (make-hash-table :weak :key)
"A hashtable mapping threads to a plist.")
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
(mp:with-mutex-lock (*thread-plist-table-lock*)
(or (getf (gethash thread *thread-plist-table*) 'thread-id)
(setf (getf (gethash thread *thread-plist-table*) 'thread-id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id (all-threads)
:key (lambda (thread)
(getf (gethash thread *thread-plist-table*) 'thread-id))))
(defimplementation thread-name (thread)
;; To guard against returning #<UNBOUND>.
(princ-to-string (mp:thread-name thread)))
(defimplementation thread-status (thread)
(if (thread-alive-p thread)
"RUNNING"
"STOPPED"))
(defimplementation make-lock (&key name)
(mp:make-mutex :name name :recursive-p t))
(defimplementation call-with-lock-held (lock function)
(mp:with-mutex-lock (lock)
(funcall function)))
(defimplementation current-thread ()
(mp:current-thread))
(defimplementation all-threads ()
(mp:list-threads))
(defimplementation interrupt-thread (thread fn)
(mp:thread-interrupt thread :function fn))
(defimplementation kill-thread (thread)
(mp:thread-interrupt thread :function t))
(defimplementation thread-alive-p (thread)
(mp:thread-active-p thread))
(defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
(defvar *mailboxes* (list))
(defstruct (mailbox (:conc-name mailbox.))
thread
(lock (make-lock :name "MAILBOX.LOCK"))
(waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(mp:with-mutex-lock (*mailboxes-lock*)
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(lock (mailbox.lock mbox)))
(mp:with-mutex-lock (lock)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(mp:exemption-broadcast (mailbox.waitqueue mbox)))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(lock (mailbox.lock mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(mp:with-mutex-lock (lock)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail))))
(when (eq timeout t) (return (values nil t)))
(mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
;;;; Weak hashtables
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak :key args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weak :value args))
(defimplementation save-image (filename &optional restart-function)
(let ((args `(,filename
,@(if restart-function
`((:init-function ,restart-function))))))
(apply #'ext:saveinitmem args)))
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; slynk-clasp.lisp --- SLY backend for CLASP.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;;; Administrivia
(defpackage slynk-clasp
(:use cl slynk-backend))
(in-package slynk-clasp)
;; #+(or)
;; (eval-when (:compile-toplevel :load-toplevel :execute)
;; (set slynk::*log-output* (open "/tmp/sly.log" :direction :output))
;; (set slynk:*log-events* t))
(defmacro sly-dbg (fmt &rest args)
`(funcall (slynk-backend:find-symbol2 "slynk::log-event")
"sly-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args)))
;; Hard dependencies.
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sockets))
;; Soft dependencies.
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (probe-file "sys:profile.fas")
(require :profile)
(pushnew :profile *features*))
(when (probe-file "sys:serve-event")
(require :serve-event)
(pushnew :serve-event *features*))
(when (find-symbol "TEMPORARY-DIRECTORY" "EXT")
(pushnew :temporary-directory *features*)))
(declaim (optimize (debug 3)))
;;; Slynk-mop
(eval-when (:compile-toplevel :load-toplevel :execute)
(import-slynk-mop-symbols :clos nil))
(defimplementation gray-package-name ()
"GRAY")
;;;; TCP Server
(defimplementation preferred-communication-style ()
:spawn
#| #+threads :spawn
#-threads nil
|#
)
(defun resolve-hostname (name)
(car (sb-bsd-sockets:host-ent-addresses
(sb-bsd-sockets:get-host-by-name name))))
(defimplementation create-socket (host port &key backlog)
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
(handler-bind
((SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR (lambda (err)
(declare (ignore err))
(invoke-restart 'use-value))))
(sb-bsd-sockets:socket-bind socket (resolve-hostname host) port))
(sb-bsd-sockets:socket-listen socket (or backlog 5))
socket))
(defimplementation local-port (socket)
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
(defimplementation close-socket (socket)
(sb-bsd-sockets:socket-close socket))
(defimplementation accept-connection (socket
&key external-format
buffering timeout)
(declare (ignore timeout))
(sb-bsd-sockets:socket-make-stream (accept socket)
:output t
:input t
:buffering (ecase buffering
((t) :full)
((nil) :none)
(:line :line))
:element-type (if external-format
'character
'(unsigned-byte 8))
:external-format external-format))
(defun accept (socket)
"Like socket-accept, but retry on EAGAIN."
(loop (handler-case
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
(defimplementation socket-fd (socket)
(etypecase socket
(fixnum socket)
(two-way-stream (socket-fd (two-way-stream-input-stream socket)))
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
(file-stream (si:file-stream-fd socket))))
(defvar *external-format-to-coding-system*
'((:latin-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")))
(defun external-format (coding-system)
(or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*))
(find coding-system (ext:all-encodings) :test #'string-equal)))
(defimplementation find-external-format (coding-system)
#+unicode (external-format coding-system)
;; Without unicode support, CLASP uses the one-byte encoding of the
;; underlying OS, and will barf on anything except :DEFAULT. We
;; return NIL here for known multibyte encodings, so
;; SLYNK:CREATE-SERVER will barf.
#-unicode (let ((xf (external-format coding-system)))
(if (member xf '(:utf-8))
nil
:default)))
;;;; Unix Integration
;;; If CLASP is built with thread support, it'll spawn a helper thread
;;; executing the SIGINT handler. We do not want to BREAK into that
;;; helper but into the main thread, though. This is coupled with the
;;; current choice of NIL as communication-style in so far as CLASP's
;;; main-thread is also the Sly's REPL thread.
#+clasp-working
(defimplementation call-with-user-break-handler (real-handler function)
(let ((old-handler #'si:terminal-interrupt))
(setf (symbol-function 'si:terminal-interrupt)
(make-interrupt-handler real-handler))
(unwind-protect (funcall function)
(setf (symbol-function 'si:terminal-interrupt) old-handler))))
#+threads
(defun make-interrupt-handler (real-handler)
(let ((main-thread (find 'si:top-level (mp:all-processes)
:key #'mp:process-name)))
#'(lambda (&rest args)
(declare (ignore args))
(mp:interrupt-process main-thread real-handler))))
#-threads
(defun make-interrupt-handler (real-handler)
#'(lambda (&rest args)
(declare (ignore args))
(funcall real-handler)))
(defimplementation getpid ()
(si:getpid))
(defimplementation set-default-directory (directory)
(ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
(default-directory))
(defimplementation default-directory ()
(namestring (ext:getcwd)))
(defimplementation quit-lisp ()
(sys:quit))
;;; Instead of busy waiting with communication-style NIL, use select()
;;; on the sockets' streams.
#+serve-event
(progn
(defun poll-streams (streams timeout)
(let* ((serve-event::*descriptor-handlers*
(copy-list serve-event::*descriptor-handlers*))
(active-fds '())
(fd-stream-alist
(loop for s in streams
for fd = (socket-fd s)
collect (cons fd s)
do (serve-event:add-fd-handler fd :input
#'(lambda (fd)
(push fd active-fds))))))
(serve-event:serve-event timeout)
(loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(loop
(cond ((check-sly-interrupts) (return :interrupt))
(timeout (return (poll-streams streams 0)))
(t
(when-let (ready (poll-streams streams 0.2))
(return ready))))))
) ; #+serve-event (progn ...
#-serve-event
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(loop
(cond ((check-sly-interrupts) (return :interrupt))
(timeout (return (remove-if-not #'listen streams)))
(t
(let ((ready (remove-if-not #'listen streams)))
(if ready (return ready))
(sleep 0.1))))))
;;;; Compilation
(defvar *buffer-name* nil)
(defvar *buffer-start-position*)
(defun condition-severity (condition)
(etypecase condition
(cmp:redefined-function-warning :redefinition)
(style-warning :style-warning)
(warning :warning)
(reader-error :read-error)
(error :error)))
(defun %condition-location (origin)
;; NOTE: If we're compiling in a buffer, the origin
;; will already be set up with the offset correctly
;; due to the :source-debug parameters from
;; swank-compile-string (below).
(make-file-location
(sys:file-scope-pathname
(sys:file-scope origin))
(sys:source-pos-info-filepos origin)))
(defun condition-location (origin)
(typecase origin
(null (make-error-location "No error location available"))
(cons (%condition-location (car origin)))
(t (%condition-location origin))))
(defun signal-compiler-condition (condition origin)
(signal 'compiler-condition
:original-condition condition
:severity (condition-severity condition)
:message (princ-to-string condition)
:location (condition-location origin)))
(defun handle-compiler-condition (condition)
;; First resignal warnings, so that outer handlers - which may choose to
;; muffle this - get a chance to run.
(when (typep condition 'warning)
(signal condition))
(signal-compiler-condition (cmp:deencapsulate-compiler-condition condition)
(cmp:compiler-condition-origin condition)))
(defimplementation call-with-compilation-hooks (function)
(handler-bind
(((or error warning) #'handle-compiler-condition))
(funcall function)))
(defun mkstemp (name)
(ext:mkstemp #+temporary-directory
(namestring (make-pathname :name name
:defaults (ext:temporary-directory)))
#-temporary-directory
(concatenate 'string "tmp:" name)))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file)
;; Ignore the output-file and generate our own
(let ((tmp-output-file (compile-file-pathname (mkstemp "clasp-slynk-compile-file-"))))
(format t "Using tmp-output-file: ~a~%" tmp-output-file)
(multiple-value-bind (fasl warnings-p failure-p)
(with-compilation-hooks ()
(compile-file input-file :output-file tmp-output-file
:external-format external-format))
(values fasl warnings-p
(or failure-p
(when load-p
(not (load fasl))))))))
(defvar *tmpfile-map* (make-hash-table :test #'equal))
(defun note-buffer-tmpfile (tmp-file buffer-name)
;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
(let ((tmp-namestring (namestring (truename tmp-file))))
(setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
tmp-namestring))
(defun tmpfile-to-buffer (tmp-file)
(gethash tmp-file *tmpfile-map*))
(defimplementation slynk-compile-string (string &key buffer position filename line column policy)
(declare (ignore column policy)) ;; We may use column in the future
(with-compilation-hooks ()
(let ((*buffer-name* buffer) ; for compilation hooks
(*buffer-start-position* position))
(let ((tmp-file (mkstemp "clasp-slynk-tmpfile-"))
(fasl-file)
(warnings-p)
(failure-p))
(unwind-protect
(with-open-file (tmp-stream tmp-file :direction :output
:if-exists :supersede)
(write-string string tmp-stream)
(finish-output tmp-stream)
(multiple-value-setq (fasl-file warnings-p failure-p)
(let ((truename (or filename (note-buffer-tmpfile tmp-file buffer))))
(compile-file tmp-file
:source-debug-pathname (pathname truename)
;; emacs numbers are 1-based instead of 0-based,
;; so we have to subtract
:source-debug-lineno (1- line)
:source-debug-offset (1- position)))))
(when fasl-file (load fasl-file))
(when (probe-file tmp-file)
(delete-file tmp-file))
(when fasl-file
(delete-file fasl-file)))
(not failure-p)))))
;;;; Documentation
(defimplementation arglist (name)
(multiple-value-bind (arglist foundp)
(sys:function-lambda-list name) ;; Uses bc-split
(if foundp arglist :not-available)))
(defimplementation function-name (f)
(typecase f
(generic-function (clos::generic-function-name f))
(function (ext:compiled-function-name f))))
;; FIXME
(defimplementation macroexpand-all (form &optional env)
(declare (ignore env))
(macroexpand form))
;;; modified from sbcl.lisp
(defimplementation collect-macro-forms (form &optional environment)
(let ((macro-forms '())
(compiler-macro-forms '())
(function-quoted-forms '()))
(format t "In collect-macro-forms~%")
(cmp:code-walk
(lambda (form environment)
(when (and (consp form)
(symbolp (car form)))
(cond ((eq (car form) 'function)
(push (cadr form) function-quoted-forms))
((member form function-quoted-forms)
nil)
((macro-function (car form) environment)
(push form macro-forms))
((not (eq form (sys:compiler-macroexpand-1 form environment)))
(push form compiler-macro-forms))))
form)
form environment)
(values macro-forms compiler-macro-forms)))
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((frob (type boundp)
(when (funcall boundp symbol)
(let ((doc (describe-definition symbol type)))
(setf result (list* type doc result))))))
(frob :VARIABLE #'boundp)
(frob :FUNCTION #'fboundp)
(frob :CLASS (lambda (x) (find-class x nil))))
result))
(defimplementation describe-definition (name type)
(case type
(:variable (documentation name 'variable))
(:function (documentation name 'function))
(:class (documentation name 'class))
(t nil)))
(defimplementation type-specifier-p (symbol)
(or (subtypep nil symbol)
(not (eq (type-specifier-arglist symbol) :not-available))))
;;; Debugging
(defun make-invoke-debugger-hook (hook)
(when hook
#'(lambda (condition old-hook)
;; Regard *debugger-hook* if set by user.
(if *debugger-hook*
nil ; decline, *DEBUGGER-HOOK* will be tried next.
(funcall hook condition old-hook)))))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
(ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(funcall fun)))
(defvar *backtrace* '())
;;; Commented out; it's not clear this is a good way of doing it. In
;;; particular because it makes errors stemming from this file harder
;;; to debug, and given the "young" age of CLASP's slynk backend, that's
;;; a bad idea.
;; (defun in-slynk-package-p (x)
;; (and
;; (symbolp x)
;; (member (symbol-package x)
;; (list #.(find-package :slynk)
;; #.(find-package :slynk-backend)
;; #.(ignore-errors (find-package :slynk-mop))
;; #.(ignore-errors (find-package :slynk-loader))))
;; t))
;; (defun is-slynk-source-p (name)
;; (setf name (pathname name))
;; (pathname-match-p
;; name
;; (make-pathname :defaults slynk-loader::*source-directory*
;; :name (pathname-name name)
;; :type (pathname-type name)
;; :version (pathname-version name))))
;; (defun is-ignorable-fun-p (x)
;; (or
;; (in-slynk-package-p (frame-name x))
;; (multiple-value-bind (file position)
;; (ignore-errors (si::bc-file (car x)))
;; (declare (ignore position))
;; (if file (is-slynk-source-p file)))))
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(clasp-debug:with-stack (stack)
(let ((*backtrace* (clasp-debug:list-stack stack)))
(funcall debugger-loop-fn))))
(defimplementation compute-backtrace (start end)
(subseq *backtrace* start
(and (numberp end)
(min end (length *backtrace*)))))
(defun frame-from-number (frame-number)
(elt *backtrace* frame-number))
(defimplementation print-frame (frame stream)
(clasp-debug:prin1-frame-call frame stream))
(defimplementation frame-source-location (frame-number)
(let ((csl (clasp-debug:frame-source-position (frame-from-number frame-number))))
(if (clasp-debug:code-source-line-pathname csl)
(make-location (list :file (namestring (translate-logical-pathname (clasp-debug:code-source-line-pathname csl))))
(list :line (clasp-debug:code-source-line-line-number csl))
'(:align t))
`(:error ,(format nil "No source for frame: ~a" frame-number)))))
(defimplementation frame-locals (frame-number)
(loop for (var . value)
in (clasp-debug:frame-locals (frame-from-number frame-number))
for i from 0
collect (list :name var :id i :value value)))
(defimplementation frame-var-value (frame-number var-number)
(let* ((frame (frame-from-number frame-number))
(locals (clasp-debug:frame-locals frame)))
(cdr (nth var-number locals))))
(defimplementation disassemble-frame (frame-number)
(clasp-debug:disassemble-frame (frame-from-number frame-number)))
(defimplementation eval-in-frame (form frame-number)
(let* ((frame (frame-from-number frame-number)))
(eval
`(let (,@(loop for (var . value)
in (clasp-debug:frame-locals frame)
collect `(,var ',value)))
(progn ,form)))))
#+clasp-working
(defimplementation gdb-initial-commands ()
;; These signals are used by the GC.
#+linux '("handle SIGPWR noprint nostop"
"handle SIGXCPU noprint nostop"))
#+clasp-working
(defimplementation command-line-args ()
(loop for n from 0 below (si:argc) collect (si:argv n)))
;;;; Inspector
;;; FIXME: Would be nice if it was possible to inspect objects
;;; implemented in C.
;;;; Definitions
(defun make-file-location (file file-position)
;; File positions in CL start at 0, but Emacs' buffer positions
;; start at 1. We specify (:ALIGN T) because the positions comming
;; from CLASP point at right after the toplevel form appearing before
;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
(make-location `(:file ,(namestring (translate-logical-pathname file)))
`(:position ,(1+ file-position))
`(:align t)))
(defun make-buffer-location (buffer-name start-position &optional (offset 0))
(make-location `(:buffer ,buffer-name)
`(:offset ,start-position ,offset)
`(:align t)))
(defun translate-location (location)
(make-location (list :file (namestring (translate-logical-pathname (ext:source-location-pathname location))))
(list :position (ext:source-location-offset location))
'(:align t)))
(defun make-dspec (name location)
(list* (ext:source-location-definer location)
name
(ext:source-location-description location)))
(defimplementation find-definitions (name)
(loop for kind in ext:*source-location-kinds*
for locations = (ext:source-location name kind)
when locations
nconc (loop for location in locations
collect (list (make-dspec name location)
(translate-location location)))))
(defun source-location (object)
(let ((location (ext:source-location object t)))
(when location
(translate-location (car location)))))
(defimplementation find-source-location (object)
(or (source-location object)
(make-error-location "Source definition of ~S not found." object)))
;;;; Profiling
;;;; as clisp and ccl
(defimplementation profile (fname)
(eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
slynk-monitor:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(slynk-monitor:unmonitor))
(defimplementation profile-report ()
(slynk-monitor:report-monitoring))
(defimplementation profile-reset ()
(slynk-monitor:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(slynk-monitor:monitor-all package))
;;;; Threads
#+threads
(progn
(defvar *thread-id-counter* 0)
(defparameter *thread-id-map* (make-hash-table))
(defvar *thread-id-map-lock*
(mp:make-lock :name "thread id map lock"))
(defimplementation spawn (fn &key name)
(mp:process-run-function name fn))
(defimplementation thread-id (target-thread)
(block thread-id
(mp:with-lock (*thread-id-map-lock*)
;; Does TARGET-THREAD have an id already?
(maphash (lambda (id thread-pointer)
(let ((thread (si:weak-pointer-value thread-pointer)))
(cond ((not thread)
(remhash id *thread-id-map*))
((eq thread target-thread)
(return-from thread-id id)))))
*thread-id-map*)
;; TARGET-THREAD not found in *THREAD-ID-MAP*
(let ((id (incf *thread-id-counter*))
(thread-pointer (si:make-weak-pointer target-thread)))
(setf (gethash id *thread-id-map*) thread-pointer)
id))))
(defimplementation find-thread (id)
(mp:with-lock (*thread-id-map-lock*)
(let* ((thread-ptr (gethash id *thread-id-map*))
(thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
(unless thread
(remhash id *thread-id-map*))
thread)))
(defimplementation thread-name (thread)
(mp:process-name thread))
(defimplementation thread-status (thread)
(if (mp:process-active-p thread)
"RUNNING"
"STOPPED"))
(defimplementation make-lock (&key name)
(mp:make-recursive-mutex name))
(defimplementation call-with-lock-held (lock function)
(declare (type function function))
(mp:with-lock (lock) (funcall function)))
(defimplementation current-thread ()
mp:*current-process*)
(defimplementation all-threads ()
(mp:all-processes))
(defimplementation interrupt-thread (thread fn)
(mp:interrupt-process thread fn))
(defimplementation kill-thread (thread)
(mp:process-kill thread))
(defimplementation thread-alive-p (thread)
(mp:process-active-p thread))
(defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
(defvar *mailboxes* (list))
(declaim (type list *mailboxes*))
(defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (mp:make-lock :name "SLYLCK"))
(cvar (mp:make-condition-variable))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(mp:with-lock (*mailbox-lock*)
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation wake-thread (thread)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(format t "About to with-lock in wake-thread~%")
(mp:with-lock (mutex)
(format t "In wake-thread~%")
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
;; (sly-dbg "clasp.lisp: send message ~a mutex: ~a~%" message mutex)
;; (sly-dbg "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
;; (sly-dbg "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
(mp:with-lock (mutex)
;; (sly-dbg "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
;; (sly-dbg "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(sly-dbg "clasp.lisp: send about to broadcast~%")
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
(defimplementation receive-if (test &optional timeout)
(sly-dbg "Entered receive-if")
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox)))
(sly-dbg "receive-if assert")
(assert (or (not timeout) (eq timeout t)))
(loop
(sly-dbg "receive-if check-sly-interrupts")
(check-sly-interrupts)
(sly-dbg "receive-if with-lock")
(mp:with-lock (mutex)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail))))
(sly-dbg "receive-if when (eq")
(when (eq timeout t) (return (values nil t)))
(sly-dbg "receive-if condition-variable-timedwait")
(mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2
(sly-dbg "came out of condition-variable-timedwait")
(sys:check-pending-interrupts)))))
) ; #+threads (progn ...
(defmethod emacs-inspect ((object sys:cxx-object))
(let ((encoded (sys:encode object)))
(loop for (key . value) in encoded
append (list (string key) ": " (list :value value) (list :newline)))))
(defmethod emacs-inspect ((object sys:vaslist))
(emacs-inspect (sys:list-from-vaslist object)))
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; slynk-ccl.lisp --- SLY backend for Clozure CL.
;;;
;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
;;;
;;; This program is licensed under the terms of the Lisp Lesser GNU
;;; Public License, known as the LLGPL, and distributed with Clozure CL
;;; as the file "LICENSE". The LLGPL consists of a preamble and the
;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
;;; these conflict, the preamble takes precedence.
;;;
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
(defpackage slynk-ccl
(:use cl slynk-backend))
(in-package slynk-ccl)
(eval-when (:compile-toplevel :execute :load-toplevel)
(assert (and (= ccl::*openmcl-major-version* 1)
(>= ccl::*openmcl-minor-version* 4))
() "This file needs CCL version 1.4 or newer"))
(defimplementation gray-package-name ()
"CCL")
(eval-when (:compile-toplevel :load-toplevel :execute)
(multiple-value-bind (ok err) (ignore-errors (require 'xref))
(unless ok
(warn "~a~%" err))))
;;; slynk-mop
(import-to-slynk-mop
'( ;; classes
cl:standard-generic-function
ccl:standard-slot-definition
cl:method
cl:standard-class
ccl:eql-specializer
openmcl-mop:finalize-inheritance
openmcl-mop:compute-applicable-methods-using-classes
;; standard-class readers
openmcl-mop:class-default-initargs
openmcl-mop:class-direct-default-initargs
openmcl-mop:class-direct-slots
openmcl-mop:class-direct-subclasses
openmcl-mop:class-direct-superclasses
openmcl-mop:class-finalized-p
cl:class-name
openmcl-mop:class-precedence-list
openmcl-mop:class-prototype
openmcl-mop:class-slots
openmcl-mop:specializer-direct-methods
;; eql-specializer accessors
openmcl-mop:eql-specializer-object
;; generic function readers
openmcl-mop:generic-function-argument-precedence-order
openmcl-mop:generic-function-declarations
openmcl-mop:generic-function-lambda-list
openmcl-mop:generic-function-methods
openmcl-mop:generic-function-method-class
openmcl-mop:generic-function-method-combination
openmcl-mop:generic-function-name
;; method readers
openmcl-mop:method-generic-function
openmcl-mop:method-function
openmcl-mop:method-lambda-list
openmcl-mop:method-specializers
openmcl-mop:method-qualifiers
;; slot readers
openmcl-mop:slot-definition-allocation
openmcl-mop:slot-definition-documentation
openmcl-mop:slot-value-using-class
openmcl-mop:slot-definition-initargs
openmcl-mop:slot-definition-initform
openmcl-mop:slot-definition-initfunction
openmcl-mop:slot-definition-name
openmcl-mop:slot-definition-type
openmcl-mop:slot-definition-readers
openmcl-mop:slot-definition-writers
openmcl-mop:slot-boundp-using-class
openmcl-mop:slot-makunbound-using-class))
(defmacro slynk-sym (sym)
(let ((str (symbol-name sym)))
`(or (find-symbol ,str :slynk)
(error "There is no symbol named ~a in the SLYNK package" ,str))))
;;; UTF8
(defimplementation string-to-utf8 (string)
(ccl:encode-string-to-octets string :external-format :utf-8))
(defimplementation utf8-to-string (octets)
(ccl:decode-string-from-octets octets :external-format :utf-8))
;;; TCP Server
(defimplementation preferred-communication-style ()
:spawn)
(defimplementation create-socket (host port &key backlog)
(ccl:make-socket :connect :passive :local-port port
:local-host host :reuse-address t
:backlog (or backlog 5)))
(defimplementation local-port (socket)
(ccl:local-port socket))
(defimplementation close-socket (socket)
(close socket))
(defimplementation accept-connection (socket &key external-format
buffering timeout)
(declare (ignore buffering timeout))
(let ((stream-args (and external-format
`(:external-format ,external-format))))
(ccl:accept-connection socket :wait t :stream-args stream-args)))
(defvar *external-format-to-coding-system*
'((:iso-8859-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
(defimplementation socket-fd (stream)
(ccl::ioblock-device (ccl::stream-ioblock stream t)))
;;; Unix signals
(defimplementation getpid ()
(ccl::getpid))
(defimplementation lisp-implementation-type-name ()
"ccl")
;;; Arglist
(defimplementation arglist (fname)
(multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
(ccl:arglist fname))
(if binding
arglist
:not-available)))
(defimplementation function-name (function)
(ccl:function-name function))
(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
(let ((flags (ccl:declaration-information decl-identifier)))
(if flags
`(&any ,flags)
(call-next-method))))
;;; Compilation
(defun handle-compiler-warning (condition)
"Resignal a ccl:compiler-warning as slynk-backend:compiler-warning."
(signal 'compiler-condition
:original-condition condition
:message (compiler-warning-short-message condition)
:source-context nil
:severity (compiler-warning-severity condition)
:location (source-note-to-source-location
(ccl:compiler-warning-source-note condition)
(lambda () "Unknown source")
(ccl:compiler-warning-function-name condition))))
(defgeneric compiler-warning-severity (condition))
(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
(defgeneric compiler-warning-short-message (condition))
;; Pretty much the same as ccl:report-compiler-warning but
;; without the source position and function name stuff.
(defmethod compiler-warning-short-message ((c ccl:compiler-warning))
(with-output-to-string (stream)
(ccl:report-compiler-warning c stream :short t)))
;; Needed because `ccl:report-compiler-warning' would return
;; "Nonspecific warning".
(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
(princ-to-string c))
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
(let ((ccl:*merge-compiler-warnings* nil))
(funcall function))))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-compilation-hooks ()
(compile-file input-file
:output-file output-file
:load load-p
:external-format external-format)))
;; Use a temp file rather than in-core compilation in order to handle
;; eval-when's as compile-time.
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore line column policy))
(with-compilation-hooks ()
(let ((temp-file-name (ccl:temp-pathname))
(ccl:*save-source-locations* t))
(unwind-protect
(progn
(with-open-file (s temp-file-name :direction :output
:if-exists :error :external-format :utf-8)
(write-string string s))
(let ((binary-filename (compile-temp-file
temp-file-name filename buffer position)))
(delete-file binary-filename)))
(delete-file temp-file-name)))))
(defvar *temp-file-map* (make-hash-table :test #'equal)
"A mapping from tempfile names to Emacs buffer names.")
(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
(compile-file temp-file-name
:load t
:compile-file-original-truename
(or buffer-file-name
(progn
(setf (gethash temp-file-name *temp-file-map*)
buffer-name)
temp-file-name))
:compile-file-original-buffer-offset (1- offset)
:external-format :utf-8))
(defimplementation save-image (filename &optional restart-function)
(ccl:save-application filename :toplevel-function restart-function))
;;; Cross-referencing
(defun xref-locations (relation name &optional inverse)
(delete-duplicates
(mapcan #'find-definitions
(if inverse
(ccl::get-relation relation name :wild :exhaustive t)
(ccl::get-relation relation :wild name :exhaustive t)))
:test 'equal))
(defimplementation who-binds (name)
(xref-locations :binds name))
(defimplementation who-macroexpands (name)
(xref-locations :macro-calls name t))
(defimplementation who-references (name)
(remove-duplicates
(append (xref-locations :references name)
(xref-locations :sets name)
(xref-locations :binds name))
:test 'equal))
(defimplementation who-sets (name)
(xref-locations :sets name))
(defimplementation who-calls (name)
(remove-duplicates
(append
(xref-locations :direct-calls name)
(xref-locations :indirect-calls name)
(xref-locations :macro-calls name t))
:test 'equal))
(defimplementation who-specializes (class)
(when (symbolp class)
(setq class (find-class class nil)))
(when class
(delete-duplicates
(mapcar (lambda (m)
(car (find-definitions m)))
(ccl:specializer-direct-methods class))
:test 'equal)))
(defimplementation list-callees (name)
(remove-duplicates
(append
(xref-locations :direct-calls name t)
(xref-locations :macro-calls name nil))
:test 'equal))
(defimplementation list-callers (symbol)
(delete-duplicates
(mapcan #'find-definitions (ccl:caller-functions symbol))
:test #'equal))
;;; Profiling (alanr: lifted from slynk-clisp)
(defimplementation profile (fname)
(eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
slynk-monitor:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(slynk-monitor:unmonitor))
(defimplementation profile-report ()
(slynk-monitor:report-monitoring))
(defimplementation profile-reset ()
(slynk-monitor:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(slynk-monitor:monitor-all package))
;;; Debugging
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* (;;(*debugger-hook* nil)
;; don't let error while printing error take us down
(ccl:*signal-printing-errors* nil))
(funcall debugger-loop-fn)))
;; This is called for an async interrupt and is running in a random
;; thread not selected by the user, so don't use thread-local vars
;; such as *emacs-connection*.
(defun find-repl-thread ()
(let* ((*break-on-signals* nil)
(conn (funcall (slynk-sym default-connection))))
(and conn
(ignore-errors ;; this errors if no repl-thread
(funcall (slynk-sym repl-thread) conn)))))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
(ccl:*break-hook* hook)
(ccl:*select-interactive-process-hook* 'find-repl-thread))
(funcall fun)))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setq ccl:*break-hook* function)
(setq ccl:*select-interactive-process-hook* 'find-repl-thread)
)
(defun map-backtrace (function &optional
(start-frame-number 0)
end-frame-number)
"Call FUNCTION passing information about each stack frame
from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
(let ((end-frame-number (or end-frame-number most-positive-fixnum)))
(ccl:map-call-frames function
:origin ccl:*top-error-frame*
:start-frame-number start-frame-number
:count (- end-frame-number start-frame-number))))
(defimplementation compute-backtrace (start-frame-number end-frame-number)
(let (result)
(map-backtrace (lambda (p context)
(push (list :frame p context) result))
start-frame-number end-frame-number)
(nreverse result)))
(defimplementation print-frame (frame stream)
(assert (eq (first frame) :frame))
(destructuring-bind (p context) (rest frame)
(let ((lfun (ccl:frame-function p context)))
(format stream "(~S" (or (ccl:function-name lfun) lfun))
(let* ((unavailable (cons nil nil))
(args (ccl:frame-supplied-arguments p context
:unknown-marker unavailable)))
(declare (dynamic-extent unavailable))
(if (eq args unavailable)
(format stream " #<Unknown Arguments>")
(dolist (arg args)
(if (eq arg unavailable)
(format stream " #<Unavailable>")
(format stream " ~s" arg)))))
(format stream ")"))))
(defmacro with-frame ((p context) frame-number &body body)
`(call/frame ,frame-number (lambda (,p ,context) . ,body)))
(defun call/frame (frame-number if-found)
(map-backtrace
(lambda (p context)
(return-from call/frame
(funcall if-found p context)))
frame-number))
(defimplementation frame-var-value (frame var)
(with-frame (p context) frame
(cdr (nth var (ccl:frame-named-variables p context)))))
(defimplementation frame-locals (index)
(with-frame (p context) index
(loop for (name . value) in (ccl:frame-named-variables p context)
collect (list :name name :value value :id 0))))
(defimplementation frame-source-location (index)
(with-frame (p context) index
(multiple-value-bind (lfun pc) (ccl:frame-function p context)
(if pc
(pc-source-location lfun pc)
(function-source-location lfun)))))
(defun function-name-package (name)
(etypecase name
(null nil)
(symbol (symbol-package name))
((cons (eql ccl::traced)) (function-name-package (second name)))
((cons (eql setf)) (symbol-package (second name)))
((cons (eql :internal)) (function-name-package (car (last name))))
((cons (and symbol (not keyword)) (or (cons list null)
(cons keyword (cons list null))))
(symbol-package (car name)))
(standard-method (function-name-package (ccl:method-name name)))))
(defimplementation frame-package (frame-number)
(with-frame (p context) frame-number
(let* ((lfun (ccl:frame-function p context))
(name (ccl:function-name lfun)))
(function-name-package name))))
(defimplementation eval-in-frame (form index)
(with-frame (p context) index
(let ((vars (ccl:frame-named-variables p context)))
(eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
(declare (ignorable ,@(mapcar #'car vars)))
,form)))))
(defimplementation return-from-frame (index form)
(let ((values (multiple-value-list (eval-in-frame form index))))
(with-frame (p context) index
(declare (ignore context))
(ccl:apply-in-frame p #'values values))))
(defimplementation restart-frame (index)
(with-frame (p context) index
(ccl:apply-in-frame p
(ccl:frame-function p context)
(ccl:frame-supplied-arguments p context))))
(defimplementation disassemble-frame (the-frame-number)
(with-frame (p context) the-frame-number
(multiple-value-bind (lfun pc) (ccl:frame-function p context)
(format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
(disassemble lfun))))
;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
;; contains some interesting details:
;;
;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
;; positions are file positions (not character positions). The text will
;; be NIL unless text recording was on at read-time. If the original
;; file is still available, you can force missing source text to be read
;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
;;
;; Source-note's are associated with definitions (via record-source-file)
;; and also stored in function objects (including anonymous and nested
;; functions). The former can be retrieved via
;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
;;
;; The recording behavior is controlled by the new variable
;; CCL:*SAVE-SOURCE-LOCATIONS*:
;;
;; If NIL, don't store source-notes in function objects, and store only
;; the filename for definitions (the latter only if
;; *record-source-file* is true).
;;
;; If T, store source-notes, including a copy of the original source
;; text, for function objects and definitions (the latter only if
;; *record-source-file* is true).
;;
;; If :NO-TEXT, store source-notes, but without saved text, for
;; function objects and defintions (the latter only if
;; *record-source-file* is true). This is the default.
;;
;; PC to source mapping is controlled by the new variable
;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
;; compressed table mapping pc offsets to corresponding source locations.
;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
;; which returns a source-note for the source at offset pc in the
;; function.
(defun function-source-location (function)
(source-note-to-source-location
(or (ccl:function-source-note function)
(function-name-source-note function))
(lambda ()
(format nil "Function has no source note: ~A" function))
(ccl:function-name function)))
(defun pc-source-location (function pc)
(source-note-to-source-location
(or (ccl:find-source-note-at-pc function pc)
(ccl:function-source-note function)
(function-name-source-note function))
(lambda ()
(format nil "No source note at PC: ~a[~d]" function pc))
(ccl:function-name function)))
(defun function-name-source-note (fun)
(let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
(and defs
(destructuring-bind ((type . name) srcloc . srclocs) (car defs)
(declare (ignore type name srclocs))
srcloc))))
(defun source-note-to-source-location (source if-nil-thunk &optional name)
(labels ((filename-to-buffer (filename)
(cond ((gethash filename *temp-file-map*)
(list :buffer (gethash filename *temp-file-map*)))
((probe-file filename)
(list :file (ccl:native-translated-namestring
(truename filename))))
(t (error "File ~s doesn't exist" filename)))))
(handler-case
(cond ((ccl:source-note-p source)
(let* ((full-text (ccl:source-note-text source))
(file-name (ccl:source-note-filename source))
(start-pos (ccl:source-note-start-pos source)))
(make-location
(when file-name (filename-to-buffer (pathname file-name)))
(when start-pos (list :position (1+ start-pos)))
(when full-text
(list :snippet (subseq full-text 0
(min 40 (length full-text))))))))
((and source name)
;; This branch is probably never used
(make-location
(filename-to-buffer source)
(list :function-name (princ-to-string
(if (functionp name)
(ccl:function-name name)
name)))))
(t `(:error ,(funcall if-nil-thunk))))
(error (c) `(:error ,(princ-to-string c))))))
(defun alphatizer-definitions (name)
(let ((alpha (gethash name ccl::*nx1-alphatizers*)))
(and alpha (ccl:find-definition-sources alpha))))
(defun p2-definitions (name)
(let ((nx1-op (gethash name ccl::*nx1-operators*)))
(and nx1-op
(let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
(and (array-in-bounds-p dispatch nx1-op)
(let ((p2 (aref dispatch nx1-op)))
(and p2
(ccl:find-definition-sources p2))))))))
(defimplementation find-definitions (name)
(let ((defs (append (or (ccl:find-definition-sources name)
(and (symbolp name)
(fboundp name)
(ccl:find-definition-sources
(symbol-function name))))
(alphatizer-definitions name)
(p2-definitions name))))
(loop for ((type . name) . sources) in defs
collect (list (definition-name type name)
(source-note-to-source-location
(find-if-not #'null sources)
(lambda () "No source-note available")
name)))))
(defimplementation find-source-location (obj)
(let* ((defs (ccl:find-definition-sources obj))
(best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
(car defs)))
(note (find-if-not #'null (cdr best-def))))
(when note
(source-note-to-source-location
note
(lambda () "No source note available")))))
(defun definition-name (type object)
(case (ccl:definition-type-name type)
(method (ccl:name-of object))
(t (list (ccl:definition-type-name type) (ccl:name-of object)))))
;;; Packages
#+#.(slynk-backend:with-symbol 'package-local-nicknames 'ccl)
(defimplementation package-local-nicknames (package)
(ccl:package-local-nicknames package))
;;; Utilities
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind &optional (sym symbol))
(or (documentation sym kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (when (boundp symbol)
(doc 'variable)))
(maybe-push
:function (if (fboundp symbol)
(doc 'function)))
(maybe-push
:setf (let ((setf-function-name (ccl:setf-function-spec-name
`(setf ,symbol))))
(when (fboundp setf-function-name)
(doc 'function setf-function-name))))
(maybe-push
:type (when (ccl:type-specifier-p symbol)
(doc 'type)))
result)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(:setf
(describe (ccl:setf-function-spec-name `(setf ,symbol))))
(:class
(describe (find-class symbol)))
(:type
(describe (or (find-class symbol nil) symbol)))))
;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*))
(defun parse-defmethod-spec (spec)
(values (second spec)
(subseq spec 2 (position-if #'consp spec))
(find-if #'consp (cddr spec))))
(defimplementation toggle-trace (spec)
"We currently ignore just about everything."
(let ((what (ecase (first spec)
((setf)
spec)
((:defgeneric)
(second spec))
((:defmethod)
(multiple-value-bind (name qualifiers specializers)
(parse-defmethod-spec spec)
(find-method (fdefinition name)
qualifiers
specializers))))))
(cond ((member what (trace) :test #'equal)
(ccl::%untrace what)
(format nil "~S is now untraced." what))
(t
(ccl:trace-function what)
(format nil "~S is now traced." what)))))
;;; Macroexpansion
(defimplementation macroexpand-all (form &optional env)
(ccl:macroexpand-all form env))
;;;; Inspection
(defun comment-type-p (type)
(or (eq type :comment)
(and (consp type) (eq (car type) :comment))))
(defmethod emacs-inspect ((o t))
(let* ((inspector:*inspector-disassembly* t)
(i (inspector:make-inspector o))
(count (inspector:compute-line-count i)))
(loop for l from 0 below count append
(multiple-value-bind (value label type) (inspector:line-n i l)
(etypecase type
((member nil :normal)
`(,(or label "") (:value ,value) (:newline)))
((member :colon)
(label-value-line label value))
((member :static)
(list (princ-to-string label) " " `(:value ,value) '(:newline)))
((satisfies comment-type-p)
(list (princ-to-string label) '(:newline))))))))
(defmethod emacs-inspect :around ((o t))
(if (or (uvector-inspector-p o)
(not (ccl:uvectorp o)))
(call-next-method)
(let ((value (call-next-method)))
(cond ((listp value)
(append value
`((:newline)
(:value ,(make-instance 'uvector-inspector :object o)
"Underlying UVECTOR"))))
(t value)))))
(defmethod emacs-inspect ((f function))
(append
(label-value-line "Name" (function-name f))
`("Its argument list is: "
,(princ-to-string (arglist f)) (:newline))
(label-value-line "Documentation" (documentation f t))
(when (function-lambda-expression f)
(label-value-line "Lambda Expression"
(function-lambda-expression f)))
(when (ccl:function-source-note f)
(label-value-line "Source note"
(ccl:function-source-note f)))
(when (typep f 'ccl:compiled-lexical-closure)
(append
(label-value-line "Inner function" (ccl::closure-function f))
'("Closed over values:" (:newline))
(loop for (name value) in (ccl::closure-closed-over-values f)
append (label-value-line (format nil " ~a" name)
value))))))
(defclass uvector-inspector ()
((object :initarg :object)))
(defgeneric uvector-inspector-p (object)
(:method ((object t)) nil)
(:method ((object uvector-inspector)) t))
(defmethod emacs-inspect ((uv uvector-inspector))
(with-slots (object) uv
(loop for i below (ccl:uvsize object) append
(label-value-line (princ-to-string i) (ccl:uvref object i)))))
(defimplementation type-specifier-p (symbol)
(or (ccl:type-specifier-p symbol)
(not (eq (type-specifier-arglist symbol) :not-available))))
;;; Multiprocessing
(defvar *known-processes*
(make-hash-table :size 20 :weak :key :test #'eq)
"A map from threads to mailboxes.")
(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
(defstruct (mailbox (:conc-name mailbox.))
(mutex (ccl:make-lock "thread mailbox"))
(semaphore (ccl:make-semaphore))
(queue '() :type list))
(defimplementation spawn (fun &key name)
(ccl:process-run-function (or name "Anonymous (Slynk)")
fun))
(defimplementation thread-id (thread)
(ccl:process-serial-number thread))
(defimplementation find-thread (id)
(find id (ccl:all-processes) :key #'ccl:process-serial-number))
(defimplementation thread-name (thread)
(ccl:process-name thread))
(defimplementation thread-status (thread)
(format nil "~A" (ccl:process-whostate thread)))
(defimplementation thread-attributes (thread)
(list :priority (ccl:process-priority thread)))
(defimplementation make-lock (&key name)
(ccl:make-lock name))
(defimplementation call-with-lock-held (lock function)
(ccl:with-lock-grabbed (lock)
(funcall function)))
(defimplementation current-thread ()
ccl:*current-process*)
(defimplementation all-threads ()
(ccl:all-processes))
(defimplementation kill-thread (thread)
;;(ccl:process-kill thread) ; doesn't cut it
(ccl::process-initial-form-exited thread :kill))
(defimplementation thread-alive-p (thread)
(not (ccl:process-exhausted-p thread)))
(defimplementation interrupt-thread (thread function)
(ccl:process-interrupt
thread
(lambda ()
(let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
(funcall function)))))
(defun mailbox (thread)
(ccl:with-lock-grabbed (*known-processes-lock*)
(or (gethash thread *known-processes*)
(setf (gethash thread *known-processes*) (make-mailbox)))))
(defimplementation send (thread message)
(assert message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(ccl:with-lock-grabbed (mutex)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(ccl:signal-semaphore (mailbox.semaphore mbox)))))
(defimplementation wake-thread (thread)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(ccl:with-lock-grabbed (mutex)
(ccl:signal-semaphore (mailbox.semaphore mbox)))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox ccl:*current-process*))
(mutex (mailbox.mutex mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(ccl:with-lock-grabbed (mutex)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox)
(nconc (ldiff q tail) (cdr tail)))
(return (car tail)))))
(when (eq timeout t) (return (values nil t)))
(ccl:wait-on-semaphore (mailbox.semaphore mbox)))))
(let ((alist '())
(lock (ccl:make-lock "register-thread")))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(ccl:with-lock-grabbed (lock)
(etypecase thread
(null
(setf alist (delete name alist :key #'car)))
(ccl:process
(let ((probe (assoc name alist)))
(cond (probe (setf (cdr probe) thread))
(t (setf alist (acons name thread alist))))))))
nil)
(defimplementation find-registered (name)
(ccl:with-lock-grabbed (lock)
(cdr (assoc name alist)))))
(defimplementation set-default-initial-binding (var form)
(eval `(ccl::def-standard-initial-binding ,var ,form)))
(defimplementation quit-lisp ()
(ccl:quit))
(defimplementation set-default-directory (directory)
(let ((dir (truename (merge-pathnames directory))))
(setf *default-pathname-defaults* (truename (merge-pathnames directory)))
(ccl:cwd dir)
(default-directory)))
;;; Weak datastructures
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak :key args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weak :value args))
(defimplementation hash-table-weakness (hashtable)
(ccl:hash-table-weak-p hashtable))
(pushnew 'deinit-log-output ccl:*save-exit-functions*)
;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
;;;
;;; slynk-allegro.lisp --- Allegro CL specific code for SLY.
;;;
;;; Created 2003
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(defpackage slynk-allegro
(:use cl slynk-backend))
(in-package slynk-allegro)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sock)
(require :process)
#+(version>= 8 2)
(require 'lldb)
)
(defimplementation gray-package-name ()
'#:excl)
;;; slynk-mop
(import-slynk-mop-symbols :clos '(:slot-definition-documentation))
(defun slynk-mop:slot-definition-documentation (slot)
(documentation slot t))
;;;; UTF8
(define-symbol-macro utf8-ef
(load-time-value
(excl:crlf-base-ef (excl:find-external-format :utf-8))
t))
(defimplementation string-to-utf8 (s)
(excl:string-to-octets s :external-format utf8-ef
:null-terminate nil))
(defimplementation utf8-to-string (u)
(excl:octets-to-string u :external-format utf8-ef))
;;;; TCP Server
(defimplementation preferred-communication-style ()
:spawn)
(defimplementation create-socket (host port &key backlog)
(socket:make-socket :connect :passive :local-port port
:local-host host :reuse-address t
:backlog (or backlog 5)))
(defimplementation local-port (socket)
(socket:local-port socket))
(defimplementation close-socket (socket)
(close socket))
(defimplementation accept-connection (socket &key external-format buffering
timeout)
(declare (ignore buffering timeout))
(let ((s (socket:accept-connection socket :wait t)))
(when external-format
(setf (stream-external-format s) external-format))
s))
(defimplementation socket-fd (stream)
(excl::stream-input-handle stream))
(defvar *external-format-to-coding-system*
'((:iso-8859-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")
(:euc-jp "euc-jp" "euc-jp-unix")
(:us-ascii "us-ascii" "us-ascii-unix")
(:emacs-mule "emacs-mule" "emacs-mule-unix")))
(defimplementation find-external-format (coding-system)
(let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
(and e (excl:crlf-base-ef
(excl:find-external-format (car e)
:try-variant t)))))
;;;; Unix signals
(defimplementation getpid ()
(excl::getpid))
(defimplementation lisp-implementation-type-name ()
"allegro")
(defimplementation set-default-directory (directory)
(let* ((dir (namestring (truename (merge-pathnames directory)))))
(setf *default-pathname-defaults* (pathname (excl:chdir dir)))
dir))
(defimplementation default-directory ()
(namestring (excl:current-directory)))
;;;; Misc
(defimplementation arglist (symbol)
(handler-case (excl:arglist symbol)
(simple-error () :not-available)))
(defimplementation macroexpand-all (form &optional env)
(declare (ignore env))
#+(version>= 8 0)
(excl::walk-form form)
#-(version>= 8 0)
(excl::walk form))
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind &optional (sym symbol))
(or (ignore-errors
(documentation sym kind))
:not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (when (boundp symbol)
(doc 'variable)))
(maybe-push
:function (if (fboundp symbol)
(doc 'function)))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
result)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(:class
(describe (find-class symbol)))))
(defimplementation type-specifier-p (symbol)
(or (ignore-errors
(subtypep nil symbol))
(not (eq (type-specifier-arglist symbol) :not-available))))
(defimplementation function-name (f)
(check-type f function)
(cross-reference::object-to-function-name f))
;;;; Debugger
(defvar *sly-db-topframe*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let ((*sly-db-topframe* (find-topframe))
(excl::*break-hook* nil))
(funcall debugger-loop-fn)))
(defimplementation sly-db-break-at-start (fname)
;; :print-before is kind of mis-used but we just want to stuff our
;; break form somewhere. This does not work for setf, :before and
;; :after methods, which need special syntax in the trace call, see
;; ACL's doc/debugging.htm chapter 10.
(eval `(trace (,fname
:print-before
((break "Function start breakpoint of ~A" ',fname)))))
`(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
(defun find-topframe ()
(let ((magic-symbol (intern (symbol-name :slynk-debugger-hook)
(find-package :slynk)))
(top-frame (excl::int-newest-frame (excl::current-thread))))
(loop for frame = top-frame then (next-frame frame)
for i from 0
while (and frame (< i 30))
when (eq (debugger:frame-name frame) magic-symbol)
return (next-frame frame)
finally (return top-frame))))
(defun next-frame (frame)
(let ((next (excl::int-next-older-frame frame)))
(cond ((not next) nil)
((debugger:frame-visible-p next) next)
(t (next-frame next)))))
(defun nth-frame (index)
(do ((frame *sly-db-topframe* (next-frame frame))
(i index (1- i)))
((zerop i) frame)))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (next-frame f)
for i from start below end
while f collect f)))
(defimplementation print-frame (frame stream)
(debugger:output-frame stream frame :moderate))
(defimplementation frame-locals (index)
(let ((frame (nth-frame index)))
(loop for i from 0 below (debugger:frame-number-vars frame)
collect (list :name (debugger:frame-var-name frame i)
:id 0
:value (debugger:frame-var-value frame i)))))
(defimplementation frame-arguments (index)
(let ((frame (nth-frame index)))
;; (values-list (debugger::.actuals frame))
(values-list
(loop for i from 0 below (debugger:frame-number-vars frame)
unless (eq :local (debugger:frame-var-type frame i))
collect (debugger:frame-var-value frame i)))))
(defimplementation frame-var-value (frame var)
(let ((frame (nth-frame frame)))
(debugger:frame-var-value frame var)))
(defimplementation disassemble-frame (index)
(let ((frame (nth-frame index)))
(multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
(format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
(disassemble (debugger:frame-function frame)))))
(defimplementation frame-source-location (index)
(let* ((frame (nth-frame index)))
(multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
(declare (ignore x xx xxx))
(cond ((and pc
#+(version>= 8 2)
(pc-source-location fun pc)
#-(version>= 8 2)
(function-source-location fun)))
(t ; frames for unbound functions etc end up here
(cadr (car (fspec-definition-locations
(car (debugger:frame-expression frame))))))))))
(defun function-source-location (fun)
(cadr (car (fspec-definition-locations
(xref::object-to-function-name fun)))))
#+(version>= 8 2)
(defun pc-source-location (fun pc)
(let* ((debug-info (excl::function-source-debug-info fun)))
(cond ((not debug-info)
(function-source-location fun))
(t
(let* ((code-loc (find-if (lambda (c)
(<= (- pc (sys::natural-width))
(let ((x (excl::ldb-code-pc c)))
(or x -1))
pc))
debug-info)))
(cond ((not code-loc)
(ldb-code-to-src-loc (aref debug-info 0)))
(t
(ldb-code-to-src-loc code-loc))))))))
#+(version>= 8 2)
(defun ldb-code-to-src-loc (code)
(declare (optimize debug))
(let* ((func (excl::ldb-code-func code))
(debug-info (excl::function-source-debug-info func))
(start (and debug-info
(loop for i from (excl::ldb-code-index code) downto 0
for bpt = (aref debug-info i)
for start = (excl::ldb-code-start-char bpt)
when start
return (if (listp start)
(first start)
start))))
(src-file (and func (excl:source-file func))))
(cond (start
(buffer-or-file-location src-file start))
(func
(let* ((debug-info (excl::function-source-debug-info func))
(whole (aref debug-info 0))
(paths (source-paths-of (excl::ldb-code-source whole)
(excl::ldb-code-source code)))
(path (if paths (longest-common-prefix paths) '()))
(start 0))
(buffer-or-file
src-file
(lambda (file)
(make-location `(:file ,file)
`(:source-path (0 . ,path) ,start)))
(lambda (buffer bstart)
(make-location `(:buffer ,buffer)
`(:source-path (0 . ,path)
,(+ bstart start)))))))
(t
nil))))
(defun longest-common-prefix (sequences)
(assert sequences)
(flet ((common-prefix (s1 s2)
(let ((diff-pos (mismatch s1 s2)))
(if diff-pos (subseq s1 0 diff-pos) s1))))
(reduce #'common-prefix sequences)))
(defun source-paths-of (whole part)
(let ((result '()))
(labels ((walk (form path)
(cond ((eq form part)
(push (reverse path) result))
((consp form)
(loop for i from 0 while (consp form) do
(walk (pop form) (cons i path)))))))
(walk whole '())
(reverse result))))
(defimplementation eval-in-frame (form frame-number)
(let ((frame (nth-frame frame-number)))
;; let-bind lexical variables
(let ((vars (loop for i below (debugger:frame-number-vars frame)
for name = (debugger:frame-var-name frame i)
if (typep name '(and symbol (not null) (not keyword)))
collect `(,name ',(debugger:frame-var-value frame i)))))
(debugger:eval-form-in-context
`(let* ,vars ,form)
(debugger:environment-of-frame frame)))))
(defimplementation frame-package (frame-number)
(let* ((frame (nth-frame frame-number))
(exp (debugger:frame-expression frame)))
(typecase exp
((cons symbol) (symbol-package (car exp)))
((cons (cons (eql :internal) (cons symbol)))
(symbol-package (cadar exp))))))
(defimplementation return-from-frame (frame-number form)
(let ((frame (nth-frame frame-number)))
(multiple-value-call #'debugger:frame-return
frame (debugger:eval-form-in-context
form
(debugger:environment-of-frame frame)))))
(defimplementation frame-restartable-p (frame)
(handler-case (debugger:frame-retryable-p frame)
(serious-condition (c)
(declare (ignore c))
;; How to log this? Should we?
nil)))
(defimplementation restart-frame (frame-number)
(let ((frame (nth-frame frame-number)))
(cond ((frame-restartable-p frame)
(apply #'debugger:frame-retry frame (debugger:frame-function frame)
(cdr (debugger:frame-expression frame))))
(t "Frame is not retryable"))))
;;;; Compiler hooks
(defvar *buffer-name* nil)
(defvar *buffer-start-position*)
(defvar *buffer-string*)
(defvar *compile-filename* nil)
(defun compiler-note-p (object)
(member (type-of object) '(excl::compiler-note compiler::compiler-note)))
(defun redefinition-p (condition)
(and (typep condition 'style-warning)
(every #'char-equal "redefin" (princ-to-string condition))))
(defun compiler-undefined-functions-called-warning-p (object)
(typep object 'excl:compiler-undefined-functions-called-warning))
(deftype compiler-note ()
`(satisfies compiler-note-p))
(deftype redefinition ()
`(satisfies redefinition-p))
(defun signal-compiler-condition (&rest args)
(apply #'signal 'compiler-condition args))
(defun handle-compiler-warning (condition)
(declare (optimize (debug 3) (speed 0) (space 0)))
(cond ((and #-(version>= 10 0) (not *buffer-name*)
(compiler-undefined-functions-called-warning-p condition))
(handle-undefined-functions-warning condition))
((and (typep condition 'excl::compiler-note)
(let ((format (slot-value condition 'excl::format-control)))
(and (search "Closure" format)
(search "will be stack allocated" format))))
;; Ignore "Closure <foo> will be stack allocated" notes.
;; That occurs often but is usually uninteresting.
)
(t
(signal-compiler-condition
:original-condition condition
:severity (etypecase condition
(redefinition :redefinition)
(style-warning :style-warning)
(warning :warning)
(compiler-note :note)
(reader-error :read-error)
(error :error))
:message (format nil "~A" condition)
:location (compiler-warning-location condition)))))
(defun condition-pathname-and-position (condition)
(let* ((context #+(version>= 10 0)
(getf (slot-value condition 'excl::plist)
:source-context))
(location-available (and context
(excl::source-context-start-char context))))
(cond (location-available
(values (excl::source-context-pathname context)
(when-let (start-char (excl::source-context-start-char context))
(let ((position (if (listp start-char) ; HACK
(first start-char)
start-char)))
(if (typep condition 'excl::compiler-free-reference-warning)
position
(1+ position))))))
((typep condition 'reader-error)
(let ((pos (car (last (slot-value condition 'excl::format-arguments))))
(file (pathname (stream-error-stream condition))))
(when (integerp pos)
(values file pos))))
(t
(let ((loc (getf (slot-value condition 'excl::plist) :loc)))
(when loc
(destructuring-bind (file . pos) loc
(let ((start
(if (consp pos)
;; FIXME: report this bug to Franz. See
;; the commit message for recipe
#+(version>= 10 1)
(if (typep
condition
'excl::compiler-inconsistent-name-usage-warning)
(second pos) (first pos))
#-(version>= 10 1)
(first pos)
pos)))
(values file start)))))))))
(defun compiler-warning-location (condition)
(multiple-value-bind (pathname position)
(condition-pathname-and-position condition)
(cond (*buffer-name*
(make-location
(list :buffer *buffer-name*)
(if position
(list :offset 1 (1- position))
(list :offset *buffer-start-position* 0))))
(pathname
(make-location
(list :file (namestring (truename pathname)))
#+(version>= 10 1)
(list :offset 1 position)
#-(version>= 10 1)
(list :position (1+ position))))
(t
(make-error-location "No error location available.")))))
;; TODO: report it as a bug to Franz that the condition's plist
;; slot contains (:loc nil).
(defun handle-undefined-functions-warning (condition)
(let ((fargs (slot-value condition 'excl::format-arguments)))
(loop for (fname . locs) in (car fargs) do
(dolist (loc locs)
(multiple-value-bind (pos file) (ecase (length loc)
(2 (values-list loc))
(3 (destructuring-bind
(start end file) loc
(declare (ignore end))
(values start file))))
(signal-compiler-condition
:original-condition condition
:severity :warning
:message (format nil "Undefined function referenced: ~S"
fname)
:location (make-location (list :file file)
#+(version>= 9 0)
(list :offset 1 pos)
#-(version>= 9 0)
(list :position (1+ pos)))))))))
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((warning #'handle-compiler-warning)
(compiler-note #'handle-compiler-warning)
(reader-error #'handle-compiler-warning))
(funcall function)))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(handler-case
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(*compile-filename* input-file)
#+(version>= 8 2)
(compiler:save-source-level-debug-info-switch t)
(excl:*load-source-file-info* t)
#+(version>= 8 2)
(excl:*load-source-debug-info* t))
(compile-file *compile-filename*
:output-file output-file
:load-after-compile load-p
:external-format external-format)))
(reader-error () (values nil nil t))))
(defun call-with-temp-file (fn)
(let ((tmpname (system:make-temp-file-name)))
(unwind-protect
(with-open-file (file tmpname :direction :output :if-exists :error)
(funcall fn file tmpname))
(delete-file tmpname))))
(defvar *temp-file-map* (make-hash-table :test #'equal)
"A mapping from tempfile names to Emacs buffer names.")
(defun write-tracking-preamble (stream file file-offset)
"Instrument the top of the temporary file to be compiled.
The header tells allegro that any definitions compiled in the temp
file should be found in FILE exactly at FILE-OFFSET. To get Allegro
to do this, this factors in the length of the inserted header itself."
(with-standard-io-syntax
(let* ((*package* (find-package :keyword))
(source-pathname-form
`(cl:eval-when (:compile-toplevel :load-toplevel :execute)
(cl:setq excl::*source-pathname*
(pathname ,(sys::frob-source-file file)))))
(source-pathname-string (write-to-string source-pathname-form))
(position-form-length-bound 160) ; should be enough for everyone
(header-length (+ (length source-pathname-string)
position-form-length-bound))
(position-form
`(cl:eval-when (:compile-toplevel :load-toplevel :execute)
(cl:setq excl::*partial-source-file-p* ,(- file-offset
header-length
1 ; for the newline
))))
(position-form-string (write-to-string position-form))
(padding-string (make-string (- position-form-length-bound
(length position-form-string))
:initial-element #\;)))
(write-string source-pathname-string stream)
(write-string position-form-string stream)
(write-string padding-string stream)
(write-char #\newline stream))))
(defun compile-from-temp-file (string buffer offset file)
(call-with-temp-file
(lambda (stream filename)
(when (and file offset (probe-file file))
(write-tracking-preamble stream file offset))
(write-string string stream)
(finish-output stream)
(multiple-value-bind (binary-filename warnings? failure?)
(let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension
#+(version>= 8 2)
(compiler:save-source-level-debug-info-switch t)
(excl:*redefinition-warnings* nil))
(compile-file filename))
(declare (ignore warnings?))
(when binary-filename
(let ((excl:*load-source-file-info* t)
#+(version>= 8 2)
(excl:*load-source-debug-info* t))
excl::*source-pathname*
(load binary-filename))
(when (and buffer offset (or (not file)
(not (probe-file file))))
(setf (gethash (pathname stream) *temp-file-map*)
(list buffer offset)))
(delete-file binary-filename))
(not failure?)))))
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore line column policy))
(handler-case
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
(*buffer-string* string))
(compile-from-temp-file string buffer position filename)))
(reader-error () nil)))
;;;; Definition Finding
(defun buffer-or-file (file file-fun buffer-fun)
(let* ((probe (gethash file *temp-file-map*)))
(cond (probe
(destructuring-bind (buffer start) probe
(funcall buffer-fun buffer start)))
(t (funcall file-fun (namestring (truename file)))))))
(defun buffer-or-file-location (file offset)
(buffer-or-file file
(lambda (filename)
(make-location `(:file ,filename)
`(:position ,(1+ offset))))
(lambda (buffer start)
(make-location `(:buffer ,buffer)
`(:offset ,start ,offset)))))
(defun fspec-primary-name (fspec)
(etypecase fspec
(symbol fspec)
(list (fspec-primary-name (second fspec)))))
(defun find-definition-in-file (fspec type file top-level)
(let* ((part
(or (scm::find-definition-in-definition-group
fspec type (scm:section-file :file file)
:top-level top-level)
(scm::find-definition-in-definition-group
(fspec-primary-name fspec)
type (scm:section-file :file file)
:top-level top-level)))
(start (and part
(scm::source-part-start part)))
(pos (if start
(list :offset 1 start)
(list :function-name (string (fspec-primary-name fspec))))))
(make-location (list :file (namestring (truename file)))
pos)))
(defun find-fspec-location (fspec type file top-level)
(handler-case
(etypecase file
(pathname
(let ((probe (gethash file *temp-file-map*)))
(cond (probe
(destructuring-bind (buffer offset) probe
(make-location `(:buffer ,buffer)
`(:offset ,offset 0))))
(t
(find-definition-in-file fspec type file top-level)))))
((member :top-level)
(make-error-location "Defined at toplevel: ~A"
(fspec->string fspec))))
(error (e)
(make-error-location "Error: ~A" e))))
(defun fspec->string (fspec)
(typecase fspec
(symbol (let ((*package* (find-package :keyword)))
(prin1-to-string fspec)))
(list (format nil "(~A ~A)"
(prin1-to-string (first fspec))
(let ((*package* (find-package :keyword)))
(prin1-to-string (second fspec)))))
(t (princ-to-string fspec))))
(defun fspec-definition-locations (fspec)
(cond
((and (listp fspec) (eq (car fspec) :internal))
(destructuring-bind (_internal next _n) fspec
(declare (ignore _internal _n))
(fspec-definition-locations next)))
(t
(let ((defs (excl::find-source-file fspec)))
(when (and (null defs)
(listp fspec)
(string= (car fspec) '#:method))
;; If methods are defined in a defgeneric form, the source location is
;; recorded for the gf but not for the methods. Therefore fall back to
;; the gf as the likely place of definition.
(setq defs (excl::find-source-file (second fspec))))
(if (null defs)
(list
(list fspec
(make-error-location "Unknown source location for ~A"
(fspec->string fspec))))
(loop for (fspec type file top-level) in defs collect
(list (list type fspec)
(find-fspec-location fspec type file top-level))))))))
(defimplementation find-definitions (symbol)
(fspec-definition-locations symbol))
(defimplementation find-source-location (obj)
(first (rest (first (fspec-definition-locations obj)))))
;;;; XREF
(defmacro defxref (name relation name1 name2)
`(defimplementation ,name (x)
(xref-result (xref:get-relation ,relation ,name1 ,name2))))
(defxref who-calls :calls :wild x)
(defxref calls-who :calls x :wild)
(defxref who-references :uses :wild x)
(defxref who-binds :binds :wild x)
(defxref who-macroexpands :macro-calls :wild x)
(defxref who-sets :sets :wild x)
(defun xref-result (fspecs)
(loop for fspec in fspecs
append (fspec-definition-locations fspec)))
;; list-callers implemented by groveling through all fbound symbols.
;; Only symbols are considered. Functions in the constant pool are
;; searched recursively. Closure environments are ignored at the
;; moment (constants in methods are therefore not found).
(defun map-function-constants (function fn depth)
"Call FN with the elements of FUNCTION's constant pool."
(do ((i 0 (1+ i))
(max (excl::function-constant-count function)))
((= i max))
(let ((c (excl::function-constant function i)))
(cond ((and (functionp c)
(not (eq c function))
(plusp depth))
(map-function-constants c fn (1- depth)))
(t
(funcall fn c))))))
(defun in-constants-p (fun symbol)
(map-function-constants fun
(lambda (c)
(when (eq c symbol)
(return-from in-constants-p t)))
3))
(defun function-callers (name)
(let ((callers '()))
(do-all-symbols (sym)
(when (fboundp sym)
(let ((fn (fdefinition sym)))
(when (in-constants-p fn name)
(push sym callers)))))
callers))
(defimplementation list-callers (name)
(xref-result (function-callers name)))
(defimplementation list-callees (name)
(let ((result '()))
(map-function-constants (fdefinition name)
(lambda (c)
(when (fboundp c)
(push c result)))
2)
(xref-result result)))
;;;; Profiling
;; Per-function profiling based on description in
;; http://www.franz.com/support/documentation/8.0/\
;; doc/runtime-analyzer.htm#data-collection-control-2
(defvar *profiled-functions* ())
(defvar *profile-depth* 0)
(defmacro with-redirected-y-or-n-p (&body body)
;; If the profiler is restarted when the data from the previous
;; session is not reported yet, the user is warned via Y-OR-N-P.
;; As the CL:Y-OR-N-P question is (for some reason) not directly
;; sent to the Sly user, the function CL:Y-OR-N-P is temporarily
;; overruled.
`(let* ((pkg (find-package :common-lisp))
(saved-pdl (excl::package-definition-lock pkg))
(saved-ynp (symbol-function 'cl:y-or-n-p)))
(setf (excl::package-definition-lock pkg) nil
(symbol-function 'cl:y-or-n-p)
(symbol-function (slynk-backend:find-symbol2 "slynk:y-or-n-p-in-emacs")))
(unwind-protect
(progn ,@body)
(setf (symbol-function 'cl:y-or-n-p) saved-ynp
(excl::package-definition-lock pkg) saved-pdl))))
(defun start-acl-profiler ()
(with-redirected-y-or-n-p
(prof:start-profiler :type :time :count t
:start-sampling-p nil :verbose nil)))
(defun acl-profiler-active-p ()
(not (eq (prof:profiler-status :verbose nil) :inactive)))
(defun stop-acl-profiler ()
(prof:stop-profiler :verbose nil))
(excl:def-fwrapper profile-fwrapper (&rest args)
;; Ensures sampling is done during the execution of the function,
;; taking into account recursion.
(declare (ignore args))
(cond ((zerop *profile-depth*)
(let ((*profile-depth* (1+ *profile-depth*)))
(prof:start-sampling)
(unwind-protect (excl:call-next-fwrapper)
(prof:stop-sampling))))
(t
(excl:call-next-fwrapper))))
(defimplementation profile (fname)
(unless (acl-profiler-active-p)
(start-acl-profiler))
(excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
(push fname *profiled-functions*))
(defimplementation profiled-functions ()
*profiled-functions*)
(defimplementation unprofile (fname)
(excl:funwrap fname 'profile-fwrapper)
(setq *profiled-functions* (remove fname *profiled-functions*)))
(defimplementation profile-report ()
(prof:show-flat-profile :verbose nil)
(when *profiled-functions*
(start-acl-profiler)))
(defimplementation profile-reset ()
(when (acl-profiler-active-p)
(stop-acl-profiler)
(start-acl-profiler))
"Reset profiling counters.")
;;;; Inspecting
(excl:without-redefinition-warnings
(defmethod emacs-inspect ((o t))
(allegro-inspect o)))
(defmethod emacs-inspect ((o function))
(allegro-inspect o))
(defmethod emacs-inspect ((o standard-object))
(allegro-inspect o))
(defun allegro-inspect (o)
(loop for (d dd) on (inspect::inspect-ctl o)
append (frob-allegro-field-def o d)
until (eq d dd)))
(defun frob-allegro-field-def (object def)
(with-struct (inspect::field-def- name type access) def
(ecase type
((:unsigned-word :unsigned-byte :unsigned-natural
:unsigned-long :unsigned-half-long
:unsigned-3byte :unsigned-long32)
(label-value-line name (inspect::component-ref-v object access type)))
((:lisp :value :func)
(label-value-line name (inspect::component-ref object access)))
(:indirect
(destructuring-bind (prefix count ref set) access
(declare (ignore set prefix))
(loop for i below (funcall count object)
append (label-value-line (format nil "~A-~D" name i)
(funcall ref object i))))))))
;;;; Multithreading
(defimplementation initialize-multiprocessing (continuation)
(mp:start-scheduler)
(funcall continuation))
(defimplementation spawn (fn &key name)
(mp:process-run-function name fn))
(defvar *process-plist-lock* (mp:make-process-lock :name "process-plist-lock"))
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
#+(version>= 10 0)
(mp:process-sequence thread)
#-(version> 10 0)
(mp:with-process-lock (*process-plist-lock*)
(or (getf (mp:process-property-list thread) 'id)
(setf (getf (mp:process-property-list thread) 'id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id mp:*all-processes*
:key
#+(version>= 10 0)
#'mp:process-sequence
#-(version>= 10 0)
(lambda (p) (getf (mp:process-property-list p) 'id))))
(defimplementation thread-name (thread)
(mp:process-name thread))
(defimplementation thread-status (thread)
(princ-to-string (mp:process-whostate thread)))
(defimplementation thread-attributes (thread)
(list :priority (mp:process-priority thread)
:times-resumed (mp:process-times-resumed thread)))
(defimplementation make-lock (&key name)
(mp:make-process-lock :name name))
(defimplementation call-with-lock-held (lock function)
(mp:with-process-lock (lock) (funcall function)))
(defimplementation current-thread ()
mp:*current-process*)
(defimplementation all-threads ()
(copy-list mp:*all-processes*))
(defimplementation interrupt-thread (thread fn)
(mp:process-interrupt thread fn))
(defimplementation kill-thread (thread)
(mp:process-kill thread))
(defstruct (mailbox (:conc-name mailbox.))
(lock (mp:make-process-lock :name "process mailbox"))
(queue '() :type list)
(gate (mp:make-gate nil)))
(defvar *global-mailbox-ht-lock*
(mp:make-process-lock :name '*global-mailbox-ht-lock*))
(defvar *mailboxes* (make-hash-table :weak-keys t)
"Threads' mailboxes.")
(defun mailbox (thread)
"Return THREAD's mailbox."
(mp:with-process-lock (*global-mailbox-ht-lock*)
(or (gethash thread *mailboxes*)
(setf (gethash thread *mailboxes*) (make-mailbox)))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread)))
(mp:with-process-lock ((mailbox.lock mbox))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(mp:open-gate (mailbox.gate mbox)))))
(defimplementation wake-thread (thread)
(let* ((mbox (mailbox thread)))
(mp:open-gate (mailbox.gate mbox))))
(defimplementation receive-if (test &optional timeout)
(let ((mbox (mailbox mp:*current-process*)))
(flet ((open-mailbox ()
;; this opens the mailbox and returns if has the message
;; we are expecting. But first, check for interrupts.
(check-sly-interrupts)
(mp:with-process-lock ((mailbox.lock mbox))
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return-from receive-if (car tail)))
;; ...if it doesn't, we close the gate (even if it
;; was already closed)
(mp:close-gate (mailbox.gate mbox))))))
(cond (timeout
;; open the mailbox and return asap
(open-mailbox)
(return-from receive-if (values nil t)))
(t
;; wait until gate open, then open mailbox. If there's
;; no message there, repeat forever.
(loop
(mp:process-wait
"receive-if (waiting on gate)"
#'mp:gate-open-p (mailbox.gate mbox))
(open-mailbox)))))))
(let ((alist '())
(lock (mp:make-process-lock :name "register-thread")))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(mp:with-process-lock (lock)
(etypecase thread
(null
(setf alist (delete name alist :key #'car)))
(mp:process
(let ((probe (assoc name alist)))
(cond (probe (setf (cdr probe) thread))
(t (setf alist (acons name thread alist))))))))
nil)
(defimplementation find-registered (name)
(mp:with-process-lock (lock)
(cdr (assoc name alist)))))
(defimplementation set-default-initial-binding (var form)
(push (cons var form)
#+(version>= 9 0)
excl:*required-thread-bindings*
#-(version>= 9 0)
excl::required-thread-bindings))
(defimplementation quit-lisp ()
(excl:exit 0 :quiet t))
;;Trace implementations
;;In Allegro 7.0, we have:
;; (trace <name>)
;; (trace ((method <name> <qualifier>? (<specializer>+))))
;; (trace ((labels <name> <label-name>)))
;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
;; <name> can be a normal name or a (setf name)
(defimplementation toggle-trace (spec)
(ecase (car spec)
((setf)
(toggle-trace-aux spec))
(:defgeneric (toggle-trace-generic-function-methods (second spec)))
((setf :defmethod :labels :flet)
(toggle-trace-aux (process-fspec-for-allegro spec)))
(:call
(destructuring-bind (caller callee) (cdr spec)
(toggle-trace-aux callee
:inside (list (process-fspec-for-allegro caller)))))))
(defun tracedp (fspec)
(member fspec (eval '(trace)) :test #'equal))
(defun toggle-trace-aux (fspec &rest args)
(cond ((tracedp fspec)
(eval `(untrace ,fspec))
(format nil "~S is now untraced." fspec))
(t
(eval `(trace (,fspec ,@args)))
(format nil "~S is now traced." fspec))))
(defun toggle-trace-generic-function-methods (name)
(let ((methods (mop:generic-function-methods (fdefinition name))))
(cond ((tracedp name)
(eval `(untrace ,name))
(dolist (method methods (format nil "~S is now untraced." name))
(excl:funtrace (mop:method-function method))))
(t
(eval `(trace (,name)))
(dolist (method methods (format nil "~S is now traced." name))
(excl:ftrace (mop:method-function method)))))))
(defun process-fspec-for-allegro (fspec)
(cond ((consp fspec)
(ecase (first fspec)
((setf) fspec)
((:defun :defgeneric) (second fspec))
((:defmethod) `(method ,@(rest fspec)))
((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
,(third fspec)))
((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
,(third fspec)))))
(t
fspec)))
;;;; Weak hashtables
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak-keys t args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :values :weak args))
(defimplementation hash-table-weakness (hashtable)
(cond ((excl:hash-table-weak-keys hashtable) :key)
((eq (excl:hash-table-values hashtable) :weak) :value)))
;;;; Character names
(defimplementation character-completion-set (prefix matchp)
(loop for name being the hash-keys of excl::*name-to-char-table*
when (funcall matchp prefix name)
collect (string-capitalize name)))
;;;; wrap interface implementation
(defimplementation wrap (spec indicator &key before after replace)
(let ((allegro-spec (process-fspec-for-allegro spec)))
(excl:fwrap allegro-spec
indicator
(excl:def-fwrapper allegro-wrapper (&rest args)
(let (retlist completed)
(unwind-protect
(progn
(when before
(funcall before args))
(setq retlist (multiple-value-list
(if replace
(funcall replace args)
(excl:call-next-fwrapper))))
(setq completed t)
(values-list retlist))
(when after
(funcall after (if completed
retlist
:exited-non-locally)))))))))
(defimplementation unwrap (spec indicator)
(let ((allegro-spec (process-fspec-for-allegro spec)))
(excl:funwrap allegro-spec indicator)
allegro-spec))
(defimplementation wrapped-p (spec indicator)
(getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator))
;;;; Package-local nicknames
#+(version>= 10 0)
(defimplementation package-local-nicknames (package)
(excl:package-local-nicknames package))
;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
;;;
;;; slynk-abcl.lisp --- Armedbear CL specific code for SLY.
;;;
;;; Adapted from slynk-acl.lisp, Andras Simon, 2004
;;; New work by Alan Ruttenberg, 2016-7
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(defpackage slynk/abcl
(:use cl slynk-backend)
(:import-from :java
#:jcall #:jstatic
#:jmethod
#:jfield
#:jconstructor
#:jnew-array #:jarray-length #:jarray-ref #:jnew-array-from-array
#:jclass #:jnew #:java-object
;; be conservative and add any import java functions only for later lisps
#+#.(slynk-backend:with-symbol 'jfield-name 'java) #:jfield-name
#+#.(slynk-backend:with-symbol 'jinstance-of-p 'java) #:jinstance-of-p
#+#.(slynk-backend:with-symbol 'jclass-superclass 'java) #:jclass-superclass
#+#.(slynk-backend:with-symbol 'jclass-interfaces 'java) #:jclass-interfaces
#+#.(slynk-backend:with-symbol 'java-exception 'java) #:java-exception
#+#.(slynk-backend:with-symbol 'jobject-class 'java) #:jobject-class
#+#.(slynk-backend:with-symbol 'jclass-name 'java) #:jclass-name
#+#.(slynk-backend:with-symbol 'java-object-p 'java) #:java-object-p))
(in-package slynk/abcl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :collect) ;just so that it doesn't spoil the flying letters
(require :pprint)
(require :gray-streams)
(require :abcl-contrib)
;;; Probe and load ABCL-INTROSPECT pushing to *FEATURES* on success
;;; allowing us to conditionalize usage via `#+abcl-introspect` forms.
(when (ignore-errors (and
(fboundp '(setf sys::function-plist))
(progn
(require :abcl-introspect)
(find "ABCL-INTROSPECT" *modules* :test
'equal))))
(pushnew :abcl-introspect *features*)))
(defimplementation gray-package-name ()
"GRAY-STREAMS")
;; FIXME: switch to shared Gray stream implementation when the
;; architecture for booting streams allows us to replace the Java-side
;; implementation of a Sly{Input,Output}Stream.java classes are
;; subsumed <http://abcl.org/trac/ticket/373>.
(progn
(defimplementation make-output-stream (write-string)
(ext:make-slime-output-stream write-string))
(defimplementation make-input-stream (read-string)
(ext:make-slime-input-stream read-string
(make-synonym-stream '*standard-output*))))
;; A hack to call functions from packages that don't exist when this code is loaded.
;; An FLET is used to make sure all the uses of it are contained in wrapper functions
;; so this hack can be easily swapped out later.
(flet ((evil-hack (function &rest args) (apply (read-from-string function) args)))
(defun %%lcons (car cdr)
(evil-hack "slynk::%lcons" car (lambda () cdr)))
(defun %%lookup-class-name (&rest args)
(evil-hack "jss::lookup-class-name" args))
(defun %%ed-in-emacs (what)
(evil-hack "slynk:ed-in-emacs" what))
(defun %%method-for-inspect-value (method)
;; Note that this one is in slynk-fancy-inspector
(evil-hack "slynk::method-for-inspect-value" method))
(defun %%abbrev-doc (doc)
(evil-hack "slynk::abbrev-doc" doc)))
;;; Have CL:INSPECT use SLY
;;;
;;; Since Slynk may also be run in a server not running under Emacs
;;; and potentially with other REPLs, we export a functional toggle
;;; for the user to call after loading these definitions.
(defun enable-cl-inspect-in-emacs ()
(slynk-backend:wrap 'cl:inspect :use-sly
:replace (slynk-backend:find-symbol2 "slynk:inspect-in-emacs")))
;; ??? repair bare print object so inspector titles show java class
(defun %print-unreadable-object-java-too (object stream type identity body)
(setf stream (sys::out-synonym-of stream))
(when *print-readably*
(error 'print-not-readable :object object))
(format stream "#<")
(when type
(if (java-object-p object)
;; Special handling for java objects
(if (jinstance-of-p object "java.lang.Class")
(progn
(write-string "jclass " stream)
(format stream "~a" (jclass-name object)))
(format stream "~a" (jclass-name (jobject-class object))))
;; usual handling
(format stream "~S" (type-of object)))
(format stream " "))
(when body
(funcall body))
(when identity
(when (or body (not type))
(format stream " "))
(format stream "{~X}" (sys::identity-hash-code object)))
(format stream ">")
nil)
;;; TODO: move such invocations out of toplevel?
(eval-when (:load-toplevel)
(unless (get 'sys::%print-unreadable-object 'slynk-backend::sly-wrap)
(wrap 'sys::%print-unreadable-object :more-informative :replace '%print-unreadable-object-java-too)))
(defimplementation call-with-compilation-hooks (function)
(funcall function))
;;;; MOP
;;dummies and definition
(defclass standard-slot-definition ()())
(defun slot-definition-documentation (slot)
#-abcl-introspect
(declare (ignore slot))
#+abcl-introspect
(documentation slot 't))
(defun slot-definition-type (slot)
(declare (ignore slot))
t)
(defun class-prototype (class)
(declare (ignore class))
nil)
(defun generic-function-declarations (gf)
(declare (ignore gf))
nil)
(defun specializer-direct-methods (spec)
(mop:class-direct-methods spec))
(defun slot-definition-name (slot)
(mop:slot-definition-name slot))
(defun class-slots (class)
(mop:class-slots class))
(defun method-generic-function (method)
(mop:method-generic-function method))
(defun method-function (method)
(mop:method-function method))
(defun slot-boundp-using-class (class object slotdef)
(declare (ignore class))
(system::slot-boundp object (slot-definition-name slotdef)))
(defun slot-value-using-class (class object slotdef)
(declare (ignore class))
(system::slot-value object (slot-definition-name slotdef)))
(defun (setf slot-value-using-class) (new class object slotdef )
(declare (ignore class))
(mop::%set-slot-value object (slot-definition-name slotdef) new))
(import-to-slynk-mop
'( ;; classes
cl:standard-generic-function
standard-slot-definition ;;dummy
cl:method
cl:standard-class
#+#.(slynk-backend:with-symbol
'compute-applicable-methods-using-classes 'mop)
mop:compute-applicable-methods-using-classes
;; standard-class readers
mop:class-default-initargs
mop:class-direct-default-initargs
mop:class-direct-slots
mop:class-direct-subclasses
mop:class-direct-superclasses
mop:eql-specializer
mop:class-finalized-p
mop:finalize-inheritance
cl:class-name
mop:class-precedence-list
class-prototype ;;dummy
class-slots
specializer-direct-methods
;; eql-specializer accessors
mop::eql-specializer-object
;; generic function readers
mop:generic-function-argument-precedence-order
generic-function-declarations ;;dummy
mop:generic-function-lambda-list
mop:generic-function-methods
mop:generic-function-method-class
mop:generic-function-method-combination
mop:generic-function-name
;; method readers
method-generic-function
method-function
mop:method-lambda-list
mop:method-specializers
mop:method-qualifiers
;; slot readers
mop:slot-definition-allocation
slot-definition-documentation ;;dummy
mop:slot-definition-initargs
mop:slot-definition-initform
mop:slot-definition-initfunction
slot-definition-name
slot-definition-type ;;dummy
mop:slot-definition-readers
mop:slot-definition-writers
slot-boundp-using-class
slot-value-using-class
set-slot-value-using-class
#+#.(slynk-backend:with-symbol
'slot-makunbound-using-class 'mop)
mop:slot-makunbound-using-class))
;;;; TCP Server
(defimplementation preferred-communication-style ()
:spawn)
(defimplementation create-socket (host port &key backlog)
(ext:make-server-socket port))
(defimplementation local-port (socket)
(jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket))
(defimplementation close-socket (socket)
(ext:server-socket-close socket))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering timeout))
(ext:get-socket-stream (ext:socket-accept socket)
:element-type (if external-format
'character
'(unsigned-byte 8))
:external-format (or external-format :default)))
;;;; UTF8
;; faster please!
(defimplementation string-to-utf8 (s)
(jbytes-to-octets
(java:jcall
(java:jmethod "java.lang.String" "getBytes" "java.lang.String")
s
"UTF8")))
(defimplementation utf8-to-string (u)
(java:jnew
(java:jconstructor "org.armedbear.lisp.SimpleString"
"java.lang.String")
(java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String")
(octets-to-jbytes u)
"UTF8")))
(defun octets-to-jbytes (octets)
(declare (type octets (simple-array (unsigned-byte 8) (*))))
(let* ((len (length octets))
(bytes (java:jnew-array "byte" len)))
(loop for byte across octets
for i from 0
do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
"java.lang.Object" "int" "byte")
"java.lang.reflect.Array"
bytes i byte))
bytes))
(defun jbytes-to-octets (jbytes)
(let* ((len (java:jarray-length jbytes))
(octets (make-array len :element-type '(unsigned-byte 8))))
(loop for i from 0 below len
for jbyte = (java:jarray-ref jbytes i)
do (setf (aref octets i) jbyte))
octets))
;;;; External formats
(defvar *external-format-to-coding-system*
'((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
((:iso-8859-1 :eol-style :lf)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
(:utf-8 "utf-8")
((:utf-8 :eol-style :lf) "utf-8-unix")
(:euc-jp "euc-jp")
((:euc-jp :eol-style :lf) "euc-jp-unix")
(:us-ascii "us-ascii")
((:us-ascii :eol-style :lf) "us-ascii-unix")))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x)
(member coding-system x :test #'equal))
*external-format-to-coding-system*)))
;;;; Unix signals
(defimplementation getpid ()
(if (fboundp 'ext::get-pid)
(ext::get-pid) ;;; Introduced with abcl-1.5.0
(handler-case
(let* ((runtime
(java:jstatic "getRuntime" "java.lang.Runtime"))
(command
(java:jnew-array-from-array
"java.lang.String" #("sh" "-c" "echo $PPID")))
(runtime-exec-jmethod
;; Complicated because java.lang.Runtime.exec() is
;; overloaded on a non-primitive type (array of
;; java.lang.String), so we have to use the actual
;; parameter instance to get java.lang.Class
(java:jmethod "java.lang.Runtime" "exec"
(java:jcall
(java:jmethod "java.lang.Object" "getClass")
command)))
(process
(java:jcall runtime-exec-jmethod runtime command))
(output
(java:jcall (java:jmethod "java.lang.Process" "getInputStream")
process)))
(java:jcall (java:jmethod "java.lang.Process" "waitFor")
process)
(loop :with b :do
(setq b
(java:jcall (java:jmethod "java.io.InputStream" "read")
output))
:until (member b '(-1 #x0a)) ; Either EOF or LF
:collecting (code-char b) :into result
:finally (return
(parse-integer (coerce result 'string)))))
(t () 0))))
(defimplementation lisp-implementation-type-name ()
"armedbear")
(defimplementation set-default-directory (directory)
(let ((dir (sys::probe-directory directory)))
(when dir (setf *default-pathname-defaults* dir))
(namestring dir)))
;;;; Misc
(defimplementation arglist (fun)
(cond ((symbolp fun)
(multiple-value-bind (arglist present)
(sys::arglist fun)
(when (and (not present)
(fboundp fun)
(typep (symbol-function fun)
'standard-generic-function))
(setq arglist
(mop::generic-function-lambda-list (symbol-function fun))
present
t))
(if present arglist :not-available)))
(t :not-available)))
(defimplementation function-name (function)
(if (fboundp 'sys::any-function-name)
;; abcl-1.5.0
(sys::any-function-name function)
;; pre abcl-1.5.0
(nth-value 2 (function-lambda-expression function))))
(defimplementation macroexpand-all (form &optional env)
(ext:macroexpand-all form env))
(defimplementation collect-macro-forms (form &optional env)
;; Currently detects only normal macros, not compiler macros.
(declare (ignore env))
(with-collected-macro-forms (macro-forms)
(handler-bind ((warning #'muffle-warning))
(ignore-errors
(compile nil `(lambda () ,(macroexpand-all form env)))))
(values macro-forms nil)))
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind &optional (sym symbol))
(or (documentation sym kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (when (boundp symbol)
(doc 'variable)))
(when (fboundp symbol)
(maybe-push
(cond ((macro-function symbol) :macro)
((special-operator-p symbol) :special-operator)
((typep (fdefinition symbol) 'generic-function)
:generic-function)
(t :function))
(doc 'function)))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
result)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
((:variable :macro)
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(:class
(describe (find-class symbol)))))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(:class
(describe (find-class symbol)))))
;;;; Debugger
;; Copied from slynk-sbcl.lisp.
#+abcl-introspect
(defvar sys::*caught-frames*)
;;
;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*,
;; so we have to make sure that the latter gets run when it was
;; established locally by a user (i.e. changed meanwhile.)
(defun make-invoke-debugger-hook (hook)
(lambda (condition old-hook)
(prog1 (let (#+abcl-introspect
(sys::*caught-frames* nil))
;; the next might be the right thing for earlier lisps but I don't know
;;; XXX probably doesn't work in absence of ABCL-INTROSPECT on abcl-1.4 and earlier
(let (#+abcl-introspect
(sys::*saved-backtrace*
(if (fboundp 'sys::new-backtrace)
(sys::new-backtrace condition)
(sys::backtrace))))
(if *debugger-hook*
(funcall *debugger-hook* condition old-hook)
(funcall hook condition old-hook)))))))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
(sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(funcall fun)))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
(defvar *sldb-topframe*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* ((magic-token (intern "SLYNK-DEBUGGER-HOOK" 'slynk))
(*sldb-topframe*
(or
(second (member magic-token
#+abcl-introspect sys::*saved-backtrace*
#-abcl-introspect (sys:backtrace)
:key (lambda (frame)
(first (sys:frame-to-list frame)))))
(car sys::*saved-backtrace*)))
#+#.(slynk-backend:with-symbol *debug-condition* 'ext)
(ext::*debug-condition*
(slynk-backend:find-symbol2 "slynk::*slynk-debugger-condition*")))
(funcall debugger-loop-fn)))
(defun backtrace (start end)
"A backtrace without initial SLYNK frames."
(let ((backtrace
#+abcl-introspect sys::*saved-backtrace*
#-abcl-introspect (sys:backtrace)))
(subseq (or (member *sldb-topframe* backtrace) backtrace) start end)))
(defun nth-frame (index)
(nth index (backtrace 0 nil)))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum)))
(backtrace start end)))
;; Don't count on JSS being loaded, but if it is then there's some more stuff we can do
+#+#.(slynk-backend:with-symbol 'invoke-restargs 'jss)
(defun jss-p ()
(and (member "JSS" *modules* :test 'string=) (intern "INVOKE-RESTARGS" "JSS")))
+#+#.(slynk-backend:with-symbol 'invoke-restargs 'jss)
(defun matches-jss-call (form)
(flet ((gensymp (s) (and (symbolp s) (null (symbol-package s))))
(invokep (s) (and (symbolp s) (eq s (jss-p)))))
(let ((method
(slynk-match::select-match
form
(((LAMBDA ((#'gensymp a) &REST (#'gensymp b))
((#'invokep fun) (#'stringp c) (#'gensymp d) (#'gensymp e) . args)) . args) '=> c)
(other nil))))
method)))
#-abcl-introspect
(defimplementation print-frame (frame stream)
(write-string (sys:frame-to-string frame)
stream))
;; Use princ cs write-string for lisp frames as it respects (print-object (function t))
;; Rewrite jss expansions to their unexpanded state
;; Show java exception frames up to where a java exception happened with a "!"
;; Check if a java class corresponds to a lisp function and tell us if to
(defvar *debugger-package* (find-package 'cl-user))
#+abcl-introspect
(defimplementation print-frame (frame stream)
;; make clear which functions aren't Common Lisp. Otherwise uses
;; default package, which is invisible
(let ((*package* (or *debugger-package* *package*)))
(if (typep frame 'sys::lisp-stack-frame)
(if (not (jss-p))
(princ (system:frame-to-list frame) stream)
;; rewrite jss forms as they would be written
(let ((form (system:frame-to-list frame)))
(if (eq (car form) (jss-p))
(format stream "(#~s ~{~s~^~})" (second form) (list* (third form) (fourth form)))
(loop initially (write-char #\( stream)
for (el . rest) on form
for method = (slynk/abcl::matches-jss-call el)
do
(cond (method
(format stream "(#~s ~{~s~^~})" method (cdr el)))
(t
(prin1 el stream)))
(unless (null rest) (write-char #\space stream))
finally (write-char #\) stream)))))
(let ((classname (getf (sys:frame-to-list frame) :class)))
(if (and (fboundp 'sys::javaframe)
(member (sys::javaframe frame) sys::*caught-frames* :test 'equal))
(write-string "! " stream))
(write-string (sys:frame-to-string frame) stream)
(if (and classname (sys::java-class-lisp-function classname))
(format stream " = ~a" (sys::java-class-lisp-function classname)))))))
;;; Machinery for DEFIMPLEMENTATION
;;; FIXME can't seem to use FLET forms with DEFIMPLEMENTATION --ME 20150403
(defun nth-frame-list (index)
(jcall "toLispList" (nth-frame index)))
(defun match-lambda (operator values)
(jvm::match-lambda-list
(multiple-value-list
(jvm::parse-lambda-list (ext:arglist operator)))
values))
(defimplementation frame-locals (index)
(let ((frame (nth-frame index)))
;; FIXME introspect locals in SYS::JAVA-STACK-FRAME
(when (typep frame 'sys::lisp-stack-frame)
(loop
:for id :upfrom 0
:with frame = (nth-frame-list index)
:with operator = (first frame)
:with values = (rest frame)
:with arglist = (if (and operator (consp values) (not (null values)))
(handler-case (match-lambda operator values)
(jvm::lambda-list-mismatch (e) (declare(ignore e))
:lambda-list-mismatch))
:not-available)
:for value :in values
:collecting (list
:name (if (not (keywordp arglist))
(first (nth id arglist))
(format nil "arg~A" id))
:id id
:value value)))))
(defimplementation frame-var-value (index id)
(elt (rest (jcall "toLispList" (nth-frame index))) id))
#+abcl-introspect
(defimplementation disassemble-frame (index)
(sys::disassemble (frame-function (nth-frame index))))
(defun frame-function (frame)
(let ((list (sys::frame-to-list frame)))
(cond
((keywordp (car list))
(find (getf list :method)
(jcall "getDeclaredMethods" (jclass (getf list :class)))
:key (lambda(e)(jcall "getName" e)) :test 'equal))
(t (car list) ))))
(defimplementation frame-source-location (index)
(let ((frame (nth-frame index)))
(or (source-location (nth-frame index))
`(:error ,(format nil "No source for frame: ~a" frame)))))
;;;; Compiler hooks
(defvar *buffer-name* nil)
(defvar *buffer-start-position*)
(defvar *buffer-string*)
(defvar *compile-filename*)
(defvar *abcl-signaled-conditions*)
(defun handle-compiler-warning (condition)
(let ((loc (when (and jvm::*compile-file-pathname*
system::*source-position*)
(cons jvm::*compile-file-pathname* system::*source-position*))))
;; filter condition signaled more than once.
(unless (member condition *abcl-signaled-conditions*)
(push condition *abcl-signaled-conditions*)
(signal 'compiler-condition
:original-condition condition
:severity :warning
:message (format nil "~A" condition)
:location (cond (*buffer-name*
(make-location
(list :buffer *buffer-name*)
(list :offset *buffer-start-position* 0)))
(loc
(destructuring-bind (file . pos) loc
(make-location
(list :file (namestring (truename file)))
(list :position (1+ pos)))))
(t
(make-location
(list :file (namestring *compile-filename*))
(list :position 1))))))))
(defimplementation slynk-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore external-format policy))
(let ((jvm::*resignal-compiler-warnings* t)
(*abcl-signaled-conditions* nil))
(handler-bind ((warning #'handle-compiler-warning))
(let ((*buffer-name* nil)
(*compile-filename* input-file))
(multiple-value-bind (fn warn fail)
(compile-file input-file :output-file output-file)
(values fn warn
(and fn load-p
(not (load fn)))))))))
(defimplementation slynk-compile-string (string &key buffer position filename
line column policy)
(declare (ignore filename line column policy))
(let ((jvm::*resignal-compiler-warnings* t)
(*abcl-signaled-conditions* nil))
(handler-bind ((warning #'handle-compiler-warning))
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
(*buffer-string* string)
(sys::*source* (make-pathname :device "emacs-buffer" :name buffer))
(sys::*source-position* position))
(funcall (compile nil (read-from-string
(format nil "(~S () ~A)" 'lambda string))))
t))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; source location and users of it
(defgeneric source-location (object))
;; try to find some kind of source for internals
#+abcl-introspect
(defun implementation-source-location (arg)
(let ((function (cond ((functionp arg)
arg)
((and (symbolp arg) (fboundp arg))
(or (symbol-function arg) (macro-function arg))))))
(when (typep function 'generic-function)
(setf function (mop::funcallable-instance-function function)))
;; functions are execute methods of class
(when (or (functionp function) (special-operator-p arg))
(let ((fclass (jcall "getClass" function)))
(let ((classname (jcall "getName" fclass)))
(destructuring-bind (class local)
(if (find #\$ classname)
(split-string classname "\\$")
(list classname (jcall "replaceFirst" classname "([^.]*\\.)*" "")))
(unless (member local '("MacroObject" "CompiledClosure" "Closure") :test 'equal)
;; look for java source
(let* ((partial-path (substitute #\/ #\. class))
(java-path (concatenate 'string partial-path ".java"))
(found-in-source-path (find-file-in-path java-path *source-path*)))
;; snippet for finding the internal class within the file
(if found-in-source-path
`((:primitive ,local)
(:location ,found-in-source-path
(:line 0)
(:snippet ,(format nil "class ~a" local))))
;; if not, look for the class file, and hope that
;; emacs is configured to disassemble class entries
;; in jars.
;; Alan uses jdc.el
;; <https://github.com/m0smith/dotfiles/blob/master/.emacs.d/site-lisp/jdc.el>
;; with jad <https://github.com/moparisthebest/jad>
;; Also (setq sys::*disassembler* "jad -a -p")
(let ((class-in-source-path
(find-file-in-path (concatenate 'string partial-path ".class") *source-path*)))
;; no snippet, since internal class is in its own file
(when class-in-source-path
`(:primitive (:location ,class-in-source-path (:line 0) nil)))))))))))))
#+abcl-introspect
(defun get-declared-field (class fieldname)
(find fieldname (jcall "getDeclaredFields" class) :key 'jfield-name :test 'equal))
#+abcl-introspect
(defun symbol-defined-in-java (symbol)
(loop with internal-name1 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "") "-" "_")
with internal-name2 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "_") "-" "_")
for class in
(load-time-value (mapcar
'jclass
'("org.armedbear.lisp.Package"
"org.armedbear.lisp.Symbol"
"org.armedbear.lisp.Debug"
"org.armedbear.lisp.Extensions"
"org.armedbear.lisp.JavaObject"
"org.armedbear.lisp.Lisp"
"org.armedbear.lisp.Pathname"
"org.armedbear.lisp.Site")))
thereis
(or (get-declared-field class internal-name1)
(get-declared-field class internal-name2))))
#+abcl-introspect
(defun maybe-implementation-variable (s)
(let ((field (symbol-defined-in-java s)))
(and field
(let ((class (jcall "getName" (jcall "getDeclaringClass" field))))
(let* ((partial-path (substitute #\/ #\. class))
(java-path (concatenate 'string partial-path ".java"))
(found-in-source-path (find-file-in-path java-path *source-path*)))
(when found-in-source-path
`(symbol (:location ,found-in-source-path (:line 0)
(:snippet ,(format nil "~s" (string s)))))))))))
#+abcl-introspect
(defun if-we-have-to-choose-one-choose-the-function (sources)
(or (loop for spec in sources
for (dspec) = spec
when (and (consp dspec) (eq (car dspec) :function))
when (and (consp dspec) (member (car dspec) '(:slynk-implementation :function)))
do (return-from if-we-have-to-choose-one-choose-the-function spec))
(car sources)))
(defmethod source-location ((symbol symbol))
(or #+abcl-introspect
(let ((maybe (if-we-have-to-choose-one-choose-the-function (get symbol 'sys::source))))
(and maybe (second (sly-location-from-source-annotation symbol maybe))))
;; This below should be obsolete - it uses the old sys:%source
;; leave it here for now just in case
(and (pathnamep (ext:source-pathname symbol))
(let ((pos (ext:source-file-position symbol))
(path (namestring (ext:source-pathname symbol))))
; boot.lisp gets recorded wrong
(when (equal path "boot.lisp")
(setq path (second (find-file-in-path "org/armedbear/lisp/boot.lisp" *source-path*))))
(cond ((ext:pathname-jar-p path)
`(:location
;; strip off "jar:file:" = 9 characters
(:zip ,@(split-string (subseq path (length "jar:file:")) "!/"))
;; pos never seems right. Use function name.
(:function-name ,(string symbol))
(:align t)))
((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer")
;; conspire with slynk-compile-string to keep the buffer
;; name in a pathname whose device is "emacs-buffer".
`(:location
(:buffer ,(pathname-name (ext:source-pathname symbol)))
(:function-name ,(string symbol))
(:align t)))
(t
`(:location
(:file ,path)
,(if pos
(list :position (1+ pos))
(list :function-name (string symbol)))
(:align t))))))
#+abcl-introspect
(second (implementation-source-location symbol))))
(defmethod source-location ((frame sys::java-stack-frame))
(destructuring-bind (&key class method file line) (sys:frame-to-list frame)
(declare (ignore method))
(let ((file (or (find-file-in-path file *source-path*)
(let ((f (format nil "~{~a/~}~a"
(butlast (split-string class "\\."))
file)))
(find-file-in-path f *source-path*)))))
(and file
`(:location ,file (:line ,line) ())))))
(defmethod source-location ((frame sys::lisp-stack-frame))
(destructuring-bind (operator &rest args) (sys:frame-to-list frame)
(declare (ignore args))
(etypecase operator
(function (source-location operator))
(list nil)
(symbol (source-location operator)))))
(defmethod source-location ((fun function))
(if #+abcl-introspect
(sys::local-function-p fun)
#-abcl-introspect
nil
(source-location (sys::local-function-owner fun))
(let ((name (function-name fun)))
(and name (source-location name)))))
(defmethod source-location ((method method))
#+abcl-introspect
(let ((found
(find `(:method ,@(sys::method-spec-list method))
(get (function-name method) 'sys::source)
:key 'car :test 'equalp)))
(and found (second (sly-location-from-source-annotation (function-name method) found))))
#-abcl-introspect
(let ((name (function-name fun)))
(and name (source-location name))))
(defun system-property (name)
(jstatic "getProperty" "java.lang.System" name))
(defun pathname-parent (pathname)
(make-pathname :directory (butlast (pathname-directory pathname))))
(defun pathname-absolute-p (pathname)
(eq (car (pathname-directory pathname)) ':absolute))
(defun split-string (string regexp)
(coerce
(jcall (jmethod "java.lang.String" "split" "java.lang.String")
string regexp)
'list))
(defun path-separator ()
(jfield "java.io.File" "pathSeparator"))
(defun search-path-property (prop-name)
(let ((string (system-property prop-name)))
(and string
(remove nil
(mapcar #'truename
(split-string string (path-separator)))))))
(defun jdk-source-path ()
(let* ((jre-home (truename (system-property "java.home")))
(src-zip (merge-pathnames "src.zip" (pathname-parent jre-home)))
(truename (probe-file src-zip)))
(and truename (list truename))))
(defun class-path ()
(append (search-path-property "java.class.path")
(search-path-property "sun.boot.class.path")))
(defvar *source-path*
(remove nil
(append (search-path-property "user.dir")
(jdk-source-path)
;; include lib jar files. contrib has lisp code. Would be good to build abcl.jar with source code as well
#+abcl-introspect
(list (sys::find-system-jar)
(sys::find-contrib-jar))))
;; you should tell sly where the abcl sources are. In .slynk.lisp I have:
;; (push (probe-file "/Users/alanr/repos/abcl/src/") *SOURCE-PATH*)
"List of directories to search for source files.")
(defun zipfile-contains-p (zipfile-name entry-name)
(let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile"
"java.lang.String")
zipfile-name)))
(jcall
(jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
zipfile entry-name)))
;; Try to find FILENAME in PATH. If found, return a file spec as
;; needed by Emacs. We also look in zip files.
(defun find-file-in-path (filename path)
(labels ((try (dir)
(cond ((not (pathname-type dir))
(let ((f (probe-file (merge-pathnames filename dir))))
(and f `(:file ,(namestring f)))))
((member (pathname-type dir) '("zip" "jar") :test 'equal)
(try-zip dir))
(t (error "strange path element: ~s" path))))
(try-zip (zip)
(let* ((zipfile-name (namestring (truename zip))))
(and (zipfile-contains-p zipfile-name filename)
`(#+abcl-introspect
:zip
#-abcl-introspect
:dir
,zipfile-name ,filename)))))
(cond ((pathname-absolute-p filename) (probe-file filename))
(t
(loop for dir in path
if (try dir) return it)))))
(defparameter *definition-types*
'(:variable defvar
:constant defconstant
:type deftype
:symbol-macro define-symbol-macro
:macro defmacro
:compiler-macro define-compiler-macro
:function defun
:generic-function defgeneric
:method defmethod
:setf-expander define-setf-expander
:structure defstruct
:condition define-condition
:class defclass
:method-combination define-method-combination
:package defpackage
:transform :deftransform
:optimizer :defoptimizer
:vop :define-vop
:source-transform :define-source-transform
:ir1-convert :def-ir1-translator
:declaration declaim
:alien-type :define-alien-type)
"Map SB-INTROSPECT definition type names to Sly-friendly forms")
(defun definition-specifier (type)
"Return a pretty specifier for NAME representing a definition of type TYPE."
(or (if (and (consp type) (getf *definition-types* (car type)))
`(,(getf *definition-types* (car type)) ,(second type) ,@(third type) ,@(cdddr type))
(getf *definition-types* type))
type))
(defun stringify-method-specs (type)
"return a (:method ..) location for sly"
(let ((*print-case* :downcase))
(flet ((p (a) (princ-to-string a)))
(destructuring-bind (name qualifiers specializers) (cdr type)
`(,(car type) ,(p name) ,(mapcar #'p specializers) ,@(mapcar #'p qualifiers))))))
;; for abcl source, check if it is still there, and if not, look in abcl jar instead
(defun maybe-redirect-to-jar (path)
(setq path (namestring path))
(if (probe-file path)
path
(if (search "/org/armedbear/lisp" path :test 'string=)
(let ((jarpath (format nil "jar:file:~a!~a" (namestring (sys::find-system-jar))
(subseq path (search "/org/armedbear/lisp" path)))))
(if (probe-file jarpath)
jarpath
path))
path)))
#-abcl-introspect
(defimplementation find-definitions (symbol)
(ext:resolve symbol)
(let ((srcloc (source-location symbol)))
(and srcloc `((,symbol ,srcloc)))))
#+abcl-introspect
(defimplementation find-definitions (symbol)
(when (stringp symbol)
;; allow a string to be passed. If it is package prefixed, remove the prefix
(setq symbol (intern (string-upcase
(subseq symbol (1+ (or (position #\: symbol :from-end t) -1))))
'keyword)))
(let ((sources nil)
(implementation-variables nil)
(implementation-functions nil))
(loop for package in (list-all-packages)
for sym = (find-symbol (string symbol) package)
when (and sym (equal (symbol-package sym) package))
do
(when (sys::autoloadp symbol)
(sys::resolve symbol))
(let ((source (or (get sym 'ext::source) (get sym 'sys::source)))
(i-var (maybe-implementation-variable sym))
(i-fun (implementation-source-location sym)))
(when source
(setq sources (append sources (or (get sym 'ext::source) (get sym 'sys::source)))))
(when i-var
(push i-var implementation-variables))
(when i-fun
(push i-fun implementation-functions))))
(setq sources (remove-duplicates sources :test 'equalp))
(append (remove-duplicates implementation-functions :test 'equalp)
(mapcar (lambda(s) (sly-location-from-source-annotation symbol s)) sources)
(remove-duplicates implementation-variables :test 'equalp))))
(defun sly-location-from-source-annotation (sym it)
(destructuring-bind (what path pos) it
(let* ((isfunction
;; all of these are (defxxx forms, which is what :function locations look for in sly
(and (consp what) (member (car what)
'(:function :generic-function :macro :class :compiler-macro
:type :constant :variable :package :structure :condition))))
(ismethod (and (consp what) (eq (car what) :method)))
(<position> (cond (isfunction (list :function-name (princ-to-string (second what))))
(ismethod (stringify-method-specs what))
(t (list :position (1+ (or pos 0))))))
(path2 (if (eq path :top-level)
;; this is bogus - figure out some way to guess which is the repl associated with :toplevel
;; or get rid of this
"emacs-buffer:*sly-repl*"
(maybe-redirect-to-jar path))))
(when (atom what)
(setq what (list what sym)))
(list (definition-specifier what)
(if (ext:pathname-jar-p path2)
`(:location
(:zip ,@(split-string (subseq path2 (length "jar:file:")) "!/"))
;; pos never seems right. Use function name.
,<position>
(:align t))
;; conspire with slynk-compile-string to keep the
;; buffer name in a pathname whose device is
;; "emacs-buffer".
(if (eql 0 (search "emacs-buffer:" path2))
`(:location
(:buffer ,(subseq path2 (load-time-value (length "emacs-buffer:"))))
,<position>
(:align t))
`(:location
(:file ,path2)
,<position>
(:align t))))))))
#+abcl-introspect
(defimplementation list-callers (thing)
(loop for caller in (sys::callers thing)
when (typep caller 'method)
append (let ((name (mop:generic-function-name
(mop:method-generic-function caller))))
(mapcar (lambda(s) (sly-location-from-source-annotation thing s))
(remove `(:method ,@(sys::method-spec-list caller))
(get
(if (consp name) (second name) name)
'sys::source)
:key 'car :test-not 'equalp)))
when (symbolp caller)
append (mapcar (lambda(s) (sly-location-from-source-annotation caller s))
(get caller 'sys::source))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Inspecting
;;; Although by convention toString() is supposed to be a
;;; non-computationally expensive operation this isn't always the
;;; case, so make its computation a user interaction.
(defparameter *to-string-hashtable* (make-hash-table :weakness :key))
(defmethod emacs-inspect ((o t))
(let* ((type (type-of o))
(class (ignore-errors (find-class type)))
(jclass (and (typep class 'sys::built-in-class)
(jcall "getClass" o))))
(let ((parts (sys:inspected-parts o)))
`((:label "Type: ") (:value ,(or class type)) (:Newline)
,@(if jclass
`((:label "Java type: ") (:value ,jclass) (:newline)))
,@(if parts
(loop :for (label . value) :in parts
:appending (list
(list :label (string-capitalize label))
": "
(list :value value (princ-to-string value)) '(:newline)))
(list '(:label "No inspectable parts, dumping output of CL:DESCRIBE:")
'(:newline)
(with-output-to-string (desc) (describe o desc))))))))
(defun %%prepend-list-to-llist (list llist)
"Takes a list (LIST) and a lazy list (LLIST) and transforms the list items into lazy list items,
which are prepended onto the existing lazy list and returned.
LIST is destructively modified."
(flet ((lcons (car cdr) (%%lcons car (lambda () cdr))))
(reduce #'lcons list :initial-value llist :from-end t)))
(defmethod emacs-inspect ((string string))
(%%prepend-list-to-llist
(list
'(:label "Value: ") `(:value ,string ,(concatenate 'string "\"" string "\"")) '(:newline)
(if (ignore-errors (jclass string))
`(:line "Names java class" ,(jclass string))
"")
#+abcl-introspect
(if (and (jss-p)
(stringp (%%lookup-class-name string :return-ambiguous t :muffle-warning t)))
`(:line
"Abbreviates java class"
,(let ((it (%%lookup-class-name string :return-ambiguous t :muffle-warning t)))
(jclass it)))
"")
(if (ignore-errors (find-package (string-upcase string)))
`(:line "Names package" ,(find-package (string-upcase string)))
""))
(call-next-method)))
#+#.(slynk-backend:with-symbol 'java-exception 'java)
(defmethod emacs-inspect ((o java:java-exception))
(append (call-next-method)
(list '(:newline) '(:label "Stack trace")
'(:newline)
(let ((w (jnew "java.io.StringWriter")))
(jcall "printStackTrace" (java:java-exception-cause o) (jnew "java.io.PrintWriter" w))
(jcall "toString" w)))))
(defmethod emacs-inspect ((slot mop::slot-definition))
`("Name: "
(:value ,(mop:slot-definition-name slot))
(:newline)
"Documentation:" (:newline)
,@(when (slot-definition-documentation slot)
`((:value ,(slot-definition-documentation slot)) (:newline)))
"Initialization:" (:newline)
(:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline)
(:label " Form: ") ,(if (mop:slot-definition-initfunction slot)
`(:value ,(mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
(:label " Function: ")
(:value ,(mop:slot-definition-initfunction slot))
(:newline)))
(defmethod emacs-inspect ((f function))
`(,@(when (function-name f)
`((:label "Name: ")
,(princ-to-string (sys::any-function-name f)) (:newline)))
,@(multiple-value-bind (args present) (sys::arglist f)
(when present
`((:label "Argument list: ")
,(princ-to-string args)
(:newline))))
#+abcl-introspect
,@(when (documentation f t)
`("Documentation:" (:newline)
,(documentation f t) (:newline)))
,@(when (function-lambda-expression f)
`((:label "Lambda expression:")
(:newline) ,(princ-to-string
(function-lambda-expression f)) (:newline)))
(:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline)
#+abcl-introspect
,@(when (jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f)
`((:label "Closed over: ")
,@(loop
for el in (sys::compiled-closure-context f)
collect `(:value ,el)
collect " ")
(:newline)))
#+abcl-introspect
,@(when (sys::get-loaded-from f)
(list `(:label "Defined in: ")
`(:value ,(sys::get-loaded-from f) ,(namestring (sys::get-loaded-from f)))
'(:newline)))
;; I think this should work in older lisps too -- alanr
,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f))))
(when (plusp (length fields))
(list* '(:label "Internal fields: ") '(:newline)
(loop for field across fields
do (jcall "setAccessible" field t) ;;; not a great idea esp. wrt. Java9
append
(let ((value (jcall "get" field f)))
(list " "
`(:label ,(jcall "getName" field))
": "
`(:value ,value ,(princ-to-string value))
'(:newline)))))))))
(defmethod emacs-inspect ((o java:java-object))
(if (jinstance-of-p o (jclass "java.lang.Class"))
(emacs-inspect-java-class o)
(emacs-inspect-java-object o)))
(defvar *sly-tostring-on-demand* nil
"Set to t if you don't want to automatically show toString() for java objects and instead have inspector action to compute")
(defun static-field? (field)
;; (plusp (logand #"reflect.Modifier.STATIC" (jcall "getModifiers" field)))
;; ugly replace with answer to avoid using jss
(plusp (logand 8 (jcall "getModifiers" field))))
(defun inspector-java-object-fields (object)
(loop
for super = (java::jobject-class object) then (jclass-superclass super)
while super
;;; NOTE: In the next line, if I write #'(lambda.... then I
;;; get an error compiling "Attempt to throw to the
;;; nonexistent tag DUPLICATABLE-CODE-P.". WTF
for fields
= (sort (jcall "getDeclaredFields" super) 'string-lessp :key (lambda(x) (jcall "getName" x)))
for fromline
= nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline))
when (and (plusp (length fields)) fromline)
append fromline
append
(loop for this across fields
for value = (jcall "get" (progn (jcall "setAccessible" this t) this) object)
for line = `(" " (:label ,(jcall "getName" this)) ": " (:value ,value) (:newline))
if (static-field? this)
append line into statics
else append line into members
finally (return (append
(if members `((:label "Member fields: ") (:newline) ,@members))
(if statics `((:label "Static fields: ") (:newline) ,@statics)))))))
(defun emacs-inspect-java-object (object)
(let ((to-string (lambda ()
(handler-case
(setf (gethash object *to-string-hashtable*)
(jcall "toString" object))
(t (e)
(setf (gethash object *to-string-hashtable*)
(format nil
"Could not invoke toString(): ~A"
e))))))
(intended-class (cdr (assoc "intendedClass" (sys::inspected-parts object)
:test 'equal))))
`((:label "Class: ")
(:value ,(jcall "getClass" object) ,(jcall "getName" (jcall "getClass" object) )) (:newline)
,@(if (and intended-class (not (equal intended-class (jcall "getName" (jcall "getClass" object)))))
`((:label "Intended Class: ")
(:value ,(jclass intended-class) ,intended-class) (:newline)))
,@(if (or (gethash object *to-string-hashtable*) (not *sly-tostring-on-demand*))
(label-value-line "toString()" (funcall to-string))
`((:action "[compute toString()]" ,to-string) (:newline)))
,@(inspector-java-object-fields object))))
(defmethod emacs-inspect ((slot mop::slot-definition))
`("Name: "
(:value ,(mop:slot-definition-name slot))
(:newline)
"Documentation:" (:newline)
,@(when (slot-definition-documentation slot)
`((:value ,(slot-definition-documentation slot)) (:newline)))
(:label "Initialization:") (:newline)
(:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline)
(:label " Form: ")
,(if (mop:slot-definition-initfunction slot)
`(:value ,(mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
" Function: "
(:value ,(mop:slot-definition-initfunction slot))
(:newline)))
(defun inspector-java-fields (class)
(loop
for super
= class then (jclass-superclass super)
while super
for fields
= (jcall "getDeclaredFields" super)
for fromline
= nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline))
when (and (plusp (length fields)) fromline)
append fromline
append
(loop for this across fields
for pre = (subseq (jcall "toString" this)
0
(1+ (position #\. (jcall "toString" this) :from-end t)))
collect " "
collect (list :value this pre)
collect (list :value this (jcall "getName" this) )
collect '(:newline))))
(defun inspector-java-methods (class)
(loop
for super
= class then (jclass-superclass super)
while super
for methods
= (jcall "getDeclaredMethods" super)
for fromline
= nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline))
when (and (plusp (length methods)) fromline)
append fromline
append
(loop for this across methods
for desc = (jcall "toString" this)
for paren = (position #\( desc)
for dot = (position #\. (subseq desc 0 paren) :from-end t)
for pre = (subseq desc 0 dot)
for name = (subseq desc dot paren)
for after = (subseq desc paren)
collect " "
collect (list :value this pre)
collect (list :value this name)
collect (list :value this after)
collect '(:newline))))
(defun emacs-inspect-java-class (class)
(let ((has-superclasses (jclass-superclass class))
(has-interfaces (plusp (length (jclass-interfaces class))))
(fields (inspector-java-fields class))
(path (jcall "replaceFirst"
(jcall "replaceFirst"
(jcall "toString" (jcall "getResource"
class
(concatenate 'string
"/" (substitute #\/ #\. (jcall "getName" class))
".class")))
"jar:file:" "") "!.*" "")))
`((:label ,(format nil "Java Class: ~a" (jcall "getName" class) ))
(:newline)
,@(when path (list `(:label ,"Loaded from: ")
`(:value ,path)
" "
`(:action "[open in emacs buffer]" ,(lambda() (%%ed-in-emacs `( ,path)))) '(:newline)))
,@(if has-superclasses
(list* '(:label "Superclasses: ") (butlast (loop for super = (jclass-superclass class) then (jclass-superclass super)
while super collect (list :value super (jcall "getName" super)) collect ", "))))
,@(if has-interfaces
(list* '(:newline) '(:label "Implements Interfaces: ")
(butlast (loop for i across (jclass-interfaces class) collect (list :value i (jcall "getName" i)) collect ", "))))
(:newline) (:label "Methods:") (:newline)
,@(inspector-java-methods class)
,@(if fields
(list*
'(:newline) '(:label "Fields:") '(:newline)
fields)))))
(defmethod emacs-inspect ((object sys::structure-object))
`((:label "Type: ") (:value ,(type-of object)) (:newline)
(:label "Class: ") (:value ,(class-of object)) (:newline)
,@(inspector-structure-slot-names-and-values object)))
(defun inspector-structure-slot-names-and-values (structure)
(let ((structure-def (get (type-of structure) 'system::structure-definition)))
(if structure-def
`((:label "Slots: ") (:newline)
,@(loop for slotdef in (sys::dd-slots structure-def)
for name = (sys::dsd-name slotdef)
for reader = (sys::dsd-reader slotdef)
for value = (eval `(,reader ,structure))
append
`(" " (:label ,(string-downcase (string name))) ": " (:value ,value) (:newline))))
`("No slots available for inspection."))))
(defmethod emacs-inspect ((object sys::structure-class))
(let* ((name (class-name object))
(def (get name 'system::structure-definition)))
`((:label "Class: ") (:value ,object) (:newline)
(:label "Raw defstruct definition: ") (:value ,def ,(let ((*print-array* nil)) (prin1-to-string def))) (:newline)
,@(parts-for-structure-def name)
;; copy-paste from slynk fancy inspector
,@(when (slynk-mop:specializer-direct-methods object)
`((:label "It is used as a direct specializer in the following methods:")
(:newline)
,@(loop
for method in (specializer-direct-methods object)
for method-spec = (%%method-for-inspect-value method)
collect " "
collect `(:value ,method ,(string-downcase (string (car method-spec))))
collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr method-spec)))
append (let ((method method))
`(" " (:action "[remove]"
,(lambda () (remove-method (slynk-mop::method-generic-function method) method)))))
collect '(:newline)
if (documentation method t)
collect " Documentation: " and
collect (%%abbrev-doc (documentation method t)) and
collect '(:newline)))))))
(defun parts-for-structure-def-slot (def)
`((:label ,(string-downcase (sys::dsd-name def)))
" reader: " (:value ,(sys::dsd-reader def)
,(string-downcase (string (sys::dsd-reader def))))
", index: " (:value ,(sys::dsd-index def))
,@(if (sys::dsd-initform def)
`(", initform: " (:value ,(sys::dsd-initform def))))
,@(if (sys::dsd-read-only def)
'(", Read only"))))
(defun parts-for-structure-def (name)
(let ((structure-def (get name 'system::structure-definition )))
(append
(loop for accessor in '(dd-name dd-conc-name dd-default-constructor dd-constructors dd-copier dd-include dd-type
dd-named dd-initial-offset dd-predicate dd-print-function dd-print-object
dd-inherited-accessors)
for key = (intern (subseq (string accessor) 3) 'keyword)
for fsym = (find-symbol (string accessor) 'system)
for value = (eval `(,fsym ,structure-def))
append `((:label ,(string-capitalize (string key))) ": " (:value ,value) (:newline)))
(let* ((direct (sys::dd-direct-slots structure-def) )
(all (sys::dd-slots structure-def))
(inherited (set-difference all direct)))
`((:label "Direct slots: ") (:newline)
,@(loop for slotdef in direct
append `(" " ,@(parts-for-structure-def-slot slotdef)
(:newline)))
,@(if inherited
(append '((:label "Inherited slots: ") (:newline))
(loop for slotdef in inherited
append `(" " (:label ,(string-downcase (string (sys::dsd-name slotdef))))
(:value ,slotdef "slot definition")
(:newline))))))))))
;;;; Multithreading
(defimplementation spawn (fn &key name)
(threads:make-thread (lambda () (funcall fn)) :name name))
(defvar *thread-plists* (make-hash-table) ; should be a weak table
"A hashtable mapping threads to a plist.")
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
(threads:synchronized-on *thread-plists*
(or (getf (gethash thread *thread-plists*) 'id)
(setf (getf (gethash thread *thread-plists*) 'id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id (all-threads)
:key (lambda (thread)
(getf (gethash thread *thread-plists*) 'id))))
(defimplementation thread-name (thread)
(threads:thread-name thread))
(defimplementation thread-status (thread)
(format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
(defimplementation make-lock (&key name)
(declare (ignore name))
(threads:make-thread-lock))
(defimplementation call-with-lock-held (lock function)
(threads:with-thread-lock (lock) (funcall function)))
(defimplementation current-thread ()
(threads:current-thread))
(defimplementation all-threads ()
(copy-list (threads:mapcar-threads #'identity)))
(defimplementation thread-alive-p (thread)
(member thread (all-threads)))
(defimplementation interrupt-thread (thread fn)
(threads:interrupt-thread thread fn))
(defimplementation kill-thread (thread)
(threads:destroy-thread thread))
(defstruct mailbox
(queue '()))
(defun mailbox (thread)
"Return THREAD's mailbox."
(threads:synchronized-on *thread-plists*
(or (getf (gethash thread *thread-plists*) 'mailbox)
(setf (getf (gethash thread *thread-plists*) 'mailbox)
(make-mailbox)))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(threads:synchronized-on mbox
(setf (mailbox-queue mbox)
(nconc (mailbox-queue mbox) (list message)))
(threads:object-notify-all mbox))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread))))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-sly-interrupts)
(threads:synchronized-on mbox
(let* ((q (mailbox-queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail)))
(when (eq timeout t) (return (values nil t)))
(threads:object-wait mbox 0.3))))))
(defimplementation quit-lisp ()
(ext:exit))
;; FIXME probably should be promoted to other lisps but I don't want to mess with them
(defvar *inspector-print-case* *print-case*)
(defimplementation call-with-syntax-hooks (fn)
(let ((*print-case* *inspector-print-case*))
(funcall fn)))
;;;
#+#.(slynk-backend:with-symbol 'package-local-nicknames 'ext)
(defimplementation package-local-nicknames (package)
(ext:package-local-nicknames package))
;; all the defimplentations aren't compiled. Compile them. Set their
;; function name to be the same as the implementation name so
;; meta-. works.
#+abcl-introspect
(eval-when (:load-toplevel :execute)
(loop for s in slynk-backend::*interface-functions*
for impl = (get s 'slynk-backend::implementation)
do (when (and impl (not (compiled-function-p impl)))
(let ((name (gensym)))
(compile name impl)
(let ((compiled (symbol-function name)))
(system::%set-lambda-name compiled (second (sys::lambda-name impl)))
(setf (get s 'slynk-backend::implementation) compiled))))))
This is sly.info, produced by makeinfo version 6.7 from sly.texi.
Written for SLIME Luke Gorrie and others, rewritten by João Távora for
SLY.
This file has been placed in the public domain.
INFO-DIR-SECTION Emacs
START-INFO-DIR-ENTRY
* SLY: (sly). Common-Lisp IDE
END-INFO-DIR-ENTRY
File: sly.info, Node: Top, Next: Introduction, Up: (dir)
SLY
***
SLY is a Common Lisp IDE for Emacs. This is the manual for version
1.0.42. (Last updated February 28, 2024)
Written for SLIME Luke Gorrie and others, rewritten by João Távora
for SLY.
This file has been placed in the public domain.
* Menu:
* Introduction::
* Getting started::
* A SLY tour for SLIME users::
* Working with source files::
* Common functionality::
* The REPL and other special buffers::
* Customization::
* Tips and Tricks::
* Extensions::
* Credits::
* Key Index::
* Command Index::
* Variable Index::
-- The Detailed Node Listing --
Getting started
* Platforms::
* Downloading::
* Basic setup::
* Running::
* Basic customization::
* Multiple Lisps::
Working with source files
* Evaluation::
* Compilation::
* Autodoc::
* Semantic indentation::
* Reader conditionals::
* Macro-expansion::
Common functionality
* Finding definitions::
* Cross-referencing::
* Completion::
* Interactive objects::
* Documentation::
* Multiple connections::
* Disassembly::
* Recovery::
* Temporary buffers::
* Multi-threading::
The REPL and other special buffers
* REPL::
* Inspector::
* Debugger::
* Trace Dialog::
* Stickers::
The REPL: the "top level"
* REPL commands::
* REPL output::
* REPL backreferences::
The SLY-DB Debugger
* Examining frames::
* Restarts::
* Frame Navigation::
* Miscellaneous::
Customization
* Emacs-side::
* Lisp-side customization::
Emacs-side
* Keybindings::
* Keymaps::
* Defcustom variables::
* Hooks::
Lisp-side (Slynk)
* Communication style::
* Other configurables::
Tips and Tricks
* Connecting to a remote Lisp::
* Loading Slynk faster::
* Auto-SLY::
* REPLs and game loops::
* Controlling SLY from outside Emacs::
Connecting to a remote Lisp
* Setting up the Lisp image::
* Setting up Emacs::
* Setting up pathname translations::
Extensions
* Loading and unloading::
* More contribs::
More contribs
* TRAMP Support::
* Scratch Buffer::
File: sly.info, Node: Introduction, Next: Getting started, Prev: Top, Up: Top
1 Introduction
**************
SLY is Sylvester the Cat's Common Lisp IDE. It extends Emacs with
support for interactive programming in Common Lisp.
The features are centered around an Emacs minor-mode called
'sly-mode', which complements the standard major-mode 'lisp-mode' for
editing Lisp source files. 'sly-mode' adds support for interacting with
a running Common Lisp process for compilation, debugging, documentation
lookup, and so on.
SLY attempts to follow the example of Emacs's own native Emacs-Lisp
environment. Many of the keybindings and interface concepts used to
interact with Emacs's Elisp machine are reused in SLY to interact with
the underlying Common Lisp run-times. Emacs makes requests to these
processes, asking them to compile files or code snippets; deliver
introspection information various objects; or invoke commands or
debugging restarts.
Internally, SLY's user-interface, written in Emacs Lisp, is connected
via sockets to one or more instances of a server program called "Slynk"
that is running in the Lisp processes.
The two sides communicate using a Remote Procedure Call (RPC)
protocol. The Lisp-side server is primarily written in portable Common
Lisp. However, because some non-standard functionality is provided
differently by each Lisp implementation (SBCL, CMUCL, Allegro, etc...)
the Lisp-side server is again split into two parts - portable and
non-portable implementation - which communicate using a well-defined
interface. Each Lisp implementation provides a separate implementation
of that interface, making SLY as a whole readily portable.
SLY is a direct fork of SLIME, the "Superior Lisp Interaction Mode
for Emacs", which itself derived from previous Emacs programs such as
SLIM and ILISP. If you already know SLIME, SLY's closeness to it is
immediately apparent. However, where SLIME has traditionally focused on
the stability of its core functionality, SLY aims for a richer feature
set, a more consistent user interface, and an experience generally
closer to Emacs' own.
To understand the differences between the two projects read SLY's
NEWS.md file. For a hand-on approach to these differences you might
want to *note A SLY tour for SLIME users::.
File: sly.info, Node: Getting started, Next: A SLY tour for SLIME users, Prev: Introduction, Up: Top
2 Getting started
*****************
This chapter tells you how to get SLY up and running.
* Menu:
* Platforms::
* Downloading::
* Basic setup::
* Running::
* Basic customization::
* Multiple Lisps::
File: sly.info, Node: Platforms, Next: Downloading, Up: Getting started
2.1 Supported Platforms
=======================
SLY supports a wide range of operating systems and Lisp implementations.
SLY runs on Unix systems, Mac OSX, and Microsoft Windows. GNU Emacs
versions 24.4 and above are supported. _XEmacs or Emacs 23 are notably
not supported_.
The supported Lisp implementations, roughly ordered from the
best-supported, are:
* CMU Common Lisp (CMUCL), 19d or newer
* Steel Bank Common Lisp (SBCL), 1.0 or newer
* Clozure Common Lisp (CCL), version 1.3 or newer
* LispWorks, version 4.3 or newer
* Allegro Common Lisp (ACL), version 6 or newer
* CLISP, version 2.35 or newer
* Armed Bear Common Lisp (ABCL)
* Scieneer Common Lisp (SCL), version 1.2.7 or newer
* Embedded Common Lisp (ECL)
* ManKai Common Lisp (MKCL)
* Clasp
Most features work uniformly across implementations, but some are
prone to variation. These include the precision of placing
compiler-note annotations, XREF support, and fancy debugger commands
(like "restart frame").
File: sly.info, Node: Downloading, Next: Basic setup, Prev: Platforms, Up: Getting started
2.2 Downloading SLY
===================
By far the easiest method for getting SLY up and running is using Emacs’
package system configured to the popular MELPA repository. This snippet
of code should already be in your configuration:
(add-to-list 'package-archives
'("melpa" . "https://melpa.org/packages/"))
(package-initialize)
You should now be able to issue the command 'M-x package-install',
choose 'sly' and have it be downloaded and installed automatically. If
you don’t find it in the list, ensure you run 'M-x
package-refresh-contents' first.
In other situations, such as when developing SLY itself, you can
access the Git repository directly:
git clone https://github.com/joaotavora/sly.git
If you want to hack on SLY, use Github's _fork_ functionality and
submit a _pull request_. Be sure to first read the CONTRIBUTING.md file
first.
File: sly.info, Node: Basic setup, Next: Running, Prev: Downloading, Up: Getting started
2.3 Basic setup
===============
If you installed SLY from MELPA, it is quite possible that you don’t
need any more configuration, provided that SLY can find a suitable Lisp
executable in your 'PATH' environment variable.
Otherwise, you need to tell it where a Lisp program can be found, so
customize the variable 'inferior-lisp-program' (*note Defcustom
variables::) or add a line like this one to your '~/.emacs' or
'~/.emacs.d/init.el' (*note Emacs Init File::).
(setq inferior-lisp-program "/opt/sbcl/bin/sbcl")
After evaluating this, you should be able to execute 'M-x sly' and be
greeted with a REPL.
If you cloned from the Git repository, you’ll have to add a couple of
more lines to your initialization file configuration:
(add-to-list 'load-path "~/dir/to/cloned/sly")
(require 'sly-autoloads)
File: sly.info, Node: Running, Next: Basic customization, Prev: Basic setup, Up: Getting started
2.4 Running SLY
===============
SLY can either ask Emacs to start its own Lisp subprocesss or connect to
a running process on a local or remote machine.
The first alternative is more common for local development and is
started via 'M-x sly'. The "inferior" Lisp process thus started is told
to load the Lisp-side server known as "Slynk" and then a socket
connection is established between Emacs and Lisp. Finally a REPL buffer
is created where you can enter Lisp expressions for evaluation.
The second alternative uses 'M-x sly-connect'. This assumes that
that a Slynk server is running on some local or remote host, and
listening on a given port. 'M-x sly-connect' prompts the user for these
values, and upon connection the REPL is established.
File: sly.info, Node: Basic customization, Next: Multiple Lisps, Prev: Running, Up: Getting started
2.5 Basic customization
=======================
A big part of Emacs, and Emacs’s extensions, are its near-infinite
customization possibilities. SLY is no exception, because it runs on
both Emacs and the Lisp process, there are layers of Emacs-side
customization and Lisp-side customization. But don’t be put off by
this! SLY tries hard to provide sensible defaults that don’t "hide" any
fanciness beneath layers of complicated code, so that even a setup with
no customization at all exposes SLY’s most important functionality.
Emacs-side customization is usually done via Emacs-lisp code snippets
added to the user’s initialization file, usually '$HOME/.emacs' or
'$HOME/.emacs.d/init.el' (*note Emacs Init File::).
90% of Emacs-lisp customization happens in either "keymaps" or
"hooks" (*note Emacs-side::). Still on the Emacs side, there is also a
separate interface, appropriately called 'customize' (or sometimes just
'custom'), that uses a nicer UI with mouse-clickable buttons to set some
special variables. See *Note Defcustom variables::.
Lisp-side customization is done exclusively via Common Lisp code
snippets added to the user’s '$HOME/.slynkrc' file. See *Note Lisp-side
customization::.
As a preview, take this simple example of a frequently customized
part of SLY: its keyboard shortcuts, known as "keybindings". In the
following snippet 'M-h' is added to 'sly-prefix-map' thus yielding 'C-c
M-h' as a shortcut to the 'sly-documentation-lookup' command.
(eval-after-load 'sly
`(define-key sly-prefix-map (kbd "M-h") 'sly-documentation-lookup))
File: sly.info, Node: Multiple Lisps, Prev: Basic customization, Up: Getting started
2.6 Multiple Lisps
==================
By default, the command 'M-x sly' starts the program specified with
'inferior-lisp-program', a variable that you can customize (*note
Defcustom variables::). However, if you invoke 'M-x sly' with a _prefix
argument_, meaning you type 'C-u M-x sly' then Emacs prompts for the
program which should be started instead.
If you need to do this frequently or if the command involves long
filenames it's more convenient to set the 'sly-lisp-implementations'
variable in your initialization file (*note Emacs Init File::). For
example here we define two programs:
(setq sly-lisp-implementations
'((cmucl ("cmucl" "-quiet"))
(sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix)))
Now, if you invoke SLY with a _negative_ prefix argument, 'M-- M-x
sly', you can select a program from that list. When called without a
prefix, either the name specified in 'sly-default-lisp', or the first
item of the list will be used. The elements of the list should look
like
(NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION ENV)
'NAME'
is a symbol and is used to identify the program.
'PROGRAM'
is the filename of the program. Note that the filename can contain
spaces.
'PROGRAM-ARGS'
is a list of command line arguments.
'CODING-SYSTEM'
the coding system for the connection. (*note
sly-net-coding-system::)x
'INIT'
should be a function which takes two arguments: a filename and a
character encoding. The function should return a Lisp expression
as a string which instructs Lisp to start the Slynk server and to
write the port number to the file. At startup, SLY starts the Lisp
process and sends the result of this function to Lisp's standard
input. As default, 'sly-init-command' is used. An example is
shown in *note Loading Slynk faster: init-example.
'INIT-FUNCTION'
should be a function which takes no arguments. It is called after
the connection is established. (See also *note
sly-connected-hook::.)
'ENV'
specifies a list of environment variables for the subprocess. E.g.
(sbcl-cvs ("/home/me/sbcl-cvs/src/runtime/sbcl"
"--core" "/home/me/sbcl-cvs/output/sbcl.core")
:env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/"))
initializes 'SBCL_HOME' in the subprocess.
File: sly.info, Node: A SLY tour for SLIME users, Next: Working with source files, Prev: Getting started, Up: Top
3 A SLY tour for SLIME users
****************************
The chances are that if you’re into Common Lisp, you already know about
SLIME, the project that originated SLY. Itself originating in older
Emacs extensions SLIM and ILISP, SLIME has been around for at least a
decade longer than SLY and is quite an amazing IDE. It's likely that
most Lispers have some experience with it, making it a good idea to
provide, in the shape of a quick tutorial, a hands-on overview of some
of the improvements of SLY over SLIME.
When you start SLY with 'M-x sly' (*note Basic setup::) you are
greeted with its REPL, a common starting point of Lisp hacking sessions.
This has been completely redesigned in SLY: you can spawn multiple REPL
sessions with 'sly-mrepl-new'; copy objects from most places directly
into it (with 'M-RET' and 'M-S-RET'); use powerful incremental history
search (with 'C-r') found in most modern shells; and get real-time
assistance when "backreferecing" previous evaluation values in your Lisp
input.
�[image src="images/tutorial-1.png"�]
Starting from the new REPL, let's showcase some of SLY’s features.
Let’s pretend we want to hack an existing Lisp project. We'll pick SLY
itself, or rather its Lisp server, called Slynk. Let's pretend we're
intrigued by the way its "flex"-style completion works. What is flex
completion, you ask? Well, if you're at the REPL you can try it now:
it's a way of 'TAB'-completing (*note Completion::) symbol names based
on educated guesses of a few letters. Thus if we type 'mvbind', SLY
guesses that we probably meant 'multiple-value-bind', and if we type
'domat' it might possibly guess 'cl-ppcre:do-matches'. Let's dig into
the code that makes this happen.
But how? Where to begin, given we know so little about this project?
Well, a good starting point is always the _apropos_ functionality,
which is a 'grep' of sorts, but aware of the symbols loaded in your
Lisp, rather the contents of text files. Furthermore, in SLY,
'sly-apropos' will do a regular-expression-enabled symbol search, which
will help us here since we don't yet know any symbols names of this
mysterious flex feature.
To enable regular expression searches you need the 'CL-PPCRE' library
is loaded (else 'sly-apropos' falls back to regex-less mode). If you
have Quicklisp (https://www.quicklisp.org/beta/) installed (you do,
right?) you need only type '(ql:quickload :cl-ppcre)' now from the
REPL.
Thus, if we want to hack SLY's flex completion, and _don't_ known any
of its symbol's names, we type 'C-c C-d C-z' (the shortcut for 'M-x
sly-apropos-all') and then type in "sly.*flex" at the prompt. We follow
with 'enter' or 'return' (abbreviated 'RET' or 'C-m'). SLY should now
present all Lisp symbols matching your search pattern.
�[image src="images/tutorial-2.png"�]
In the 'apropos' buffer, let’s grab the mouse and right-click the
symbol 'SLYNK-COMPLETIONS:FLEX-COMPLETIONS'. We’ll be presented with a
context menu with options for describing the symbol, inspecting it, or
navigating to its source definition. In general, the Lisp-side objects
that SLY presents -- symbols, CLOS objects, function calls, etc... --
are right-clickable buttons with such a context menu (*note Interactive
objects::). For now, let’s navigate to the source definition of the
symbol by choosing "Go To source" from the menu. Alternatively, we
could also have just pressed 'M-.' on the symbol, of course.
From the Lisp source buffer that we landed on (probably
'slynk-completion.lisp'), let’s _trace_ the newly found function
'SLYNK-COMPLETIONS:FLEX-COMPLETIONS'. However, instead of using the
regular 'CL:TRACE', we’ll use SLY’s Trace Dialog functionality. This is
how we set it up:
1. first type 'C-c C-t' on the function’s name, or enter that in the
minibuffer prompt;
2. now, open the Trace Dialog in a new window by typing 'C-c T'
(that’s a capital 'T'). We should already see our traced function
under the heading "Traced specs";
3. thirdly, for good measure, let’s also trace the nearby function
'SLYNK-COMPLETIONS::FLEX-SCORE' by also typing 'C-c C-t' on its
name, or just entering it in the minibuffer prompt.
Now let’s return to the REPL by switching to its '*sly-mrepl ...'
buffer or typing 'C-c C-z'. To exercise the code we just traced, let’s
type something like 'desbind', followed by tab, and see if it suggest
'destructuring-bind' as the top match. We could now select some
completion from the list, but instead let's just type 'C-g' to dismiss
the completion, since we wanted to test completion, not write any actual
'destructuring-bind' expression.
Remember the traced functions in the Trace Dialog? Time to see if we
got any traces. let's type 'C-c T' to switch to that buffer, and then
type capital 'G'. This should produce a fair number of traces organized
in a call graph.
�[image src="images/tutorial-3.png"�]
We can later learn more about this mode (*note Trace Dialog::), but
for now let’s again pretend we expected the function 'FLEX-SCORE' to
return a wildly different score for 'COMMON-LISP:DESTRUCTURING-BIND'.
In that case we should like to witness said 'FLEX-SCORE' function
respond to any implementation improvements we perform. To do so, it's
useful to be able to surgically re-run that function with those very
same arguments. Let's do this by finding the function call in the Trace
Dialog window, right-clicking it with the mouse and selecting "Copy call
to REPL". Pressing 'M-S-RET' on it should accomplish the same. We are
automatically transported to the REPL again, where the desired function
call has already been typed out for us at the command prompt, awaiting a
confirmation 'RET', which will run the function call:
; The actual arguments passed to trace 15
"desbind"
"COMMON-LISP:DESTRUCTURING-BIND"
(12 13 14 26 27 28 29)
SLYNK-COMPLETION> (slynk-completion::flex-score #v1:0 #v1:1 #v1:2)
0.003030303 (0.30303028%)
SLYNK-COMPLETION>
�[image src="images/tutorial-4.png"�]
If those '#v...''s look odd, here’s what’s going on: to copy the call
to the REPL, SLY first copied over its actual arguments, and then wrote
the function using special _backreferences_ to those arguments in the
correct place. These are the '#v4:0' and '#v4:1' bits seen at the
command prompt. If one puts the cursor on them or hovers with the
mouse, this highlights the corresponding object a few lines above in the
buffer. Later, you can also try typing "#v" at the REPL to
incrementally write your own backreferences (*note REPL
backreferences::).
For one final demonstration, let’s now suppose say we are still
intrigued by how that function ('FLEX-SCORE') works internally. So
let's navigate to its definition using 'M-.' again (or just open the
'slynk-completion.lisp' buffer that you probably still have open). The
function’s code might look like this:
(defun flex-score (pattern string indexes)
"Score the match of PATTERN on STRING.
INDEXES as calculated by FLEX-MATCHES"
;; FIXME: hideously naive scoring
(declare (ignore pattern))
(float
(/ 1
(* (length string)
(max 1
(reduce #'+
(loop for (a b) on indexes
while b
collect (- b a 1))))))))
Can this function be working correctly? What do all those
expressions return? Should we reach for good old C-style 'printf'?
Let's try "stickers" instead. SLY's stickers are a form of
non-intrusive function instrumentation that work like carefully crafted
'print' or '(format t ...)'), but are much easier to work with. You can
later read more about them (*note Stickers::), but for now you can just
think of them as colorful labels placed on s-exp’s. Let’s place a bunch
here, like this:
1. on the last line of 'flex-score', place your cursor on the first
open parenthesis of that line (the opening parenthesis of the
expression '(- b a 1)') and press 'C-c C-s C-s';
2. now do the same for the symbol 'indexes' a couple of lines above;
3. again, the same for the expressions '(loop...)', '(reduce...)',
'(max...)', '(length...)', '(*...)', '(/... )' and '(float...)'.
You could have done this in any order, by the way;
Now let’s recompile this definition with 'C-c C-c'. Beside the
minibuffer note something about stickers being "armed" our function
should now look like a rainbow in blue.
�[image src="images/tutorial-5.png"�]
Now we return to the SLY REPL, but this time let’s use 'C-c ~'
(that’s 'C-c' followed by "tilde") to do so. This syncs the REPL’s
local package and local directory to the Lisp file that we’re visiting.
This is something not strictly necessary here but generally convenient
when hacking on a system, because you can now call functions from the
file you came from without package-qualification.
Now, to re-run the newly instrumented function, by calling it with
the same arguments. No need to type all that again, because this REPL
supports reverse history i-search, remember? So just type the binding
'C-r' and then type something like 'scor' to search history backwards
and arrive at the function call copied to the REPL earlier. Type 'RET'
once to confirm that's the call your after, and 'RET' again to evaluate
it. Because those '#v...' backreferences are still trained specifically
on those very same function arguments, you can be sure that the function
call is equivalent.
We can now use the 'C-c C-s C-r' to _replay_ the sticker recordings
of this last function call. This is a kind of slow walk-through
conducted in separate navigation window called '*sly-stickers-replay*'
which pops up. There we can see the Lisp value(s) that each sticker
'eval'’ed to each time (or a note if it exited non-locally). We can
navigate recordings with 'n' and 'p', and do the usual things allowed by
interactive objects like inspecting them and returning them to the REPL.
If you need help, toggle help by typing 'h'. There are lots of options
here for navigating stickers, ignoring some stickers, etc. When we’re
done in this window, we press 'q' to quit.
�[image src="images/tutorial-6.png"�]
Finally, we declare that we’re finished debugging 'FLEX-MATCHES'.
Even though stickers don’t get saved to the file in any way, we decide
we’re not interested in them anymore. So let’s open the "SLY" menu in
the menu bar, find the "Delete stickers from top-level form" option
under the "Stickers" sub-menu, and click it. Alternatively, we could
have typed 'C-u C-c C-s C-s'.
File: sly.info, Node: Working with source files, Next: Common functionality, Prev: A SLY tour for SLIME users, Up: Top
4 Working with source files
***************************
SLY's commands when editing a Lisp file are provided via
'sly-editing-mode', a minor-mode used in conjunction with Emacs's
'lisp-mode'.
This chapter describes SLY’s commands for editing and working in Lisp
source buffers. There are, of course, more SLY’s commands that also
apply to these buffers (*note Common functionality::), but with very few
exceptions these commands will always be run from a '.lisp' file.
* Menu:
* Evaluation::
* Compilation::
* Autodoc::
* Semantic indentation::
* Reader conditionals::
* Macro-expansion::
File: sly.info, Node: Evaluation, Next: Compilation, Up: Working with source files
4.1 Evaluating code
===================
These commands each evaluate a Common Lisp expression in a different
way. Usually they mimic commands for evaluating Emacs Lisp code. By
default they show their results in the echo area, but a prefix argument
'C-u' inserts the results into the current buffer, while a negative
prefix argument 'M--' sends them to the kill ring.
'C-x C-e'
'M-x sly-eval-last-expression'
Evaluate the expression before point and show the result in the
echo area.
'C-M-x'
'M-x sly-eval-defun'
Evaluate the current toplevel form and show the result in the echo
area. 'C-M-x' treats 'defvar' expressions specially. Normally,
evaluating a 'defvar' expression does nothing if the variable it
defines already has a value. But 'C-M-x' unconditionally resets
the variable to the initial value specified in the 'defvar'
expression. This special feature is convenient for debugging Lisp
programs.
If 'C-M-x' or 'C-x C-e' is given a numeric argument, it inserts the
value into the current buffer, rather than displaying it in the echo
area.
'C-c :'
'M-x sly-interactive-eval'
Evaluate an expression read from the minibuffer.
'C-c C-r'
'M-x sly-eval-region'
Evaluate the region.
'C-c C-p'
'M-x sly-pprint-eval-last-expression'
Evaluate the expression before point and pretty-print the result in
a fresh buffer.
'C-c E'
'M-x sly-edit-value'
Edit the value of a setf-able form in a new buffer '*Edit <form>*'.
The value is inserted into a temporary buffer for editing and then
set in Lisp when committed with 'C-c C-c'.
'C-c C-u'
'M-x sly-undefine-function'
Undefine the function, with 'fmakunbound', for the symbol at point.
'M-x sly-remove-method'
Remove a specific method of a generic function at point.
File: sly.info, Node: Compilation, Next: Autodoc, Prev: Evaluation, Up: Working with source files
4.2 Compiling functions and files
=================================
SLY has fancy commands for compiling functions, files, and packages.
The fancy part is that notes and warnings offered by the Lisp compiler
are intercepted and annotated directly onto the corresponding
expressions in the Lisp source buffer. (Give it a try to see what this
means.)
'C-c C-c'
'M-x sly-compile-defun'
Compile the top-level form at point. The region blinks shortly to
give some feedback which part was chosen.
With (positive) prefix argument the form is compiled with maximal
debug settings ('C-u C-c C-c'). With negative prefix argument it
is compiled for speed ('M-- C-c C-c'). If a numeric argument is
passed set debug or speed settings to it depending on its sign.
The code for the region is executed after compilation. In
principle, the command writes the region to a file, compiles that
file, and loads the resulting code.
This compilation may arm stickers (*note Stickers::).
'C-c C-k'
'M-x sly-compile-and-load-file'
Compile and load the current buffer's source file. If the
compilation step fails, the file is not loaded. It's not always
easy to tell whether the compilation failed: occasionally you may
end up in the debugger during the load step.
With (positive) prefix argument the file is compiled with maximal
debug settings ('C-u C-c C-k'). With negative prefix argument it
is compiled for speed ('M-- C-c C-k'). If a numeric argument is
passed set debug or speed settings to it depending on its sign.
This compilation may arm stickers (*note Stickers::).
'C-c M-k'
'M-x sly-compile-file'
Compile (but don't load) the current buffer's source file.
'C-c C-l'
'M-x sly-load-file'
Load a Lisp file. This command uses the Common Lisp LOAD function.
'M-x sly-compile-region'
Compile the selected region.
This compilation may arm stickers (*note Stickers::).
The annotations are indicated as underlining on source forms. The
compiler message associated with an annotation can be read either by
placing the mouse over the text or with the selection commands below.
'M-n'
'M-x sly-next-note'
Move the point to the next compiler note and displays the note.
'M-p'
'M-x sly-previous-note'
Move the point to the previous compiler note and displays the note.
'C-c M-c'
'M-x sly-remove-notes'
Remove all annotations from the buffer.
'C-x `'
'M-x next-error'
Visit the next-error message. This is not actually a SLY command
but SLY creates a hidden buffer so that most of the Compilation
mode commands (*note (emacs)Compilation Mode::) work similarly for
Lisp as for batch compilers.
File: sly.info, Node: Autodoc, Next: Semantic indentation, Prev: Compilation, Up: Working with source files
4.3 Autodoc
===========
SLY automatically shows information about symbols near the point. For
function names the argument list is displayed, and for global variables,
the value. Autodoc is implemented by means of 'eldoc-mode' of Emacs.
'M-x sly-arglist NAME'
Show the argument list of the function NAME.
'M-x sly-autodoc-mode'
Toggles autodoc-mode on or off according to the argument, and
toggles the mode when invoked without argument.
'M-x sly-autodoc-manually'
Like sly-autodoc, but when called twice, or after sly-autodoc was
already automatically called, display multiline arglist.
If 'sly-autodoc-use-multiline-p' is set to non-nil, allow long
autodoc messages to resize echo area display.
'autodoc-mode' is a SLY extension and can be turned off if you so
wish (*note Extensions::)
File: sly.info, Node: Semantic indentation, Next: Reader conditionals, Prev: Autodoc, Up: Working with source files
4.4 Semantic indentation
========================
SLY automatically discovers how to indent the macros in your Lisp
system. To do this the Lisp side scans all the macros in the system and
reports to Emacs all the ones with '&body' arguments. Emacs then
indents these specially, putting the first arguments four spaces in and
the "body" arguments just two spaces, as usual.
This should "just work." If you are a lucky sort of person you
needn't read the rest of this section.
To simplify the implementation, SLY doesn't distinguish between
macros with the same symbol-name but different packages. This makes it
fit nicely with Emacs's indentation code. However, if you do have
several macros with the same symbol-name then they will all be indented
the same way, arbitrarily using the style from one of their arglists.
You can find out which symbols are involved in collisions with:
(slynk:print-indentation-lossage)
If a collision causes you irritation, don't have a nervous breakdown,
just override the Elisp symbol's 'sly-common-lisp-indent-function'
property to your taste. SLY won't override your custom settings, it
just tries to give you good defaults.
A more subtle issue is that imperfect caching is used for the sake of
performance. (1)
In an ideal world, Lisp would automatically scan every symbol for
indentation changes after each command from Emacs. However, this is too
expensive to do every time. Instead Lisp usually just scans the symbols
whose home package matches the one used by the Emacs buffer where the
request comes from. That is sufficient to pick up the indentation of
most interactively-defined macros. To catch the rest we make a full
scan of every symbol each time a new Lisp package is created between
commands - that takes care of things like new systems being loaded.
You can use 'M-x sly-update-indentation' to force all symbols to be
scanned for indentation information.
---------- Footnotes ----------
(1) _Of course_ we made sure it was actually too slow before making
the ugly optimization.
File: sly.info, Node: Reader conditionals, Next: Macro-expansion, Prev: Semantic indentation, Up: Working with source files
4.5 Reader conditional fontification
====================================
SLY automatically evaluates reader-conditional expressions, like
'#+linux', in source buffers and "grays out" code that will be skipped
for the current Lisp connection.
File: sly.info, Node: Macro-expansion, Prev: Reader conditionals, Up: Working with source files
4.6 Macro-expansion commands
============================
'C-c C-m'
'M-x sly-expand-1'
Macroexpand (or compiler-macroexpand) the expression at point once.
If invoked with a prefix argument use macroexpand instead or
macroexpand-1 (or compiler-macroexpand instead of
compiler-macroexpand-1).
'M-x sly-macroexpand-1'
Macroexpand the expression at point once. If invoked with a prefix
argument, use macroexpand instead of macroexpand-1.
'C-c M-m'
'M-x sly-macroexpand-all'
Fully macroexpand the expression at point.
'M-x sly-compiler-macroexpand-1'
Display the compiler-macro expansion of sexp at point.
'M-x sly-compiler-macroexpand'
Repeatedly expand compiler macros of sexp at point.
'M-x sly-format-string-expand'
Expand the format-string at point and display it. With prefix arg,
or if no string at point, prompt the user for a string to expand.
Within a sly macroexpansion buffer some extra commands are provided
(these commands are always available but are only bound to keys in a
macroexpansion buffer).
'C-c C-m'
'M-x sly-macroexpand-1-inplace'
Just like sly-macroexpand-1 but the original form is replaced with
the expansion.
'g'
'M-x sly-macroexpand-1-inplace'
The last macroexpansion is performed again, the current contents of
the macroexpansion buffer are replaced with the new expansion.
'q'
'M-x sly-temp-buffer-quit'
Close the expansion buffer.
'C-_'
'M-x sly-macroexpand-undo'
Undo last macroexpansion operation.
File: sly.info, Node: Common functionality, Next: The REPL and other special buffers, Prev: Working with source files, Up: Top
5 Common functionality
**********************
This chapter describes the commands available throughout SLY-enabled
buffers, which are not only Lisp source buffers, but every auxiliary
buffer created by SLY, such as the REPL, Inspector, etc (*note The REPL
and other special buffers::) In general, it’s a good bet that if the
buffer’s name starts with '*sly-...*', these commands and functionality
will be available there.
* Menu:
* Finding definitions::
* Cross-referencing::
* Completion::
* Interactive objects::
* Documentation::
* Multiple connections::
* Disassembly::
* Recovery::
* Temporary buffers::
* Multi-threading::
File: sly.info, Node: Finding definitions, Next: Cross-referencing, Up: Common functionality
5.1 Finding definitions
=======================
One of the most used keybindings across all of SLY is the familiar 'M-.'
binding for 'sly-edit-definition'.
Here's the gist of it: when pressed with the cursor over a symbol
name, that symbol's name definition is looked up by the Lisp process,
thus producing a Lisp source location, which might be a file, or a
file-less buffer. For convenience, a type of "breadcrumb" is left
behind at the original location where 'M-.' was pressed, so that another
keybinding 'M-,' takes the user back to the original location. Thus
multiple 'M-.' trace a path through lisp sources that can be traced back
with an equal number of 'M-,'.
'M-.'
'M-x sly-edit-definition'
Go to the definition of the symbol at point.
'M-,'
'M-*'
'M-x sly-pop-find-definition-stack'
Go back to the point where 'M-.' was invoked. This gives
multi-level backtracking when 'M-.' has been used several times.
'C-x 4 .'
'M-x sly-edit-definition-other-window'
Like 'sly-edit-definition' but switches to the other window to edit
the definition in.
'C-x 5 .'
'M-x sly-edit-definition-other-frame'
Like 'sly-edit-definition' but opens another frame to edit the
definition in.
The behaviour of the 'M-.' binding is sometimes affected by the type
of symbol you are giving it.
* For single functions or variables, 'M-.' immediately switches the
current window's buffer and position to the target 'defun' or
'defvar'.
* For symbols with more than one associated definition, say, generic
functions, the same 'M-.' finds all methods and presents these
results in separate window displaying a special '*sly-xref*' buffer
(*note Cross-referencing::).
File: sly.info, Node: Cross-referencing, Next: Completion, Prev: Finding definitions, Up: Common functionality
5.2 Cross-referencing
=====================
Finding and presenting the definition of a function is actually the most
elementary aspect of broader _cross-referencing_ facilities framework in
SLY. There are other types of questions about the source code relations
that you can ask the Lisp process.(1)
The following keybindings behave much like the 'M-.' keybinding
(*note Finding definitions::): when pressed as is they make a query
about the symbol at point, but with a 'C-u' prefix argument they prompt
the user for a symbol. Importantly, they always popup a transient
'*sly-xref*' buffer in a different window.
'M-?'
'M-x sly-edit-uses'
Find all the references to this symbol, whatever the type of that
reference.
'C-c C-w C-c'
'M-x sly-who-calls'
Show function callers.
'C-c C-w C-w'
'M-x sly-calls-who'
Show all known callees.
'C-c C-w C-r'
'M-x sly-who-references'
Show references to global variable.
'C-c C-w C-b'
'M-x sly-who-binds'
Show bindings of a global variable.
'C-c C-w C-s'
'M-x sly-who-sets'
Show assignments to a global variable.
'C-c C-w C-m'
'M-x sly-who-macroexpands'
Show expansions of a macro.
'M-x sly-who-specializes'
Show all known methods specialized on a class.
There are two further "List callers/callees" commands that operate by
rummaging through function objects on the heap at a low-level to
discover the call graph. They are only available with some Lisp
systems, and are most useful as a fallback when precise XREF information
is unavailable.
'C-c <'
'M-x sly-list-callers'
List callers of a function.
'C-c >'
'M-x sly-list-callees'
List callees of a function.
In the resulting '*sly-xref*' buffer, these commands are available:
'RET'
'M-x sly-show-xref'
Show definition at point in the other window. Do not leave the
'*sly-xref' buffer.
'Space'
'M-x sly-goto-xref'
Show definition at point in the other window and close the
'*sly-xref' buffer.
'C-c C-c'
'M-x sly-recompile-xref'
Recompile definition at point. Uses prefix arguments like
'sly-compile-defun'.
'C-c C-k'
'M-x sly-recompile-all-xrefs'
Recompile all definitions. Uses prefix arguments like
'sly-compile-defun'.
---------- Footnotes ----------
(1) This depends on the underlying implementation of some of these
facilities: for systems with no built-in XREF support SLY queries a
portable XREF package, which is taken from the 'CMU AI Repository' and
bundled with SLY.
File: sly.info, Node: Completion, Next: Interactive objects, Prev: Cross-referencing, Up: Common functionality
5.3 Auto-completion
===================
Completion commands are used to complete a symbol or form based on what
is already present at point. Emacs has many completion mechanisms that
SLY tries to mimic as much as possible.
SLY provides two styles of completion. The choice between them
happens in the Emacs customization variable *note
sly-complete-symbol-function::, which can be set to two values, or
methods:
1. 'sly-flex-completions' This method is speculative. It assumes that
the letters you've already typed aren't necessarily an exact prefix
of the symbol you're thinking of. Therefore, any possible
completion that contains these letters, in the order that you have
typed them, is potentially a match. Completion matches are then
sorted according to a score that should reflect the probability
that you really meant that them.
Flex completion implies that the package-qualification needed to
access some symbols is automatically discovered for you. However,
to avoid searching too many symbols unnecessarily, this method
makes some minimal assumptions that you can override: it assumes,
for example, that you don't normally want to complete to fully
qualified internal symbols, but will do so if it finds two
consecutive colons ('::') in your initial pattern. Similarly, it
assumes that if you start a completion on a word starting ':', you
must mean a keyword (a symbol from the keyword package.)
Here are the top results for some typical searches.
CL-USER> (quiloa<TAB>) -> (ql:quickload)
CL-USER> (mvbind<TAB>) -> (multiple-value-bind)
CL-USER> (scan<TAB>) -> (ppcre:scan)
CL-USER> (p::scan<TAB>) -> (ppcre::scanner)
CL-USER> (setf locadirs<TAB>) -> (setf ql:*local-project-directories*)
CL-USER> foobar -> asdf:monolithic-binary-op
2. 'sly-simple-completions' This method uses "classical" completion on
an exact prefix. Although poorer, this is simpler, more
predictable and closer to the default Emacs completion method. You
type a prefix for a symbol reference and SLY let's you choose from
symbols whose beginnings match it exactly.
As an enhancement in SLY over Emacs' built-in completion styles, when
the '*sly-completions*' buffer pops up, some keybindings are momentarily
diverted to it:
'C-n'
'<down>'
'M-x sly-next-completion'
Select the next completion.
'C-p'
'<up>'
'M-x sly-prev-completion'
Select the previous completion.
'tab'
'RET'
'M-x sly-choose-completion'
Choose the currently selected completion and enter it at point.
As soon as the user selects a completion or gives up by pressing
'C-g' or moves out of the symbol being completed, the
'*sly-completions*' buffer is closed.
File: sly.info, Node: Interactive objects, Next: Documentation, Prev: Completion, Up: Common functionality
5.4 Interactive objects
=======================
In many buffers and modes in SLY, there are snippets of text that
represent objects "living" in the Lisp process connected to SLY. These
regions are known in SLY as interactive values or objects. You can tell
these objects from regular text by their distinct "face", is Emacs
parlance for text colour, or decoration. Another way to check if bit of
text is an interactive object is to hover above it with the mouse and
right-click ('<mouse-3>') it: a context menu will appear listing actions
that you can take on that object.
Depending on the mode, different actions may be active for different
types of objects. Actions can also be invoked using keybindings active
only when the cursor is on the button.
'M-RET, ``Copy to REPL'''
Copy the object to the main REPL (*note REPL output:: and *note
REPL backreferences::).
'M-S-RET, ``Copy call to REPL'''
An experimental feature. On some backtrace frames in the Debugger
(*note Debugger::) and Trace Dialog (*note Trace Dialog::), copy
the object to the main REPL. That’s _meta-shift-return_, by the
way, there’s no capital "S".
'.,''Go To Source'''
For function symbols, debugger frames, or traced function calls, go
to the Lisp source, much like with 'M-.'.
'v,''Show Source'''
For function symbols, debugger frames, or traced function calls,
show the Lisp source in another window, but don’t switch to it.
'p,''Pretty Print'''
Pretty print the object in a separate buffer, much like
'sly-pprint-eval-last-expression'.
'i,''Inspect'''
Inspect the object in a separate inspector buffer (*note
Inspector::).
'd,''Describe'''
Describe the object in a separate buffer using Lisp’s
'CL:DESCRIBE'.
File: sly.info, Node: Documentation, Next: Multiple connections, Prev: Interactive objects, Up: Common functionality
5.5 Documentation commands
==========================
SLY's online documentation commands follow the example of Emacs Lisp.
The commands all share the common prefix 'C-c C-d' and allow the final
key to be modified or unmodified (*note Keybindings::.)
'M-x sly-info'
This command should land you in an electronic version of this very
manual that you can read inside Emacs.
'C-c C-d C-d'
'M-x sly-describe-symbol'
Describe the symbol at point.
'C-c C-d C-f'
'M-x sly-describe-function'
Describe the function at point.
'C-c C-d C-a'
'M-x sly-apropos'
Perform an apropos search on Lisp symbol names for a regular
expression match and display their documentation strings. By
default the external symbols of all packages are searched. With a
prefix argument you can choose a specific package and whether to
include unexported symbols.
'C-c C-d C-z'
'M-x sly-apropos-all'
Like 'sly-apropos' but also includes internal symbols by default.
'C-c C-d C-p'
'M-x sly-apropos-package'
Show apropos results of all symbols in a package. This command is
for browsing a package at a high-level. With package-name
completion it also serves as a rudimentary Smalltalk-ish
image-browser.
'C-c C-d C-h'
'M-x sly-hyperspec-lookup'
Lookup the symbol at point in the 'Common Lisp Hyperspec'. This
uses the familiar 'hyperspec.el' to show the appropriate section in
a web browser. The Hyperspec is found either on the Web or in
'common-lisp-hyperspec-root', and the browser is selected by
'browse-url-browser-function'.
Note: this is one case where 'C-c C-d h' is _not_ the same as 'C-c
C-d C-h'.
'C-c C-d ~'
'M-x hyperspec-lookup-format'
Lookup a _format character_ in the 'Common Lisp Hyperspec'.
'C-c C-d #'
'M-x hyperspec-lookup-reader-macro'
Lookup a _reader macro_ in the 'Common Lisp Hyperspec'.
File: sly.info, Node: Multiple connections, Next: Disassembly, Prev: Documentation, Up: Common functionality
5.6 Multiple connections
========================
SLY is able to connect to multiple Lisp processes at the same time. The
'M-x sly' command, when invoked with a prefix argument, will offer to
create an additional Lisp process if one is already running. This is
often convenient, but it requires some understanding to make sure that
your SLY commands execute in the Lisp that you expect them to.
Some SLY buffers are tied to specific Lisp processes. It’s easy read
that from the buffer’s name which will usually be '*sly-<something> for
<connection>*', where 'connection' is the name of the connection.
Each Lisp connection has its own main REPL buffer (*note REPL::), and
all expressions entered or SLY commands invoked in that buffer are sent
to the associated connection. Other buffers created by SLY are
similarly tied to the connections they originate from, including SLY-DB
buffers (*note Debugger::), apropos result listings, and so on. These
buffers are the result of some interaction with a Lisp process, so
commands in them always go back to that same process.
Commands executed in other places, such as 'sly-mode' source buffers,
always use the "default" connection. Usually this is the most recently
established connection, but this can be reassigned via the "connection
list" buffer:
'C-c C-x c'
'M-x sly-list-connections'
Pop up a buffer listing the established connections.
'C-c C-x n'
'M-x sly-next-connection'
Switch to the next Lisp connection by cycling through all
connections.
'C-c C-x p'
'M-x sly-prev-connection'
Switch to the previous Lisp connection by cycling through all
connections.
The buffer displayed by 'sly-list-connections' gives a one-line
summary of each connection. The summary shows the connection's serial
number, the name of the Lisp implementation, and other details of the
Lisp process. The current "default" connection is indicated with an
asterisk.
The commands available in the connection-list buffer are:
'RET'
'M-x sly-goto-connection'
Pop to the REPL buffer of the connection at point.
'd'
'M-x sly-connection-list-make-default'
Make the connection at point the "default" connection. It will
then be used for commands in 'sly-mode' source buffers.
'g'
'M-x sly-update-connection-list'
Update the connection list in the buffer.
'q'
'M-x sly-temp-buffer-quit'
Quit the connection list (kill buffer, restore window
configuration).
'R'
'M-x sly-restart-connection-at-point'
Restart the Lisp process for the connection at point.
'M-x sly-connect'
Connect to a running Slynk server. With prefix argument, asks if
all connections should be closed first.
'M-x sly-disconnect'
Disconnect all connections.
'M-x sly-abort-connection'
Abort the current attempt to connect.
File: sly.info, Node: Disassembly, Next: Recovery, Prev: Multiple connections, Up: Common functionality
5.7 Disassembly commands
========================
'C-c M-d'
'M-x sly-disassemble-symbol'
Disassemble the function definition of the symbol at point.
'C-c C-t'
'M-x sly-toggle-trace-fdefinition'
Toggle tracing of the function at point. If invoked with a prefix
argument, read additional information, like which particular method
should be traced.
'M-x sly-untrace-all'
Untrace all functions.
File: sly.info, Node: Recovery, Next: Temporary buffers, Prev: Disassembly, Up: Common functionality
5.8 Abort/Recovery commands
===========================
'C-c C-b'
'M-x sly-interrupt'
Interrupt Lisp (send 'SIGINT').
'M-x sly-restart-inferior-lisp'
Restart the 'inferior-lisp' process.
'C-c ~'
'M-x sly-mrepl-sync'
Synchronize the current package and working directory from Emacs to
Lisp.
'M-x sly-cd'
Set the current directory of the Lisp process. This also changes
the current directory of the REPL buffer.
'M-x sly-pwd'
Print the current directory of the Lisp process.
File: sly.info, Node: Temporary buffers, Next: Multi-threading, Prev: Recovery, Up: Common functionality
5.9 Temporary buffers
=====================
Some SLY commands create temporary buffers to display their results.
Although these buffers usually have their own special-purpose
major-modes, certain conventions are observed throughout.
Temporary buffers can be dismissed by pressing 'q'. This kills the
buffer and restores the window configuration as it was before the buffer
was displayed. Temporary buffers can also be killed with the usual
commands like 'kill-buffer', in which case the previous window
configuration won't be restored.
Pressing 'RET' is supposed to "do the most obvious useful thing."
For instance, in an apropos buffer this prints a full description of the
symbol at point, and in an XREF buffer it displays the source code for
the reference at point. This convention is inherited from Emacs's own
buffers for apropos listings, compilation results, etc.
Temporary buffers containing Lisp symbols use 'sly-mode' in addition
to any special mode of their own. This makes the usual SLY commands
available for describing symbols, looking up function definitions, and
so on.
Initial focus of those "description" buffers depends on the variable
'sly-description-autofocus'. If 'nil' (the default), description
buffers do not receive focus automatically, and vice versa.
File: sly.info, Node: Multi-threading, Prev: Temporary buffers, Up: Common functionality
5.10 Multi-threading
====================
If the Lisp system supports multi-threading, SLY spawns a new thread for
each request, e.g., 'C-x C-e' creates a new thread to evaluate the
expression. An exception to this rule are requests from the REPL: all
commands entered in the REPL buffer are evaluated in a dedicated REPL
thread.
You can see a listing of the threads for the current connection with
the command 'M-x sly-list-threads', or 'C-c C-x t'. This pops open a
'*sly-threads*' buffer, where some keybindings to control threads are
active, if you know what you are doing. The most useful is probably 'k'
to kill a thread, but type 'C-h m' in that buffer to get a full listing.
Some complications arise with multi-threading and special variables.
Non-global special bindings are thread-local, e.g., changing the value
of a let bound special variable in one thread has no effect on the
binding of the variables with the same name in other threads. This
makes it sometimes difficult to change the printer or reader behaviour
for new threads. The variable 'slynk:*default-worker-thread-bindings*'
was introduced for such situations: instead of modifying the global
value of a variable, add a binding the
'slynk:*default-worker-thread-bindings*'. E.g., with the following
code, new threads will read floating point values as doubles by default:
(push '(*read-default-float-format* . double-float)
slynk:*default-worker-thread-bindings*).
File: sly.info, Node: The REPL and other special buffers, Next: Customization, Prev: Common functionality, Up: Top
6 The REPL and other special buffers
************************************
* Menu:
* REPL::
* Inspector::
* Debugger::
* Trace Dialog::
* Stickers::
File: sly.info, Node: REPL, Next: Inspector, Up: The REPL and other special buffers
6.1 The REPL: the "top level"
=============================
SLY uses a custom Read-Eval-Print Loop (REPL, also known as a "top
level", or listener):
* Conditions signalled in REPL expressions are debugged with the
integrated SLY debugger.
* Return values are interactive values (*note Interactive objects::)
distinguished from printed output by separate Emacs faces (colors).
* Output from the Lisp process is inserted in the right place, and
doesn't get mixed up with user input.
* Multiple REPLs are possible in the same Lisp connection. This is
useful for performing quick one-off experiments in different
packages or directories without disturbing the state of an existing
REPL.
* The REPL is a central hub for much of SLY's functionality, since
objects examined in the inspector (*note Inspector::), debugger
(*note Debugger::), and other extensions can be returned there.
Switching to the REPL from anywhere in a SLY buffer is a very common
task. One way to do it is to find the '*sly-mrepl...*' buffer in
Emacs’s buffer list, but there are other ways to reach a REPL.
'C-c C-z'
'M-x sly-mrepl'
Start or select an existing main REPL buffer.
'M-x sly-mrepl-new'
Start a new secondary REPL session, prompting for a nickname.
'C-c ~'
'M-x sly-mrepl-sync'
Go to the REPL, switching package and default directory as
applicable. More precisely the Lisp variables '*package*' and
'*default-pathname-defaults*' are affected by the location where
the command was issued. In a specific position of a '.lisp' file,
for instance the current package and that file’s directory are
chosen.
* Menu:
* REPL commands::
* REPL output::
* REPL backreferences::
File: sly.info, Node: REPL commands, Next: REPL output, Up: REPL
6.1.1 REPL commands
-------------------
'RET'
'M-x sly-mrepl-return'
Evaluate the expression at prompt and return the result.
'TAB'
'M-x sly-mrepl-indent-and-complete-symbol'
Indent the current line. If line already indented complete the
symbol at point (*note Completion::). If there is not symbol at
point show the argument list of the most recently enclosed function
or macro in the minibuffer.
'M-p'
'M-x sly-mrepl-previous-input-or-button'
When at the current prompt, fetches previous input from the
history, otherwise jumps to the previous interactive value (*note
Interactive objects::) representing a Lisp object.
'M-n'
'M-x sly-mrepl-next-input-or-button'
When at the current prompt, fetches next input from the history,
otherwise jumps to the previous interactive value representing a
Lisp object.
'C-r'
'M-x isearch-backward'
This regular Emacs keybinding, when invoked at the current REPL
prompt, starts a special transient mode turning the prompt into the
string "History-isearch backward". While in this mode, the user
can compose a string used to search backwards through history, and
reverse the direction of search by pressing 'C-s'. When invoked
outside the current REPL prompt, does a normal text search through
the buffer contents.
'C-c C-b'
'M-x sly-interrupt'
Interrupts the current thread of the inferior-lisp process.
For convenience this function is also bound to 'C-c C-c'.
'C-M-p'
'M-x sly-button-backward'
Jump to the previous interactive value representing a Lisp object.
'C-M-n'
'M-x sly-button-forward'
Jump to the next interactive value representing a Lisp object.
'C-c C-o'
'M-x sly-mrepl-clear-recent-output'
Clear output between current and last REPL prompts, keeping
results.
'C-c M-o'
'M-x sly-mrepl-clear-repl'
Clear the whole REPL of output and results.
File: sly.info, Node: REPL output, Next: REPL backreferences, Prev: REPL commands, Up: REPL
6.1.2 REPL output
-----------------
REPLs wouldn’t be much use if they just took user input and didn’t print
anything back. In SLY the output printed to the REPL can come from four
different places:
* A function’s return values. One line per return value is printed.
Each line of printed text, called a REPL result, persists after
more expressions are evaluated, and is actually a button (*note
Interactive objects::) presenting the Lisp-side object. You can,
for instance, inspect it (*note Inspector::) or re-return it to
right before the current command prompt so that you may conjure it
up again, as usual in Lisp REPLs, with the special variable '*'.
In the SLY REPL, in addition to the '*', '**' and '***' special
variables, return values can also be accessed through a special
backreference (*note REPL backreferences::).
* An object may be copied to the REPL from some other part in SLY,
such as the Inspector (*note Inspector::), Debugger (*note
Debugger::), etc. using the familiar 'M-RET' binding, or by
selecting "Copy to REPL" from the context menu of an interactive
object. Aside from not having been produced by the evaluation of a
Lisp form in the REPL, these objects behaves exactly like a REPL
result.
* The characters printed to the standard Lisp streams
'*standard-output*', '*error-output*' and '*trace-output*' as a
_synchronous_ and direct result of the evaluation of an expression
in the REPL.
* The characters printed to the standard Lisp streams
'*standard-output*', '*error-output*' and '*trace-output*' printed,
perhaps _asynchronously_, from others threads, for instance. This
feature is optional and controlled by the variable
'SLYNK:*GLOBALLY-REDIRECT-IO*'.
For advanced users, there are some Lisp-side Slynk variables affecting
the way Slynk transmits REPL output to SLY.
'SLYNK:*GLOBALLY-REDIRECT-IO*'
This variable controls the global redirection of the the standard
streams ('*standard-output*', etc) to the REPL in Emacs. The
default value is ':started-from-emacs', which means that
redirection should only take place upon 'M-x sly' invocations.
When 't', global redirection happens even for sessions started with
'M-x sly-connect', meaning output may be diverted from wherever you
started the Lisp server originally.
When 'NIL' these streams are only temporarily redirected to Emacs
using dynamic bindings while handling requests, meaning you only
see output caused by the commands you issued to the REPL.
Note that '*standard-input*' is currently never globally redirected
into Emacs, because it can interact badly with the Lisp's native
REPL by having it try to read from the Emacs one.
Also note that secondary REPLs (those started with 'sly-mrepl-new')
don’t receive any redirected output.
'SLYNK:*USE-DEDICATED-OUTPUT-STREAM*'
This variable controls whether to use a separate socket solely for
Lisp to send printed output to Emacs through, which is more
efficient than sending the output in protocol messages to Emacs.
The default value is ':started-from-emacs', which means that the
socket should only be established upon 'M-x sly' invocations. When
't', it's established even for sessions started with 'M-x
sly-connect'. When 'NIL' usual protocol messages are used for
sending input to the REPL.
Notice that using a dedicated output stream makes it more difficult
to communicate to a Lisp running on a remote host via SSH (*note
Connecting to a remote Lisp::). If you connect via 'M-x
sly-connect', the default ':started-from-emacs' value should ensure
this isn't a problem.
'SLYNK:*DEDICATED-OUTPUT-STREAM-PORT*'
When '*USE-DEDICATED-OUTPUT-STREAM*' is 't' the stream will be
opened on this port. The default value, '0', means that the stream
will be opened on some random port.
'SLYNK:*DEDICATED-OUTPUT-STREAM-BUFFERING*'
For efficiency, some Lisps backends wait until a certain conditions
are met in a Lisp character stream before flushing that stream’s
contents, thus sending it to the SLY REPL. Be advised that this
sometimes works poorly on some implementations, so it’s probably
best to leave alone. Possible values are 'nil' (no buffering), 't'
(enable buffering) or ':line' (enable buffering on EOL)
File: sly.info, Node: REPL backreferences, Prev: REPL output, Up: REPL
6.1.3 REPL backreferences
-------------------------
In a regular Lisp REPL, the objects produced by evaluating expressions
at the command prompt can usually be referenced in future commands using
the special variables '*', '**' and '***'. This is also true of the SLY
REPL, but it also provides a different way to re-conjure these objects
through a special Lisp reader macro character available only in the
REPL. The macro character, which is '#v' by default takes, in a terse
syntax, two indexes specifying the precise objects in all of the SLY
REPL’s recorded history.
Consider this fragment of a REPL session:
; Cleared REPL history
CL-USER> (values 'a 'b 'c)
A
B
C
CL-USER> (list #v0)
(A)
CL-USER> (list #v0:1 #v0:2)
(B C)
CL-USER> (append #v1:0 #v2:0)
(A B C)
CL-USER>
Admittedly, while useful, this doesn’t seem terribly easy to use at
first sight. There are a couple of reasons, however, that should make
it worth considering:
* Backreference annotation and highlighting
As soon as the SLY REPL detects that you have pressed '#v', all the
REPL results that can possibly be referenced are temporarily
annotated on their left with two special numbers. These numbers
are in the syntax accepted by the '#v' macro-character, namely
'#vENTRY-IDX:VALUE-IDX'.
Furthermore, as soon as you type a number for 'ENTRY-IDX', only
that entries values remain highlighted. Then, as you finish the
entry with 'VALUE-IDX', only that exact object remains highlighted.
If you make a mistake (say, by typing a letter or an invalid
number) while composing '#v' syntax, SLY lets you know by painting
the backreference red.
Highlighting also happens when you place the cursor over existing
valid '#v' expressions.
* Returning functions calls
An experimental feature in SLY allows copying _function calls_ to
the REPL from the Debugger (*note Debugger::) and the Trace Dialog
(*note Trace Dialog::). In those buffers, pressing keybinding
'M-S-RET' over objects that represent function calls will copy the
_call_, and not the object, to the REPL. This works by first
copying over the argument objects in order to the REPL results, and
then composing an input line that includes the called function's
name and backreferences to those arguments (*note REPL
backreferences::).
Naturally, this call isn't _exactly_ the same because it doesn’t
evaluate in the same dynamic environment as the original one. But
it's a useful debug technique because backreferences are stable
(1), so repeating that very same function call with the very same
arguments is just a matter of textually copying the previous
expression into the command prompt, no matter how far ago it
happened. And that, in turn, is as easy as using 'C-r' and some
characters (*note REPL commands::) to arrive and repeat the desired
REPL history entry.
---------- Footnotes ----------
(1) until you clear the REPL’s output, that is
File: sly.info, Node: Inspector, Next: Debugger, Prev: REPL, Up: The REPL and other special buffers
6.2 The Inspector
=================
The SLY inspector is a Emacs-based alternative to the standard 'INSPECT'
function. The inspector presents objects in Emacs buffers using a
combination of plain text, hyperlinks to related objects.
The inspector can easily be specialized for the objects in your own
programs. For details see the 'inspect-for-emacs' generic function in
'slynk-backend.lisp'.
'C-c I'
'M-x sly-inspect'
Inspect the value of an expression entered in the minibuffer.
The standard commands available in the inspector are:
'RET'
'M-x sly-inspector-operate-on-point'
If point is on a value then recursively call the inspector on that
value. If point is on an action then call that action.
'D'
'M-x sly-inspector-describe-inspectee'
Describe the slot at point.
'e'
'M-x sly-inspector-eval'
Evaluate an expression in the context of the inspected object. The
variable '*' will be bound to the inspected object.
'v'
'M-x sly-inspector-toggle-verbose'
Toggle between verbose and terse mode. Default is determined by
'slynk:*inspector-verbose*'.
'l'
'M-x sly-inspector-pop'
Go back to the previous object (return from 'RET').
'n'
'M-x sly-inspector-next'
The inverse of 'l'. Also bound to 'SPC'.
'g'
'M-x sly-inspector-reinspect'
Reinspect.
'h'
'M-x sly-inspector-history'
Show the previously inspected objects.
'q'
'M-x sly-inspector-quit'
Dismiss the inspector buffer.
'>'
'M-x sly-inspector-fetch-all'
Fetch all inspector contents and go to the end.
'M-RET'
'M-x sly-mrepl-copy-part-to-repl'
Store the value under point in the variable '*'. This can then be
used to access the object in the REPL.
'TAB, M-x forward-button'
'S-TAB, M-x backward-button'
Jump to the next and previous inspectable object respectively.
File: sly.info, Node: Debugger, Next: Trace Dialog, Prev: Inspector, Up: The REPL and other special buffers
6.3 The SLY-DB Debugger
=======================
SLY has a custom Emacs-based debugger called SLY-DB. Conditions
signalled in the Lisp system invoke SLY-DB in Emacs by way of the Lisp
'*DEBUGGER-HOOK*'.
SLY-DB pops up a buffer when a condition is signalled. The buffer
displays a description of the condition, a list of restarts, and a
backtrace. Commands are offered for invoking restarts, examining the
backtrace, and poking around in stack frames.
* Menu:
* Examining frames::
* Restarts::
* Frame Navigation::
* Miscellaneous::
File: sly.info, Node: Examining frames, Next: Restarts, Up: Debugger
6.3.1 Examining frames
----------------------
Commands for examining the stack frame at point.
't'
'M-x sly-db-toggle-details'
Toggle display of local variables and 'CATCH' tags.
'v'
'M-x sly-db-show-frame-source'
View the frame's current source expression. The expression is
presented in the Lisp source file's buffer.
'e'
'M-x sly-db-eval-in-frame'
Evaluate an expression in the frame. The expression can refer to
the available local variables in the frame.
'd'
'M-x sly-db-pprint-eval-in-frame'
Evaluate an expression in the frame and pretty-print the result in
a temporary buffer.
'D'
'M-x sly-db-disassemble'
Disassemble the frame's function. Includes information such as the
instruction pointer within the frame.
'i'
'M-x sly-db-inspect-in-frame'
Inspect the result of evaluating an expression in the frame.
'C-c C-c'
'M-x sly-db-recompile-frame-source'
Recompile frame. 'C-u C-c C-c' for recompiling with maximum debug
settings.
File: sly.info, Node: Restarts, Next: Frame Navigation, Prev: Examining frames, Up: Debugger
6.3.2 Invoking restarts
-----------------------
'a'
'M-x sly-db-abort'
Invoke the 'ABORT' restart.
'q'
'M-x sly-db-quit'
"Quit" - For SLY evaluation requests, invoke a restart which
restores to a known program state. For errors in other threads,
*Note *SLY-DB-QUIT-RESTART*::.
'c'
'M-x sly-db-continue'
Invoke the 'CONTINUE' restart.
'0 ... 9'
'M-x sly-db-invoke-restart-n'
Invoke a restart by number.
Restarts can also be invoked by pressing 'RET' or 'Mouse-2' on them
in the buffer.
File: sly.info, Node: Frame Navigation, Next: Miscellaneous, Prev: Restarts, Up: Debugger
6.3.3 Navigating between frames
-------------------------------
'n, M-x sly-db-down'
'p, M-x sly-db-up'
Move between frames.
'M-n, M-x sly-db-details-down'
'M-p, M-x sly-db-details-up'
Move between frames "with sugar": hide the details of the original
frame and display the details and source code of the next. Sugared
motion makes you see the details and source code for the current
frame only.
'>'
'M-x sly-db-end-of-backtrace'
Fetch the entire backtrace and go to the last frame.
'<'
'M-x sly-db-beginning-of-backtrace'
Go to the first frame.
File: sly.info, Node: Miscellaneous, Prev: Frame Navigation, Up: Debugger
6.3.4 Miscellaneous Commands
----------------------------
'r'
'M-x sly-db-restart-frame'
Restart execution of the frame with the same arguments it was
originally called with. (This command is not available in all
implementations.)
'R'
'M-x sly-db-return-from-frame'
Return from the frame with a value entered in the minibuffer.
(This command is not available in all implementations.)
'B'
'M-x sly-db-break-with-default-debugger'
Exit SLY-DB and debug the condition using the Lisp system's default
debugger.
'C'
'M-x sly-db-inspect-condition'
Inspect the condition currently being debugged.
':'
'M-x sly-interactive-eval'
Evaluate an expression entered in the minibuffer.
'A'
'M-x sly-db-break-with-system-debugger'
Attach debugger (e.g. gdb) to the current lisp process.
File: sly.info, Node: Trace Dialog, Next: Stickers, Prev: Debugger, Up: The REPL and other special buffers
6.4 Trace Dialog
================
The SLY Trace Dialog, in package 'sly-trace-dialog', is a tracing
facility, similar to Common Lisp's 'trace', but interactive rather than
purely textual.
You use it just like you would regular 'trace': after tracing a
function, calling it causes interesting information about that
particular call to be reported.
However, instead of printing the trace results to the the
'*trace-output*' stream (usually the REPL), the SLY Trace Dialog
collects and stores them in your Lisp environment until, on user's
request, they are fetched into Emacs and displayed in a dialog-like
interactive view.
After starting up SLY, SLY's Trace Dialog installs a _Trace_ menu in
the menu-bar of any 'sly-mode' buffer and adds two new commands, with
respective key-bindings:
'C-c C-t'
'M-x sly-trace-dialog-toggle-trace'
If point is on a symbol name, toggle tracing of its function
definition. If point is not on a symbol, prompt user for a
function.
With a 'C-u' prefix argument, and if your lisp implementation
allows it, attempt to decipher lambdas, methods and other
complicated function signatures.
The function is traced for the SLY Trace Dialog only, i.e. it is
not found in the list returned by Common Lisp's 'trace'.
'C-c T'
'M-x sly-trace-dialog'
Pop to the interactive Trace Dialog buffer associated with the
current connection (*note Multiple connections::).
Consider the (useless) program:
(defun foo (n) (if (plusp n) (* n (bar (1- n))) 1))
(defun bar (n) (if (plusp n) (* n (foo (1- n))) 1))
After tracing both 'foo' and 'bar' with 'C-c M-t', calling call '(foo
2)' and moving to the trace dialog with 'C-c T', we are presented with
this buffer.
Traced specs (2) [refresh]
[untrace all]
[untrace] common-lisp-user::bar
[untrace] common-lisp-user::foo
Trace collection status (3/3) [refresh]
[clear]
0 - common-lisp-user::foo
| > 2
| < 2
1 `--- common-lisp-user::bar
| > 1
| < 1
2 `-- common-lisp-user::foo
> 0
< 1
The dialog is divided into sections displaying the functions already
traced, the trace collection progress and the actual trace tree that
follow your program's logic. The most important key-bindings in this
buffer are:
'g'
'M-x sly-trace-dialog-fetch-status'
Update information on the trace collection and traced specs.
'G'
'M-x sly-trace-dialog-fetch-traces'
Fetch the next batch of outstanding (not fetched yet) traces. With
a 'C-u' prefix argument, repeat until no more outstanding traces.
'C-k'
'M-x sly-trace-dialog-clear-fetched-traces'
Prompt for confirmation, then clear all traces, both fetched and
outstanding.
The arguments and return values below each entry are interactive
buttons. Clicking them opens the inspector (*note Inspector::).
Invoking 'M-RET' ('sly-trace-dialog-copy-down-to-repl') returns them to
the REPL for manipulation (*note REPL::). The number left of each entry
indicates its absolute position in the calling order, which might differ
from display order in case multiple threads call the same traced
function.
'sly-trace-dialog-hide-details-mode' hides arguments and return
values so you can concentrate on the calling logic. Additionally,
'sly-trace-dialog-autofollow-mode' will automatically display additional
detail about an entry when the cursor moves over it.
File: sly.info, Node: Stickers, Prev: Trace Dialog, Up: The REPL and other special buffers
6.5 Stickers
============
SLY Stickers, implemented as the 'sly-stickers' contrib (*note
Extensions::), is a tool for "live" code annotations. It's an
alternative to the 'print' or 'break' statements you add to your code
when debugging.
Contrary to these techniques, "stickers" are non-intrusive, meaning
that saving your file doesn't save your debug code along with it.
Here's the general workflow:
* In Lisp source files, using 'C-c C-s C-s' or 'M-x
sly-stickers-dwim' places a sticker on any Lisp form. Stickers can
exist inside other stickers.
�[image src="images/stickers-1-placed-stickers.png"�]
* Stickers are "armed" when a definition or a file is compiled with
the familiar 'C-c C-c' ('M-x sly-compile-defun') or 'C-c C-k' ('M-x
sly-compile-file') commands. An armed sticker changes color from
the default grey background to a blue background.
�[image src="images/stickers-2-armed-stickers.png"�]
From this point on, when the Lisp code is executed, the results of
evaluating the underlying forms are captured in the Lisp side. Stickers
help you examine your program's behaviour in three ways:
1. 'C-c C-s C-r' (or 'M-x sly-stickers-replay') interactively walks
the user through recordings in the order that they occurred. In
the created '*sly-stickers-replay*' buffer, type 'h' for a list of
keybindings active in that buffer.
�[image src="images/stickers-3-replay-stickers.png"�]
2. To step through stickers as your code is executed, ensure that
"breaking stickers" are enabled via 'M-x
sly-stickers-toggle-break-on-stickers'. Whenever a sticker-covered
expression is reached, the debugger comes up with useful restarts
and interactive for the values produced. You can tweak this
behaviour by setting the Lisp-side variable
'SLYNK-STICKERS:*BREAK-ON-STICKERS*' to a list with the elements
':before' and ':after', making SLY break before a sticker, after
it, or both.
�[image src="images/stickers-4-breaking-stickers.png"�]
3. 'C-c C-s S' ('M-x sly-stickers-fetch') populates the sticker
overlay with the latest captured results, called "recordings". If
a sticker has captured any recordings, it will turn green,
otherwise it will turn red. A sticker whose Lisp expression has
caused a non-local exit, will be also be marked with a special
face.
�[image src="images/stickers-5-fetch-recordings.png"�]
At any point, stickers can be removed with the same
'sly-stickers-dwim' keybinding, by placing the cursor at the beginning
of a sticker. Additionally adding prefix arguments to
'sly-stickers-dwim' increase its scope, so 'C-u C-c C-s C-s' will remove
all stickers from the current function and 'C-u C-u C-c C-s C-s' will
remove all stickers from the current file.
Stickers can be nested inside other stickers, so it is possible to
record the value of an expression inside another expression which is
also annotated.
Stickers are interactive parts just like any other part in SLY that
represents Lisp-side objects, so they can be inspected and returned to
the REPL, for example. To move through the stickers with the keyboard
use the existing keybindings to move through compilation notes ('M-p'
and 'M-n') or use 'C-c C-s p' and 'C-c C-s n'
('sly-stickers-prev-sticker' and 'sly-stickers-next-sticker').
There are some caveats when using SLY Stickers:
* Stickers on unevaluated forms (such as 'let' variable bindings, or
other constructs) are rejected, though the function is still
compiled as usual. To let the user know about this, these stickers
remain grey, and are marked as "disarmed". A message also appears
in the echo area.
* Stickers placed on expressions inside backquoted expressions in
macros are always armed, even though they may come to provoke a
runtime error when the macro's expansion is run. Think of this
when setting a sticker inside a macro definition.
File: sly.info, Node: Customization, Next: Tips and Tricks, Prev: The REPL and other special buffers, Up: Top
7 Customization
***************
* Menu:
* Emacs-side::
* Lisp-side customization::
File: sly.info, Node: Emacs-side, Next: Lisp-side customization, Up: Customization
7.1 Emacs-side
==============
* Menu:
* Keybindings::
* Keymaps::
* Defcustom variables::
* Hooks::
File: sly.info, Node: Keybindings, Next: Keymaps, Up: Emacs-side
7.1.1 Keybindings
-----------------
In general we try to make our key bindings fit with the overall Emacs
style.
We never bind 'C-h' anywhere in a key sequence. This is because
Emacs has a built-in default so that typing a prefix followed by 'C-h'
will display all bindings starting with that prefix, so 'C-c C-d C-h'
will actually list the bindings for all documentation commands. This
feature is just a bit too useful to clobber!
"Are you deliberately spiting Emacs's brilliant online help
facilities? The gods will be angry!"
This is a brilliant piece of advice. The Emacs online help facilities
are your most immediate, up-to-date and complete resource for keybinding
information. They are your friends:
'C-h k <key>'
'describe-key' "What does this key do?"
Describes current function bound to '<key>' for focus buffer.
'C-h b'
'describe-bindings' "Exactly what bindings are available?"
Lists the current key-bindings for the focus buffer.
'C-h m'
'describe-mode' "Tell me all about this mode"
Shows all the available major mode keys, then the minor mode keys,
for the modes of the focus buffer.
'C-h l'
'view-lossage' "Woah, what key chord did I just do?"
Shows you the literal sequence of keys you've pressed in order.
For example, you can add one of the following to your Emacs init file
(usually '~/.emacs' or '~/.emacs.d/init.el', but *note Init File:
(emacs)Init File.).
(eval-after-load 'sly
`(define-key sly-prefix-map (kbd "M-h") 'sly-documentation-lookup))
SLY comes bundled with many extensions (called "contribs" for
historical reasons, *note Extensions::) which you can customize just
like SLY's code. To make 'C-c C-c' clear the last REPL prompt's output,
for example, use
(eval-after-load 'sly-mrepl
`(define-key sly-mrepl-mode-map (kbd "C-c C-k")
'sly-mrepl-clear-recent-output))
File: sly.info, Node: Keymaps, Next: Defcustom variables, Prev: Keybindings, Up: Emacs-side
7.1.2 Keymaps
-------------
Emacs’s keybindings "live" in keymap variables. To customize a
particular binding and keep it from trampling on other important keys
you should do it in one of SLY's keymaps. The following non-exhaustive
list of SLY-related keymaps is just a reference: the manual will go over
each associated functionality in detail.
'sly-doc-map'
Keymap for documentation commands (*note Documentation::) in
SLY-related buffers, accessible by the 'C-c C-d' prefix.
'sly-who-map'
Keymap for cross-referencing ("who-calls") commands (*note
Cross-referencing::) in SLY-related buffers, accessible by the 'C-c
C-w' prefix.
'sly-selector-map'
A keymap for SLY-related functionality that should be available in
globally in all Emacs buffers (not just SLY-related buffers).
'sly-mode-map'
A keymap for functionality available in all SLY-related buffers.
'sly-editing-mode-map'
A keymap for SLY functionality available in Lisp source files.
'sly-popup-buffer-mode-map'
A keymap for functionality available in the temporary "popup"
buffers that SLY displays (*note Temporary buffers::)
'sly-apropos-mode-map'
A keymap for functionality available in the temporary SLY "apropos"
buffers (*note Documentation::).
'sly-xref-mode-map'
A keymap for functionality available in the temporary 'xref'
buffers used by cross-referencing commands (*note
Cross-referencing::).
'sly-macroexpansion-minor-mode-map'
A keymap for functionality available in the temporary buffers used
for macroexpansion presentation (*note Macro-expansion::).
'sly-db-mode-map'
A keymap for functionality available in the debugger buffers used
to debug errors in the Lisp process (*note Debugger::).
'sly-thread-control-mode-map'
A keymap for functionality available in the SLY buffers dedicated
to controlling Lisp threads (*note Multi-threading::).
'sly-connection-list-mode-map'
A keymap for functionality available in the SLY buffers dedicated
to managing multiple Lisp connections (*note Multiple
connections::).
'sly-inspector-mode-map'
A keymap for functionality available in the SLY buffers dedicated
to inspecting Lisp objects (*note Inspector::).
'sly-mrepl-mode-map'
A keymap for functionality available in SLY’s REPL buffers (*note
REPL::).
'sly-trace-dialog-mode-map'
A keymap for functionality available in SLY’s "Trace Dialog"
buffers (*note Trace Dialog::).
File: sly.info, Node: Defcustom variables, Next: Hooks, Prev: Keymaps, Up: Emacs-side
7.1.3 Defcustom variables
-------------------------
The Emacs part of SLY can be configured with the Emacs 'customize'
system, just use 'M-x customize-group sly RET'. Because the customize
system is self-describing, we only cover a few important or obscure
configuration options here in the manual.
'sly-truncate-lines'
The value to use for 'truncate-lines' in line-by-line summary
buffers popped up by SLY. This is 't' by default, which ensures
that lines do not wrap in backtraces, apropos listings, and so on.
It can however cause information to spill off the screen.
'sly-complete-symbol-function'
The function to use for completion of Lisp symbols. Two completion
styles are available: 'sly-simple-completions' and
'sly-flex-completions' (*note Completion::).
'sly-filename-translations'
This variable controls filename translation between Emacs and the
Lisp system. It is useful if you run Emacs and Lisp on separate
machines which don't share a common file system or if they share
the filesystem but have different layouts, as is the case with
SMB-based file sharing.
'sly-net-coding-system'
If you want to transmit Unicode characters between Emacs and the
Lisp system, you should customize this variable. E.g., if you use
SBCL, you can set:
(setq sly-net-coding-system 'utf-8-unix)
To actually display Unicode characters you also need appropriate
fonts, otherwise the characters will be rendered as hollow boxes.
If you are using Allegro CL and GNU Emacs, you can also use
'emacs-mule-unix' as coding system. GNU Emacs has often nicer
fonts for the latter encoding. (Different encodings can be used
for different Lisps, see *note Multiple Lisps::.)
'sly-keep-buffers-on-connection-close'
This variable holds a list of keywords indicating SLY buffer types
that should be kept around when a connection closes. For example,
if the variable's value includes ':mrepl' (which is the default),
REPL buffer is kept around while all other stale buffers (debugger,
inspector, etc..) are automatically killed.
The following customization variables affect the behaviour of the
REPL (*note REPL::):
'sly-mrepl-shortcut'
The key to use to trigger the REPL's "comma shortcut". We
recommend you keep the default setting which is the comma (',')
key, since there's special logic in the REPL to discern if you're
typing a comma inside a backquoted list or not.
'sly-mrepl-prompt-formatter'
Holds a function that can be set from your Emacs init file (*note
Init File: (emacs)Init File.) to change the way the prompt is
rendered. It takes a number of arguments describing the prompt and
should return a propertized Elisp string. See the default value,
'sly-mrepl-default-prompt', for how to implement such a prompt.
'sly-mrepl-history-file-name'
Holds a string designating the file to use for keeping the shared
REPL histories persistently. The default is to use a hidden file
named '.sly-mrepl-history' in the user's home directory.
'sly-mrepl-prevent-duplicate-history'
A symbol. If non-nil, prevent duplicate entries in input history.
If the non-nil value is the symbol 'move', the previously occuring
entry is moved to a more recent spot.
'sly-mrepl-eli-like-history-navigation'
If non-NIL, navigate history like in ELI, Franz's Common Lisp IDE
for Emacs.
File: sly.info, Node: Hooks, Prev: Defcustom variables, Up: Emacs-side
7.1.4 Hooks
-----------
'sly-mode-hook'
This hook is run each time a buffer enters 'sly-mode'. It is most
useful for setting buffer-local configuration in your Lisp source
buffers. An example use is to enable 'sly-autodoc-mode' (*note
Autodoc::).
'sly-connected-hook'
This hook is run when SLY establishes a connection to a Lisp
server. An example use is to pop to a new REPL.
'sly-db-hook'
This hook is run after SLY-DB is invoked. The hook functions are
called from the SLY-DB buffer after it is initialized. An example
use is to add 'sly-db-print-condition' to this hook, which makes
all conditions debugged with SLY-DB be recorded in the REPL buffer.
File: sly.info, Node: Lisp-side customization, Prev: Emacs-side, Up: Customization
7.2 Lisp-side (Slynk)
=====================
The Lisp server side of SLY (known as "Slynk") offers several variables
to configure. The initialization file '~/.slynk.lisp' is automatically
evaluated at startup and can be used to set these variables.
* Menu:
* Communication style::
* Other configurables::
File: sly.info, Node: Communication style, Next: Other configurables, Up: Lisp-side customization
7.2.1 Communication style
-------------------------
The most important configurable is 'SLYNK:*COMMUNICATION-STYLE*', which
specifies the mechanism by which Lisp reads and processes protocol
messages from Emacs. The choice of communication style has a global
influence on SLY's operation.
The available communication styles are:
'NIL'
This style simply loops reading input from the communication socket
and serves SLY protocol events as they arise. The simplicity means
that the Lisp cannot do any other processing while under SLY's
control.
':FD-HANDLER'
This style uses the classical Unix-style "'select()'-loop." Slynk
registers the communication socket with an event-dispatching
framework (such as 'SERVE-EVENT' in CMUCL and SBCL) and receives a
callback when data is available. In this style requests from Emacs
are only detected and processed when Lisp enters the event-loop.
This style is simple and predictable.
':SIGIO'
This style uses "signal-driven I/O" with a 'SIGIO' signal handler.
Lisp receives requests from Emacs along with a signal, causing it
to interrupt whatever it is doing to serve the request. This style
has the advantage of responsiveness, since Emacs can perform
operations in Lisp even while it is busy doing other things. It
also allows Emacs to issue requests concurrently, e.g. to send one
long-running request (like compilation) and then interrupt that
with several short requests before it completes. The disadvantages
are that it may conflict with other uses of 'SIGIO' by Lisp code,
and it may cause untold havoc by interrupting Lisp at an awkward
moment.
':SPAWN'
This style uses multiprocessing support in the Lisp system to
execute each request in a separate thread. This style has similar
properties to ':SIGIO', but it does not use signals and all
requests issued by Emacs can be executed in parallel.
The default request handling style is chosen according to the
capabilities of your Lisp system. The general order of preference is
':SPAWN', then ':SIGIO', then ':FD-HANDLER', with 'NIL' as a last
resort. You can check the default style by calling
'SLYNK-BACKEND::PREFERRED-COMMUNICATION-STYLE'. You can also override
the default by setting 'SLYNK:*COMMUNICATION-STYLE*' in your Slynk init
file (*note Lisp-side customization::).
File: sly.info, Node: Other configurables, Prev: Communication style, Up: Lisp-side customization
7.2.2 Other configurables
-------------------------
These Lisp variables can be configured via your '~/.slynk.lisp' file:
'SLYNK:*CONFIGURE-EMACS-INDENTATION*'
This variable controls whether indentation styles for
'&body'-arguments in macros are discovered and sent to Emacs. It
is enabled by default.
'SLYNK:*GLOBAL-DEBUGGER*'
When true (the default) this causes '*DEBUGGER-HOOK*' to be
globally set to 'SLYNK:SLYNK-DEBUGGER-HOOK' and thus for SLY to
handle all debugging in the Lisp image. This is for debugging
multithreaded and callback-driven applications.
'SLYNK:*SLY-DB-QUIT-RESTART*'
This variable names the restart that is invoked when pressing 'q'
(*note sly-db-quit::) in SLY-DB. For SLY evaluation requests this
is _unconditionally_ bound to a restart that returns to a safe
point. This variable is supposed to customize what 'q' does if an
application's thread lands into the debugger (see
'SLYNK:*GLOBAL-DEBUGGER*').
(setf slynk:*sly-db-quit-restart* 'sb-thread:terminate-thread)
'SLYNK:*BACKTRACE-PRINTER-BINDINGS*'
'SLYNK:*MACROEXPAND-PRINTER-BINDINGS*'
'SLYNK:*SLY-DB-PRINTER-BINDINGS*'
'SLYNK:*SLYNK-PPRINT-BINDINGS*'
These variables can be used to customize the printer in various
situations. The values of the variables are association lists of
printer variable names with the corresponding value. E.g., to
enable the pretty printer for formatting backtraces in SLY-DB, you
can use:
(push '(*print-pretty* . t) slynk:*sly-db-printer-bindings*).
The fact that most SLY output (in the REPL for instance, *note
REPL::) uses 'SLYNK:*SLYNK-PPRINT-BINDINGS*' may surprise you if
you expected it to use a global setting for, say, '*PRINT-LENGTH*'.
The rationale for this decision is that output is a very basic
feature of SLY, and it should keep operating normally even if you
(mistakenly) set absurd values for some '*PRINT-...*' variable.
You, of course, override this protection:
(setq slynk:*slynk-pprint-bindings*
(delete '*print-length*
slynk:*slynk-pprint-bindings* :key #'car))
'SLYNK:*STRING-ELISION-LENGTH*'
'SLYNK:*STRING-ELISION-LENGTH*'
This variable controls the maximum length of strings before their
pretty printed representation in the Inspector, Debugger, REPL, etc
is elided. Don't set this variable directly, create a binding for
this variable in 'SLYNK:*SLYNK-PPRINT-BINDINGS*' instead.
'SLYNK:*ECHO-NUMBER-ALIST*'
'SLYNK:*PRESENT-NUMBER-ALIST*'
These variables hold function designators used for displaying
numbers when SLY presents them in its interface.
The difference between the two functions is that
'*PRESENT-NUMBER-ALIST*', if non-nil, overrides
'*ECHO-NUMBER-ALIST*' in the context of the REPL, Trace Dialog and
Stickers (see *note REPL::, *note Trace Dialog:: and *note
Stickers::), while the latter is used for commands like 'C-x C-e'
or the inspector (see *note Evaluation::, *note Inspector::).
If in doubt, use '*ECHO-NUMBER-ALIST*'.
Both variables have the same structure: each element in the alist
takes the form '(TYPE . FUNCTIONS)', where 'TYPE' is a type
designator and 'FUNCTIONS' is a list of function designators for
displaying that number in SLY. Each function takes the number as a
single argument and returns a string, or nil, if that particular
representation is to be disregarded.
Additionally if a given function chooses to return 't' as its
optional second value, then all the remaining functions following
it in the list are disregarded.
For integer numbers, the default value of this variable holds
function designators that echo an integer number in its binary,
hexadecimal and octal representation. However, if your application
is using integers to represent Unix Epoch Times you can use this
function to display a human-readable time whenever you evaluate an
integer.
(defparameter *day-names* '("Monday" "Tuesday" "Wednesday"
"Thursday" "Friday" "Saturday"
"Sunday"))
(defun fancy-unix-epoch-time (integer)
"Format INTEGER as a Unix Epoch Time if within 10 years from now."
(let ((now (get-universal-time))
(tenyears (encode-universal-time 0 0 0 1 1 1910 0))
(unix-to-universal
(+ integer
(encode-universal-time 0 0 0 1 1 1970 0))))
(when (< (- now tenyears) unix-to-universal (+ now tenyears))
(multiple-value-bind
(second minute hour date month year day-of-week dst-p tz)
(decode-universal-time unix-to-universal)
(declare (ignore dst-p))
(format nil "~2,'0d:~2,'0d:~2,'0d on ~a, ~d/~2,'0d/~d (GMT~@d)"
hour minute second (nth day-of-week *day-names*)
month date year (- tz))))))
(pushnew 'fancy-unix-epoch-time
(cdr (assoc 'integer slynk:*echo-number-alist*)))
42 ; => 42 (6 bits, #x2A, #o52, #b101010)
1451404675 ; => 1451404675 (15:57:55 on Tuesday, 12/29/2015 (GMT+0), 31 bits, #x5682AD83)
'SLYNK-APROPOS:*PREFERRED-APROPOS-MATCHER*'
This variable holds a function used for performing apropos
searches. It defaults to 'SLYNK-APROPOS:MAKE-FLEX-MATCHER', but
can also be set to 'SLYNK-APROPOS:MAKE-CL-PPCRE-MATCHER' (to use a
regex-able matcher) or 'SLYNK-APROPOS:MAKE-PLAIN-MATCHER', for
example.
'SLYNK:*LOG-EVENTS*'
Setting this variable to 't' causes all protocol messages exchanged
with Emacs to be printed to '*TERMINAL-IO*'. This is useful for
low-level debugging and for observing how SLY works "on the wire."
The output of '*TERMINAL-IO*' can be found in your Lisp system's
own listener, usually in the buffer '*inferior-lisp*'.
File: sly.info, Node: Tips and Tricks, Next: Extensions, Prev: Customization, Up: Top
8 Tips and Tricks
*****************
* Menu:
* Connecting to a remote Lisp::
* Loading Slynk faster::
* Auto-SLY::
* REPLs and game loops::
* Controlling SLY from outside Emacs::
File: sly.info, Node: Connecting to a remote Lisp, Next: Loading Slynk faster, Up: Tips and Tricks
8.1 Connecting to a remote Lisp
===============================
One of the advantages of the way SLY is implemented is that we can
easily run the Emacs side ('sly.el' and friends) on one machine and the
Lisp backend (Slynk) on another. The basic idea is to start up Lisp on
the remote machine, load Slynk and wait for incoming SLY connections.
On the local machine we start up Emacs and tell SLY to connect to the
remote machine. The details are a bit messier but the underlying idea
is that simple.
* Menu:
* Setting up the Lisp image::
* Setting up Emacs::
* Setting up pathname translations::
File: sly.info, Node: Setting up the Lisp image, Next: Setting up Emacs, Up: Connecting to a remote Lisp
8.1.1 Setting up the Lisp image
-------------------------------
The easiest way to load Slynk "standalone" (i.e. without having 'M-x
sly' start a Lisp that is subsidiary to a particular Emacs), is to load
the ASDF system definition for Slynk.
Make sure the path to the directory containing Slynk's '.asd' file is
in 'ASDF:*CENTRAL-REGISTRY*'. This file lives in the 'slynk'
subdirectory of SLY. Type:
(push #p"/path/to/sly/slynk/" ASDF:*CENTRAL-REGISTRY*)
(asdf:require-system :slynk)
inside a running Lisp image(1).
Now all we need to do is startup our Slynk server. A working example
uses the default settings:
(slynk:create-server)
This creates a "one-connection-only" server on port 4005 using the
preferred communication style for your Lisp system. The following
parameters to 'slynk:create-server' can be used to change that
behaviour:
':PORT'
Port number for the server to listen on (default: 4005).
':DONT-CLOSE'
Boolean indicating if the server will continue to accept
connections after the first one (default: 'NIL'). For
"long-running" Lisp processes to which you want to be able to
connect from time to time, specify ':dont-close t'
':STYLE'
See *Note Communication style::.
So a more complete example will be
(slynk:create-server :port 4006 :dont-close t)
Finally, since section we're going to be tunneling our connection via
SSH(2) we'll only have one port open we must tell Slynk's REPL contrib
(see REPL) to not use an extra connection for output, which it will do
by default.
(setf slynk:*use-dedicated-output-stream* nil)
(3)
---------- Footnotes ----------
(1) SLY also SLIME's old-style 'slynk-loader.lisp' loader which does
the same thing, but ASDF is preferred
(2) there is a way to connect without an SSH tunnel, but it has the
side-effect of giving the entire world access to your Lisp image, so
we're not going to talk about it
(3) Alternatively, a separate tunnel for the port set in
'slynk:*dedicated-output-stream-port*' can also be used if a dedicated
output is essential.
File: sly.info, Node: Setting up Emacs, Next: Setting up pathname translations, Prev: Setting up the Lisp image, Up: Connecting to a remote Lisp
8.1.2 Setting up Emacs
----------------------
Now we need to create the tunnel between the local machine and the
remote machine. Assuming a UNIX command-line, this can be done with:
ssh -L4005:localhost:4005 youruser@remote.example.com
This incantation creates a SSH tunnel between the port 4005 on our
local machine and the port 4005 on the remote machine, where 'youruser'
is expected to have an account. (1).
Finally we start SLY with 'sly-connect' instead of the usual 'sly':
M-x sly-connect RET RET
The 'RET RET' sequence just means that we want to use the default
host ('localhost') and the default port ('4005'). Even though we're
connecting to a remote machine the SSH tunnel fools Emacs into thinking
it's actually 'localhost'.
---------- Footnotes ----------
(1) By default Slynk listens for incoming connections on port 4005,
had we passed a ':port' parameter to 'slynk:create-server' we'd be using
that port number instead
File: sly.info, Node: Setting up pathname translations, Prev: Setting up Emacs, Up: Connecting to a remote Lisp
8.1.3 Setting up pathname translations
--------------------------------------
One of the main problems with running slynk remotely is that Emacs
assumes the files can be found using normal filenames. if we want
things like 'sly-compile-and-load-file' ('C-c C-k') and
'sly-edit-definition' ('M-.') to work correctly we need to find a way to
let our local Emacs refer to remote files.
There are, mainly, two ways to do this. The first is to mount, using
NFS or similar, the remote machine's hard disk on the local machine's
file system in such a fashion that a filename like
'/opt/project/source.lisp' refers to the same file on both machines.
Unfortunately NFS is usually slow, often buggy, and not always feasible.
Fortunately we have an ssh connection and Emacs' 'tramp-mode' can do the
rest. (See *note TRAMP User Manual: (tramp)Top.)
What we do is teach Emacs how to take a filename on the remote
machine and translate it into something that tramp can understand and
access (and vice versa). Assuming the remote machine's host name is
'remote.example.com', 'cl:machine-instance' returns "remote" and we
login as the user "user" we can use 'sly-tramp' contrib to setup the
proper translations by simply doing:
(add-to-list 'sly-filename-translations
(sly-create-filename-translator
:machine-instance "remote"
:remote-host "remote.example.com"
:username "user"))
File: sly.info, Node: Loading Slynk faster, Next: Auto-SLY, Prev: Connecting to a remote Lisp, Up: Tips and Tricks
8.2 Loading Slynk faster
========================
In this section, a technique to load Slynk faster on South Bank Common
Lisp (SBCL) is presented. Similar setups should also work for other
Lisp implementations.
A pre-canned solution that automates this technique was developed by
Pierre Neidhardt (https://gitlab.com/ambrevar/lisp-repl-core-dumper).
For SBCL, we recommend that you create a custom core file with socket
support and POSIX bindings included because those modules take the most
time to load. To create such a core, execute the following steps:
shell$ sbcl
* (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf))
* (save-lisp-and-die "sbcl.core-for-sly")
After that, add something like this to your '~/.emacs' or
'~/.emacs.d/init.el' (*note Emacs Init File::):
(setq sly-lisp-implementations '((sbcl ("sbcl" "--core"
"sbcl.core-for-sly"))))
For maximum startup speed you can include the Slynk server directly
in a core file. The disadvantage of this approach is that the setup is
a bit more involved and that you need to create a new core file when you
want to update SLY or SBCL. The steps to execute are:
shell$ sbcl
* (load ".../sly/slynk-loader.lisp")
* (slynk-loader:dump-image "sbcl.core-with-slynk")
Then add this to the Emacs initializion file:
(setq sly-lisp-implementations
'((sbcl ("sbcl" "--core" "sbcl.core-with-slynk")
:init (lambda (port-file _)
(format "(slynk:start-server %S)\n" port-file)))))
File: sly.info, Node: Auto-SLY, Next: REPLs and game loops, Prev: Loading Slynk faster, Up: Tips and Tricks
8.3 Connecting to SLY automatically
===================================
To make SLY connect to your lisp whenever you open a lisp file just add
this to your '~/.emacs' or '~/.emacs.d/init.el' (*note Emacs Init
File::):
(add-hook 'sly-mode-hook
(lambda ()
(unless (sly-connected-p)
(save-excursion (sly)))))
File: sly.info, Node: REPLs and game loops, Next: Controlling SLY from outside Emacs, Prev: Auto-SLY, Up: Tips and Tricks
8.4 REPLs and "Game Loops"
==========================
When developing Common Lisp video games or graphical applications, a
REPL (*note REPL::) is just as useful as anywhere else. But it is often
the case that one needs to control exactly the timing of REPL requests
and ensure they do not interfere with the "game loop". In other
situations, the choice of communication style (*note Communication
style::) to the Slynk server may invalidate simultaneous multi-threaded
operation of REPL and game loop.
Instead of giving up on the REPL or using a complicated solution,
SLY's REPL can be built into your game loop by using a couple of Slynk
Common Lisp functions, 'SLYNK-MREPL:SEND-PROMPT' and
'SLYNK:PROCESS-REQUESTS'.
(defun my-repl-aware-game-loop ()
(loop initially
(princ "Starting our game")
(slynk-mrepl:send-prompt)
for i from 0
do (with-simple-restart (abort "Skip rest of this game loop iteration")
(when (zerop (mod i 10))
(fresh-line)
(princ "doing high-priority 3D game loop stuff"))
(sleep 0.1)
;; When you're ready to serve a potential waiting
;; REPL request, just do this non-blocking thing:
(with-simple-restart (abort "Abort this game REPL evaluation")
(slynk:process-requests t)))))
Note that this function is to be called _from the REPL_, and will
enter kind of "sub-REPL" inside it. It'll likely "just work" in this
situation. However, if you need you need to call this from anywhere
else (like, say, another thread), you must additionally arrange for the
variable 'SLYNK-API:*CHANNEL*' to be bound to the value it is bound to
in whatever SLY REPL you wish to interact with your game.
File: sly.info, Node: Controlling SLY from outside Emacs, Prev: REPLs and game loops, Up: Tips and Tricks
8.5 Controlling SLY from outside Emacs
======================================
If your application has a non-SLY, non-Emacs user interface (graphical
or otherwise), you can use it to exert some control over SLY
functionality, such as its REPL (*note REPL::) and inspector (*note
Inspector::). This requires that you first set, in Emacs, variable
'sly-enable-evaluate-in-emacs' to non-nil. As the name suggests, it
lets outside Slynk servers evaluate code in your Elisp runtime. It is
set to 'nil' by default for security purposes.
Once you've done that, you can call
'SLYNK-MREPL:COPY-TO-REPL-IN-EMACS' from your CL code with some objects
you'd like to manipulate in the REPL. Then you can have this code run
from some UI event handler:
(lambda ()
(slynk-mrepl:copy-to-repl-in-emacs
(list 42 'foo)
:blurb "Just a forty-two and a foo"))
And see those objects pop up in your REPL for inspection and
manipulation.
You can also use the functions 'SLYNK:INSPECT-IN-EMACS',
'SLYNK:ED-IN-EMACS', and in general, any exported function ending in
'IN-EMACS'. See their docstrings for details.
File: sly.info, Node: Extensions, Next: Credits, Prev: Tips and Tricks, Up: Top
9 Extensions
************
* Menu:
* Loading and unloading:: More contribs::
* More contribs::
Extensions, also known as "contribs" are Emacs packages that extend
SLY’s functionality. Contrasting with its ancestor SLIME (*note
Introduction::), most contribs bundled with SLY are active by default,
since they are a decent way to split SLY into pluggable modules. The
auto-documentation (*note Autodoc::), trace (*note Trace Dialog::) and
Stickers (*note Stickers::) are contribs enabled by default, for
example.
Usually, contribs differ from regular Emacs plugins in that they are
partly written in Emacs-lisp and partly in Common Lisp. The former is
usually the UI that queries the latter for information and then presents
it to the user. SLIME used to load all the contribs’ Common Lisp code
upfront, but SLY takes care to loading these two parts at the correct
time. In this way, developers can write third-party contribs that live
independently of SLY perhaps even in different code repositories. The
'sly-macrostep' contrib (<https://github.com/joaotavora/sly-macrostep>)
is one such example.
A special 'sly-fancy' contrib package is the only one loaded by
default. You might never want to fiddle with it (it is the one that
contains the default extensions), but if you find that you don't like
some package or you are having trouble with a package, you can modify
your setup a bit. Generally, you set the variable 'sly-contribs' with
the list of package-names that you want to use. For example, a setup to
load only the 'sly-scratch' and 'sly-mrepl' packages looks like:
;; _Setup load-path and autoloads_
(add-to-list 'load-path "~/dir/to/cloned/sly")
(require 'sly-autoloads)
;; _Set your lisp system and some contribs_
(setq inferior-lisp-program "/opt/sbcl/bin/sbcl")
(setq sly-contribs '(sly-scratch sly-mrepl))
After starting SLY, the commands of both packages should be
available.
File: sly.info, Node: Loading and unloading, Next: More contribs, Up: Extensions
9.1 Loading and unloading "on the fly"
======================================
We recommend that you setup the 'sly-contribs' variable _before_
starting SLY via 'M-x sly', but if you want to enable more contribs
_after_ you that, you can set new 'sly-contribs' variable to another
value and call 'M-x sly-setup' or 'M-x sly-enable-contrib'. Note this
though:
* If you've removed contribs from the list they won't be unloaded
automatically.
* If you have more than one SLY connection currently active, you must
manually repeat the 'sly-setup' step for each of them.
Short of restarting Emacs, a reasonable way of unloading contribs is
by calling an Emacs Lisp function whose name is obtained by adding
'-unload' to the contrib's name, for every contrib you wish to unload.
So, to remove 'sly-mrepl', you must call 'sly-mrepl-unload'. Because
the unload function will only, if ever, unload the Emacs Lisp side of
the contrib, you may also need to restart your lisps.
File: sly.info, Node: More contribs, Prev: Loading and unloading, Up: Extensions
9.2 More contribs
=================
* Menu:
* TRAMP Support::
* Scratch Buffer::
File: sly.info, Node: TRAMP Support, Next: Scratch Buffer, Up: More contribs
9.2.1 TRAMP
-----------
The package 'sly-tramp' provides some functions to set up filename
translations for TRAMP. (*note Setting up pathname translations::)
File: sly.info, Node: Scratch Buffer, Prev: TRAMP Support, Up: More contribs
9.2.2 Scratch Buffer
--------------------
The SLY scratch buffer, in contrib package 'sly-scratch', imitates
Emacs' usual '*scratch*' buffer. If 'sly-scratch-file' is set, it is
used to back the scratch buffer, making it persistent. The buffer is
like any other Lisp buffer, except for the command bound to 'C-j'.
'C-j'
'M-x sly-eval-print-last-expression'
Evaluate the expression sexp before point and insert a printed
representation of the return values into the current buffer.
'M-x sly-scratch'
Create a '*sly-scratch*' buffer. In this buffer you can enter Lisp
expressions and evaluate them with 'C-j', like in Emacs's
'*scratch*' buffer.
File: sly.info, Node: Credits, Next: Key Index, Prev: Extensions, Up: Top
10 Credits
**********
_The soppy ending..._
Hackers of the good hack
========================
SLY is a fork of SLIME which is itself an Extension of SLIM by Eric
Marsden. At the time of writing, the authors and code-contributors of
SLY are:
Helmut Eller João Távora Luke Gorrie
Tobias C. Rittweiler Stas Boukarev Marco Baringer
Matthias Koeppe Nikodemus Siivola Alan Ruttenberg
Attila Lendvai Luís Borges de Dan Barlow
Oliveira
Andras Simon Martin Simmons Geo Carncross
Christophe Rhodes Peter Seibel Mark Evenson
Juho Snellman Douglas Crosher Wolfgang Jenkner
R Primus Javier Olaechea Edi Weitz
Zach Shaftel James Bielman Daniel Kochmanski
Terje Norderhaug Vladimir Sedach Juan Jose Garcia
Ripoll
Alexander Artemenko Spenser Truex Nathan Trapuzzano
Brian Downing Mark Jeffrey Cunningham
Espen Wiborg Paul M. Rodriguez Masataro Asai
Jan Moringen Sébastien Villemot Samuel Freilich
Raymond Toy Pierre Neidhardt Phil Hargett
Paulo Madeira Kris Katterjohn Jonas Bernoulli
Ivan Shvedunov Gábor Melis Francois-Rene Rideau
Christophe Junke Bozhidar Batsov Bart Botta
Wilfredo Tianxiang Xiong Syohei YOSHIDA
Velázquez-Rodríguez
Stefan Monnier Rommel MARTINEZ Pavel Kulyov
Paul A. Patience Olof-Joachim Frahm Mike Clarke
Michał Herda Mark H. David Mario Lang
Manfred Bergmann Leo Liu Koga Kazuo
Jon Oddie John Stracke Joe Robertson
Grant Shangreaux Graham Dobbins Eric Timmons
Douglas Katzman Dmitry Igrishin Dmitrii Korobeinikov
Deokhwan Kim Denis Budyak Chunyang Xu
Cayman Angelo Rossi Andrew Kirkpatrick
... not counting the bundled code from 'hyperspec.el', 'CLOCC', and
the 'CMU AI Repository'.
Many people on the 'sly-devel' mailing list have made non-code
contributions to SLY. Life is hard though: you gotta send code to get
your name in the manual. ':-)'
Thanks!
=======
We're indebted to the good people of 'common-lisp.net' for their hosting
and help, and for rescuing us from "Sourceforge hell."
Implementors of the Lisps that we support have been a great help.
We'd like to thank the CMUCL maintainers for their helpful answers,
Craig Norvell and Kevin Layer at Franz providing Allegro CL licenses for
SLY development, and Peter Graves for his help to get SLY running with
ABCL.
Most of all we're happy to be working with the Lisp implementors
who've joined in the SLY development: Dan Barlow and Christophe Rhodes
of SBCL, Gary Byers of OpenMCL, and Martin Simmons of LispWorks. Thanks
also to Alain Picard and Memetrics for funding Martin's initial work on
the LispWorks backend!
File: sly.info, Node: Key Index, Next: Command Index, Prev: Credits, Up: Top
Key (Character) Index
*********************
�[index�]
* Menu:
* 0 ... 9: Restarts. (line 22)
* :: Miscellaneous. (line 28)
* <: Frame Navigation. (line 23)
* >: Inspector. (line 61)
* > <1>: Frame Navigation. (line 19)
* a: Restarts. (line 8)
* A: Miscellaneous. (line 31)
* B: Miscellaneous. (line 19)
* c: Restarts. (line 18)
* C: Miscellaneous. (line 24)
* C-c :: Evaluation. (line 34)
* C-c <: Cross-referencing. (line 57)
* C-c >: Cross-referencing. (line 61)
* C-c C-b: Recovery. (line 8)
* C-c C-b <1>: REPL commands. (line 46)
* C-c C-c: Compilation. (line 14)
* C-c C-c <1>: Cross-referencing. (line 77)
* C-c C-c <2>: Examining frames. (line 38)
* C-c C-d #: Documentation. (line 58)
* C-c C-d C-a: Documentation. (line 24)
* C-c C-d C-d: Documentation. (line 16)
* C-c C-d C-f: Documentation. (line 20)
* C-c C-d C-h: Documentation. (line 43)
* C-c C-d C-p: Documentation. (line 36)
* C-c C-d C-z: Documentation. (line 32)
* C-c C-d ~: Documentation. (line 54)
* C-c C-k: Compilation. (line 30)
* C-c C-k <1>: Cross-referencing. (line 82)
* C-c C-l: Compilation. (line 48)
* C-c C-m: Macro-expansion. (line 8)
* C-c C-m <1>: Macro-expansion. (line 37)
* C-c C-o: REPL commands. (line 63)
* C-c C-p: Evaluation. (line 42)
* C-c C-r: Evaluation. (line 38)
* C-c C-t: Disassembly. (line 12)
* C-c C-t <1>: Trace Dialog. (line 26)
* C-c C-u: Evaluation. (line 53)
* C-c C-w C-b: Cross-referencing. (line 36)
* C-c C-w C-c: Cross-referencing. (line 24)
* C-c C-w C-m: Cross-referencing. (line 44)
* C-c C-w C-r: Cross-referencing. (line 32)
* C-c C-w C-s: Cross-referencing. (line 40)
* C-c C-w C-w: Cross-referencing. (line 28)
* C-c C-x c: Multiple connections. (line 31)
* C-c C-x n: Multiple connections. (line 35)
* C-c C-x p: Multiple connections. (line 40)
* C-c C-z: REPL. (line 29)
* C-c E: Evaluation. (line 47)
* C-c I: Inspector. (line 16)
* C-c M-c: Compilation. (line 69)
* C-c M-d: Disassembly. (line 8)
* C-c M-k: Compilation. (line 44)
* C-c M-m: Macro-expansion. (line 19)
* C-c M-o: REPL commands. (line 69)
* C-c T: Trace Dialog. (line 39)
* C-c ~: Recovery. (line 15)
* C-c ~ <1>: REPL. (line 36)
* C-j: Scratch Buffer. (line 13)
* C-k: Trace Dialog. (line 83)
* C-M-n: REPL commands. (line 58)
* C-M-p: REPL commands. (line 53)
* C-M-x: Evaluation. (line 20)
* C-n: Completion. (line 55)
* C-p: Completion. (line 60)
* C-r: REPL commands. (line 35)
* C-x 4 .: Finding definitions. (line 30)
* C-x 5 .: Finding definitions. (line 35)
* C-x C-e: Evaluation. (line 14)
* C-x `: Compilation. (line 73)
* C-_: Macro-expansion. (line 51)
* d: Multiple connections. (line 57)
* D: Inspector. (line 27)
* d <1>: Examining frames. (line 24)
* D <1>: Examining frames. (line 29)
* e: Inspector. (line 31)
* e <1>: Examining frames. (line 19)
* g: Macro-expansion. (line 42)
* g <1>: Multiple connections. (line 62)
* g <2>: Inspector. (line 49)
* g <3>: Trace Dialog. (line 76)
* G: Trace Dialog. (line 79)
* h: Inspector. (line 53)
* i: Examining frames. (line 34)
* l: Inspector. (line 41)
* M-,: Finding definitions. (line 25)
* M-.: Finding definitions. (line 20)
* M-?: Cross-referencing. (line 19)
* M-n: Compilation. (line 61)
* M-n <1>: REPL commands. (line 28)
* M-n <2>: Frame Navigation. (line 12)
* M-p: Compilation. (line 65)
* M-p <1>: REPL commands. (line 21)
* M-p <2>: Frame Navigation. (line 12)
* M-RET: Inspector. (line 65)
* n: Inspector. (line 45)
* n <1>: Frame Navigation. (line 8)
* p: Frame Navigation. (line 8)
* q: Macro-expansion. (line 47)
* q <1>: Multiple connections. (line 66)
* q <2>: Inspector. (line 57)
* q <3>: Restarts. (line 12)
* R: Multiple connections. (line 71)
* r: Miscellaneous. (line 8)
* R <1>: Miscellaneous. (line 14)
* RET: Cross-referencing. (line 67)
* RET <1>: Multiple connections. (line 53)
* RET <2>: REPL commands. (line 8)
* RET <3>: Inspector. (line 22)
* S-TAB: Inspector. (line 70)
* Space: Cross-referencing. (line 72)
* t: Examining frames. (line 10)
* tab: Completion. (line 65)
* TAB: REPL commands. (line 13)
* TAB <1>: Inspector. (line 70)
* v: Inspector. (line 36)
* v <1>: Examining frames. (line 14)
File: sly.info, Node: Command Index, Next: Variable Index, Prev: Key Index, Up: Top
Command and Function Index
**************************
�[index�]
* Menu:
* backward-button: Inspector. (line 70)
* forward-button: Inspector. (line 70)
* hyperspec-lookup-format: Documentation. (line 54)
* hyperspec-lookup-reader-macro: Documentation. (line 58)
* isearch-backward: REPL commands. (line 35)
* next-error: Compilation. (line 73)
* sly-abort-connection: Multiple connections. (line 81)
* sly-apropos: Documentation. (line 24)
* sly-apropos-all: Documentation. (line 32)
* sly-apropos-package: Documentation. (line 36)
* sly-arglist NAME: Autodoc. (line 11)
* sly-autodoc-manually: Autodoc. (line 17)
* sly-autodoc-mode: Autodoc. (line 14)
* sly-button-backward: REPL commands. (line 53)
* sly-button-forward: REPL commands. (line 58)
* sly-calls-who: Cross-referencing. (line 28)
* sly-cd: Recovery. (line 19)
* sly-choose-completion: Completion. (line 65)
* sly-compile-and-load-file: Compilation. (line 30)
* sly-compile-defun: Compilation. (line 14)
* sly-compile-file: Compilation. (line 44)
* sly-compile-region: Compilation. (line 51)
* sly-compiler-macroexpand: Macro-expansion. (line 25)
* sly-compiler-macroexpand-1: Macro-expansion. (line 22)
* sly-connect: Multiple connections. (line 74)
* sly-connection-list-make-default: Multiple connections. (line 57)
* sly-db-abort: Restarts. (line 8)
* sly-db-beginning-of-backtrace: Frame Navigation. (line 23)
* sly-db-break-with-default-debugger: Miscellaneous. (line 19)
* sly-db-break-with-system-debugger: Miscellaneous. (line 31)
* sly-db-continue: Restarts. (line 18)
* sly-db-details-down: Frame Navigation. (line 12)
* sly-db-details-up: Frame Navigation. (line 12)
* sly-db-disassemble: Examining frames. (line 29)
* sly-db-down: Frame Navigation. (line 8)
* sly-db-end-of-backtrace: Frame Navigation. (line 19)
* sly-db-eval-in-frame: Examining frames. (line 19)
* sly-db-inspect-condition: Miscellaneous. (line 24)
* sly-db-inspect-in-frame: Examining frames. (line 34)
* sly-db-invoke-restart-n: Restarts. (line 22)
* sly-db-pprint-eval-in-frame: Examining frames. (line 24)
* sly-db-quit: Restarts. (line 12)
* sly-db-recompile-frame-source: Examining frames. (line 38)
* sly-db-restart-frame: Miscellaneous. (line 8)
* sly-db-return-from-frame: Miscellaneous. (line 14)
* sly-db-show-frame-source: Examining frames. (line 14)
* sly-db-toggle-details: Examining frames. (line 10)
* sly-db-up: Frame Navigation. (line 8)
* sly-describe-function: Documentation. (line 20)
* sly-describe-symbol: Documentation. (line 16)
* sly-disassemble-symbol: Disassembly. (line 8)
* sly-disconnect: Multiple connections. (line 78)
* sly-edit-definition: Finding definitions. (line 20)
* sly-edit-definition-other-frame: Finding definitions. (line 35)
* sly-edit-definition-other-window: Finding definitions. (line 30)
* sly-edit-uses: Cross-referencing. (line 19)
* sly-edit-value: Evaluation. (line 47)
* sly-eval-defun: Evaluation. (line 20)
* sly-eval-last-expression: Evaluation. (line 14)
* sly-eval-print-last-expression: Scratch Buffer. (line 13)
* sly-eval-region: Evaluation. (line 38)
* sly-expand-1: Macro-expansion. (line 8)
* sly-format-string-expand: Macro-expansion. (line 28)
* sly-goto-connection: Multiple connections. (line 53)
* sly-goto-xref: Cross-referencing. (line 72)
* sly-hyperspec-lookup: Documentation. (line 43)
* sly-info: Documentation. (line 11)
* sly-inspect: Inspector. (line 16)
* sly-inspector-describe-inspectee: Inspector. (line 27)
* sly-inspector-eval: Inspector. (line 31)
* sly-inspector-fetch-all: Inspector. (line 61)
* sly-inspector-history: Inspector. (line 53)
* sly-inspector-next: Inspector. (line 45)
* sly-inspector-operate-on-point: Inspector. (line 22)
* sly-inspector-pop: Inspector. (line 41)
* sly-inspector-quit: Inspector. (line 57)
* sly-inspector-reinspect: Inspector. (line 49)
* sly-inspector-toggle-verbose: Inspector. (line 36)
* sly-interactive-eval: Evaluation. (line 34)
* sly-interactive-eval <1>: Miscellaneous. (line 28)
* sly-interrupt: Recovery. (line 8)
* sly-interrupt <1>: REPL commands. (line 46)
* sly-list-callees: Cross-referencing. (line 61)
* sly-list-callers: Cross-referencing. (line 57)
* sly-list-connections: Multiple connections. (line 31)
* sly-load-file: Compilation. (line 48)
* sly-macroexpand-1: Macro-expansion. (line 14)
* sly-macroexpand-1-inplace: Macro-expansion. (line 37)
* sly-macroexpand-1-inplace <1>: Macro-expansion. (line 42)
* sly-macroexpand-all: Macro-expansion. (line 19)
* sly-macroexpand-undo: Macro-expansion. (line 51)
* sly-mrepl: REPL. (line 29)
* sly-mrepl-clear-recent-output: REPL commands. (line 63)
* sly-mrepl-clear-repl: REPL commands. (line 69)
* sly-mrepl-copy-part-to-repl: Inspector. (line 65)
* sly-mrepl-indent-and-complete-symbol: REPL commands. (line 13)
* sly-mrepl-new: REPL. (line 32)
* sly-mrepl-next-input-or-button: REPL commands. (line 28)
* sly-mrepl-previous-input-or-button: REPL commands. (line 21)
* sly-mrepl-return: REPL commands. (line 8)
* sly-mrepl-sync: Recovery. (line 15)
* sly-mrepl-sync <1>: REPL. (line 36)
* sly-next-completion: Completion. (line 55)
* sly-next-connection: Multiple connections. (line 35)
* sly-next-note: Compilation. (line 61)
* sly-pop-find-definition-stack: Finding definitions. (line 25)
* sly-pprint-eval-last-expression: Evaluation. (line 42)
* sly-prev-completion: Completion. (line 60)
* sly-prev-connection: Multiple connections. (line 40)
* sly-previous-note: Compilation. (line 65)
* sly-pwd: Recovery. (line 23)
* sly-recompile-all-xrefs: Cross-referencing. (line 82)
* sly-recompile-xref: Cross-referencing. (line 77)
* sly-remove-method: Evaluation. (line 56)
* sly-remove-notes: Compilation. (line 69)
* sly-restart-connection-at-point: Multiple connections. (line 71)
* sly-restart-inferior-lisp: Recovery. (line 11)
* sly-scratch: Scratch Buffer. (line 17)
* sly-show-xref: Cross-referencing. (line 67)
* sly-temp-buffer-quit: Macro-expansion. (line 47)
* sly-temp-buffer-quit <1>: Multiple connections. (line 66)
* sly-toggle-trace-fdefinition: Disassembly. (line 12)
* sly-trace-dialog: Trace Dialog. (line 39)
* sly-trace-dialog-clear-fetched-traces: Trace Dialog. (line 83)
* sly-trace-dialog-fetch-status: Trace Dialog. (line 76)
* sly-trace-dialog-fetch-traces: Trace Dialog. (line 79)
* sly-trace-dialog-toggle-trace: Trace Dialog. (line 26)
* sly-undefine-function: Evaluation. (line 53)
* sly-untrace-all: Disassembly. (line 17)
* sly-update-connection-list: Multiple connections. (line 62)
* sly-who-binds: Cross-referencing. (line 36)
* sly-who-calls: Cross-referencing. (line 24)
* sly-who-macroexpands: Cross-referencing. (line 44)
* sly-who-references: Cross-referencing. (line 32)
* sly-who-sets: Cross-referencing. (line 40)
* sly-who-specializes: Cross-referencing. (line 47)
File: sly.info, Node: Variable Index, Prev: Command Index, Up: Top
Variable and Concept Index
**************************
�[index�]
* Menu:
* ASCII: Defcustom variables. (line 29)
* Character Encoding: Defcustom variables. (line 29)
* Compilation: Compilation. (line 6)
* Compiling Functions: Compilation. (line 12)
* Completion: Completion. (line 6)
* Contribs: Extensions. (line 11)
* Contributions: Extensions. (line 11)
* Debugger: Debugger. (line 6)
* Extensions: Extensions. (line 11)
* LATIN-1: Defcustom variables. (line 29)
* Listener: REPL. (line 6)
* Macros: Macro-expansion. (line 6)
* Plugins: Extensions. (line 11)
* Symbol Completion: Completion. (line 6)
* TRAMP: TRAMP Support. (line 6)
* Unicode: Defcustom variables. (line 29)
* UTF-8: Defcustom variables. (line 29)
Tag Table:
Node: Top294
Node: Introduction2281
Node: Getting started4600
Node: Platforms4911
Node: Downloading6011
Node: Basic setup7011
Node: Running7944
Node: Basic customization8808
Node: Multiple Lisps10524
Node: A SLY tour for SLIME users13019
Node: Working with source files23905
Node: Evaluation24633
Node: Compilation26547
Node: Autodoc29400
Node: Semantic indentation30342
Ref: Semantic indentation-Footnote-132449
Node: Reader conditionals32544
Node: Macro-expansion32920
Node: Common functionality34552
Node: Finding definitions35323
Node: Cross-referencing37153
Ref: Cross-referencing-Footnote-139545
Node: Completion39773
Node: Interactive objects42765
Node: Documentation44681
Node: Multiple connections46715
Node: Disassembly49666
Node: Recovery50198
Node: Temporary buffers50821
Node: Multi-threading52237
Node: The REPL and other special buffers53805
Node: REPL54078
Node: REPL commands55930
Node: REPL output57945
Node: REPL backreferences62550
Ref: REPL backreferences-Footnote-165702
Node: Inspector65755
Node: Debugger67701
Node: Examining frames68358
Node: Restarts69442
Ref: sly-db-quit69648
Node: Frame Navigation70067
Node: Miscellaneous70751
Node: Trace Dialog71660
Node: Stickers75444
Node: Customization79558
Node: Emacs-side79761
Node: Keybindings79953
Ref: describe-key80755
Ref: describe-bindings80882
Ref: describe-mode81013
Ref: view-lossage81185
Ref: Emacs Init File81321
Node: Keymaps81953
Node: Defcustom variables84590
Ref: sly-complete-symbol-function85279
Ref: sly-net-coding-system85827
Node: Hooks88186
Ref: sly-connected-hook88534
Node: Lisp-side customization88977
Node: Communication style89375
Node: Other configurables91902
Ref: *SLY-DB-QUIT-RESTART*92609
Node: Tips and Tricks98143
Node: Connecting to a remote Lisp98417
Node: Setting up the Lisp image99124
Ref: Setting up the Lisp image-Footnote-1100911
Ref: Setting up the Lisp image-Footnote-2101022
Ref: Setting up the Lisp image-Footnote-3101196
Node: Setting up Emacs101349
Ref: Setting up Emacs-Footnote-1102303
Node: Setting up pathname translations102473
Node: Loading Slynk faster104050
Ref: init-example105527
Node: Auto-SLY105749
Node: REPLs and game loops106230
Node: Controlling SLY from outside Emacs108197
Node: Extensions109442
Node: Loading and unloading111489
Node: More contribs112565
Node: TRAMP Support112736
Node: Scratch Buffer112979
Ref: sly-scratch113105
Node: Credits113738
Node: Key Index117007
Node: Command Index125626
Node: Variable Index135722
End Tag Table
Local Variables:
coding: utf-8
End:
;;; sly.el --- Sylvester the Cat's Common Lisp IDE -*- lexical-binding: t; -*-
;; Version: 1.0.43
;; URL: https://github.com/joaotavora/sly
;; Package-Requires: ((emacs "24.3"))
;; Keywords: languages, lisp, sly
;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler
;; Copyright (C) 2014 João Távora
;; For a detailed list of contributors, see the manual.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; _____ __ __ __
;; / ___/ / / \ \/ / |\ _,,,---,,_
;; \__ \ / / \ / /,`.-'`' -. ;-;;,_
;; ___/ / / /___ / / |,4- ) )-,_..;\ ( `'-'
;; /____/ /_____/ /_/ '---''(_/--' `-'\_)
;;
;;
;; SLY is Sylvester the Cat's Common Lisp IDE.
;;
;; SLY is a direct fork of SLIME, and contains the following
;; improvements over it:
;;
;; * A full-featured REPL based on Emacs's `comint.el`;
;; * Live code annotations via a new `sly-stickers` contrib;
;; * Consistent button interface. Every Lisp object can be copied to the REPL;
;; * flex-style completion out-of-the-box, using Emacs's completion API.
;; Company, Helm, and others supported natively, no plugin required;
;; * Cleanly ASDF-loaded by default, including contribs, enabled out-of-the-box;
;; * Multiple inspectors and multiple REPLs;
;; * An interactive trace dialog with interactive objects. Copies function calls
;; to the REPL;
;; * "Presentations" replaced by interactive backreferences which
;; highlight the object and remain stable throughout the REPL session;
;;
;; SLY is a fork of SLIME. We track its bugfixes, particularly to the
;; implementation backends. All SLIME's familar features (debugger,
;; inspector, xref, etc...) are still available, with improved overall
;; UX.
;;
;; See the NEWS.md file (should be sitting alongside this file) for
;; more information
;;; Code:
(require 'cl-lib)
(eval-and-compile
(if (version< emacs-version "24.3")
(error "Sly requires at least Emacs 24.3")))
(eval-and-compile
(or (require 'hyperspec nil t)
(require 'hyperspec "lib/hyperspec")))
(require 'thingatpt)
(require 'comint)
(require 'pp)
(require 'easymenu)
(require 'arc-mode)
(require 'etags)
(require 'apropos)
(require 'bytecomp) ;; for `byte-compile-current-file' and
;; `sly-byte-compile-hotspots'.
(require 'sly-common "lib/sly-common")
(require 'sly-messages "lib/sly-messages")
(require 'sly-buttons "lib/sly-buttons")
(require 'sly-completion "lib/sly-completion")
(require 'gv) ; for gv--defsetter
(eval-when-compile
(require 'compile)
(require 'gud))
(defvar sly-path nil
"Directory containing the SLY package.
This is used to load the supporting Common Lisp library, Slynk.
The default value is automatically computed from the location of the
Emacs Lisp package.")
;; Determine `sly-path' at load time, regardless of filename (.el or
;; .elc) being loaded.
;;
(setq sly-path
(if load-file-name
(file-name-directory load-file-name)
(error "[sly] fatal: impossible to determine sly-path")))
(defun sly-slynk-path ()
"Path where the bundled Slynk server is located."
(expand-file-name "slynk/" sly-path))
;;;###autoload
(define-obsolete-variable-alias 'sly-setup-contribs
'sly-contribs "2.3.2")
;;;###autoload
(defvar sly-contribs '(sly-fancy)
"A list of contrib packages to load with SLY.")
;;;###autoload
(defun sly-setup (&optional contribs)
"Have SLY load and use extension modules CONTRIBS.
CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...)
symbols of `provide'd and `require'd Elisp libraries.
If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise
it is set to CONTRIBS.
However, after `require'ing LIB1, LIB2 ..., this command invokes
additional initialization steps associated with each element
LIB1, LIB2, which can theoretically be reverted by
`sly-disable-contrib.'
Notably, one of the extra initialization steps is affecting the
value of `sly-required-modules' (which see) thus affecting the
libraries loaded in the Slynk servers.
If SLY is currently connected to a Slynk and a contrib in
CONTRIBS has never been loaded, that Slynk is told to load the
associated Slynk extension module.
To ensure that a particular contrib is loaded, use
`sly-enable-contrib' instead."
;; FIXME: The contract should be like some hypothetical
;; `sly-refresh-contribs'
;;
(interactive)
(when contribs
(setq sly-contribs contribs))
(sly--setup-contribs))
(defvaralias 'sly-required-modules 'sly-contrib--required-slynk-modules)
(defvar sly-contrib--required-slynk-modules '()
"Alist of (MODULE . (WHERE CONTRIB)) for slynk-provided features.
MODULE is a symbol naming a specific Slynk feature, WHERE is
the full pathname to the directory where the file(s)
providing the feature are found and CONTRIB is a symbol as found
in `sly-contribs.'")
(cl-defmacro sly--contrib-safe (contrib &body body)
"Run BODY catching and resignalling any errors for CONTRIB"
(declare (indent 1))
`(condition-case-unless-debug e
(progn
,@body)
(error (sly-error "There's an error in %s: %s"
,contrib
e))))
(defun sly--setup-contribs ()
"Load and initialize contribs."
;; active != enabled
;; ^ ^
;; | |
;; v v
;; forgotten != disabled
(add-to-list 'load-path (expand-file-name "contrib" sly-path))
(mapc (lambda (c)
(sly--contrib-safe c (require c)))
sly-contribs)
(let* ((all-active-contribs
;; these are the contribs the user chose to activate
;;
(mapcar #'sly-contrib--find-contrib
(cl-reduce #'append (mapcar #'sly-contrib--all-dependencies
sly-contribs))))
(defined-but-forgotten-contribs
;; "forgotten contribs" are the ones the chose not to
;; activate but whose definitions we have seen
;;
(cl-remove-if #'(lambda (contrib)
(memq contrib all-active-contribs))
(sly-contrib--all-contribs))))
;; Disable any forgotten contribs that are enabled right now.
;;
(cl-loop for to-disable in defined-but-forgotten-contribs
when (sly--contrib-safe to-disable
(sly-contrib--enabled-p to-disable))
do (funcall (sly-contrib--disable to-disable)))
;; Enable any active contrib that is *not* enabled right now.
;;
(cl-loop for to-enable in all-active-contribs
unless (sly--contrib-safe to-enable
(sly-contrib--enabled-p to-enable))
do (funcall (sly-contrib--enable to-enable)))
;; Some contribs add stuff to `sly-mode-hook' or
;; `sly-editing-hook', so make sure we re-run those hooks now.
(when all-active-contribs
(defvar sly-editing-mode) ;FIXME: Forward reference!
(cl-loop for buffer in (buffer-list)
do (with-current-buffer buffer
(when sly-editing-mode (sly-editing-mode 1)))))))
(eval-and-compile
(defun sly-version (&optional interactive file)
"Read SLY's version of its own sly.el file.
If FILE is passed use that instead to discover the version."
(interactive "p")
(let ((version
(with-temp-buffer
(insert-file-contents
(or file
(expand-file-name "sly.el" sly-path))
nil 0 200)
(and (search-forward-regexp
";;[[:space:]]*Version:[[:space:]]*\\(.*\\)$" nil t)
(match-string 1)))))
(if interactive
(sly-message "SLY %s" version)
version))))
(defvar sly-protocol-version nil)
(setq sly-protocol-version
;; Compile the version string into the generated .elc file, but
;; don't actualy affect `sly-protocol-version' until load-time.
;;
(eval-when-compile (sly-version nil (or load-file-name
byte-compile-current-file))))
;;;; Customize groups
;;
;;;;; sly
(defgroup sly nil
"Interaction with the Superior Lisp Environment."
:prefix "sly-"
:group 'applications)
;;;;; sly-ui
(defgroup sly-ui nil
"Interaction with the Superior Lisp Environment."
:prefix "sly-"
:group 'sly)
(defcustom sly-truncate-lines t
"Set `truncate-lines' in popup buffers.
This applies to buffers that present lines as rows of data, such as
debugger backtraces and apropos listings."
:type 'boolean
:group 'sly-ui)
(defcustom sly-kill-without-query-p nil
"If non-nil, kill SLY processes without query when quitting Emacs.
This applies to the *inferior-lisp* buffer and the network connections."
:type 'boolean
:group 'sly-ui)
;;;;; sly-lisp
(defgroup sly-lisp nil
"Lisp server configuration."
:prefix "sly-"
:group 'sly)
(defcustom sly-ignore-protocol-mismatches nil
"If non-nil, ignore protocol mismatches between SLY and Slynk.
Programatically, this variable can be let-bound around calls to
`sly' or `sly-connect'."
:type 'boolean
:group 'sly)
(defcustom sly-init-function 'sly-init-using-asdf
"Function bootstrapping slynk on the remote.
Value is a function of two arguments: SLYNK-PORTFILE and an
ingored argument for backward compatibility. Function should
return a string issuing very first commands issued by Sly to
the remote-connection process. Some time after this there should
be a port number ready in SLYNK-PORTFILE."
:type '(choice (const :tag "Use ASDF"
sly-init-using-asdf)
(const :tag "Use legacy slynk-loader.lisp"
sly-init-using-slynk-loader))
:group 'sly-lisp)
(define-obsolete-variable-alias 'sly-backend
'sly-slynk-loader-backend "3.0")
(defcustom sly-slynk-loader-backend "slynk-loader.lisp"
"The name of the slynk-loader that loads the Slynk server.
Only applicable if `sly-init-function' is set to
`sly-init-using-slynk-loader'. This name is interpreted
relative to the directory containing sly.el, but could also be
set to an absolute filename."
:type 'string
:group 'sly-lisp)
(defcustom sly-connected-hook nil
"List of functions to call when SLY connects to Lisp."
:type 'hook
:group 'sly-lisp)
(defcustom sly-enable-evaluate-in-emacs nil
"*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs.
The default is nil, as this feature can be a security risk."
:type '(boolean)
:group 'sly-lisp)
(defcustom sly-lisp-host "localhost"
"The default hostname (or IP address) to connect to."
:type 'string
:group 'sly-lisp)
(defcustom sly-port 4005
"Port to use as the default for `sly-connect'."
:type 'integer
:group 'sly-lisp)
(defvar sly-connect-host-history (list sly-lisp-host))
(defvar sly-connect-port-history (list (prin1-to-string sly-port)))
(defvar sly-net-valid-coding-systems
'((iso-latin-1-unix nil "iso-latin-1-unix")
(iso-8859-1-unix nil "iso-latin-1-unix")
(binary nil "iso-latin-1-unix")
(utf-8-unix t "utf-8-unix")
(emacs-mule-unix t "emacs-mule-unix")
(euc-jp-unix t "euc-jp-unix"))
"A list of valid coding systems.
Each element is of the form: (NAME MULTIBYTEP CL-NAME)")
(defun sly-find-coding-system (name)
"Return the coding system for the symbol NAME.
The result is either an element in `sly-net-valid-coding-systems'
of nil."
(let ((probe (assq name sly-net-valid-coding-systems)))
(when (and probe (if (fboundp 'check-coding-system)
(ignore-errors (check-coding-system (car probe)))
(eq (car probe) 'binary)))
probe)))
(defcustom sly-net-coding-system
(car (cl-find-if 'sly-find-coding-system
sly-net-valid-coding-systems :key 'car))
"Coding system used for network connections.
See also `sly-net-valid-coding-systems'."
:type (cons 'choice
(mapcar (lambda (x)
(list 'const (car x)))
sly-net-valid-coding-systems))
:group 'sly-lisp)
;;;;; sly-mode
(defgroup sly-mode nil
"Settings for sly-mode Lisp source buffers."
:prefix "sly-"
:group 'sly)
;;;;; sly-mode-faces
(defgroup sly-mode-faces nil
"Faces in sly-mode source code buffers."
:prefix "sly-"
:group 'sly-mode)
(defface sly-error-face
`((((class color) (background light))
(:underline "tomato"))
(((class color) (background dark))
(:underline "tomato"))
(t (:underline t)))
"Face for errors from the compiler."
:group 'sly-mode-faces)
(defface sly-warning-face
`((((class color) (background light))
(:underline "orange"))
(((class color) (background dark))
(:underline "coral"))
(t (:underline t)))
"Face for warnings from the compiler."
:group 'sly-mode-faces)
(defface sly-style-warning-face
`((((class color) (background light))
(:underline "olive drab"))
(((class color) (background dark))
(:underline "khaki"))
(t (:underline t)))
"Face for style-warnings from the compiler."
:group 'sly-mode-faces)
(defface sly-note-face
`((((class color) (background light))
(:underline "brown3"))
(((class color) (background dark))
(:underline "light goldenrod"))
(t (:underline t)))
"Face for notes from the compiler."
:group 'sly-mode-faces)
;;;;; sly-db
(defgroup sly-debugger nil
"Backtrace options and fontification."
:prefix "sly-db-"
:group 'sly)
(defmacro define-sly-db-faces (&rest faces)
"Define the set of SLY-DB faces.
Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES).
NAME is a symbol; the face will be called sly-db-NAME-face.
DESCRIPTION is a one-liner for the customization buffer.
PROPERTIES specifies any default face properties."
`(progn ,@(cl-loop for face in faces
collect `(define-sly-db-face ,@face))))
(defmacro define-sly-db-face (name description &optional default)
(let ((facename (intern (format "sly-db-%s-face" (symbol-name name)))))
`(defface ,facename
(list (list t ,default))
,(format "Face for %s." description)
:group 'sly-debugger)))
(define-sly-db-faces
(topline "the top line describing the error")
(condition "the condition class" '(:inherit error))
(section "the labels of major sections in the debugger buffer"
'(:inherit header-line))
(frame-label "backtrace frame numbers"
'(:inherit shadow))
(restart "restart descriptions")
(restart-number "restart numbers (correspond to keystrokes to invoke)"
'(:inherit shadow))
(frame-line "function names and arguments in the backtrace")
(restartable-frame-line
"frames which are surely restartable"
'(:inherit font-lock-constant-face))
(non-restartable-frame-line
"frames which are surely not restartable")
(local-name "local variable names")
(catch-tag "catch tags"))
;;;;; Key bindings
(defvar sly-doc-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-a") 'sly-apropos)
(define-key map (kbd "C-z") 'sly-apropos-all)
(define-key map (kbd "C-p") 'sly-apropos-package)
(define-key map (kbd "C-d") 'sly-describe-symbol)
(define-key map (kbd "C-f") 'sly-describe-function)
(define-key map (kbd "C-h") 'sly-documentation-lookup)
(define-key map (kbd "~") 'common-lisp-hyperspec-format)
(define-key map (kbd "C-g") 'common-lisp-hyperspec-glossary-term)
(define-key map (kbd "#") 'common-lisp-hyperspec-lookup-reader-macro)
map))
(defvar sly-who-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c") 'sly-who-calls)
(define-key map (kbd "C-w") 'sly-calls-who)
(define-key map (kbd "C-r") 'sly-who-references)
(define-key map (kbd "C-b") 'sly-who-binds)
(define-key map (kbd "C-s") 'sly-who-sets)
(define-key map (kbd "C-m") 'sly-who-macroexpands)
(define-key map (kbd "C-a") 'sly-who-specializes)
map))
(defvar sly-selector-map (let ((map (make-sparse-keymap)))
(define-key map "c" 'sly-list-connections)
(define-key map "t" 'sly-list-threads)
(define-key map "d" 'sly-db-pop-to-debugger-maybe)
(define-key map "e" 'sly-pop-to-events-buffer)
(define-key map "i" 'sly-inferior-lisp-buffer)
(define-key map "l" 'sly-switch-to-most-recent)
map)
"A keymap for frequently used SLY shortcuts.
Access to this keymap can be installed in in
`sly-mode-map', using something like
(global-set-key (kbd \"C-z\") sly-selector-map)
This will bind C-z to this prefix map, one keystroke away from
the available shortcuts:
\\{sly-selector-map}
As usual, users or extensions can plug in
any command into it using
(define-key sly-selector-map (kbd \"k\") 'sly-command)
Where \"k\" is the key to bind and \"sly-command\" is any
interactive command.\".")
(defvar sly-prefix-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-r") 'sly-eval-region)
(define-key map (kbd ":") 'sly-interactive-eval)
(define-key map (kbd "C-e") 'sly-interactive-eval)
(define-key map (kbd "E") 'sly-edit-value)
(define-key map (kbd "C-l") 'sly-load-file)
(define-key map (kbd "C-b") 'sly-interrupt)
(define-key map (kbd "M-d") 'sly-disassemble-symbol)
(define-key map (kbd "C-t") 'sly-toggle-trace-fdefinition)
(define-key map (kbd "I") 'sly-inspect)
(define-key map (kbd "C-x t") 'sly-list-threads)
(define-key map (kbd "C-x n") 'sly-next-connection)
(define-key map (kbd "C-x c") 'sly-list-connections)
(define-key map (kbd "C-x p") 'sly-prev-connection)
(define-key map (kbd "<") 'sly-list-callers)
(define-key map (kbd ">") 'sly-list-callees)
;; Include DOC keys...
(define-key map (kbd "C-d") sly-doc-map)
;; Include XREF WHO-FOO keys...
(define-key map (kbd "C-w") sly-who-map)
;; `sly-selector-map' used to be bound to "C-c C-s" by default,
;; but sly-stickers has a better binding for that.
;;
;; (define-key map (kbd "C-s") sly-selector-map)
map))
(defvar sly-mode-map
(let ((map (make-sparse-keymap)))
;; These used to be a `sly-parent-map'
(define-key map (kbd "M-.") 'sly-edit-definition)
(define-key map (kbd "M-,") 'sly-pop-find-definition-stack)
(define-key map (kbd "M-_") 'sly-edit-uses) ; for German layout
(define-key map (kbd "M-?") 'sly-edit-uses) ; for USian layout
(define-key map (kbd "C-x 4 .") 'sly-edit-definition-other-window)
(define-key map (kbd "C-x 5 .") 'sly-edit-definition-other-frame)
(define-key map (kbd "C-x C-e") 'sly-eval-last-expression)
(define-key map (kbd "C-M-x") 'sly-eval-defun)
;; Include PREFIX keys...
(define-key map (kbd "C-c") sly-prefix-map)
;; Completion
(define-key map (kbd "C-c TAB") 'completion-at-point)
;; Evaluating
(define-key map (kbd "C-c C-p") 'sly-pprint-eval-last-expression)
;; Macroexpand
(define-key map (kbd "C-c C-m") 'sly-expand-1)
(define-key map (kbd "C-c M-m") 'sly-macroexpand-all)
;; Misc
(define-key map (kbd "C-c C-u") 'sly-undefine-function)
map))
(defvar sly-editing-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "M-p") 'sly-previous-note)
(define-key map (kbd "M-n") 'sly-next-note)
(define-key map (kbd "C-c M-c") 'sly-remove-notes)
(define-key map (kbd "C-c C-k") 'sly-compile-and-load-file)
(define-key map (kbd "C-c M-k") 'sly-compile-file)
(define-key map (kbd "C-c C-c") 'sly-compile-defun)
map))
(defvar sly-popup-buffer-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "q") 'quit-window)
map))
;;;; Minor modes
;;;;; sly-mode
(defvar sly-buffer-connection)
(defvar sly-dispatching-connection)
(defvar sly-current-thread)
;; exceptional forward decl
(defvar company-tooltip-align-annotations)
;;;###autoload
(define-minor-mode sly-mode
"Minor mode for horizontal SLY functionality."
nil nil nil
;; Company-mode should have this by default
;; See gh#166
(set (make-local-variable 'company-tooltip-align-annotations) t))
(defun sly--lisp-indent-function (&rest args)
(let ((fn (if (fboundp 'sly-common-lisp-indent-function)
#'sly-common-lisp-indent-function
#'lisp-indent-function)))
(apply fn args)))
;;;###autoload
(define-minor-mode sly-editing-mode
"Minor mode for editing `lisp-mode' buffers."
nil nil nil
(sly-mode 1)
(setq-local lisp-indent-function #'sly--lisp-indent-function))
(define-minor-mode sly-popup-buffer-mode
"Minor mode for all read-only SLY buffers"
nil nil nil
(sly-mode 1)
(sly-interactive-buttons-mode 1)
(setq buffer-read-only t))
;;;;;; Mode-Line
(defface sly-mode-line
'((t (:inherit font-lock-constant-face
:weight bold)))
"Face for package-name in SLY's mode line."
:group 'sly)
(defvar sly--mode-line-format `(:eval (sly--mode-line-format)))
(put 'sly--mode-line-format 'risky-local-variable t)
(defvar sly-menu) ;; forward referenced
(defvar sly-extra-mode-line-constructs nil
"A list of mode-line constructs to add to SLY's mode-line.
Each construct is separated by a \"/\" and may be a regular
mode-line construct or a symbol naming a function of no arguments
that returns one such construct.")
(defun sly--mode-line-format ()
(let* ((conn (sly-current-connection))
(conn (and (process-live-p conn) conn))
(name (or (and conn
(sly-connection-name conn))
"*"))
(pkg (sly-current-package))
(format-number (lambda (n) (cond ((and n (not (zerop n)))
(format "%d" n))
(n "-")
(t "*"))))
(package-name (and pkg
(sly--pretty-package-name pkg)))
(pending (and conn
(length (sly-rex-continuations conn))))
(sly-dbs (and conn (length (sly-db-buffers conn)))))
`((:propertize "sly"
face sly-mode-line
keymap ,(let ((map (make-sparse-keymap)))
(define-key map [mode-line down-mouse-1]
sly-menu)
map)
mouse-face mode-line-highlight
help-echo "mouse-1: pop-up SLY menu"
)
" "
(:propertize ,name
face sly-mode-line
keymap ,(let ((map (make-sparse-keymap)))
(define-key map [mode-line mouse-1] 'sly-prev-connection)
(define-key map [mode-line mouse-2] 'sly-list-connections)
(define-key map [mode-line mouse-3] 'sly-next-connection)
map)
mouse-face mode-line-highlight
help-echo ,(concat "mouse-1: previous connection\n"
"mouse-2: list connections\n"
"mouse-3: next connection"))
"/"
,(or package-name "*")
"/"
(:propertize ,(funcall format-number pending)
help-echo ,(if conn (format "%s pending events outgoing\n%s"
pending
(concat "mouse-1: go to *sly-events* buffer"
"mouse-3: forget pending continuations"))
"No current connection")
mouse-face mode-line-highlight
face ,(cond ((and pending (cl-plusp pending))
'warning)
(t
'sly-mode-line))
keymap ,(let ((map (make-sparse-keymap)))
(define-key map [mode-line mouse-1] 'sly-pop-to-events-buffer)
(define-key map [mode-line mouse-3] 'sly-forget-pending-events)
map))
"/"
(:propertize ,(funcall format-number sly-dbs)
help-echo ,(if conn (format "%s SLY-DB buffers waiting\n%s"
pending
"mouse-1: go to first one")
"No current connection")
mouse-face mode-line-highlight
face ,(cond ((and sly-dbs (cl-plusp sly-dbs))
'warning)
(t
'sly-mode-line))
keymap ,(let ((map (make-sparse-keymap)))
(define-key map [mode-line mouse-1] 'sly-db-pop-to-debugger)
map))
,@(cl-loop for construct in sly-extra-mode-line-constructs
collect "/"
collect (if (and (symbolp construct)
(fboundp construct))
(condition-case _oops
(funcall construct)
(error "*sly-invalid*"))
construct)))))
(defun sly--refresh-mode-line ()
(force-mode-line-update t))
(defun sly--pretty-package-name (name)
"Return a pretty version of a package name NAME."
(cond ((string-match "^#?:\\(.*\\)$" name)
(match-string 1 name))
((string-match "^\"\\(.*\\)\"$" name)
(match-string 1 name))
(t name)))
(add-to-list 'mode-line-misc-info
`(sly-mode (" [" sly--mode-line-format "] ")))
;;;; Framework'ey bits
;;;
;;; This section contains some standard SLY idioms: basic macros,
;;; ways of showing messages to the user, etc. All the code in this
;;; file should use these functions when applicable.
;;;
;;;;; Syntactic sugar
(cl-defmacro sly--when-let ((var value) &rest body)
"Evaluate VALUE, if the result is non-nil bind it to VAR and eval BODY.
\(fn (VAR VALUE) &rest BODY)"
(declare (indent 1))
`(let ((,var ,value))
(when ,var ,@body)))
(cl-defmacro sly--when-let* (bindings &rest body)
"Same as `sly--when-let', but for multiple BINDINGS"
(declare (indent 1))
(if bindings
`(sly--when-let ,(car bindings)
(sly--when-let* ,(cdr bindings) ,@body))
`(progn ,@body)))
(defmacro sly-dcase (value &rest patterns)
(declare (indent 1)
(debug (sexp &rest (sexp &rest form))))
"Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
(let ((operator (cl-gensym "op-"))
(operands (cl-gensym "rand-"))
(tmp (cl-gensym "tmp-")))
`(let* ((,tmp ,value)
(,operator (car ,tmp))
(,operands (cdr ,tmp)))
(cl-case ,operator
,@(mapcar (lambda (clause)
(if (eq (car clause) t)
`(t ,@(cdr clause))
(cl-destructuring-bind ((op &rest rands) &rest body)
clause
`(,op (cl-destructuring-bind ,rands ,operands
. ,(or body
'((ignore)) ; suppress some warnings
))))))
patterns)
,@(if (eq (caar (last patterns)) t)
'()
`((t (sly-error "Elisp sly-dcase failed: %S" ,tmp))))))))
;;;;; Very-commonly-used functions
;; Interface
(cl-defun sly-buffer-name (type &key connection hidden suffix)
(cl-assert (keywordp type))
(mapconcat #'identity
`(,@(if hidden `(" "))
"*sly-"
,(downcase (substring (symbol-name type) 1))
,@(if connection
`(" for "
,(sly-connection-name
(if (eq connection t)
(sly-current-connection)
connection))))
,@(if suffix
`(" ("
,suffix
")"))
"*")
""))
(defun sly-recenter (target &optional move-point)
"Make the region between point and TARGET visible.
Minimize window motion if possible. If MOVE-POINT allow point to
move to make TARGET visible."
(unless (pos-visible-in-window-p target)
(redisplay)
(let ((screen-line (- (line-number-at-pos)
(line-number-at-pos (window-start))))
(window-end (line-number-at-pos (window-end)))
(window-start (line-number-at-pos (window-start)))
(target-line (line-number-at-pos target))
recenter-arg)
(cond ((> (point) target)
(setq recenter-arg (+ screen-line (- window-start target-line)))
(if (or (not move-point)
(<= recenter-arg (window-height)))
(recenter recenter-arg)
(goto-char target)
(recenter -1)
(move-to-window-line -1)))
((<= (point) target)
(setq recenter-arg (- screen-line (- target-line window-end)))
(if (or (not move-point)
(> recenter-arg 0))
(recenter (max recenter-arg 0))
(goto-char target)
(recenter 0)
(move-to-window-line 0)))))))
;; Interface
(defun sly-set-truncate-lines ()
"Apply `sly-truncate-lines' to the current buffer."
(when sly-truncate-lines
(set (make-local-variable 'truncate-lines) t)))
;; Interface
(defun sly-read-package-name (prompt &optional initial-value allow-blank)
"Read a package name from the minibuffer, prompting with PROMPT.
If ALLOW-BLANK may return nil to signal no particular package
selected."
(let* ((completion-ignore-case t)
(res (completing-read
(concat "[sly] " prompt)
(sly-eval
`(slynk:list-all-package-names t))
nil (not allow-blank) initial-value)))
(unless (zerop (length res))
res)))
;; Interface
(defmacro sly-propertize-region (props &rest body)
"Execute BODY and add PROPS to all the text it inserts.
More precisely, PROPS are added to the region between the point's
positions before and after executing BODY."
(declare (indent 1) (debug (sexp &rest form)))
(let ((start (cl-gensym)))
`(let ((,start (point)))
(prog1 (progn ,@body)
(add-text-properties ,start (point) ,props)))))
(defun sly-add-face (face string)
(declare (indent 1))
(add-text-properties 0 (length string) (list 'face face) string)
string)
;; Interface
(defsubst sly-insert-propertized (props &rest args)
"Insert all ARGS and then add text-PROPS to the inserted text."
(sly-propertize-region props (apply #'insert args)))
(defmacro sly-with-rigid-indentation (level &rest body)
"Execute BODY and then rigidly indent its text insertions.
Assumes all insertions are made at point."
(declare (indent 1))
(let ((start (cl-gensym)) (l (cl-gensym)))
`(let ((,start (point)) (,l ,(or level '(current-column))))
(prog1 (progn ,@body)
(sly-indent-rigidly ,start (point) ,l)))))
(defun sly-indent-rigidly (start end column)
;; Similar to `indent-rigidly' but doesn't inherit text props.
(let ((indent (make-string column ?\ )))
(save-excursion
(goto-char end)
(beginning-of-line)
(while (and (<= start (point))
(progn
(insert-before-markers indent)
(zerop (forward-line -1))))))))
(defun sly-insert-indented (&rest strings)
"Insert all arguments rigidly indented."
(sly-with-rigid-indentation nil
(apply #'insert strings)))
(defun sly-compose (&rest functions)
"Compose unary FUNCTIONS right-associatively, returning a function"
#'(lambda (x)
(cl-reduce #'funcall functions :initial-value x :from-end t)))
(defun sly-curry (fun &rest args)
"Partially apply FUN to ARGS. The result is a new function."
(lambda (&rest more) (apply fun (append args more))))
(defun sly-rcurry (fun &rest args)
"Like `sly-curry' but ARGS on the right are applied."
(lambda (&rest more) (apply fun (append more args))))
;;;;; Temporary popup buffers
;; keep compiler quiet
(defvar sly-buffer-package)
(defvar sly-buffer-connection)
;; Interface
(cl-defmacro sly-with-popup-buffer ((name &key package connection select
same-window-p
mode)
&body body)
"Similar to `with-output-to-temp-buffer'.
Bind standard-output and initialize some buffer-local variables.
Restore window configuration when closed. NAME is the name of
the buffer to be created. PACKAGE is the value
`sly-buffer-package'. CONNECTION is the value for
`sly-buffer-connection', if nil, no explicit connection is
associated with the buffer. If t, the current connection is
taken. MODE is the name of a major mode which will be enabled.
Non-nil SELECT indicates the buffer should be switched to, unless
it is `:hidden' meaning the buffer should not even be
displayed. SELECT can also be `:raise' meaning the buffer should
be switched to and the frame raised. SAME-WINDOW-P is a form
indicating if the popup *can* happen in the same window. The
forms SELECT and SAME-WINDOW-P are evaluated at runtime, not
macroexpansion time.
"
(declare (indent 1)
(debug (sexp &rest form)))
(let* ((package-sym (cl-gensym "package-"))
(connection-sym (cl-gensym "connection-"))
(select-sym (cl-gensym "select"))
(major-mode-sym (cl-gensym "select")))
`(let ((,package-sym ,(if (eq package t)
`(sly-current-package)
package))
(,connection-sym ,(if (eq connection t)
`(sly-current-connection)
connection))
(,major-mode-sym major-mode)
(,select-sym ,select)
(view-read-only nil))
(with-current-buffer (get-buffer-create ,name)
(let ((inhibit-read-only t)
(standard-output (current-buffer)))
(erase-buffer)
,@(cond (mode
`((funcall ,mode)))
(t
`((sly-popup-buffer-mode 1))))
(setq sly-buffer-package ,package-sym
sly-buffer-connection ,connection-sym)
(set-syntax-table lisp-mode-syntax-table)
,@body
(unless (eq ,select-sym :hidden)
(let ((window (display-buffer
(current-buffer)
(if ,(cond (same-window-p same-window-p)
(mode `(eq ,major-mode-sym ,mode)))
nil
t))))
(when ,select-sym
(if window
(select-window window t))))
(if (eq ,select-sym :raise) (raise-frame)))
(current-buffer))))))
;;;;; Filename translation
;;;
;;; Filenames passed between Emacs and Lisp should be translated using
;;; these functions. This way users who run Emacs and Lisp on separate
;;; machines have a chance to integrate file operations somehow.
(defvar sly-to-lisp-filename-function #'convert-standard-filename
"Function to translate Emacs filenames to CL namestrings.")
(defvar sly-from-lisp-filename-function #'identity
"Function to translate CL namestrings to Emacs filenames.")
(defun sly-to-lisp-filename (filename)
"Translate the string FILENAME to a Lisp filename."
(funcall sly-to-lisp-filename-function (substring-no-properties filename)))
(defun sly-from-lisp-filename (filename)
"Translate the Lisp filename FILENAME to an Emacs filename."
(funcall sly-from-lisp-filename-function filename))
;;;; Starting SLY
;;;
;;; This section covers starting an inferior-lisp, compiling and
;;; starting the server, initiating a network connection.
;;;;; Entry points
;; We no longer load inf-lisp, but we use this variable for backward
;; compatibility.
(defcustom inferior-lisp-program "lisp"
"Program name for starting a Lisp subprocess to Emacs.
Can be a string naming a program, a whitespace-separated string
of \"EXECUTABLE ARG1 ARG2\" or a list (EXECUTABLE ARGS...) where
EXECUTABLE and ARGS are strings."
:type 'string
:group 'sly-lisp)
(defvar sly-lisp-implementations nil
"*A list of known Lisp implementations.
The list should have the form:
((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...)
NAME is a symbol for the implementation.
PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process.
For KEYWORD-ARGS see `sly-start'.
Here's an example:
((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init sly-init-command)
(acl (\"acl7\") :coding-system emacs-mule))")
(defcustom sly-command-switch-to-existing-lisp 'ask
"Should the `sly' command start new lisp if one is available?"
:type '(choice (const :tag "Ask the user" ask)
(const :tag "Always" 'always)
(const :tag "Never" 'never)))
(defcustom sly-auto-select-connection 'ask
"Controls auto selection after the default connection was closed."
:group 'sly-mode
:type '(choice (const never)
(const always)
(const ask)))
(defcustom sly-default-lisp nil
"A symbol naming the preferred Lisp implementation.
See `sly-lisp-implementations'"
:type 'function
:group 'sly-mode)
;; dummy definitions for the compiler
(defvar sly-net-processes)
(defvar sly-default-connection)
;;;###autoload
(cl-defun sly (&optional command coding-system interactive)
"Start a Lisp implementation and connect to it.
COMMAND designates a the Lisp implementation to start as an
\"inferior\" process to the Emacs process. It is either a
pathname string pathname to a lisp executable, a list (EXECUTABLE
ARGS...), or a symbol indexing
`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding
`sly-net-coding-system'.
Interactively, both COMMAND and CODING-SYSTEM are nil and the
prefix argument controls the precise behaviour:
- With no prefix arg, try to automatically find a Lisp. First
consult `sly-command-switch-to-existing-lisp' and analyse open
connections to maybe switch to one of those. If a new lisp is
to be created, first lookup `sly-lisp-implementations', using
`sly-default-lisp' as a default strategy. Then try
`inferior-lisp-program' if it looks like it points to a valid
lisp. Failing that, guess the location of a lisp
implementation.
- With a positive prefix arg (one C-u), prompt for a command
string that starts a Lisp implementation.
- With a negative prefix arg (M-- M-x sly, for example) prompt
for a symbol indexing one of the entries in
`sly-lisp-implementations'"
(interactive (list nil nil t))
(sly--when-let*
((active (and interactive
(not current-prefix-arg)
(sly--purge-connections)))
(target (or (and (eq sly-command-switch-to-existing-lisp 'ask)
(sly-prompt-for-connection
"[sly] Switch to open connection?\n\
(Customize `sly-command-switch-to-existing-lisp' to avoid this prompt.)\n\
Connections: " nil "(start a new one)"))
(and (eq sly-command-switch-to-existing-lisp 'always)
(car active)))))
(sly-message "Switching to `%s'" (sly-connection-name target))
(sly-connection-list-default-action target)
(cl-return-from sly nil))
(let ((command (or command inferior-lisp-program))
(sly-net-coding-system (or coding-system sly-net-coding-system)))
(apply #'sly-start
(cond (interactive
(sly--read-interactive-args))
(t
(if sly-lisp-implementations
(sly--lookup-lisp-implementation
sly-lisp-implementations
(or (and (symbolp command) command)
sly-default-lisp
(car (car sly-lisp-implementations))))
(let ((command-and-args (if (listp command)
command
(split-string command))))
`(:program ,(car command-and-args)
:program-args ,(cdr command-and-args)))))))))
(defvar sly-inferior-lisp-program-history '()
"History list of command strings. Used by M-x sly.")
(defun sly--read-interactive-args ()
"Return the list of args which should be passed to `sly-start'.
Helper for M-x sly"
(cond ((not current-prefix-arg)
(cond (sly-lisp-implementations
(sly--lookup-lisp-implementation sly-lisp-implementations
(or sly-default-lisp
(car (car sly-lisp-implementations)))))
(t (cl-destructuring-bind (program &rest args)
(split-string-and-unquote
(sly--guess-inferior-lisp-program t))
(list :program program :program-args args)))))
((eq current-prefix-arg '-)
(let ((key (completing-read
"Lisp name: " (mapcar (lambda (x)
(list (symbol-name (car x))))
sly-lisp-implementations)
nil t)))
(sly--lookup-lisp-implementation sly-lisp-implementations (intern key))))
(t
(cl-destructuring-bind (program &rest program-args)
(split-string-and-unquote
(read-shell-command "[sly] Run lisp: "
(sly--guess-inferior-lisp-program nil)
'sly-inferior-lisp-program-history))
(let ((coding-system
(if (eq 16 (prefix-numeric-value current-prefix-arg))
(read-coding-system "[sly] Set sly-coding-system: "
sly-net-coding-system)
sly-net-coding-system)))
(list :program program :program-args program-args
:coding-system coding-system))))))
(defun sly--lookup-lisp-implementation (table name)
(let ((arguments (cl-rest (assoc name table))))
(unless arguments
(error "Could not find lisp implementation with the name '%S'" name))
(when (and (= (length arguments) 1)
(functionp (cl-first arguments)))
(setf arguments (funcall (cl-first arguments))))
(cl-destructuring-bind ((prog &rest args) &rest keys) arguments
(cl-list* :name name :program prog :program-args args keys))))
(defun sly-inferior-lisp-buffer (sly-process-or-connection &optional pop-to-buffer)
"Return PROCESS's buffer. With POP-TO-BUFFER, pop to it."
(interactive (list (sly-process) t))
(let ((buffer (cond ((and sly-process-or-connection
(process-get sly-process-or-connection
'sly-inferior-lisp-process))
(process-buffer sly-process-or-connection))
(sly-process-or-connection
;; call ourselves recursively with a
;; sly-started process
;;
(sly-inferior-lisp-buffer (sly-process sly-process-or-connection)
pop-to-buffer )))))
(cond ((and buffer
pop-to-buffer)
(pop-to-buffer buffer))
((and pop-to-buffer
sly-process-or-connection)
(sly-message "No *inferior lisp* process for current connection!"))
(pop-to-buffer
(sly-error "No *inferior lisp* buffer")))
buffer))
(defun sly--guess-inferior-lisp-program (&optional interactive)
"Compute pathname to a seemingly valid lisp implementation.
If ERRORP, error if such a thing cannot be found"
(let ((inferior-lisp-program-and-args
(and inferior-lisp-program
(if (listp inferior-lisp-program)
inferior-lisp-program
(split-string-and-unquote inferior-lisp-program)))))
(if (and inferior-lisp-program-and-args
(executable-find (car inferior-lisp-program-and-args)))
(combine-and-quote-strings inferior-lisp-program-and-args)
(let ((guessed (cl-some #'executable-find
'("lisp" "sbcl" "clisp" "cmucl"
"acl" "alisp"))))
(cond ((and guessed
(or (not interactive)
noninteractive
(sly-y-or-n-p
"Can't find `inferior-lisp-program' (set to `%s'). Use `%s' instead? "
inferior-lisp-program guessed)))
guessed)
(interactive
(sly-error
(substitute-command-keys
"Can't find a suitable Lisp. Use \\[sly-info] to read about `Multiple Lisps'")))
(t
nil))))))
(cl-defun sly-start (&key (program
(sly-error "must supply :program"))
program-args
directory
(coding-system sly-net-coding-system)
(init sly-init-function)
name
(buffer (format "*sly-started inferior-lisp for %s*"
(file-name-nondirectory program)))
init-function
env)
"Start a Lisp process and connect to it.
This function is intended for programmatic use if `sly' is not
flexible enough.
PROGRAM and PROGRAM-ARGS are the filename and argument strings
for the subprocess.
INIT is a function that should return a string to load and start
Slynk. The function will be called with the PORT-FILENAME and ENCODING as
arguments. INIT defaults to `sly-init-function'.
CODING-SYSTEM a symbol for the coding system. The default is
sly-net-coding-system
ENV environment variables for the subprocess (see `process-environment').
INIT-FUNCTION function to call right after the connection is established.
BUFFER the name of the buffer to use for the subprocess.
NAME a symbol to describe the Lisp implementation
DIRECTORY change to this directory before starting the process.
"
(let ((args (list :program program :program-args program-args :buffer buffer
:coding-system coding-system :init init :name name
:init-function init-function :env env)))
(sly-check-coding-system coding-system)
(let ((proc (sly-maybe-start-lisp program program-args env
directory buffer)))
(sly-inferior-connect proc args)
(sly-inferior-lisp-buffer proc))))
;;;###autoload
(defun sly-connect (host port &optional _coding-system interactive-p)
"Connect to a running Slynk server. Return the connection.
With prefix arg, asks if all connections should be closed
before."
(interactive (list (read-from-minibuffer
"[sly] Host: " (cl-first sly-connect-host-history)
nil nil '(sly-connect-host-history . 1))
(string-to-number
(read-from-minibuffer
"[sly] Port: " (cl-first sly-connect-port-history)
nil nil '(sly-connect-port-history . 1)))
nil t))
(when (and interactive-p
sly-net-processes
current-prefix-arg
(sly-y-or-n-p "[sly] Close all connections first? "))
(sly-disconnect-all))
(sly-message "Connecting to Slynk on port %S.." port)
(let* ((process (sly-net-connect host port))
(sly-dispatching-connection process))
(sly-setup-connection process)))
;;;;; Start inferior lisp
;;;
;;; Here is the protocol for starting SLY via `M-x sly':
;;;
;;; 1. Emacs starts an inferior Lisp process.
;;; 2. Emacs tells Lisp (via stdio) to load and start Slynk.
;;; 3. Lisp recompiles the Slynk if needed.
;;; 4. Lisp starts the Slynk server and writes its TCP port to a temp file.
;;; 5. Emacs reads the temp file to get the port and then connects.
;;; 6. Emacs prints a message of warm encouragement for the hacking ahead.
;;;
;;; Between steps 2-5 Emacs polls for the creation of the temp file so
;;; that it can make the connection. This polling may continue for a
;;; fair while if Slynk needs recompilation.
(defvar sly-connect-retry-timer nil
"Timer object while waiting for an inferior-lisp to start.")
(defun sly-abort-connection ()
"Abort connection the current connection attempt."
(interactive)
(cond (sly-connect-retry-timer
(sly-cancel-connect-retry-timer)
(sly-message "Cancelled connection attempt."))
(t (error "Not connecting"))))
;;; Starting the inferior Lisp and loading Slynk:
(defun sly-maybe-start-lisp (program program-args env directory buffer)
"Return a new or existing inferior lisp process."
(cond ((not (comint-check-proc buffer))
(sly-start-lisp program program-args env directory buffer))
(t (sly-start-lisp program program-args env directory
(generate-new-buffer-name buffer)))))
(defvar sly-inferior-process-start-hook nil
"Hook called whenever a new process gets started.")
(defun sly-start-lisp (program program-args env directory buffer)
"Does the same as `inferior-lisp' but less ugly.
Return the created process."
(with-current-buffer (get-buffer-create buffer)
(when directory
(cd (expand-file-name directory)))
(comint-mode)
(let ((process-environment (append env process-environment))
(process-connection-type nil))
(comint-exec (current-buffer) "inferior-lisp" program nil program-args))
(lisp-mode-variables t)
(let ((proc (get-buffer-process (current-buffer))))
(process-put proc 'sly-inferior-lisp-process t)
(set-process-query-on-exit-flag proc (not sly-kill-without-query-p))
(run-hooks 'sly-inferior-process-start-hook)
proc)))
(defun sly-inferior-connect (process args)
"Start a Slynk server in the inferior Lisp and connect."
(sly-delete-slynk-port-file 'quiet)
(sly-start-slynk-server process args)
(sly-read-port-and-connect process))
(defun sly-start-slynk-server (inf-process args)
"Start a Slynk server on the inferior lisp."
(cl-destructuring-bind (&key coding-system init &allow-other-keys) args
(with-current-buffer (process-buffer inf-process)
(process-put inf-process 'sly-inferior-lisp-args args)
(let ((str (funcall init (sly-slynk-port-file) coding-system)))
(goto-char (process-mark inf-process))
(insert-before-markers str)
(process-send-string inf-process str)))))
(defun sly-inferior-lisp-args (inf-process)
"Return the initial process arguments.
See `sly-start'."
(process-get inf-process 'sly-inferior-lisp-args))
(defun sly-init-using-asdf (port-filename coding-system)
"Return a string to initialize Lisp using ASDF.
Fall back to `sly-init-using-slynk-loader' if ASDF fails."
(format "%S\n\n"
`(cond ((ignore-errors
(funcall 'require "asdf")
(funcall (read-from-string "asdf:version-satisfies")
(funcall (read-from-string "asdf:asdf-version"))
"2.019"))
(push (pathname ,(sly-to-lisp-filename (sly-slynk-path)))
(symbol-value
(read-from-string "asdf:*central-registry*")))
(funcall
(read-from-string "asdf:load-system")
:slynk)
(funcall
(read-from-string "slynk:start-server")
,(sly-to-lisp-filename port-filename)))
(t
,(read (sly-init-using-slynk-loader port-filename
coding-system))))))
;; XXX load-server & start-server used to be separated. maybe that was better.
(defun sly-init-using-slynk-loader (port-filename _coding-system)
"Return a string to initialize Lisp."
(let ((loader (sly-to-lisp-filename
(expand-file-name sly-slynk-loader-backend (sly-slynk-path)))))
;; Return a single form to avoid problems with buffered input.
(format "%S\n\n"
`(progn
(load ,loader :verbose t)
(funcall (read-from-string "slynk-loader:init"))
(funcall (read-from-string "slynk:start-server")
,port-filename)))))
(defun sly-slynk-port-file ()
"Filename where the SLYNK server writes its TCP port number."
(expand-file-name (format "sly.%S" (emacs-pid)) (sly-temp-directory)))
(defun sly-temp-directory ()
(cond ((fboundp 'temp-directory) (temp-directory))
((boundp 'temporary-file-directory) temporary-file-directory)
(t "/tmp/")))
(defun sly-delete-slynk-port-file (&optional quiet)
(condition-case data
(delete-file (sly-slynk-port-file))
(error
(cl-ecase quiet
((nil) (signal (car data) (cdr data)))
(quiet)
(sly-message (sly-message "Unable to delete slynk port file %S"
(sly-slynk-port-file)))))))
(defun sly-read-port-and-connect (inferior-process)
(sly-attempt-connection inferior-process nil 1))
(defcustom sly-connection-poll-interval 0.3
"Seconds to wait between connection attempts when first connecting."
:type 'number
:group 'sly-ui)
(defun sly-attempt-connection (process retries attempt)
;; A small one-state machine to attempt a connection with
;; timer-based retries.
(sly-cancel-connect-retry-timer)
(let ((file (sly-slynk-port-file)))
(unless (active-minibuffer-window)
(sly-message "Polling %S .. %d (Abort with `M-x sly-abort-connection'.)"
file attempt))
(cond ((and (file-exists-p file)
(> (nth 7 (file-attributes file)) 0)) ; file size
(let ((port (sly-read-slynk-port))
(args (sly-inferior-lisp-args process)))
(sly-delete-slynk-port-file 'message)
(let ((c (sly-connect sly-lisp-host port
(plist-get args :coding-system))))
(sly-set-inferior-process c process))))
((and retries (zerop retries))
(sly-message "Gave up connecting to Slynk after %d attempts." attempt))
((eq (process-status process) 'exit)
(sly-message "Failed to connect to Slynk: inferior process exited."))
(t
(when (and (file-exists-p file)
(zerop (nth 7 (file-attributes file))))
(sly-message "(Zero length port file)")
;; the file may be in the filesystem but not yet written
(unless retries (setq retries 3)))
(cl-assert (not sly-connect-retry-timer))
(setq sly-connect-retry-timer
(run-with-timer
sly-connection-poll-interval nil
(lambda ()
(let ((sly-ignore-protocol-mismatches
sly-ignore-protocol-mismatches))
(sly-attempt-connection process (and retries (1- retries))
(1+ attempt))))))))))
(defun sly-cancel-connect-retry-timer ()
(when sly-connect-retry-timer
(cancel-timer sly-connect-retry-timer)
(setq sly-connect-retry-timer nil)))
(defun sly-read-slynk-port ()
"Read the Slynk server port number from the `sly-slynk-port-file'."
(save-excursion
(with-temp-buffer
(insert-file-contents (sly-slynk-port-file))
(goto-char (point-min))
(let ((port (read (current-buffer))))
(cl-assert (integerp port))
port))))
(defun sly-toggle-debug-on-slynk-error ()
(interactive)
(if (sly-eval `(slynk:toggle-debug-on-slynk-error))
(sly-message "Debug on SLYNK error enabled.")
(sly-message "Debug on SLYNK error disabled.")))
;;; Words of encouragement
(defun sly-user-first-name ()
(let ((name (if (string= (user-full-name) "")
(user-login-name)
(user-full-name))))
(string-match "^[^ ]*" name)
(capitalize (match-string 0 name))))
(defvar sly-words-of-encouragement
`("Let the hacking commence!"
"Hacks and glory await!"
"Hack and be merry!"
"Your hacking starts... NOW!"
"May the source be with you!"
"Take this REPL, brother, and may it serve you well."
"Lemonodor-fame is but a hack away!"
"Are we consing yet?"
,(format "%s, this could be the start of a beautiful program."
(sly-user-first-name)))
"Scientifically-proven optimal words of hackerish encouragement.")
(defun sly-random-words-of-encouragement ()
"Return a string of hackerish encouragement."
(eval (nth (random (length sly-words-of-encouragement))
sly-words-of-encouragement)
t))
;;;; Networking
;;;
;;; This section covers the low-level networking: establishing
;;; connections and encoding/decoding protocol messages.
;;;
;;; Each SLY protocol message beings with a 6-byte header followed
;;; by an S-expression as text. The sexp must be readable both by
;;; Emacs and by Common Lisp, so if it contains any embedded code
;;; fragments they should be sent as strings:
;;;
;;; The set of meaningful protocol messages are not specified
;;; here. They are defined elsewhere by the event-dispatching
;;; functions in this file and in slynk.lisp.
(defvar sly-net-processes nil
"List of processes (sockets) connected to Lisps.")
(defvar sly-net-process-close-hooks '()
"List of functions called when a sly network connection closes.
The functions are called with the process as their argument.")
(defun sly-secret ()
"Find the magic secret from the user's home directory.
Return nil if the file doesn't exist or is empty; otherwise the
first line of the file."
(condition-case _err
(with-temp-buffer
(insert-file-contents "~/.sly-secret")
(goto-char (point-min))
(buffer-substring (point-min) (line-end-position)))
(file-error nil)))
;;; Interface
(defvar sly--net-connect-counter 0)
(defun sly-send-secret (proc)
(sly--when-let (secret (sly-secret))
(let* ((payload (encode-coding-string secret 'utf-8-unix))
(string (concat (sly-net-encode-length (length payload))
payload)))
(process-send-string proc string))))
(defun sly-net-connect (host port)
"Establish a connection with a CL."
(let* ((inhibit-quit nil)
(name (format "sly-%s" (cl-incf sly--net-connect-counter)))
(connection (open-network-stream name nil host port))
(buffer (sly-make-net-buffer (format " *%s*" name))))
(push connection sly-net-processes)
(set-process-plist connection `(sly--net-connect-counter
,sly--net-connect-counter))
(set-process-buffer connection buffer)
(set-process-filter connection 'sly-net-filter)
(set-process-sentinel connection 'sly-net-sentinel)
(set-process-query-on-exit-flag connection (not sly-kill-without-query-p))
(when (fboundp 'set-process-coding-system)
(set-process-coding-system connection 'binary 'binary))
(sly-send-secret connection)
connection))
(defun sly-make-net-buffer (name)
"Make a buffer suitable for a network process."
(let ((buffer (generate-new-buffer name)))
(with-current-buffer buffer
(buffer-disable-undo)
(set (make-local-variable 'kill-buffer-query-functions) nil))
buffer))
;;;;; Coding system madness
(defun sly-check-coding-system (coding-system)
"Signal an error if CODING-SYSTEM isn't a valid coding system."
(interactive)
(let ((props (sly-find-coding-system coding-system)))
(unless props
(error "Invalid sly-net-coding-system: %s. %s"
coding-system (mapcar #'car sly-net-valid-coding-systems)))
(when (and (cl-second props) (boundp 'default-enable-multibyte-characters))
(cl-assert default-enable-multibyte-characters))
t))
(defun sly-coding-system-mulibyte-p (coding-system)
(cl-second (sly-find-coding-system coding-system)))
(defun sly-coding-system-cl-name (coding-system)
(cl-third (sly-find-coding-system coding-system)))
;;; Interface
(defvar sly-net-send-translator nil
"If non-nil, function to translate outgoing sexps for the wire.")
(defun sly--sanitize-or-lose (form)
"Sanitize FORM for Slynk or error."
(cl-typecase form
(number)
(symbol 'fonix)
(string (set-text-properties 0 (length form) nil form))
(cons (sly--sanitize-or-lose (car form))
(sly--sanitize-or-lose (cdr form)))
(t (sly-error "Can't serialize %s for Slynk." form)))
form)
(defun sly-net-send (sexp proc)
"Send a SEXP to Lisp over the socket PROC.
This is the lowest level of communication. The sexp will be READ and
EVAL'd by Lisp."
(let* ((print-circle nil)
(print-quoted nil)
(sexp (sly--sanitize-or-lose sexp))
(sexp (if (and sly-net-send-translator
(fboundp sly-net-send-translator))
(funcall sly-net-send-translator sexp)
sexp))
(payload (encode-coding-string
(concat (sly-prin1-to-string sexp) "\n")
'utf-8-unix))
(string (concat (sly-net-encode-length (length payload))
payload)))
(sly-log-event sexp proc)
(process-send-string proc string)))
(defun sly-safe-encoding-p (coding-system string)
"Return true iff CODING-SYSTEM can safely encode STRING."
(or (let ((candidates (find-coding-systems-string string))
(base (coding-system-base coding-system)))
(or (equal candidates '(undecided))
(memq base candidates)))
(and (not (multibyte-string-p string))
(not (sly-coding-system-mulibyte-p coding-system)))))
(defun sly-net-close (connection reason &optional debug _force)
"Close the network connection CONNECTION because REASON."
(process-put connection 'sly-net-close-reason reason)
(setq sly-net-processes (remove connection sly-net-processes))
(when (eq connection sly-default-connection)
(setq sly-default-connection nil))
;; Run hooks
;;
(unless debug
(run-hook-with-args 'sly-net-process-close-hooks connection))
;; We close the socket connection by killing its hidden
;; *sly-<number>* buffer, but we first unset the connection's
;; sentinel otherwise we could get a second `sly-net-close' call. In
;; case the buffer is already killed (we killed it manually), this
;; function is probably running as a result of that, and rekilling
;; it is harmless.
;;
(set-process-sentinel connection nil)
(when debug
(set-process-filter connection nil))
(if debug
(delete-process connection) ; leave the buffer
(kill-buffer (process-buffer connection))))
(defun sly-net-sentinel (process message)
(let ((reason (format "Lisp connection closed unexpectedly: %s" message)))
(sly-message reason)
(sly-net-close process reason)))
;;; Socket input is handled by `sly-net-filter', which decodes any
;;; complete messages and hands them off to the event dispatcher.
(defun sly-net-filter (process string)
"Accept output from the socket and process all complete messages."
(with-current-buffer (process-buffer process)
(goto-char (point-max))
(insert string))
(sly-process-available-input process))
(defun sly-process-available-input (process)
"Process all complete messages that have arrived from Lisp."
(with-current-buffer (process-buffer process)
(while (sly-net-have-input-p)
(let ((event (sly-net-read-or-lose process))
(ok nil))
(sly-log-event event process)
(unwind-protect
(save-current-buffer
(sly-dispatch-event event process)
(setq ok t))
(unless ok
(run-at-time 0 nil 'sly-process-available-input process)))))))
(defsubst sly-net-decode-length ()
(string-to-number (buffer-substring (point) (+ (point) 6))
16))
(defun sly-net-have-input-p ()
"Return true if a complete message is available."
(goto-char (point-min))
(and (>= (buffer-size) 6)
(>= (- (buffer-size) 6) (sly-net-decode-length))))
(defun sly-handle-net-read-error (error)
(let ((packet (buffer-string)))
(sly-with-popup-buffer ((sly-buffer-name :error
:connection (get-buffer-process (current-buffer))))
(princ (format "%s\nin packet:\n%s" (error-message-string error) packet))
(goto-char (point-min)))
(cond ((sly-y-or-n-p "Skip this packet? ")
`(:emacs-skipped-packet ,packet))
(t
(when (sly-y-or-n-p "Enter debugger instead? ")
(debug 'error error))
(signal (car error) (cdr error))))))
(defun sly-net-read-or-lose (process)
(condition-case error
(sly-net-read)
(error
(sly-net-close process "Fatal net-read error" t)
(error "net-read error: %S" error))))
(defun sly-net-read ()
"Read a message from the network buffer."
(goto-char (point-min))
(let* ((length (sly-net-decode-length))
(start (+ (point) 6))
(end (+ start length)))
(cl-assert (cl-plusp length))
(prog1 (save-restriction
(narrow-to-region start end)
(condition-case error
(progn
(decode-coding-region start end 'utf-8-unix)
(setq end (point-max))
(read (current-buffer)))
(error
(sly-handle-net-read-error error))))
(delete-region (point-min) end))))
(defun sly-net-encode-length (n)
(format "%06x" n))
(defun sly-prin1-to-string (sexp)
"Like `prin1-to-string' but don't octal-escape non-ascii characters.
This is more compatible with the CL reader."
(let (print-escape-nonascii
print-escape-newlines
print-length
print-level)
(prin1-to-string sexp)))
;;;; Connections
;;;
;;; "Connections" are the high-level Emacs<->Lisp networking concept.
;;;
;;; Emacs has a connection to each Lisp process that it's interacting
;;; with. Typically there would only be one, but a user can choose to
;;; connect to many Lisps simultaneously.
;;;
;;; A connection consists of a control socket, optionally an extra
;;; socket dedicated to receiving Lisp output (an optimization), and a
;;; set of connection-local state variables.
;;;
;;; The state variables are stored as buffer-local variables in the
;;; control socket's process-buffer and are used via accessor
;;; functions. These variables include things like the *FEATURES* list
;;; and Unix Pid of the Lisp process.
;;;
;;; One connection is "current" at any given time. This is:
;;; `sly-dispatching-connection' if dynamically bound, or
;;; `sly-buffer-connection' if this is set buffer-local, or
;;; `sly-default-connection' otherwise.
;;;
;;; When you're invoking commands in your source files you'll be using
;;; `sly-default-connection'. This connection can be interactively
;;; reassigned via the connection-list buffer.
;;;
;;; When a command creates a new buffer it will set
;;; `sly-buffer-connection' so that commands in the new buffer will
;;; use the connection that the buffer originated from. For example,
;;; the apropos command creates the *Apropos* buffer and any command
;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the
;;; apropos search. REPL buffers are similarly tied to their
;;; respective connections.
;;;
;;; When Emacs is dispatching some network message that arrived from a
;;; connection it will dynamically bind `sly-dispatching-connection'
;;; so that the event will be processed in the context of that
;;; connection.
;;;
;;; This is mostly transparent. The user should be aware that he can
;;; set the default connection to pick which Lisp handles commands in
;;; Lisp-mode source buffers, and sly hackers should be aware that
;;; they can tie a buffer to a specific connection. The rest takes
;;; care of itself.
(defvar sly-dispatching-connection nil
"Network process currently executing.
This is dynamically bound while handling messages from Lisp; it
overrides `sly-buffer-connection' and `sly-default-connection'.")
(make-variable-buffer-local
(defvar sly-buffer-connection nil
"Network connection to use in the current buffer.
This overrides `sly-default-connection'."))
(defvar sly-default-connection nil
"Network connection to use by default.
Used for all Lisp communication, except when overridden by
`sly-dispatching-connection' or `sly-buffer-connection'.")
(defun sly-current-connection ()
"Return the connection to use for Lisp interaction.
Return nil if there's no connection."
(or sly-dispatching-connection
sly-buffer-connection
sly-default-connection))
(defun sly-connection ()
"Return the connection to use for Lisp interaction.
Signal an error if there's no connection."
(let ((conn (sly-current-connection)))
(cond ((and (not conn) sly-net-processes)
(or (sly-auto-select-connection)
(error "Connections available, but none selected.")))
((not conn)
(or (sly-auto-start)
(error "No current SLY connection.")))
((not (process-live-p conn))
(error "Current connection %s is closed." conn))
(t conn))))
(define-obsolete-variable-alias 'sly-auto-connect
'sly-auto-start "2.5")
(defcustom sly-auto-start 'never
"Controls auto connection when information from lisp process is needed.
This doesn't mean it will connect right after SLY is loaded."
:group 'sly-mode
:type '(choice (const never)
(const always)
(const ask)))
(defun sly-auto-start ()
(cond ((or (eq sly-auto-start 'always)
(and (eq sly-auto-start 'ask)
(sly-y-or-n-p "No connection. Start SLY? ")))
(save-window-excursion
(sly)
(while (not (sly-current-connection))
(sleep-for 1))
(sly-connection)))
(t nil)))
(cl-defmacro sly-with-connection-buffer ((&optional process) &rest body)
"Execute BODY in the process-buffer of PROCESS.
If PROCESS is not specified, `sly-connection' is used.
\(fn (&optional PROCESS) &body BODY))"
(declare (indent 1))
`(with-current-buffer
(process-buffer (or ,process (sly-connection)
(error "No connection")))
,@body))
;;; Connection-local variables:
(defmacro sly-def-connection-var (varname &rest initial-value-and-doc)
"Define a connection-local variable.
The value of the variable can be read by calling the function of the
same name (it must not be accessed directly). The accessor function is
setf-able.
The actual variable bindings are stored buffer-local in the
process-buffers of connections. The accessor function refers to
the binding for `sly-connection'."
(declare (indent 2))
`(progn
;; Accessor
(defun ,varname (&optional process)
,(cl-second initial-value-and-doc)
(let ((process (or process
(sly-current-connection)
(error "Can't access prop %s for no connection" ',varname))))
(or (process-get process ',varname)
(let ((once ,(cl-first initial-value-and-doc)))
(process-put process ',varname once)
once))))
;; Setf
(gv-define-setter ,varname (store &optional process)
`(let ((process (or ,process
(sly-current-connection)
(error "Can't access prop %s for no connection" ',',varname)))
(store-once ,store))
(process-put process ',',varname store-once)
store-once))
'(\, varname)))
(sly-def-connection-var sly-connection-number nil
"Serial number of a connection.
Bound in the connection's process-buffer.")
(sly-def-connection-var sly-lisp-features '()
"The symbol-names of Lisp's *FEATURES*.
This is automatically synchronized from Lisp.")
(sly-def-connection-var sly-lisp-modules '()
"The strings of Lisp's *MODULES*.")
(sly-def-connection-var sly-pid nil
"The process id of the Lisp process.")
(sly-def-connection-var sly-lisp-implementation-type nil
"The implementation type of the Lisp process.")
(sly-def-connection-var sly-lisp-implementation-version nil
"The implementation type of the Lisp process.")
(sly-def-connection-var sly-lisp-implementation-name nil
"The short name for the Lisp implementation.")
(sly-def-connection-var sly-lisp-implementation-program nil
"The argv[0] of the process running the Lisp implementation.")
(sly-def-connection-var sly-connection-name nil
"The short name for connection.")
(sly-def-connection-var sly-inferior-process nil
"The inferior process for the connection if any.")
(sly-def-connection-var sly-communication-style nil
"The communication style.")
(sly-def-connection-var sly-machine-instance nil
"The name of the (remote) machine running the Lisp process.")
(sly-def-connection-var sly-connection-coding-systems nil
"Coding systems supported by the Lisp process.")
;;;;; Connection setup
(defvar sly-connection-counter 0
"The number of SLY connections made. For generating serial numbers.")
;;; Interface
(defun sly-setup-connection (process)
"Make a connection out of PROCESS."
(let ((sly-dispatching-connection process))
(sly-init-connection-state process)
(sly-select-connection process)
(sly--setup-contribs)
process))
(defun sly-init-connection-state (proc)
"Initialize connection state in the process-buffer of PROC."
;; To make life simpler for the user: if this is the only open
;; connection then reset the connection counter.
(when (equal sly-net-processes (list proc))
(setq sly-connection-counter 0))
(sly-with-connection-buffer ()
(setq sly-buffer-connection proc))
(setf (sly-connection-number proc) (cl-incf sly-connection-counter))
;; We do the rest of our initialization asynchronously. The current
;; function may be called from a timer, and if we setup the REPL
;; from a timer then it mysteriously uses the wrong keymap for the
;; first command.
(let ((sly-current-thread t))
(sly-eval-async '(slynk:connection-info)
(sly-curry #'sly-set-connection-info proc)
nil
`((sly-ignore-protocol-mismatches . ,sly-ignore-protocol-mismatches)))))
(defun sly--trampling-rename-buffer (newname)
"Rename current buffer NEWNAME, trampling over existing ones."
(let ((existing (get-buffer newname)))
(unless (eq existing
(current-buffer))
;; Trample over any existing buffers on reconnection
(when existing
(let ((kill-buffer-query-functions nil))
(kill-buffer existing)))
(rename-buffer newname))))
(defun sly-set-connection-info (connection info)
"Initialize CONNECTION with INFO received from Lisp."
(let ((sly-dispatching-connection connection)
(sly-current-thread t))
(cl-destructuring-bind (&key pid style lisp-implementation machine
features version modules encoding
&allow-other-keys) info
(sly-check-version version connection)
(setf (sly-pid) pid
(sly-communication-style) style
(sly-lisp-features) features
(sly-lisp-modules) modules)
(cl-destructuring-bind (&key type name version program)
lisp-implementation
(setf (sly-lisp-implementation-type) type
(sly-lisp-implementation-version) version
(sly-lisp-implementation-name) name
(sly-lisp-implementation-program) program
(sly-connection-name) (sly-generate-connection-name name)))
(cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine
(setf (sly-machine-instance) instance))
(cl-destructuring-bind (&key coding-systems) encoding
(setf (sly-connection-coding-systems) coding-systems)))
(let ((args (sly--when-let (p (sly-inferior-process))
(sly-inferior-lisp-args p))))
(sly--when-let (name (plist-get args ':name))
(unless (string= (sly-lisp-implementation-name) name)
(setf (sly-connection-name)
(sly-generate-connection-name (symbol-name name)))))
(sly-contrib--load-slynk-dependencies)
(run-hooks 'sly-connected-hook)
(sly--when-let (fun (plist-get args ':init-function))
(funcall fun)))
;; Give the events buffer its final name
(with-current-buffer (sly--events-buffer connection)
(sly--trampling-rename-buffer (sly-buffer-name
:events
:connection connection)))
;; Rename the inferior lisp buffer if there is one (i.e. when
;; started via `M-x sly')
;;
(let ((inferior-lisp-buffer (sly-inferior-lisp-buffer
(sly-process connection))))
(when inferior-lisp-buffer
(with-current-buffer inferior-lisp-buffer
(sly--trampling-rename-buffer (sly-buffer-name
:inferior-lisp
:connection connection)))))
(sly-message "Connected. %s" (sly-random-words-of-encouragement))))
(defun sly-check-version (version conn)
(or (equal version sly-protocol-version)
(null sly-protocol-version)
sly-ignore-protocol-mismatches
(sly-y-or-n-p
(format "Versions differ: %s (sly) vs. %s (slynk). Continue? "
sly-protocol-version version))
(sly-net-close conn "Versions differ")
(top-level)))
(defun sly-generate-connection-name (lisp-name)
(when (file-exists-p lisp-name)
(setq lisp-name (file-name-nondirectory lisp-name)))
(cl-loop for i from 1
for name = lisp-name then (format "%s<%d>" lisp-name i)
while (cl-find name sly-net-processes
:key #'sly-connection-name :test #'equal)
finally (cl-return name)))
(defun sly-select-new-default-connection (conn)
"If dead CONN was the default connection, select a new one."
(when (eq conn sly-default-connection)
(when sly-net-processes
(sly-select-connection (car sly-net-processes))
(sly-message "Default connection closed; default is now #%S (%S)"
(sly-connection-number)
(sly-connection-name)))))
(defcustom sly-keep-buffers-on-connection-close '(:mrepl)
"List of buffers to keep around after a connection closes."
:group 'sly-mode
:type '(repeat
(choice
(const :tag "Debugger" :db)
(const :tag "Repl" :mrepl)
(const :tag "Ispector" :inspector)
(const :tag "Stickers replay" :stickers-replay)
(const :tag "Error" :error)
(const :tag "Source" :source)
(const :tag "Compilation" :compilation)
(const :tag "Apropos" :apropos)
(const :tag "Xref" :xref)
(const :tag "Macroexpansion" :macroexpansion)
(symbol :tag "Other"))))
(defun sly-kill-stale-connection-buffers (conn) ;
"If CONN had some stale buffers, kill them.
Respect `sly-keep-buffers-on-connection-close'."
(let ((buffer-list (buffer-list))
(matchers
(mapcar
(lambda (type)
(format ".*%s.*$"
;; XXX: this is synched with `sly-buffer-name'.
(regexp-quote (format "*sly-%s"
(downcase (substring (symbol-name type)
1))))))
(cl-set-difference '(:db
:mrepl
:inspector
:stickers-replay
:error
:source
:compilation
:apropos
:xref
:macroexpansion)
sly-keep-buffers-on-connection-close))))
(cl-loop for buffer in buffer-list
when (and (cl-some (lambda (matcher)
(string-match matcher (buffer-name buffer)))
matchers)
(with-current-buffer buffer
(eq sly-buffer-connection conn)))
do (kill-buffer buffer))))
(add-hook 'sly-net-process-close-hooks 'sly-select-new-default-connection)
(add-hook 'sly-net-process-close-hooks 'sly-kill-stale-connection-buffers 'append)
;;;;; Commands on connections
(defun sly--purge-connections ()
"Purge `sly-net-processes' of dead processes, return living."
(cl-loop for process in sly-net-processes
if (process-live-p process)
collect process
else do
(sly-warning "process %s in `sly-net-processes' dead. Force closing..." process)
(sly-net-close process "process state invalid" nil t)))
(defun sly-prompt-for-connection (&optional prompt connections dont-require-match)
(let* ((connections (or connections (sly--purge-connections)))
(connection-names (cl-loop for process in
(sort connections
#'(lambda (p1 _p2)
(eq p1 (sly-current-connection))))
collect (sly-connection-name process)))
(connection-names (if dont-require-match
(cons dont-require-match
connection-names)
connection-names))
(connection-name (and connection-names
(completing-read
(or prompt "Connection: ")
connection-names
nil (not dont-require-match))))
(target (cl-find connection-name sly-net-processes :key #'sly-connection-name
:test #'string=)))
(cond (target target)
((and dont-require-match (or (zerop (length connection-name))
(string= connection-name dont-require-match)))
nil)
(connection-name
(sly-error "No such connection"))
(t
(sly-error "No connections")))))
(defun sly-auto-select-connection ()
(let* ((c0 (car (sly--purge-connections)))
(c (cond ((eq sly-auto-select-connection 'always) c0)
((and (eq sly-auto-select-connection 'ask)
(sly-prompt-for-connection "Choose a new default connection: "))))))
(when c
(sly-select-connection c)
(sly-message "Switching to connection: %s" (sly-connection-name c))
c)))
(defvar sly-select-connection-hook nil)
(defun sly-select-connection (process)
"Make PROCESS the default connection."
(setq sly-default-connection process)
(run-hooks 'sly-select-connection-hook))
(define-obsolete-function-alias 'sly-cycle-connections 'sly-next-connection "1.0.0-beta")
(defun sly-next-connection (arg &optional dont-wrap)
"Switch to the next SLY connection, cycling through all connections.
Skip ARG-1 connections. Negative ARG means cycle back. DONT-WRAP
means don't wrap around when last connection is reached."
(interactive "p")
(cl-labels ((connection-full-name
(c)
(format "%s %s" (sly-connection-name c) (process-contact c))))
(cond ((not sly-net-processes)
(sly-error "No connections to cycle"))
((null (cdr sly-net-processes))
(sly-message "Only one connection: %s" (connection-full-name (car sly-net-processes))))
(t
(let* ((dest (append (member (sly-current-connection)
sly-net-processes)
(unless dont-wrap sly-net-processes)))
(len (length sly-net-processes))
(target (nth (mod arg len)
dest)))
(unless target
(sly-error "No more connections"))
(sly-select-connection target)
(if (and sly-buffer-connection
(not (eq sly-buffer-connection target)))
(sly-message "switched to: %s but buffer remains in: %s"
(connection-full-name target)
(connection-full-name sly-buffer-connection))
(sly-message "switched to: %s (%s/%s)" (connection-full-name target)
(1+ (cl-position target sly-net-processes))
len))
(sly--refresh-mode-line))))))
(defun sly-prev-connection (arg &optional dont-wrap)
"Switch to the previous SLY connection, cycling through all connections.
See `sly-next-connection' for other args."
(interactive "p")
(sly-next-connection (- arg) dont-wrap))
(defun sly-disconnect (&optional interactive)
"Close the current connection."
(interactive (list t))
(let ((connection (if interactive
(sly-prompt-for-connection "Connection to disconnect: ")
(sly-current-connection))))
(sly-net-close connection "Disconnecting")))
(defun sly-disconnect-all ()
"Disconnect all connections."
(interactive)
(mapc #'(lambda (process)
(sly-net-close process "Disconnecting all connections"))
sly-net-processes))
(defun sly-connection-port (connection)
"Return the remote port number of CONNECTION."
(cadr (process-contact connection)))
(defun sly-process (&optional connection)
"Return the Lisp process for CONNECTION (default `sly-connection').
Return nil if there's no process object for the connection."
(let ((proc (sly-inferior-process connection)))
(if (and proc
(memq (process-status proc) '(run stop)))
proc)))
;; Non-macro version to keep the file byte-compilable.
(defun sly-set-inferior-process (connection process)
(setf (sly-inferior-process connection) process))
(defun sly-use-sigint-for-interrupt (&optional connection)
(let ((c (or connection (sly-connection))))
(cl-ecase (sly-communication-style c)
((:fd-handler nil) t)
((:spawn :sigio) nil))))
(defvar sly-inhibit-pipelining t
"*If true, don't send background requests if Lisp is already busy.")
(defun sly-background-activities-enabled-p ()
(and (let ((con (sly-current-connection)))
(and con
(eq (process-status con) 'open)))
(or (not (sly-busy-p))
(not sly-inhibit-pipelining))))
;;;; Communication protocol
;;;;; Emacs Lisp programming interface
;;;
;;; The programming interface for writing Emacs commands is based on
;;; remote procedure calls (RPCs). The basic operation is to ask Lisp
;;; to apply a named Lisp function to some arguments, then to do
;;; something with the result.
;;;
;;; Requests can be either synchronous (blocking) or asynchronous
;;; (with the result passed to a callback/continuation function). If
;;; an error occurs during the request then the debugger is entered
;;; before the result arrives -- for synchronous evaluations this
;;; requires a recursive edit.
;;;
;;; You should use asynchronous evaluations (`sly-eval-async') for
;;; most things. Reserve synchronous evaluations (`sly-eval') for
;;; the cases where blocking Emacs is really appropriate (like
;;; completion) and that shouldn't trigger errors (e.g. not evaluate
;;; user-entered code).
;;;
;;; We have the concept of the "current Lisp package". RPC requests
;;; always say what package the user is making them from and the Lisp
;;; side binds that package to *BUFFER-PACKAGE* to use as it sees
;;; fit. The current package is defined as the buffer-local value of
;;; `sly-buffer-package' if set, and otherwise the package named by
;;; the nearest IN-PACKAGE as found by text search (cl-first backwards,
;;; then forwards).
;;;
;;; Similarly we have the concept of the current thread, i.e. which
;;; thread in the Lisp process should handle the request. The current
;;; thread is determined solely by the buffer-local value of
;;; `sly-current-thread'. This is usually bound to t meaning "no
;;; particular thread", but can also be used to nominate a specific
;;; thread. The REPL and the debugger both use this feature to deal
;;; with specific threads.
(make-variable-buffer-local
(defvar sly-current-thread t
"The id of the current thread on the Lisp side.
t means the \"current\" thread;
fixnum a specific thread."))
(make-variable-buffer-local
(defvar sly-buffer-package nil
"The Lisp package associated with the current buffer.
This is set only in buffers bound to specific packages."))
;;; `sly-rex' is the RPC primitive which is used to implement both
;;; `sly-eval' and `sly-eval-async'. You can use it directly if
;;; you need to, but the others are usually more convenient.
(defvar sly-rex-extra-options-functions nil
"Functions returning extra options to send with `sly-rex'.")
(cl-defmacro sly-rex ((&rest _)
(sexp &optional
(package '(sly-current-package))
(thread 'sly-current-thread))
&rest continuations)
"(sly-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)
Remote EXecute SEXP.
SEXP is evaluated and the princed version is sent to Lisp.
PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
The default value is (sly-current-package).
CLAUSES is a list of patterns with same syntax as
`sly-dcase'. The result of the evaluation of SEXP is
dispatched on CLAUSES. The result is either a sexp of the
form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed
asynchronously.
Note: don't use backquote syntax for SEXP, because various Emacs
versions cannot deal with that."
(declare (indent 2)
(debug (sexp (form &optional sexp sexp)
&rest (sexp &rest form))))
(let ((result (cl-gensym)))
`(sly-dispatch-event
(cl-list* :emacs-rex ,sexp ,package ,thread
(lambda (,result)
(sly-dcase ,result
,@continuations))
(cl-loop for fn in sly-rex-extra-options-functions
append (funcall fn))))))
;;; Interface
(defun sly-current-package ()
"Return the Common Lisp package in the current context.
If `sly-buffer-package' has a value then return that, otherwise
search for and read an `in-package' form."
(or sly-buffer-package
(save-restriction
(widen)
(sly-find-buffer-package))))
(defvar sly-find-buffer-package-function 'sly-search-buffer-package
"*Function to use for `sly-find-buffer-package'.
The result should be the package-name (a string)
or nil if nothing suitable can be found.")
(defun sly-find-buffer-package ()
"Figure out which Lisp package the current buffer is associated with."
(funcall sly-find-buffer-package-function))
(make-variable-buffer-local
(defvar sly-package-cache nil
"Cons of the form (buffer-modified-tick . package)"))
;; When modifing this code consider cases like:
;; (in-package #.*foo*)
;; (in-package #:cl)
;; (in-package :cl)
;; (in-package "CL")
;; (in-package |CL|)
;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp)
(defun sly-search-buffer-package ()
(let ((case-fold-search t)
(regexp (concat "^[ \t]*(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
"\\([^)]+\\)[ \t]*)")))
(save-excursion
(when (or (re-search-backward regexp nil t)
(re-search-forward regexp nil t))
(match-string-no-properties 2)))))
;;; Synchronous requests are implemented in terms of asynchronous
;;; ones. We make an asynchronous request with a continuation function
;;; that `throw's its result up to a `catch' and then enter a loop of
;;; handling I/O until that happens.
(defvar sly--stack-eval-tags nil
"List of stack-tags of waiting on the elisp stack.
This is used by the sly-db debugger to decide whether to enter a
`recursive-edit', so that if a synchronous `sly-eval' request
errors and brings us a Slynk debugger, we can fix the error,
invoke a restart and still get the return value of the `sly-eval'
as if nothing had happened.")
(defun sly-eval (sexp &optional package cancel-on-input cancel-on-input-retval)
"Evaluate SEXP in Slynk's PACKAGE and return the result.
If CANCEL-ON-INPUT cancel the request immediately if the user
wants to input, and return CANCEL-ON-INPUT-RETVAL."
(when (null package) (setq package (sly-current-package)))
(let* ((catch-tag (make-symbol (format "sly-result-%d"
(sly-continuation-counter))))
(sly--stack-eval-tags (cons catch-tag sly--stack-eval-tags))
(cancelled nil)
(check-conn
(lambda ()
(unless (eq (process-status (sly-connection)) 'open)
(error "Lisp connection closed unexpectedly"))))
(retval
(unwind-protect
(catch catch-tag
(sly-rex ()
(sexp package)
((:ok value)
(unless cancelled
(unless (member catch-tag sly--stack-eval-tags)
(error "Reply to nested `sly-eval' request with tag=%S sexp=%S"
catch-tag sexp))
(throw catch-tag (list #'identity value))))
((:abort _condition)
(unless cancelled
(throw catch-tag
(list #'error "Synchronous Lisp Evaluation aborted")))))
(cond (cancel-on-input
;; Setting `inhibit-quit' to t helps with
;; callers that wrap us in `while-no-input',
;; like `fido-mode' and Helm. It doesn't seem
;; to create any specific problems, since
;; `sit-for' exits immediately given input
;; anyway. This include the C-g input, and
;; thus even with `inhibit-quit' set to t, quit
;; happens immediately.
(unwind-protect
(let ((inhibit-quit t)) (while (sit-for 30)))
(setq cancelled t))
(funcall check-conn))
(t
(while t
(funcall check-conn)
(accept-process-output nil 30))))
(list #'identity cancel-on-input-retval))
;; Protect against user quit during
;; `accept-process-output' or `sit-for', so that if the
;; Lisp is alive and replies, we don't get an error.
(setq cancelled t))))
(apply (car retval) (cdr retval))))
(defun sly-eval-async (sexp &optional cont package env)
"Evaluate SEXP on the superior Lisp and call CONT with the result.
CONT is called with the overriding dynamic environment in ENV, an
alist of bindings"
(declare (indent 1))
(let ((buffer (current-buffer)))
(sly-rex ()
(sexp (or package (sly-current-package)))
((:ok result)
(when cont
(set-buffer buffer)
(cl-progv (mapcar #'car env) (mapcar #'cdr env)
(if debug-on-error
(funcall cont result)
(condition-case err
(funcall cont result)
(error
(sly-message "`sly-eval-async' errored: %s"
(if (and (eq 'error (car err))
(stringp (cadr err)))
(cadr err)
err))))))))
((:abort condition)
(sly-message "Evaluation aborted on %s." condition))))
;; Guard against arbitrary return values which once upon a time
;; showed up in the minibuffer spuriously (due to a bug in
;; sly-autodoc.) If this ever happens again, returning the
;; following will make debugging much easier:
:sly-eval-async)
;;; These functions can be handy too:
(defun sly-connected-p ()
"Return true if the Slynk connection is open."
(not (null sly-net-processes)))
(defun sly-check-connected ()
"Signal an error if we are not connected to Lisp."
(unless (sly-connected-p)
(error "Not connected. Use `%s' to start a Lisp."
(substitute-command-keys "\\[sly]"))))
;; UNUSED
(defun sly-debugged-connection-p (conn)
;; This previously was (AND (SLY-DB-DEBUGGED-CONTINUATIONS CONN) T),
;; but an SLY-DB buffer may exist without having continuations
;; attached to it, e.g. the one resulting from `sly-interrupt'.
(cl-loop for b in (sly-db-buffers)
thereis (with-current-buffer b
(eq sly-buffer-connection conn))))
(defun sly-busy-p (&optional conn)
"True if Lisp has outstanding requests.
Debugged requests are ignored."
(let ((debugged (sly-db-debugged-continuations (or conn (sly-connection)))))
(cl-remove-if (lambda (id)
(memq id debugged))
(sly-rex-continuations)
:key #'car)))
(defun sly-sync ()
"Block until the most recent request has finished."
(when (sly-rex-continuations)
(let ((tag (caar (sly-rex-continuations))))
(while (cl-find tag (sly-rex-continuations) :key #'car)
(accept-process-output nil 0.1)))))
(defun sly-ping ()
"Check that communication works."
(interactive)
(sly-message "%s" (sly-eval "PONG")))
;;;;; Protocol event handler (the guts)
;;;
;;; This is the protocol in all its glory. The input to this function
;;; is a protocol event that either originates within Emacs or arrived
;;; over the network from Lisp.
;;;
;;; Each event is a list beginning with a keyword and followed by
;;; arguments. The keyword identifies the type of event. Events
;;; originating from Emacs have names starting with :emacs- and events
;;; from Lisp don't.
(sly-def-connection-var sly-rex-continuations '()
"List of (ID . FUNCTION) continuations waiting for RPC results.")
(sly-def-connection-var sly-continuation-counter 0
"Continuation serial number counter.")
(defvar sly-event-hooks)
(defun sly-dispatch-event (event &optional process)
(let ((sly-dispatching-connection (or process (sly-connection))))
(or (run-hook-with-args-until-success 'sly-event-hooks event)
(sly-dcase event
((:emacs-rex form package thread continuation &rest extra-options)
(when (and (sly-use-sigint-for-interrupt) (sly-busy-p))
(sly-display-oneliner "; pipelined request... %S" form))
(let ((id (cl-incf (sly-continuation-counter))))
;; JT@2020-12-10: FIXME: Force inhibit-quit here to
;; ensure atomicity between `sly-send' and the `push'?
;; See Github#385..
(sly-send `(:emacs-rex ,form ,package ,thread ,id ,@extra-options))
(push (cons id continuation) (sly-rex-continuations))
(sly--refresh-mode-line)))
((:return value id)
(let ((rec (assq id (sly-rex-continuations))))
(cond (rec (setf (sly-rex-continuations)
(remove rec (sly-rex-continuations)))
(funcall (cdr rec) value)
(sly--refresh-mode-line))
(t
(error "Unexpected reply: %S %S" id value)))))
((:debug-activate thread level &optional _ignored)
(cl-assert thread)
(sly-db--ensure-initialized thread level))
((:debug thread level condition restarts frames conts)
(cl-assert thread)
(sly-db-setup thread level condition restarts frames conts))
((:debug-return thread level stepping)
(cl-assert thread)
(sly-db-exit thread level stepping))
((:emacs-interrupt thread)
(sly-send `(:emacs-interrupt ,thread)))
((:read-from-minibuffer thread tag prompt initial-value)
(sly-read-from-minibuffer-for-slynk thread tag prompt
initial-value))
((:y-or-n-p thread tag question)
(sly-remote-y-or-n-p thread tag question))
((:emacs-return-string thread tag string)
(sly-send `(:emacs-return-string ,thread ,tag ,string)))
((:new-features features)
(setf (sly-lisp-features) features))
((:indentation-update info)
(sly-handle-indentation-update info))
((:eval-no-wait form)
(sly-check-eval-in-emacs-enabled)
(eval (read form) t))
((:eval thread tag form-string)
(sly-check-eval-in-emacs-enabled)
(sly-eval-for-lisp thread tag form-string))
((:emacs-return thread tag value)
(sly-send `(:emacs-return ,thread ,tag ,value)))
((:ed what)
(sly-ed what))
((:inspect what thread tag)
(let ((hook (when (and thread tag)
(sly-curry #'sly-send
`(:emacs-return ,thread ,tag nil)))))
(sly--open-inspector what :kill-hook hook :switch :raise)))
((:background-message message)
(sly-temp-message 1 3 "[background-message] %s" message))
((:debug-condition thread message)
(cl-assert thread)
(sly-message "[debug-condition] %s" message))
((:ping thread tag)
(sly-send `(:emacs-pong ,thread ,tag)))
((:reader-error packet condition)
(sly-with-popup-buffer ((sly-buffer-name :error
:connection sly-dispatching-connection))
(princ (format "Invalid protocol message:\n%s\n\n%s"
condition packet))
(goto-char (point-min)))
(error "Invalid protocol message"))
((:invalid-rpc id message)
(setf (sly-rex-continuations)
(cl-remove id (sly-rex-continuations) :key #'car))
(error "Invalid rpc: %s" message))
((:emacs-skipped-packet _pkg))
((:test-delay seconds) ; for testing only
(sit-for seconds))
((:channel-send id msg)
(sly-channel-send (or (sly-find-channel id)
(error "Invalid channel id: %S %S" id msg))
msg))
((:emacs-channel-send id msg)
(sly-send `(:emacs-channel-send ,id ,msg)))
((:invalid-channel channel-id reason)
(error "Invalid remote channel %s: %s" channel-id reason))))))
(defvar sly--send-last-command nil
"Value of `this-command' at time of last `sly-send' call.")
(defun sly-send (sexp)
"Send SEXP directly over the wire on the current connection."
(setq sly--send-last-command this-command)
(sly-net-send sexp (sly-connection)))
(defun sly-reset ()
"Clear all pending continuations and erase connection buffer."
(interactive)
(setf (sly-rex-continuations) '())
(mapc #'kill-buffer (sly-db-buffers))
(sly-with-connection-buffer ()
(erase-buffer)))
(defun sly-send-sigint ()
(interactive)
(signal-process (sly-pid) 'SIGINT))
;;;;; Channels
;;; A channel implements a set of operations. Those operations can be
;;; invoked by sending messages to the channel. Channels are used for
;;; protocols which can't be expressed naturally with RPCs, e.g. for
;;; streaming data over the wire.
;;;
;;; A channel can be "remote" or "local". Remote channels are
;;; represented by integers. Local channels are structures. Messages
;;; sent to a closed (remote) channel are ignored.
(sly-def-connection-var sly-channels '()
"Alist of the form (ID . CHANNEL).")
(sly-def-connection-var sly-channels-counter 0
"Channel serial number counter.")
(cl-defstruct (sly-channel (:conc-name sly-channel.)
(:constructor
sly-make-channel% (operations name id plist)))
operations name id plist)
(defun sly-make-channel (operations &optional name)
(let* ((id (cl-incf (sly-channels-counter)))
(ch (sly-make-channel% operations name id nil)))
(push (cons id ch) (sly-channels))
ch))
(defun sly-close-channel (channel)
(setf (sly-channel.operations channel) 'closed-channel)
(let ((probe (assq (sly-channel.id channel)
(and (sly-current-connection)
(sly-channels)))))
(cond (probe (setf (sly-channels) (delete probe (sly-channels))))
(t (error "Can't close invalid channel: %s" channel)))))
(defun sly-find-channel (id)
(cdr (assq id (sly-channels))))
(defun sly-channel-send (channel message)
(apply (or (gethash (car message) (sly-channel.operations channel))
(error "Unsupported operation %S for channel %d"
(car message)
(sly-channel.id channel)))
channel (cdr message)))
(defun sly-channel-put (channel prop value)
(setf (sly-channel.plist channel)
(plist-put (sly-channel.plist channel) prop value)))
(defun sly-channel-get (channel prop)
(plist-get (sly-channel.plist channel) prop))
(eval-and-compile
(defun sly-channel-method-table-name (type)
(intern (format "sly-%s-channel-methods" type))))
(defmacro sly-define-channel-type (name)
(declare (indent defun))
(let ((tab (sly-channel-method-table-name name)))
`(defvar ,tab (make-hash-table :size 10))))
(defmacro sly-define-channel-method (type method args &rest body)
(declare (indent 3) (debug (&define sexp name lambda-list
def-body)))
`(puthash ',method
(lambda (self . ,args) ,@body)
,(sly-channel-method-table-name type)))
(defun sly-send-to-remote-channel (channel-id msg)
(sly-dispatch-event `(:emacs-channel-send ,channel-id ,msg)))
;;;;; Event logging to *sly-events*
;;;
;;; The *sly-events* buffer logs all protocol messages for debugging
;;; purposes.
(defvar sly-log-events t
"*Log protocol events to the *sly-events* buffer.")
(defun sly-log-event (event process)
"Record the fact that EVENT occurred in PROCESS."
(when sly-log-events
(with-current-buffer (sly--events-buffer process)
;; trim?
(when (> (buffer-size) 100000)
(goto-char (/ (buffer-size) 2))
(re-search-forward "^(" nil t)
(delete-region (point-min) (point)))
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(cond ((and (stringp event)
(string-match "^;" event))
(insert-before-markers event))
(t
(save-excursion
(sly-pprint-event event (current-buffer)))))
(goto-char (point-max)))))
(defun sly-pprint-event (event buffer)
"Pretty print EVENT in BUFFER with limited depth and width."
(let ((print-length 20)
(print-level 6)
(pp-escape-newlines t))
;; HACK workaround for gh#183
(condition-case _oops (pp event buffer) (error (print event buffer)))))
(defun sly--events-buffer (process)
"Return or create the event log buffer."
(let* ((probe (process-get process 'sly--events-buffer))
(buffer (or (and (buffer-live-p probe)
probe)
(let ((buffer (get-buffer-create
(apply #'sly-buffer-name
:events
(if (sly-connection-name process)
`(:connection ,process)
`(:suffix ,(format "%s" process)))))))
(with-current-buffer buffer
(buffer-disable-undo)
(when (fboundp 'lisp-data-mode) ; Emacs >= 28 only
(funcall 'lisp-data-mode))
(set (make-local-variable 'sly-buffer-connection) process)
(sly-mode 1))
(process-put process 'sly--events-buffer buffer)
buffer))))
buffer))
(defun sly-pop-to-events-buffer (process)
"Pop to the SLY events buffer for PROCESS"
(interactive (list (sly-current-connection)))
(pop-to-buffer (sly--events-buffer process)))
(defun sly-switch-to-most-recent (mode)
"Switch to most recent buffer in MODE, a major-mode symbol.
With prefix argument, prompt for MODE"
(interactive
(list (if current-prefix-arg
(intern (completing-read
"Switch to most recent buffer in what mode? "
(mapcar #'symbol-name '(lisp-mode
emacs-lisp-mode))
nil t))
'lisp-mode)))
(cl-loop for buffer in (buffer-list)
when (and (with-current-buffer buffer (eq major-mode mode))
(not (eq buffer (current-buffer)))
(not (string-match "^ " (buffer-name buffer))))
do (pop-to-buffer buffer) and return buffer))
(defun sly-forget-pending-events (process)
"Forget any outgoing events for the PROCESS"
(interactive (list (sly-current-connection)))
(setf (sly-rex-continuations process) nil))
;;;;; Cleanup after a quit
(defun sly-restart-inferior-lisp ()
"Kill and restart the Lisp subprocess."
(interactive)
(cl-assert (sly-inferior-process) () "No inferior lisp process")
(sly-quit-lisp-internal (sly-connection) 'sly-restart-sentinel t))
(defun sly-restart-sentinel (connection _message)
"When CONNECTION dies, start a similar inferior lisp process.
Also rearrange windows."
(cl-assert (process-status connection) 'closed)
(let* ((moribund-proc (sly-inferior-process connection))
(args (sly-inferior-lisp-args moribund-proc))
(buffer (buffer-name (process-buffer moribund-proc))))
(sly-net-close connection "Restarting inferior lisp process")
(sly-inferior-connect (sly-start-lisp (plist-get args :program)
(plist-get args :program-args)
(plist-get args :env)
nil
buffer)
args)))
;;;; Compilation and the creation of compiler-note annotations
(defvar sly-highlight-compiler-notes t
"*When non-nil annotate buffers with compilation notes etc.")
(defcustom sly-compilation-finished-hook '(sly-maybe-show-compilation-log)
"Hook called after compilation.
Each function is called with four arguments (SUCCESSP NOTES BUFFER LOADP)
SUCCESSP indicates if the compilation was successful.
NOTES is a list of compilation notes.
BUFFER is the buffer just compiled, or nil if a string was compiled.
LOADP is the value of the LOAD flag passed to `sly-compile-file', or t
if a string."
:group 'sly-mode
:type 'hook
:options '(sly-maybe-show-compilation-log
sly-show-compilation-log
sly-maybe-show-xrefs-for-notes
sly-goto-first-note))
;; FIXME: I doubt that anybody uses this directly and it seems to be
;; only an ugly way to pass arguments.
(defvar sly-compilation-policy nil
"When non-nil compile with these optimization settings.")
(defun sly-compute-policy (arg)
"Return the policy for the prefix argument ARG."
(let ((between (lambda (min n max)
(cond ((< n min) min)
((> n max) max)
(t n)))))
(let ((n (prefix-numeric-value arg)))
(cond ((not arg) sly-compilation-policy)
((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3))))
((eq arg '-) `((cl:speed . 3)))
(t `((cl:speed . ,(funcall between 0 (abs n) 3))))))))
(cl-defstruct (sly-compilation-result
(:type list)
(:conc-name sly-compilation-result.)
(:constructor nil)
(:copier nil))
tag notes successp duration loadp faslfile)
(defvar sly-last-compilation-result nil
"The result of the most recently issued compilation.")
(defun sly-compiler-notes ()
"Return all compiler notes, warnings, and errors."
(sly-compilation-result.notes sly-last-compilation-result))
(defun sly-compile-and-load-file (&optional policy)
"Compile and load the buffer's file and highlight compiler notes.
With (positive) prefix argument the file is compiled with maximal
debug settings (`C-u'). With negative prefix argument it is compiled for
speed (`M--'). If a numeric argument is passed set debug or speed settings
to it depending on its sign.
Each source location that is the subject of a compiler note is
underlined and annotated with the relevant information. The commands
`sly-next-note' and `sly-previous-note' can be used to navigate
between compiler notes and to display their full details."
(interactive "P")
(sly-compile-file t (sly-compute-policy policy)))
(defcustom sly-compile-file-options '()
"Plist of additional options that C-c C-k should pass to Lisp.
Currently only :fasl-directory is supported."
:group 'sly-lisp
:type '(plist :key-type symbol :value-type (file :must-match t)))
(defun sly-compile-file (&optional load policy)
"Compile current buffer's file and highlight resulting compiler notes.
See `sly-compile-and-load-file' for further details."
(interactive)
(unless buffer-file-name
(error "Buffer %s is not associated with a file." (buffer-name)))
(check-parens)
(when (and (buffer-modified-p)
(or (not compilation-ask-about-save)
(sly-y-or-n-p (format "Save file %s? " (buffer-file-name)))))
(save-buffer))
(let ((file (sly-to-lisp-filename (buffer-file-name)))
(options (sly-simplify-plist `(,@sly-compile-file-options
:policy ,policy))))
(sly-eval-async
`(slynk:compile-file-for-emacs ,file ,(if load t nil)
. ,(sly-hack-quotes options))
#'(lambda (result)
(sly-compilation-finished result (current-buffer))))
(sly-message "Compiling %s..." file)))
(defun sly-hack-quotes (arglist)
;; eval is the wrong primitive, we really want funcall
(cl-loop for arg in arglist collect `(quote ,arg)))
(defun sly-simplify-plist (plist)
(cl-loop for (key val) on plist by #'cddr
append (cond ((null val) '())
(t (list key val)))))
(defun sly-compile-defun (&optional raw-prefix-arg)
"Compile the current toplevel form.
With (positive) prefix argument the form is compiled with maximal
debug settings (`C-u'). With negative prefix argument it is compiled for
speed (`M--'). If a numeric argument is passed set debug or speed settings
to it depending on its sign."
(interactive "P")
(let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg)))
(if (use-region-p)
(sly-compile-region (region-beginning) (region-end))
(apply #'sly-compile-region (sly-region-for-defun-at-point)))))
(defvar sly-compile-region-function 'sly-compile-region-as-string
"Function called by `sly-compile-region' to do actual work.")
(defun sly-compile-region (start end)
"Compile the region."
(interactive "r")
;; Check connection before running hooks things like
;; sly-flash-region don't make much sense if there's no connection
(sly-connection)
(funcall sly-compile-region-function start end))
(defun sly-compile-region-as-string (start end)
(sly-flash-region start end)
(sly-compile-string (buffer-substring-no-properties start end) start))
(defun sly-compile-string (string start-offset)
(let* ((position (sly-compilation-position start-offset)))
(sly-eval-async
`(slynk:compile-string-for-emacs
,string
,(buffer-name)
',position
,(if (buffer-file-name) (sly-to-lisp-filename (buffer-file-name)))
',sly-compilation-policy)
#'(lambda (result)
(sly-compilation-finished result nil)))))
(defun sly-compilation-position (start-offset)
(let ((line (save-excursion
(goto-char start-offset)
(list (line-number-at-pos) (1+ (current-column))))))
`((:position ,start-offset) (:line ,@line))))
(defcustom sly-load-failed-fasl 'never
"Which action to take when COMPILE-FILE set FAILURE-P to T.
NEVER doesn't load the fasl
ALWAYS loads the fasl
ASK asks the user."
:type '(choice (const never)
(const always)
(const ask)))
(defun sly-load-failed-fasl-p ()
(cl-ecase sly-load-failed-fasl
(never nil)
(always t)
(ask (sly-y-or-n-p "Compilation failed. Load fasl file anyway? "))))
(defun sly-compilation-finished (result buffer &optional message)
(let ((notes (sly-compilation-result.notes result))
(duration (sly-compilation-result.duration result))
(successp (sly-compilation-result.successp result))
(faslfile (sly-compilation-result.faslfile result))
(loadp (sly-compilation-result.loadp result)))
(setf sly-last-compilation-result result)
(sly-show-note-counts notes duration (cond ((not loadp) successp)
(t (and faslfile successp)))
(or (not buffer) loadp)
message)
(when sly-highlight-compiler-notes
(sly-highlight-notes notes))
(when (and loadp faslfile
(or successp
(sly-load-failed-fasl-p)))
(sly-eval-async `(slynk:load-file ,faslfile)))
(run-hook-with-args 'sly-compilation-finished-hook successp notes buffer loadp)))
(defun sly-show-note-counts (notes secs successp loadp &optional message)
(sly-message (concat
(cond ((and successp loadp)
"Compiled and loaded")
(successp "Compilation finished")
(t (sly-add-face 'font-lock-warning-face
"Compilation failed")))
(if (null notes) ". (No warnings)" ": ")
(mapconcat
(lambda (msgs)
(cl-destructuring-bind (sev . notes) msgs
(let ((len (length notes)))
(format "%d %s%s" len (sly-severity-label sev)
(if (= len 1) "" "s")))))
(sort (sly-alistify notes #'sly-note.severity #'eq)
(lambda (x y) (sly-severity< (car y) (car x))))
" ")
(if secs (format " [%.2f secs]" secs))
message)))
(defun sly-highlight-notes (notes)
"Highlight compiler notes, warnings, and errors in the buffer."
(interactive (list (sly-compiler-notes)))
(with-temp-message "Highlighting notes..."
(save-excursion
(save-restriction
(widen) ; highlight notes on the whole buffer
(sly-remove-notes (point-min) (point-max))
(mapc #'sly--add-in-buffer-note notes)))))
;;;;; Recompilation.
;; FIXME: This whole idea is questionable since it depends so
;; crucially on precise source-locs.
(defun sly-recompile-location (location)
(save-excursion
(sly-move-to-source-location location)
(sly-compile-defun)))
(defun sly-recompile-locations (locations cont)
(sly-eval-async
`(slynk:compile-multiple-strings-for-emacs
',(cl-loop for loc in locations collect
(save-excursion
(sly-move-to-source-location loc)
(cl-destructuring-bind (start end)
(sly-region-for-defun-at-point)
(list (buffer-substring-no-properties start end)
(buffer-name)
(sly-current-package)
start
(if (buffer-file-name)
(sly-to-lisp-filename (buffer-file-name))
nil)))))
',sly-compilation-policy)
cont))
;;;;; Compiler notes list
(defun sly-one-line-ify (string)
"Return a single-line version of STRING.
Each newlines and following indentation is replaced by a single space."
(with-temp-buffer
(insert string)
(goto-char (point-min))
(while (re-search-forward "\n[\n \t]*" nil t)
(replace-match " "))
(buffer-string)))
(defun sly-xref--get-xrefs-for-notes (notes)
(let ((xrefs))
(dolist (note notes)
(let* ((location (cl-getf note :location))
(fn (cadr (assq :file (cdr location))))
(file (assoc fn xrefs))
(node
(list (format "%s: %s"
(cl-getf note :severity)
(sly-one-line-ify (cl-getf note :message)))
location)))
(when fn
(if file
(push node (cdr file))
(setf xrefs (cl-acons fn (list node) xrefs))))))
xrefs))
(defun sly-maybe-show-xrefs-for-notes (_successp notes _buffer _loadp)
"Show the compiler notes NOTES if they come from more than one file."
(let ((xrefs (sly-xref--get-xrefs-for-notes notes)))
(when (cdr xrefs) ; >1 file
(sly-xref--show-results
xrefs 'definition "Compiler notes" (sly-current-package)))))
(defun sly-maybe-show-compilation-log (successp notes buffer loadp)
"Display the log on failed compilations or if NOTES is non-nil."
(sly-show-compilation-log successp notes buffer loadp
(if successp :hidden nil)))
(defun sly-show-compilation-log (successp notes buffer loadp &optional select)
"Create and display the compilation log buffer."
(interactive (list (sly-compiler-notes)))
(sly-with-popup-buffer ((sly-buffer-name :compilation)
:mode 'compilation-mode
:select select)
(sly--insert-compilation-log successp notes buffer loadp)
(insert "Compilation "
(if successp "successful" "failed")
".")))
(defvar sly-compilation-log--notes (make-hash-table)
"Hash-table (NOTE -> (BUFFER POSITION)) for finding notes in
the SLY compilation log")
(defun sly--insert-compilation-log (_successp notes _buffer _loadp)
"Insert NOTES in format suitable for `compilation-mode'."
(clrhash sly-compilation-log--notes)
(cl-multiple-value-bind (grouped-notes canonicalized-locs-table)
(sly-group-and-sort-notes notes)
(with-temp-message "Preparing compilation log..."
(let ((inhibit-read-only t)
(inhibit-modification-hooks t)) ; inefficient font-lock-hook
(insert (format "cd %s\n%d compiler notes:\n\n"
default-directory (length notes)))
(cl-loop for notes in grouped-notes
for loc = (gethash (cl-first notes) canonicalized-locs-table)
for start = (point)
do
(cl-loop for note in notes
do (puthash note
(cons (current-buffer) start)
sly-compilation-log--notes))
(insert
(sly--compilation-note-group-button
(sly-canonicalized-location-to-string loc) notes)
":")
(sly-insert-note-group notes)
(insert "\n")
(add-text-properties start (point) `(field ,notes))))
(set (make-local-variable 'compilation-skip-threshold) 0)
(setq next-error-last-buffer (current-buffer)))))
(defun sly-insert-note-group (notes)
"Insert a group of compiler messages."
(insert "\n")
(dolist (note notes)
(insert " " (sly-severity-label (sly-note.severity note)) ": ")
(let ((start (point)))
(insert (sly-note.message note))
(let ((ctx (sly-note.source-context note)))
(if ctx (insert "\n" ctx)))
(sly-indent-block start 4))
(insert "\n")))
(defun sly-indent-block (start column)
"If the region back to START isn't a one-liner indent it."
(when (< start (line-beginning-position))
(save-excursion
(goto-char start)
(insert "\n"))
(sly-indent-rigidly start (point) column)))
(defun sly-canonicalized-location (location)
"Return a list (FILE LINE COLUMN) for sly-location LOCATION.
This is quite an expensive operation so use carefully."
(save-excursion
(sly-goto-location-buffer (sly-location.buffer location))
(save-excursion
(sly-move-to-source-location location)
(list (or (buffer-file-name) (buffer-name))
(save-restriction
(widen)
(line-number-at-pos))
(1+ (current-column))))))
(defun sly-canonicalized-location-to-string (loc)
(if loc
(cl-destructuring-bind (filename line col) loc
(format "%s:%d:%d"
(cond ((not filename) "")
((let ((rel (file-relative-name filename)))
(if (< (length rel) (length filename))
rel)))
(t filename))
line col))
(format "Unknown location")))
(defun sly-group-and-sort-notes (notes)
"First sort, then group NOTES according to their canonicalized locs."
(let ((locs (make-hash-table :test #'eq)))
(mapc (lambda (note)
(let ((loc (sly-note.location note)))
(when (sly-location-p loc)
(puthash note (sly-canonicalized-location loc) locs))))
notes)
(cl-values (sly-group-similar
(lambda (n1 n2)
(equal (gethash n1 locs nil) (gethash n2 locs t)))
(let* ((bottom most-negative-fixnum)
(+default+ (list "" bottom bottom)))
(sort notes
(lambda (n1 n2)
(cl-destructuring-bind (filename1 line1 col1)
(gethash n1 locs +default+)
(cl-destructuring-bind (filename2 line2 col2)
(gethash n2 locs +default+)
(cond ((string-lessp filename1 filename2) t)
((string-lessp filename2 filename1) nil)
((< line1 line2) t)
((> line1 line2) nil)
(t (< col1 col2)))))))))
locs)))
(defun sly-note.severity (note)
(plist-get note :severity))
(defun sly-note.message (note)
(plist-get note :message))
(defun sly-note.source-context (note)
(plist-get note :source-context))
(defun sly-note.location (note)
(plist-get note :location))
(defun sly-severity-label (severity)
(cl-subseq (symbol-name severity) 1))
;;;;; Adding a single compiler note
;;;;;
(defun sly-choose-overlay-region (note)
"Choose the start and end points for an overlay over NOTE.
If the location's sexp is a list spanning multiple lines, then the
region around the first element is used.
Return nil if there's no useful source location."
(let ((location (sly-note.location note)))
(when location
(sly-dcase location
((:error _)) ; do nothing
((:location file pos _hints)
(cond ((eq (car file) ':source-form) nil)
((eq (sly-note.severity note) :read-error)
(sly-choose-overlay-for-read-error location))
((equal pos '(:eof))
(list (1- (point-max)) (point-max)))
(t
(sly-choose-overlay-for-sexp location))))))))
(defun sly-choose-overlay-for-read-error (location)
(let ((pos (sly-location-offset location)))
(save-excursion
(goto-char pos)
(cond ((sly-symbol-at-point)
;; package not found, &c.
(list (sly-symbol-start-pos) (sly-symbol-end-pos)))
(t
(list pos (1+ pos)))))))
(defun sly-choose-overlay-for-sexp (location)
(sly-move-to-source-location location)
(skip-chars-forward "'#`")
(let ((start (point)))
(ignore-errors (sly-forward-sexp))
(if (sly-same-line-p start (point))
(list start (point))
(list (1+ start)
(progn (goto-char (1+ start))
(ignore-errors (forward-sexp 1))
(point))))))
(defun sly-same-line-p (pos1 pos2)
"Return t if buffer positions POS1 and POS2 are on the same line."
(save-excursion (goto-char (min pos1 pos2))
(<= (max pos1 pos2) (line-end-position))))
(defvar sly-severity-face-plist
(list :error 'sly-error-face
:read-error 'sly-error-face
:warning 'sly-warning-face
:redefinition 'sly-style-warning-face
:style-warning 'sly-style-warning-face
:note 'sly-note-face))
(defun sly-severity-face (severity)
"Return the name of the font-lock face representing SEVERITY."
(or (plist-get sly-severity-face-plist severity)
(error "No face for: %S" severity)))
(defvar sly-severity-order
'(:note :style-warning :redefinition :warning :error :read-error))
(defun sly-severity< (sev1 sev2)
"Return true if SEV1 is less severe than SEV2."
(< (cl-position sev1 sly-severity-order)
(cl-position sev2 sly-severity-order)))
(defun sly-forward-positioned-source-path (source-path)
"Move forward through a sourcepath from a fixed position.
The point is assumed to already be at the outermost sexp, making the
first element of the source-path redundant."
(ignore-errors
(sly-forward-sexp)
(beginning-of-defun))
(sly--when-let (source-path (cdr source-path))
(down-list 1)
(sly-forward-source-path source-path)))
(defun sly-forward-source-path (source-path)
(let ((origin (point)))
(condition-case nil
(progn
(cl-loop for (count . more) on source-path
do (progn
(sly-forward-sexp count)
(when more (down-list 1))))
;; Align at beginning
(sly-forward-sexp)
(beginning-of-sexp))
(error (goto-char origin)))))
;; FIXME: really fix this mess
;; FIXME: the check shouln't be done here anyway but by M-. itself.
(defun sly-filesystem-toplevel-directory ()
;; Windows doesn't have a true toplevel root directory, and all
;; filenames look like "c:/foo/bar/quux.baz" from an Emacs
;; perspective anyway.
(if (memq system-type '(ms-dos windows-nt))
""
(file-name-as-directory "/")))
(defun sly-file-name-merge-source-root (target-filename buffer-filename)
"Returns a filename where the source root directory of TARGET-FILENAME
is replaced with the source root directory of BUFFER-FILENAME.
If no common source root could be determined, return NIL.
E.g. (sly-file-name-merge-source-root
\"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\"
\"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\")
==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\"
"
(let ((target-dirs (split-string (file-name-directory target-filename)
"/" t))
(buffer-dirs (split-string (file-name-directory buffer-filename)
"/" t)))
;; Starting from the end, we look if one of the TARGET-DIRS exists
;; in BUFFER-FILENAME---if so, it and everything left from that dirname
;; is considered to be the source root directory of BUFFER-FILENAME.
(cl-loop with target-suffix-dirs = nil
with buffer-dirs* = (reverse buffer-dirs)
with target-dirs* = (reverse target-dirs)
for target-dir in target-dirs*
do (let ((concat-dirs (lambda (dirs)
(apply #'concat
(mapcar #'file-name-as-directory
dirs))))
(pos (cl-position target-dir buffer-dirs*
:test #'equal)))
(if (not pos) ; TARGET-DIR not in BUFFER-FILENAME?
(push target-dir target-suffix-dirs)
(let* ((target-suffix
; PUSH reversed for us!
(funcall concat-dirs target-suffix-dirs))
(buffer-root
(funcall concat-dirs
(reverse (nthcdr pos buffer-dirs*)))))
(cl-return (concat (sly-filesystem-toplevel-directory)
buffer-root
target-suffix
(file-name-nondirectory
target-filename)))))))))
(defun sly-highlight-differences-in-dirname (base-dirname contrast-dirname)
"Returns a copy of BASE-DIRNAME where all differences between
BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a
highlighting face."
(setq base-dirname (file-name-as-directory base-dirname))
(setq contrast-dirname (file-name-as-directory contrast-dirname))
(let ((base-dirs (split-string base-dirname "/" t))
(contrast-dirs (split-string contrast-dirname "/" t)))
(with-temp-buffer
(cl-loop initially (insert (sly-filesystem-toplevel-directory))
for base-dir in base-dirs do
(let ((pos (cl-position base-dir contrast-dirs :test #'equal)))
(cond ((not pos)
(sly-insert-propertized '(face highlight) base-dir)
(insert "/"))
(t
(insert (file-name-as-directory base-dir))
(setq contrast-dirs
(nthcdr (1+ pos) contrast-dirs))))))
(buffer-substring (point-min) (point-max)))))
(defvar sly-warn-when-possibly-tricked-by-M-. t
"When working on multiple source trees simultaneously, the way
`sly-edit-definition' (M-.) works can sometimes be confusing:
`M-.' visits locations that are present in the current Lisp image,
which works perfectly well as long as the image reflects the source
tree that one is currently looking at.
In the other case, however, one can easily end up visiting a file
in a different source root directory (the one corresponding to
the Lisp image), and is thus easily tricked to modify the wrong
source files---which can lead to quite some stressfull cursing.
If this variable is T, a warning message is issued to raise the
user's attention whenever `M-.' is about opening a file in a
different source root that also exists in the source root
directory of the user's current buffer.
There's no guarantee that all possible cases are covered, but
if you encounter such a warning, it's a strong indication that
you should check twice before modifying.")
(defun sly-maybe-warn-for-different-source-root (target-filename
buffer-filename)
(let ((guessed-target (sly-file-name-merge-source-root target-filename
buffer-filename)))
(when (and guessed-target
(not (equal guessed-target target-filename))
(file-exists-p guessed-target))
(sly-message "Attention: This is `%s'."
(concat (sly-highlight-differences-in-dirname
(file-name-directory target-filename)
(file-name-directory guessed-target))
(file-name-nondirectory target-filename))))))
(defun sly-check-location-filename-sanity (filename)
(when sly-warn-when-possibly-tricked-by-M-.
(cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file))))
(let ((target-filename (truename-safe filename))
(buffer-filename (truename-safe (buffer-file-name))))
(when (and target-filename
buffer-filename)
(sly-maybe-warn-for-different-source-root
target-filename buffer-filename))))))
(defun sly-check-location-buffer-name-sanity (buffer-name)
(sly-check-location-filename-sanity
(buffer-file-name (get-buffer buffer-name))))
(defun sly-goto-location-buffer (buffer)
(sly-dcase buffer
((:file filename)
(let ((filename (sly-from-lisp-filename filename)))
(sly-check-location-filename-sanity filename)
(set-buffer (or (get-file-buffer filename)
(let ((find-file-suppress-same-file-warnings t))
(find-file-noselect filename))))))
((:buffer buffer-name)
(sly-check-location-buffer-name-sanity buffer-name)
(set-buffer buffer-name))
((:buffer-and-file buffer filename)
(sly-goto-location-buffer
(if (get-buffer buffer)
(list :buffer buffer)
(list :file filename))))
((:source-form string)
(set-buffer (get-buffer-create (sly-buffer-name :source)))
(erase-buffer)
(lisp-mode)
(insert string)
(goto-char (point-min)))
((:zip file entry)
(require 'arc-mode)
(set-buffer (find-file-noselect file t))
(goto-char (point-min))
(re-search-forward (concat " " entry "$"))
(let ((buffer (save-window-excursion
(archive-extract)
(current-buffer))))
(set-buffer buffer)
(goto-char (point-min))))))
(defun sly-goto-location-position (position)
(sly-dcase position
((:position pos)
(goto-char 1)
(forward-char (- (1- pos) (sly-eol-conversion-fixup (1- pos)))))
((:offset start offset)
(goto-char start)
(forward-char offset))
((:line start &optional column)
(goto-char (point-min))
(beginning-of-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)))
(goto-char (point-min))
(when (or
(re-search-forward
(format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_"
(regexp-quote name)) nil t)
(re-search-forward
(format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))
(goto-char (match-beginning 0)))))
((:method name specializers &rest qualifiers)
(sly-search-method-location name specializers qualifiers))
((:source-path source-path start-position)
(cond (start-position
(goto-char start-position)
(sly-forward-positioned-source-path source-path))
(t
(sly-forward-source-path source-path))))
((:eof)
(goto-char (point-max)))))
(defun sly-eol-conversion-fixup (n)
;; Return the number of \r\n eol markers that we need to cross when
;; moving N chars forward. N is the number of chars but \r\n are
;; counted as 2 separate chars.
(if (zerop n) 0
(cl-case (coding-system-eol-type buffer-file-coding-system)
((1)
(save-excursion
(cl-do ((pos (+ (point) n))
(count 0 (1+ count)))
((>= (point) pos) (1- count))
(forward-line)
(cl-decf pos))))
(t 0))))
(defun sly-search-method-location (name specializers qualifiers)
;; Look for a sequence of words (def<something> method name
;; qualifers specializers don't look for "T" since it isn't requires
;; (arg without t) as class is taken as such.
(let* ((case-fold-search t)
(name (regexp-quote name))
(qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>"))
qualifiers ""))
(specializers (mapconcat
(lambda (el)
(if (eql (aref el 0) ?\()
(let ((spec (read el)))
(if (eq (car spec) 'EQL)
(concat
".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}"
(format "%s" (cl-second spec)) ")")
(error "don't understand specializer: %s,%s"
el (car spec))))
(concat ".+?\n\\{0,1\\}.+?\\<" el "\\>")))
(remove "T" specializers) ""))
(regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name
qualifiers specializers)))
(or (and (re-search-forward regexp nil t)
(goto-char (match-beginning 0)))
;; (sly-goto-location-position `(:function-name ,name))
)))
(defun sly-search-call-site (fname)
"Move to the place where FNAME called.
Don't move if there are multiple or no calls in the current defun."
(save-restriction
(narrow-to-defun)
(let ((start (point))
(regexp (concat "(" fname "[)\n \t]"))
(case-fold-search t))
(cond ((and (re-search-forward regexp nil t)
(not (re-search-forward regexp nil t)))
(goto-char (match-beginning 0)))
(t (goto-char start))))))
(defun sly-search-edit-path (edit-path)
"Move to EDIT-PATH starting at the current toplevel form."
(when edit-path
(unless (and (= (current-column) 0)
(looking-at "("))
(beginning-of-defun))
(sly-forward-source-path edit-path)))
(defun sly-move-to-source-location (location &optional noerror)
"Move to the source location LOCATION.
If NOERROR don't signal an error, but return nil.
Several kinds of locations are supported:
<location> ::= (:location <buffer> <position> <hints>)
| (:error <message>)
<buffer> ::= (:file <filename>)
| (:buffer <buffername>)
| (:buffer-and-file <buffername> <filename>)
| (:source-form <string>)
| (:zip <file> <entry>)
<position> ::= (:position <fixnum>) ; 1 based (for files)
| (:offset <start> <offset>) ; start+offset (for C-c C-c)
| (:line <line> [<column>])
| (:function-name <string>)
| (:source-path <list> <start-position>)
| (:method <name string> <specializers> . <qualifiers>)"
(sly-dcase location
((:location buffer _position _hints)
(sly-goto-location-buffer buffer)
(let ((pos (sly-location-offset location)))
(cond ((and (<= (point-min) pos) (<= pos (point-max))))
(widen-automatically (widen))
(t
(error "Location is outside accessible part of buffer")))
(goto-char pos)))
((:error message)
(cond (noerror
(sly-message "%s" message)
nil)
(t
(error "%s" message))))))
(defun sly--highlight-sexp (&optional start end)
"Highlight the first sexp after point."
(let ((start (or start (point)))
(end (or end (save-excursion (ignore-errors (forward-sexp)) (point)))))
(sly-flash-region start end)))
(defun sly--highlight-line (&optional timeout)
(sly-flash-region (+ (line-beginning-position) (current-indentation))
(line-end-position)
:timeout timeout))
(make-variable-buffer-local
(defvar sly-xref--popup-method nil
"Helper for `sly--display-source-location'"))
(cl-defun sly--display-source-location (source-location
&optional noerror (method 'window))
"Display SOURCE-LOCATION in a window according to METHOD.
Highlight the resulting sexp. Return the window or raise an
error, unless NOERROR is nil, in which case return nil. METHOD
specifies how to behave when a reference is selected in an xref
buffer. If one of symbols `window' or `frame' just
`display-buffer' accordingly. If nil, just switch to buffer in
current window. If a cons (WINDOW . METHOD) consider WINDOW the
\"starting window\" and reconsider METHOD like above: If it is
nil try to use WINDOW exclusively for showing the location,
otherwise prevent that window from being reused when popping to a
new window or frame."
(cl-labels
((pop-it
(target-buffer method)
(cond ((eq method 'window)
(display-buffer target-buffer t))
((eq method 'frame)
(let ((pop-up-frames t))
(display-buffer target-buffer t)))
((consp method)
(let* ((window (car method))
(sub-method (cdr method)))
(cond ((not (window-live-p window))
;; the original window has been deleted: all
;; bets are off!
;;
(pop-it target-buffer sub-method))
(sub-method
;; shield window from reuse, but restoring
;; any dedicatedness
;;
(let ((dedicatedness (window-dedicated-p window)))
(unwind-protect
(progn
;; (set-window-dedicated-p window 'soft)
;;
;; jt@2018-01-27 commented the line
;; above because since the fix to
;; emacs' bug#28814 in Emacs 26.1
;; (which I myself authored), it won't
;; work correctly. Best to disable it
;; for now and eventually copy Emacs's
;; approach to xref buffers, or better
;; yet, reuse it.
(pop-it target-buffer sub-method))
(set-window-dedicated-p window dedicatedness))))
(t
;; make efforts to reuse the window, respecting
;; any `display-buffer' overrides
;;
(display-buffer
target-buffer
`(,(lambda (buffer _alist)
(when (window-live-p window)
(set-window-buffer window buffer)
window))))))))
(t
(switch-to-buffer target-buffer)
(selected-window)))))
(when (eq method 'sly-xref)
(setq method sly-xref--popup-method))
(when (sly-move-to-source-location source-location noerror)
(let ((pos (point)))
(with-selected-window (pop-it (current-buffer) method)
(goto-char pos)
(recenter (if (= (current-column) 0) 1))
(sly--highlight-sexp)
(selected-window))))))
(defun sly--pop-to-source-location (source-location &optional method)
"Pop to SOURCE-LOCATION using METHOD.
If called from an xref buffer, method will be `sly-xref' and
thus also honour `sly-xref--popup-method'."
(let* ((xref-window (selected-window))
(xref-buffer (window-buffer xref-window)))
(when (eq method 'sly-xref)
(quit-restore-window xref-window 'bury))
(with-current-buffer xref-buffer
;; now pop to target
;;
(select-window
(sly--display-source-location source-location nil method)))
(set-buffer (window-buffer (selected-window)))))
(defun sly-location-offset (location)
"Return the position, as character number, of LOCATION."
(save-restriction
(widen)
(condition-case nil
(sly-goto-location-position
(sly-location.position location))
(error (goto-char 0)))
(let ((hints (sly-location.hints location)))
(sly--when-let (snippet (cl-getf hints :snippet))
(sly-isearch snippet))
(sly--when-let (snippet (cl-getf hints :edit-path))
(sly-search-edit-path snippet))
(sly--when-let (fname (cl-getf hints :call-site))
(sly-search-call-site fname))
(when (cl-getf hints :align)
(sly-forward-sexp)
(beginning-of-sexp)))
(point)))
;;;;; Incremental search
;;
;; Search for the longest match of a string in either direction.
;;
;; This is for locating text that is expected to be near the point and
;; may have been modified (but hopefully not near the beginning!)
(defun sly-isearch (string)
"Find the longest occurence of STRING either backwards of forwards.
If multiple matches exist the choose the one nearest to point."
(goto-char
(let* ((start (point))
(len1 (sly-isearch-with-function 'search-forward string))
(pos1 (point)))
(goto-char start)
(let* ((len2 (sly-isearch-with-function 'search-backward string))
(pos2 (point)))
(cond ((and len1 len2)
;; Have a match in both directions
(cond ((= len1 len2)
;; Both are full matches -- choose the nearest.
(if (< (abs (- start pos1))
(abs (- start pos2)))
pos1 pos2))
((> len1 len2) pos1)
((> len2 len1) pos2)))
(len1 pos1)
(len2 pos2)
(t start))))))
(defun sly-isearch-with-function (search-fn string)
"Search for the longest substring of STRING using SEARCH-FN.
SEARCH-FN is either the symbol `search-forward' or `search-backward'."
(unless (string= string "")
(cl-loop for i from 1 to (length string)
while (funcall search-fn (substring string 0 i) nil t)
for match-data = (match-data)
do (cl-case search-fn
(search-forward (goto-char (match-beginning 0)))
(search-backward (goto-char (1+ (match-end 0)))))
finally (cl-return (if (null match-data)
nil
;; Finish based on the last successful match
(store-match-data match-data)
(goto-char (match-beginning 0))
(- (match-end 0) (match-beginning 0)))))))
;;;;; Visiting and navigating the overlays of compiler notes
(defun sly-note-button-p (button)
(eq (button-type button) 'sly-in-buffer-note))
(defalias 'sly-next-note 'sly-button-forward)
(defalias 'sly-previous-note 'sly-button-backward)
(put 'sly-next-note 'sly-button-navigation-command t)
(put 'sly-previous-note 'sly-button-navigation-command t)
(defun sly-goto-first-note (_successp notes _buffer _loadp)
"Go to the first note in the buffer."
(interactive (list (sly-compiler-notes)))
(when notes
(goto-char (point-min))
(sly-next-note 1)))
(defun sly-remove-notes (beg end)
"Remove `sly-note' annotation buttons from BEG to END."
(interactive (if (region-active-p)
(list (region-beginning) (region-end))
(list (point-min) (point-max))))
(cl-loop for existing in (overlays-in beg end)
when (sly-note-button-p existing)
do (delete-overlay existing)))
(defun sly-show-notes (button &rest more-buttons)
"Present the details of a compiler note to the user."
(interactive)
(let ((notes (mapcar (sly-rcurry #'button-get 'sly-note)
(cons button more-buttons))))
(sly-button-flash button :face (let ((color (face-underline-p (button-get button 'face))))
(if color `(:background ,color) 'highlight)))
;; If the compilation window is showing, try to land in a suitable
;; place there, too...
;;
(let* ((anchor (car notes))
(compilation-buffer (sly-buffer-name :compilation))
(compilation-window (get-buffer-window compilation-buffer t)))
(if compilation-window
(with-current-buffer compilation-buffer
(with-selected-window compilation-window
(let ((buffer-and-pos (gethash anchor
sly-compilation-log--notes)))
(when buffer-and-pos
(cl-assert (eq (car buffer-and-pos) (current-buffer)))
(goto-char (cdr buffer-and-pos))
(let ((field-end (field-end (1+ (point)))))
(sly-flash-region (point) field-end)
(sly-recenter field-end))))
(sly-message "Showing note in %s" (current-buffer))))
;; Else, do the next best thing, which is echo the messages.
;;
(if (cdr notes)
(sly-message "%s notes:\n%s"
(length notes)
(mapconcat #'sly-note.message notes "\n"))
(sly-message "%s" (sly-note.message (car notes))))))))
(define-button-type 'sly-note :supertype 'sly-button)
(define-button-type 'sly-in-buffer-note :supertype 'sly-note
'keymap (let ((map (copy-keymap button-map)))
(define-key map "RET" nil)
map)
'mouse-action 'sly-show-notes
'sly-button-echo 'sly-show-notes
'modification-hooks '(sly--in-buffer-note-modification))
(define-button-type 'sly-compilation-note-group :supertype 'sly-note
'face nil)
(defun sly--in-buffer-note-modification (button after? _beg _end &optional _len)
(unless after? (delete-overlay button)))
(defun sly--add-in-buffer-note (note)
"Add NOTE as a `sly-in-buffer-note' button to the source buffer."
(cl-destructuring-bind (&optional beg end)
(sly-choose-overlay-region note)
(when beg
(let* ((contained (sly-button--overlays-between beg end))
(containers (cl-set-difference (sly-button--overlays-at beg)
contained)))
(cl-loop for ov in contained do (cl-incf (sly-button--level ov)))
(let ((but (make-button beg
end
:type 'sly-in-buffer-note
'sly-button-search-id (sly-button-next-search-id)
'sly-note note
'help-echo (format "[sly] %s" (sly-note.message note))
'face (sly-severity-face (sly-note.severity note)))))
(setf (sly-button--level but)
(1+ (cl-reduce #'max containers
:key #'sly-button--level
:initial-value 0))))))))
(defun sly--compilation-note-group-button (label notes)
"Pepare notes as a `sly-compilation-note' button.
For insertion in the `compilation-mode' buffer"
(sly--make-text-button label nil :type 'sly-compilation-note-group 'sly-notes-group notes))
;;;; Basic arglisting
;;;;
(defun sly-show-arglist ()
(let ((op (ignore-errors
(save-excursion
(backward-up-list 1)
(down-list 1)
(sly-symbol-at-point)))))
(when op
(sly-eval-async `(slynk:operator-arglist ,op ,(sly-current-package))
(lambda (arglist)
(when arglist
(sly-message "%s" arglist)))))))
;;;; Edit definition
(defun sly-push-definition-stack ()
"Add point to find-tag-marker-ring."
(require 'etags)
(if (fboundp 'xref-push-marker-stack)
(xref-push-marker-stack)
(ring-insert find-tag-marker-ring (point-marker))))
(defun sly-pop-find-definition-stack ()
"Pop the edit-definition stack and goto the location."
(interactive)
(pop-tag-mark))
(cl-defstruct (sly-xref (:conc-name sly-xref.) (:type list))
dspec location)
(cl-defstruct (sly-location (:conc-name sly-location.) (:type list)
(:constructor nil)
(:copier nil))
tag buffer position hints)
(defun sly-location-p (o) (and (consp o) (eq (car o) :location)))
(defun sly-xref-has-location-p (xref)
(sly-location-p (sly-xref.location xref)))
(defun make-sly-buffer-location (buffer-name position &optional hints)
`(:location (:buffer ,buffer-name) (:position ,position)
,(when hints `(:hints ,hints))))
(defun make-sly-file-location (file-name position &optional hints)
`(:location (:file ,file-name) (:position ,position)
,(when hints `(:hints ,hints))))
(defun sly-edit-definition (&optional name method)
"Lookup the definition of the name at point.
If there's no name at point, or a prefix argument is given, then
the function name is prompted. METHOD can be nil, or one of
`window' or `frame' to specify if the new definition should be
popped, respectively, in the current window, a new window, or a
new frame."
(interactive (list (or (and (not current-prefix-arg)
(sly-symbol-at-point t))
(sly-read-symbol-name "Edit Definition of: "))))
;; The hooks might search for a name in a different manner, so don't
;; ask the user if it's missing before the hooks are run
(let ((xrefs (sly-eval `(slynk:find-definitions-for-emacs ,name))))
(unless xrefs
(error "No known definition for: %s (in %s)"
name (sly-current-package)))
(cl-destructuring-bind (1loc file-alist)
(sly-analyze-xrefs xrefs)
(cond (1loc
(sly-push-definition-stack)
(sly--pop-to-source-location
(sly-xref.location (car xrefs)) method))
((null (cdr xrefs)) ; ((:error "..."))
(error "%s" xrefs))
(t
(sly-push-definition-stack)
(sly-xref--show-results file-alist 'definition name
(sly-current-package)
(cons (selected-window)
method)))))))
(defvar sly-edit-uses-xrefs
'(:calls :macroexpands :binds :references :sets :specializes))
;;; FIXME. TODO: Would be nice to group the symbols (in each
;;; type-group) by their home-package.
(defun sly-edit-uses (symbol)
"Lookup all the uses of SYMBOL."
(interactive (list (sly-read-symbol-name "Edit Uses of: ")))
(sly-xref--get-xrefs
sly-edit-uses-xrefs
symbol
(lambda (xrefs type symbol package)
(cond
((and (sly-length= xrefs 1) ; one group
(sly-length= (cdar xrefs) 1)) ; one ref in group
(cl-destructuring-bind (_ (_ loc)) (cl-first xrefs)
(sly-push-definition-stack)
(sly--pop-to-source-location loc)))
(t
(sly-push-definition-stack)
(sly-xref--show-results xrefs type symbol package 'window))))))
(defun sly-analyze-xrefs (xrefs)
"Find common filenames in XREFS.
Return a list (SINGLE-LOCATION FILE-ALIST).
SINGLE-LOCATION is true if all xrefs point to the same location.
FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)."
(list (and xrefs
(let ((loc (sly-xref.location (car xrefs))))
(and (sly-location-p loc)
(cl-every (lambda (x) (equal (sly-xref.location x) loc))
(cdr xrefs)))))
(sly-alistify xrefs #'sly-xref-group #'equal)))
(defun sly-xref-group (xref)
(cond ((sly-xref-has-location-p xref)
(sly-dcase (sly-location.buffer (sly-xref.location xref))
((:file filename) filename)
((:buffer bufname)
(let ((buffer (get-buffer bufname)))
(if buffer
(format "%S" buffer) ; "#<buffer foo.lisp>"
(format "%s (previously existing buffer)" bufname))))
((:buffer-and-file _buffer filename) filename)
((:source-form _) "(S-Exp)")
((:zip _zip entry) entry)))
(t
"(No location)")))
(defun sly-edit-definition-other-window (name)
"Like `sly-edit-definition' but switch to the other window."
(interactive (list (sly-read-symbol-name "Symbol: ")))
(sly-edit-definition name 'window))
(defun sly-edit-definition-other-frame (name)
"Like `sly-edit-definition' but switch to the other window."
(interactive (list (sly-read-symbol-name "Symbol: ")))
(sly-edit-definition name 'frame))
;;;;; first-change-hook
(defun sly-first-change-hook ()
"Notify Lisp that a source file's buffer has been modified."
;; Be careful not to disturb anything!
;; In particular if we muck up the match-data then query-replace
;; breaks. -luke (26/Jul/2004)
(save-excursion
(save-match-data
(when (and (buffer-file-name)
(file-exists-p (buffer-file-name))
(sly-background-activities-enabled-p))
(let ((filename (sly-to-lisp-filename (buffer-file-name))))
(sly-eval-async `(slynk:buffer-first-change ,filename)))))))
(defun sly-setup-first-change-hook ()
(add-hook 'first-change-hook #'sly-first-change-hook nil t))
(add-hook 'sly-mode-hook 'sly-setup-first-change-hook)
;;;; Eval for Lisp
(defun sly-eval-for-lisp (thread tag form-string)
(let ((ok nil)
(value nil)
(error nil)
(c (sly-connection)))
(unwind-protect
(condition-case err
(progn
(sly-check-eval-in-emacs-enabled)
(setq value (eval (read form-string) t))
(sly-check-eval-in-emacs-result value)
(setq ok t))
((debug error)
(setq error err)))
(let ((result (cond (ok `(:ok ,value))
(error `(:error ,(symbol-name (car error))
. ,(mapcar #'prin1-to-string
(cdr error))))
(t `(:abort)))))
(sly-dispatch-event `(:emacs-return ,thread ,tag ,result) c)))))
(defun sly-check-eval-in-emacs-result (x)
"Raise an error if X can't be marshaled."
(or (stringp x)
(memq x '(nil t))
(integerp x)
(keywordp x)
(and (consp x)
(let ((l x))
(while (consp l)
(sly-check-eval-in-emacs-result (car x))
(setq l (cdr l)))
(sly-check-eval-in-emacs-result l)))
(error "Non-serializable return value: %S" x)))
(defun sly-check-eval-in-emacs-enabled ()
"Raise an error if `sly-enable-evaluate-in-emacs' isn't true."
(unless sly-enable-evaluate-in-emacs
(error (concat "sly-eval-in-emacs disabled for security."
"Set sly-enable-evaluate-in-emacs true to enable it."))))
;;;; `ED'
(defvar sly-ed-frame nil
"The frame used by `sly-ed'.")
(defcustom sly-ed-use-dedicated-frame nil
"*When non-nil, `sly-ed' will create and reuse a dedicated frame."
:type 'boolean
:group 'sly-mode)
(cl-defun sly-ed (what )
"Edit WHAT.
WHAT can be:
A filename (string),
A list (:filename FILENAME &key LINE COLUMN POSITION),
A function name (:function-name STRING)
nil.
This is for use in the implementation of COMMON-LISP:ED."
(when sly-ed-use-dedicated-frame
(unless (and sly-ed-frame (frame-live-p sly-ed-frame))
(setq sly-ed-frame (make-frame)))
(select-frame sly-ed-frame))
(raise-frame)
(when what
(sly-dcase what
((:filename file &key line column position bytep)
(find-file (sly-from-lisp-filename file))
(when line (sly-goto-line line))
(when column (move-to-column column))
(when position
(goto-char (if bytep
(byte-to-position position)
position))))
((:function-name name)
(sly-edit-definition name)))))
(defun sly-goto-line (line-number)
"Move to line LINE-NUMBER (1-based).
This is similar to `goto-line' but without pushing the mark and
the display stuff that we neither need nor want."
(cl-assert (= (buffer-size) (- (point-max) (point-min))) ()
"sly-goto-line in narrowed buffer")
(goto-char (point-min))
(forward-line (1- line-number)))
(defun sly-remote-y-or-n-p (thread tag question)
(sly-dispatch-event `(:emacs-return ,thread ,tag ,(sly-y-or-n-p question))))
(defun sly-read-from-minibuffer-for-slynk (thread tag prompt initial-value)
(let ((answer (condition-case nil
(sly-read-from-minibuffer prompt initial-value t)
(quit nil))))
(sly-dispatch-event `(:emacs-return ,thread ,tag ,answer))))
;;;; Interactive evaluation.
(defun sly-interactive-eval (string)
"Read and evaluate STRING and print value in minibuffer.
A prefix argument(`C-u') inserts the result into the current
buffer. A negative prefix argument (`M--') will sends it to the
kill ring."
(interactive (list (sly-read-from-minibuffer "SLY Eval: ")))
(cl-case current-prefix-arg
((nil)
(sly-eval-with-transcript `(slynk:interactive-eval ,string)))
((-)
(sly-eval-save string))
(t
(sly-eval-print string))))
(defvar sly-transcript-start-hook nil
"Hook run before start an evalution.")
(defvar sly-transcript-stop-hook nil
"Hook run after finishing a evalution.")
(defun sly-display-eval-result (value)
;; Use `message', not `sly-message'
(with-temp-buffer
(insert value)
(goto-char (point-min))
(end-of-line 1)
(if (or (< (1+ (point)) (point-max))
(>= (- (point) (point-min)) (frame-width)))
(sly-show-description value (sly-current-package))
(message "=> %s" value))))
(defun sly-eval-with-transcript (form)
"Eval FORM in Lisp. Display output, if any."
(run-hooks 'sly-transcript-start-hook)
(sly-rex () (form)
((:ok value)
(run-hooks 'sly-transcript-stop-hook)
(sly-display-eval-result value))
((:abort condition)
(run-hooks 'sly-transcript-stop-hook)
(sly-message "Evaluation aborted on %s." condition))))
(defun sly-eval-print (string)
"Eval STRING in Lisp; insert any output and the result at point."
(sly-eval-async `(slynk:eval-and-grab-output ,string)
(lambda (result)
(cl-destructuring-bind (output value) result
(push-mark)
(let* ((start (point))
(ppss (syntax-ppss))
(string-or-comment-p (or (nth 3 ppss) (nth 4 ppss))))
(insert output (if string-or-comment-p
""
" => ") value)
(unless string-or-comment-p
(comment-region start (point) 1)))))))
(defun sly-eval-save (string)
"Evaluate STRING in Lisp and save the result in the kill ring."
(sly-eval-async `(slynk:eval-and-grab-output ,string)
(lambda (result)
(cl-destructuring-bind (output value) result
(let ((string (concat output value)))
(kill-new string)
(sly-message "Evaluation finished; pushed result to kill ring."))))))
(defun sly-eval-describe (form)
"Evaluate FORM in Lisp and display the result in a new buffer."
(sly-eval-async form (sly-rcurry #'sly-show-description
(sly-current-package))))
(defvar sly-description-autofocus nil
"If non-nil select description windows on display.")
(defun sly-show-description (string package)
;; So we can have one description buffer open per connection. Useful
;; for comparing the output of DISASSEMBLE across implementations.
;; FIXME: could easily be achieved with M-x rename-buffer
(let ((bufname (sly-buffer-name :description)))
(sly-with-popup-buffer (bufname :package package
:connection t
:select sly-description-autofocus
:mode 'lisp-mode)
(sly-popup-buffer-mode)
(princ string)
(goto-char (point-min)))))
(defun sly-last-expression ()
(buffer-substring-no-properties
(save-excursion (backward-sexp) (point))
(point)))
(defun sly-eval-last-expression ()
"Evaluate the expression preceding point."
(interactive)
(sly-interactive-eval (sly-last-expression)))
(defun sly-eval-defun ()
"Evaluate the current toplevel form.
Use `sly-re-evaluate-defvar' if the from starts with '(defvar'"
(interactive)
(let ((form (apply #'buffer-substring-no-properties
(sly-region-for-defun-at-point))))
(cond ((string-match "^(defvar " form)
(sly-re-evaluate-defvar form))
(t
(sly-interactive-eval form)))))
(defun sly-eval-region (start end)
"Evaluate region."
(interactive "r")
(sly-eval-with-transcript
`(slynk:interactive-eval-region
,(buffer-substring-no-properties start end))))
(defun sly-pprint-eval-region (start end)
"Evaluate region; pprint the value in a buffer."
(interactive "r")
(sly-eval-describe
`(slynk:pprint-eval
,(buffer-substring-no-properties start end))))
(defun sly-eval-buffer ()
"Evaluate the current buffer.
The value is printed in the echo area."
(interactive)
(sly-eval-region (point-min) (point-max)))
(defun sly-re-evaluate-defvar (form)
"Force the re-evaluaton of the defvar form before point.
First make the variable unbound, then evaluate the entire form."
(interactive (list (sly-last-expression)))
(sly-eval-with-transcript `(slynk:re-evaluate-defvar ,form)))
(defun sly-pprint-eval-last-expression ()
"Evaluate the form before point; pprint the value in a buffer."
(interactive)
(sly-eval-describe `(slynk:pprint-eval ,(sly-last-expression))))
(defun sly-eval-print-last-expression (string)
"Evaluate sexp before point; print value into the current buffer"
(interactive (list (sly-last-expression)))
(insert "\n")
(sly-eval-print string))
;;;; Edit Lisp value
;;;
(defun sly-edit-value (form-string)
"\\<sly-edit-value-mode-map>\
Edit the value of a setf'able form in a new buffer.
The value is inserted into a temporary buffer for editing and then set
in Lisp when committed with \\[sly-edit-value-commit]."
(interactive
(list (sly-read-from-minibuffer "Edit value (evaluated): "
(sly-sexp-at-point))))
(sly-eval-async `(slynk:value-for-editing ,form-string)
(let ((form-string form-string)
(package (sly-current-package)))
(lambda (result)
(sly-edit-value-callback form-string result
package)))))
(make-variable-buffer-local
(defvar sly-edit-form-string nil
"The form being edited by `sly-edit-value'."))
(define-minor-mode sly-edit-value-mode
"Mode for editing a Lisp value."
nil
" Edit-Value"
'(("\C-c\C-c" . sly-edit-value-commit)))
(defun sly-edit-value-callback (form-string current-value package)
(let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))
(buffer (sly-with-popup-buffer (name :package package
:connection t
:select t
:mode 'lisp-mode)
(sly-mode 1)
(sly-edit-value-mode 1)
(setq sly-edit-form-string form-string)
(insert current-value)
(current-buffer))))
(with-current-buffer buffer
(setq buffer-read-only nil)
(sly-message "Type C-c C-c when done"))))
(defun sly-edit-value-commit ()
"Commit the edited value to the Lisp image.
\\(See `sly-edit-value'.)"
(interactive)
(if (null sly-edit-form-string)
(error "Not editing a value.")
(let ((value (buffer-substring-no-properties (point-min) (point-max))))
(let ((buffer (current-buffer)))
(sly-eval-async `(slynk:commit-edited-value ,sly-edit-form-string
,value)
(lambda (_)
(with-current-buffer buffer
(quit-window t))))))))
;;;; Tracing
(defun sly-untrace-all ()
"Untrace all functions."
(interactive)
(sly-eval `(slynk:untrace-all)))
(defun sly-toggle-trace-fdefinition (spec)
"Toggle trace."
(interactive (list (sly-read-from-minibuffer
"(Un)trace: " (sly-symbol-at-point))))
(sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec))))
(defun sly-disassemble-symbol (symbol-name)
"Display the disassembly for SYMBOL-NAME."
(interactive (list (sly-read-symbol-name "Disassemble: ")))
(sly-eval-describe `(slynk:disassemble-form ,(concat "'" symbol-name))))
(defun sly-undefine-function (symbol-name)
"Unbind the function slot of SYMBOL-NAME."
(interactive (list (sly-read-symbol-name "fmakunbound: " t)))
(sly-eval-async `(slynk:undefine-function ,symbol-name)
(lambda (result) (sly-message "%s" result))))
(defun sly-remove-method (name qualifiers specializers)
"Remove a method from generic function named NAME.
The method removed is identified by QUALIFIERS and SPECIALIZERS."
(interactive (sly--read-method
"[sly] Remove method from which generic function: "
"[sly] Remove which method from %s"))
(sly-eval `(slynk:remove-method-by-name ,name
',qualifiers
',specializers))
(sly-message "Method removed"))
(defun sly-unintern-symbol (symbol-name package)
"Unintern the symbol given with SYMBOL-NAME PACKAGE."
(interactive (list (sly-read-symbol-name "Unintern symbol: " t)
(sly-read-package-name "from package: "
(sly-current-package))))
(sly-eval-async `(slynk:unintern-symbol ,symbol-name ,package)
(lambda (result) (sly-message "%s" result))))
(defun sly-delete-package (package-name)
"Delete the package with name PACKAGE-NAME."
(interactive (list (sly-read-package-name "Delete package: "
(sly-current-package))))
(sly-eval-async `(cl:delete-package
(slynk::guess-package ,package-name))))
(defun sly-load-file (filename)
"Load the Lisp file FILENAME."
(interactive (list
(read-file-name "[sly] Load file: " nil nil
nil (if (buffer-file-name)
(file-name-nondirectory
(buffer-file-name))))))
(let ((lisp-filename (sly-to-lisp-filename (expand-file-name filename))))
(sly-eval-with-transcript `(slynk:load-file ,lisp-filename))))
(defvar sly-change-directory-hooks nil
"Hook run by `sly-change-directory'.
The functions are called with the new (absolute) directory.")
(defun sly-change-directory (directory)
"Make DIRECTORY become Lisp's current directory.
Return whatever slynk:set-default-directory returns."
(let ((dir (expand-file-name directory)))
(prog1 (sly-eval `(slynk:set-default-directory
(slynk-backend:filename-to-pathname
,(sly-to-lisp-filename dir))))
(sly-with-connection-buffer nil (cd-absolute dir))
(run-hook-with-args 'sly-change-directory-hooks dir))))
(defun sly-cd (directory)
"Make DIRECTORY become Lisp's current directory.
Return whatever slynk:set-default-directory returns."
(interactive (list (read-directory-name "[sly] Directory: " nil nil t)))
(sly-message "default-directory: %s" (sly-change-directory directory)))
(defun sly-pwd ()
"Show Lisp's default directory."
(interactive)
(sly-message "Directory %s" (sly-eval `(slynk:default-directory))))
;;;; Documentation
(defvar sly-documentation-lookup-function
'sly-hyperspec-lookup)
(defun sly-documentation-lookup ()
"Generalized documentation lookup. Defaults to hyperspec lookup."
(interactive)
(call-interactively sly-documentation-lookup-function))
;;;###autoload
(defun sly-hyperspec-lookup (symbol-name)
"A wrapper for `hyperspec-lookup'"
(interactive (list (common-lisp-hyperspec-read-symbol-name
(sly-symbol-at-point))))
(hyperspec-lookup symbol-name))
(defun sly-describe-symbol (symbol-name)
"Describe the symbol at point."
(interactive (list (sly-read-symbol-name "Describe symbol: ")))
(when (not symbol-name)
(error "No symbol given"))
(sly-eval-describe `(slynk:describe-symbol ,symbol-name)))
(defun sly-documentation (symbol-name)
"Display function- or symbol-documentation for SYMBOL-NAME."
(interactive (list (sly-read-symbol-name "Documentation for symbol: ")))
(when (not symbol-name)
(error "No symbol given"))
(sly-eval-describe
`(slynk:documentation-symbol ,symbol-name)))
(defun sly-describe-function (symbol-name)
(interactive (list (sly-read-symbol-name "Describe symbol's function: ")))
(when (not symbol-name)
(error "No symbol given"))
(sly-eval-describe `(slynk:describe-function ,symbol-name)))
(defface sly-apropos-symbol
'((t (:inherit sly-part-button-face)))
"Face for the symbol name in Apropos output."
:group 'sly)
(defface sly-apropos-label
'((t (:inherit italic)))
"Face for label (`Function', `Variable' ...) in Apropos output."
:group 'sly)
(defun sly-apropos-summary (string case-sensitive-p package only-external-p)
"Return a short description for the performed apropos search."
(concat (if case-sensitive-p "Case-sensitive " "")
"Apropos for "
(format "%S" string)
(if package (format " in package %S" package) "")
(if only-external-p " (external symbols only)" "")))
(defun sly-apropos (string &optional only-external-p package
case-sensitive-p)
"Show all bound symbols whose names match STRING. With prefix
arg, you're interactively asked for parameters of the search.
With M-- (negative) prefix arg, prompt for package only. "
(interactive
(cond ((eq '- current-prefix-arg)
(list (sly-read-from-minibuffer "Apropos external symbols: ")
t
(sly-read-package-name "Package (blank for all): "
nil 'allow-blank)
nil))
(current-prefix-arg
(list (sly-read-from-minibuffer "Apropos: ")
(sly-y-or-n-p "External symbols only? ")
(sly-read-package-name "Package (blank for all): "
nil 'allow-blank)
(sly-y-or-n-p "Case-sensitive? ")))
(t
(list (sly-read-from-minibuffer "Apropos external symbols: ") t nil nil))))
(sly-eval-async
`(slynk-apropos:apropos-list-for-emacs ,string ,only-external-p
,case-sensitive-p ',package)
(sly-rcurry #'sly-show-apropos string package
(sly-apropos-summary string case-sensitive-p
package only-external-p))))
(defun sly-apropos-all ()
"Shortcut for (sly-apropos <string> nil nil)"
(interactive)
(sly-apropos (sly-read-from-minibuffer "Apropos all symbols: ") nil nil))
(defun sly-apropos-package (package &optional internal)
"Show apropos listing for symbols in PACKAGE.
With prefix argument include internal symbols."
(interactive (list (let ((pkg (sly-read-package-name "Package: ")))
(if (string= pkg "") (sly-current-package) pkg))
current-prefix-arg))
(sly-apropos "" (not internal) package))
(defvar sly-apropos-mode-map
(let ((map (make-sparse-keymap)))
map))
(define-derived-mode sly-apropos-mode apropos-mode "SLY-Apropos"
"SLY Apropos Mode
TODO"
(sly-mode))
(defun sly-show-apropos (plists string package summary)
(cond ((null plists)
(sly-message "No apropos matches for %S" string))
(t
(sly-with-popup-buffer ((sly-buffer-name :apropos
:connection t)
:package package :connection t
:mode 'sly-apropos-mode)
(if (boundp 'header-line-format)
(setq header-line-format summary)
(insert summary "\n\n"))
(sly-set-truncate-lines)
(sly-print-apropos plists (not package))
(set-syntax-table lisp-mode-syntax-table)
(goto-char (point-min))))))
(define-button-type 'sly-apropos-symbol :supertype 'sly-part
'face nil
'action 'sly-button-goto-source ;default action
'sly-button-inspect
#'(lambda (name _type)
(sly-inspect (format "(quote %s)" name)))
'sly-button-goto-source
#'(lambda (name _type)
(sly-edit-definition name 'window))
'sly-button-describe
#'(lambda (name _type)
(sly-eval-describe `(slynk:describe-symbol ,name))))
(defun sly--package-designator-prefix (designator)
(unless (listp designator)
(error "unknown designator type"))
(concat (cadr designator)
(if (cl-caddr designator) ":" "::")))
(defun sly-apropos-designator-string (designator)
(concat (sly--package-designator-prefix designator)
(car designator)))
(defun sly-apropos-insert-symbol (designator item bounds package-designator-searched-p)
(let ((label (sly-apropos-designator-string designator)))
(setq label
(sly--make-text-button label nil
'face 'sly-apropos-symbol
'part-args (list item nil)
'part-label "Symbol"
:type 'sly-apropos-symbol))
(cl-loop
with offset = (if package-designator-searched-p
0
(length (sly--package-designator-prefix designator)))
for bound in bounds
for (start end) = (if (listp bound) bound (list bound (1+ bound)))
do
(put-text-property (+ start offset) (+ end offset) 'face 'highlight label)
finally (insert label))))
(defun sly-print-apropos (plists package-designator-searched-p)
(cl-loop
for plist in plists
for designator = (plist-get plist :designator)
for item = (substring-no-properties
(sly-apropos-designator-string designator))
do
(sly-apropos-insert-symbol designator item (plist-get plist :bounds) package-designator-searched-p)
(terpri)
(cl-loop for (prop value) on plist by #'cddr
for start = (point)
unless (memq prop '(:designator
:package
:bounds))
do
(let ((namespace (upcase-initials
(replace-regexp-in-string
"-" " " (substring (symbol-name prop) 1)))))
(princ " ")
(insert (propertize namespace
'face 'sly-apropos-label))
(princ ": ")
(princ (cond ((and value
(not (eq value :not-documented)))
value)
(t
"(not documented)")))
(add-text-properties
start (point)
(list 'action 'sly-button-describe
'sly-button-describe
#'(lambda (name type)
(sly-eval-describe `(slynk:describe-definition-for-emacs ,name
,type)))
'part-args (list item prop)
'button t 'apropos-label namespace))
(terpri)))))
(defun sly-apropos-describe (name type)
(sly-eval-describe `(slynk:describe-definition-for-emacs ,name ,type)))
(require 'info)
(defun sly-info--file ()
(or (cl-some (lambda (subdir)
(cl-flet ((existing-file
(name) (let* ((path (expand-file-name subdir sly-path))
(probe (expand-file-name name path)))
(and (file-exists-p probe) probe))))
(or (existing-file "sly.info")
(existing-file "sly.info.gz"))))
(append '("doc" ".") Info-directory-list))
(sly-error
"No sly.info, run `make -C doc sly.info' from a SLY git checkout")))
(require 'info)
(defvar sly-info--cached-node-names nil)
(defun sly-info--node-names (file)
(or sly-info--cached-node-names
(setq sly-info--cached-node-names
(with-temp-buffer
(info file (current-buffer))
(ignore-errors
(Info-build-node-completions))))))
;;;###autoload
(defun sly-info (file &optional node)
"Read SLY manual"
(interactive
(let ((file (sly-info--file)))
(list file
(completing-read "Manual node? (`Top' to read the whole manual): "
(remove '("*") (sly-info--node-names file))
nil t))))
(info (if node (format "(%s)%s" file node) file)))
;;;; XREF: cross-referencing
(defvar sly-xref-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'sly-xref-goto)
(define-key map (kbd "SPC") 'sly-xref-show)
(define-key map (kbd "n") 'sly-xref-next-line)
(define-key map (kbd "p") 'sly-xref-prev-line)
(define-key map (kbd ".") 'sly-xref-next-line)
(define-key map (kbd ",") 'sly-xref-prev-line)
(define-key map (kbd "C-c C-c") 'sly-recompile-xref)
(define-key map (kbd "C-c C-k") 'sly-recompile-all-xrefs)
(define-key map (kbd "q") 'quit-window)
(set-keymap-parent map button-buffer-map)
map))
(define-derived-mode sly-xref-mode lisp-mode "Xref"
"sly-xref-mode: Major mode for cross-referencing.
\\<sly-xref-mode-map>\
The most important commands:
\\[sly-xref-show] - Display referenced source and keep xref window.
\\[sly-xref-goto] - Jump to referenced source and dismiss xref window.
\\{sly-xref-mode-map}"
(setq font-lock-defaults nil)
(setq delayed-mode-hooks nil)
(setq buffer-read-only t)
(sly-mode))
(defun sly-next-line/not-add-newlines ()
(interactive)
(let ((next-line-add-newlines nil))
(forward-line 1)))
;;;;; XREF results buffer and window management
(cl-defmacro sly-with-xref-buffer ((_xref-type _symbol &optional package)
&body body)
"Execute BODY in a xref buffer, then show that buffer."
(declare (indent 1))
`(sly-with-popup-buffer ((sly-buffer-name :xref
:connection t)
:package ,package
:connection t
:select t
:mode 'sly-xref-mode)
(sly-set-truncate-lines)
,@body))
;; TODO: Have this button support more options, not just "show source"
;; and "goto-source"
(define-button-type 'sly-xref :supertype 'sly-part
'action 'sly-button-goto-source ;default action
'mouse-action 'sly-button-goto-source ;default action
'sly-button-show-source #'(lambda (location)
(sly-xref--show-location location))
'sly-button-goto-source #'(lambda (location)
(sly--pop-to-source-location location 'sly-xref)))
(defun sly-xref-button (label location)
(sly--make-text-button label nil
:type 'sly-xref
'part-args (list location)
'part-label "Location"))
(defun sly-insert-xrefs (xref-alist)
"Insert XREF-ALIST in the current-buffer.
XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...).
GROUP and LABEL are for decoration purposes. LOCATION is a
source-location."
(cl-loop for (group . refs) in xref-alist do
(sly-insert-propertized '(face bold) group "\n")
(cl-loop for (label location) in refs
for start = (point)
do
(insert
" "
(sly-xref-button (sly-one-line-ify label) location)
"\n")
(add-text-properties start (point) (list 'sly-location location))))
;; Remove the final newline to prevent accidental window-scrolling
(backward-delete-char 1))
(defun sly-xref-next-line (arg)
(interactive "p")
(let ((button (forward-button arg)))
(when button (sly-button-show-source button))))
(defun sly-xref-prev-line (arg)
(interactive "p")
(sly-xref-next-line (- arg)))
(defun sly-xref--show-location (loc)
(cl-ecase (car loc)
(:location (sly--display-source-location loc))
(:error (sly-message "%s" (cadr loc)))
((nil))))
(defun sly-xref--show-results (xrefs _type symbol package &optional method)
"Maybe show a buffer listing the cross references XREFS.
METHOD is used to set `sly-xref--popup-method', which see."
(cond ((null xrefs)
(sly-message "No references found for %s." symbol)
nil)
(t
(sly-with-xref-buffer (_type _symbol package)
(sly-insert-xrefs xrefs)
(setq sly-xref--popup-method method)
(goto-char (point-min))
(current-buffer)))))
;;;;; XREF commands
(defun sly-who-calls (symbol)
"Show all known callers of the function SYMBOL.
This is implemented with special compiler support, see `sly-list-callers' for a
portable alternative."
(interactive (list (sly-read-symbol-name "Who calls: " t)))
(sly-xref :calls symbol))
(defun sly-calls-who (symbol)
"Show all known functions called by the function SYMBOL.
This is implemented with special compiler support and may not be supported by
all implementations.
See `sly-list-callees' for a portable alternative."
(interactive (list (sly-read-symbol-name "Who calls: " t)))
(sly-xref :calls-who symbol))
(defun sly-who-references (symbol)
"Show all known referrers of the global variable SYMBOL."
(interactive (list (sly-read-symbol-name "Who references: " t)))
(sly-xref :references symbol))
(defun sly-who-binds (symbol)
"Show all known binders of the global variable SYMBOL."
(interactive (list (sly-read-symbol-name "Who binds: " t)))
(sly-xref :binds symbol))
(defun sly-who-sets (symbol)
"Show all known setters of the global variable SYMBOL."
(interactive (list (sly-read-symbol-name "Who sets: " t)))
(sly-xref :sets symbol))
(defun sly-who-macroexpands (symbol)
"Show all known expanders of the macro SYMBOL."
(interactive (list (sly-read-symbol-name "Who macroexpands: " t)))
(sly-xref :macroexpands symbol))
(defun sly-who-specializes (symbol)
"Show all known methods specialized on class SYMBOL."
(interactive (list (sly-read-symbol-name "Who specializes: " t)))
(sly-xref :specializes symbol))
(defun sly-list-callers (symbol-name)
"List the callers of SYMBOL-NAME in a xref window.
See `sly-who-calls' for an implementation-specific alternative."
(interactive (list (sly-read-symbol-name "List callers: ")))
(sly-xref :callers symbol-name))
(defun sly-list-callees (symbol-name)
"List the callees of SYMBOL-NAME in a xref window.
See `sly-calls-who' for an implementation-specific alternative."
(interactive (list (sly-read-symbol-name "List callees: ")))
(sly-xref :callees symbol-name))
(defun sly-xref (type symbol &optional continuation)
"Make an XREF request to Lisp."
(sly-eval-async
`(slynk:xref ',type ',symbol)
(sly-rcurry (lambda (result type symbol package cont)
(and (sly-xref-implemented-p type result)
(let* ((file-alist (cadr (sly-analyze-xrefs result))))
(funcall (or cont 'sly-xref--show-results)
file-alist type symbol package))))
type
symbol
(sly-current-package)
continuation)))
(defun sly-xref-implemented-p (type xrefs)
"Tell if xref TYPE is available according to XREFS."
(cond ((eq xrefs :not-implemented)
(sly-display-oneliner "%s is not implemented yet on %s."
(sly-xref-type type)
(sly-lisp-implementation-name))
nil)
(t t)))
(defun sly-xref-type (type)
"Return a human readable version of xref TYPE."
(format "who-%s" (sly-cl-symbol-name type)))
(defun sly-xref--get-xrefs (types symbol &optional continuation)
"Make multiple XREF requests at once."
(sly-eval-async
`(slynk:xrefs ',types ',symbol)
#'(lambda (result)
(funcall (or continuation
#'sly-xref--show-results)
(cl-loop for (key . val) in result
collect (cons (sly-xref-type key) val))
types symbol (sly-current-package)))))
;;;;; XREF navigation
(defun sly-xref-location-at-point ()
(save-excursion
;; When the end of the last line is at (point-max) we can't find
;; the text property there. Going to bol avoids this problem.
(beginning-of-line 1)
(or (get-text-property (point) 'sly-location)
(error "No reference at point."))))
(defun sly-xref-dspec-at-point ()
(save-excursion
(beginning-of-line 1)
(with-syntax-table lisp-mode-syntax-table
(forward-sexp) ; skip initial whitespaces
(backward-sexp)
(sly-sexp-at-point))))
(defun sly-all-xrefs ()
(let ((xrefs nil))
(save-excursion
(goto-char (point-min))
(while (zerop (forward-line 1))
(sly--when-let (loc (get-text-property (point) 'sly-location))
(let* ((dspec (sly-xref-dspec-at-point))
(xref (make-sly-xref :dspec dspec :location loc)))
(push xref xrefs)))))
(nreverse xrefs)))
(defun sly-xref-goto ()
"Goto the cross-referenced location at point."
(interactive)
(sly--pop-to-source-location (sly-xref-location-at-point) 'sly-xref))
(defun sly-xref-show ()
"Display the xref at point in the other window."
(interactive)
(sly--display-source-location (sly-xref-location-at-point)))
(defun sly-search-property (prop &optional backward prop-value-fn)
"Search the next text range where PROP is non-nil.
Return the value of PROP.
If BACKWARD is non-nil, search backward.
If PROP-VALUE-FN is non-nil use it to extract PROP's value."
(let ((next-candidate (if backward
#'previous-single-char-property-change
#'next-single-char-property-change))
(prop-value-fn (or prop-value-fn
(lambda ()
(get-text-property (point) prop))))
(start (point))
(prop-value))
(while (progn
(goto-char (funcall next-candidate (point) prop))
(not (or (setq prop-value (funcall prop-value-fn))
(eobp)
(bobp)))))
(cond (prop-value)
(t (goto-char start) nil))))
(defun sly-recompile-xref (&optional raw-prefix-arg)
"Recompile definition at point.
Uses prefix arguments like `sly-compile-defun'."
(interactive "P")
(let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg)))
(let ((location (sly-xref-location-at-point))
(dspec (sly-xref-dspec-at-point)))
(sly-recompile-locations
(list location)
(sly-rcurry #'sly-xref-recompilation-cont
(list dspec) (current-buffer))))))
(defun sly-recompile-all-xrefs (&optional raw-prefix-arg)
"Recompile all definitions.
Uses prefix arguments like `sly-compile-defun'."
(interactive "P")
(let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg)))
(let ((dspecs) (locations))
(dolist (xref (sly-all-xrefs))
(when (sly-xref-has-location-p xref)
(push (sly-xref.dspec xref) dspecs)
(push (sly-xref.location xref) locations)))
(sly-recompile-locations
locations
(sly-rcurry #'sly-xref-recompilation-cont
dspecs (current-buffer))))))
(defun sly-xref-recompilation-cont (results dspecs buffer)
;; Extreme long-windedness to insert status of recompilation;
;; sometimes Elisp resembles more of an Ewwlisp.
;; FIXME: Should probably throw out the whole recompilation cruft
;; anyway. -- helmut
;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt
(with-current-buffer buffer
(sly-compilation-finished (sly-aggregate-compilation-results results)
nil)
(save-excursion
(sly-xref-insert-recompilation-flags
dspecs (cl-loop for r in results collect
(or (sly-compilation-result.successp r)
(and (sly-compilation-result.notes r)
:complained)))))))
(defun sly-aggregate-compilation-results (results)
`(:compilation-result
,(cl-reduce #'append (mapcar #'sly-compilation-result.notes results))
,(cl-every #'sly-compilation-result.successp results)
,(cl-reduce #'+ (mapcar #'sly-compilation-result.duration results))))
(defun sly-xref-insert-recompilation-flags (dspecs compilation-results)
(let* ((buffer-read-only nil)
(max-column (sly-column-max)))
(goto-char (point-min))
(cl-loop for dspec in dspecs
for result in compilation-results
do (save-excursion
(cl-loop for dspec2 = (progn (search-forward dspec)
(sly-xref-dspec-at-point))
until (equal dspec2 dspec))
(end-of-line) ; skip old status information.
(insert-char ?\ (1+ (- max-column (current-column))))
(insert (format "[%s]"
(cl-case result
((t) :success)
((nil) :failure)
(t result))))))))
;;;; Macroexpansion
(defvar sly-macroexpansion-minor-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "g") 'sly-macroexpand-again)
(define-key map (kbd "a") 'sly-macroexpand-all-inplace)
(define-key map (kbd "q") 'quit-window)
(define-key map [remap sly-macroexpand-1] 'sly-macroexpand-1-inplace)
(define-key map [remap sly-macroexpand-all] 'sly-macroexpand-all-inplace)
(define-key map [remap sly-compiler-macroexpand-1] 'sly-compiler-macroexpand-1-inplace)
(define-key map [remap sly-expand-1] 'sly-expand-1-inplace)
(define-key map [remap undo] 'sly-macroexpand-undo)
map))
(define-minor-mode sly-macroexpansion-minor-mode
"SLY mode for macroexpansion"
nil
" Macroexpand"
nil
(read-only-mode 1))
(defun sly-macroexpand-undo (&optional arg)
(interactive)
;; Emacs 22.x introduced `undo-only' which
;; works by binding `undo-no-redo' to t. We do
;; it this way so we don't break prior Emacs
;; versions.
(cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg))))
(let ((inhibit-read-only t))
(when (fboundp 'sly-remove-edits)
(sly-remove-edits (point-min) (point-max)))
(undo-only arg))))
(defvar sly-eval-macroexpand-expression nil
"Specifies the last macroexpansion preformed.
This variable specifies both what was expanded and how.")
(defun sly-eval-macroexpand (expander &optional string)
(let ((string (or string
(sly-sexp-at-point 'interactive))))
(setq sly-eval-macroexpand-expression `(,expander ,string))
(sly-eval-async sly-eval-macroexpand-expression
#'sly-initialize-macroexpansion-buffer)))
(defun sly-macroexpand-again ()
"Reperform the last macroexpansion."
(interactive)
(sly-eval-async sly-eval-macroexpand-expression
(sly-rcurry #'sly-initialize-macroexpansion-buffer
(current-buffer))))
(defun sly-initialize-macroexpansion-buffer (expansion &optional buffer)
(pop-to-buffer (or buffer (sly-create-macroexpansion-buffer)))
(setq buffer-undo-list nil) ; Get rid of undo information from
; previous expansions.
(let ((inhibit-read-only t)
(buffer-undo-list t)) ; Make the initial insertion not be undoable.
(erase-buffer)
(insert expansion)
(goto-char (point-min))
(if (fboundp 'font-lock-ensure)
(font-lock-ensure)
(with-no-warnings (font-lock-fontify-buffer)))))
(defun sly-create-macroexpansion-buffer ()
(let ((name (sly-buffer-name :macroexpansion)))
(sly-with-popup-buffer (name :package t :connection t
:mode 'lisp-mode)
(sly-macroexpansion-minor-mode 1)
(setq font-lock-keywords-case-fold-search t)
(current-buffer))))
(defun sly-eval-macroexpand-inplace (expander)
"Substitute the sexp at point with its macroexpansion.
NB: Does not affect sly-eval-macroexpand-expression"
(interactive)
(let* ((bounds (sly-bounds-of-sexp-at-point 'interactive)))
(let* ((start (copy-marker (car bounds)))
(end (copy-marker (cdr bounds)))
(point (point))
(buffer (current-buffer)))
(sly-eval-async
`(,expander ,(buffer-substring-no-properties start end))
(lambda (expansion)
(with-current-buffer buffer
(let ((buffer-read-only nil))
(when (fboundp 'sly-remove-edits)
(sly-remove-edits (point-min) (point-max)))
(goto-char start)
(delete-region start end)
(sly-insert-indented expansion)
(goto-char point))))))))
(defun sly-macroexpand-1 (&optional repeatedly)
"Display the macro expansion of the form at point.
The form is expanded with CL:MACROEXPAND-1 or, if a prefix
argument is given, with CL:MACROEXPAND."
(interactive "P")
(sly-eval-macroexpand
(if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1)))
(defun sly-macroexpand-1-inplace (&optional repeatedly)
(interactive "P")
(sly-eval-macroexpand-inplace
(if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1)))
(defun sly-macroexpand-all (&optional just-one)
"Display the recursively macro expanded sexp at point.
With optional JUST-ONE prefix arg, use CL:MACROEXPAND-1."
(interactive "P")
(sly-eval-macroexpand (if just-one
'slynk:slynk-macroexpand-1
'slynk:slynk-macroexpand-all)))
(defun sly-macroexpand-all-inplace ()
"Display the recursively macro expanded sexp at point."
(interactive)
(sly-eval-macroexpand-inplace 'slynk:slynk-macroexpand-all))
(defun sly-compiler-macroexpand-1 (&optional repeatedly)
"Display the compiler-macro expansion of sexp at point."
(interactive "P")
(sly-eval-macroexpand
(if repeatedly
'slynk:slynk-compiler-macroexpand
'slynk:slynk-compiler-macroexpand-1)))
(defun sly-compiler-macroexpand-1-inplace (&optional repeatedly)
"Display the compiler-macro expansion of sexp at point."
(interactive "P")
(sly-eval-macroexpand-inplace
(if repeatedly
'slynk:slynk-compiler-macroexpand
'slynk:slynk-compiler-macroexpand-1)))
(defun sly-expand-1 (&optional repeatedly)
"Display the macro expansion of the form at point.
The form is expanded with CL:MACROEXPAND-1 or, if a prefix
argument is given, with CL:MACROEXPAND.
Contrary to `sly-macroexpand-1', if the form denotes a compiler
macro, SLYNK-BACKEND:COMPILER-MACROEXPAND or
SLYNK-BACKEND:COMPILER-MACROEXPAND-1 are used instead."
(interactive "P")
(sly-eval-macroexpand
(if repeatedly
'slynk:slynk-expand
'slynk:slynk-expand-1)))
(defun sly-expand-1-inplace (&optional repeatedly)
"Display the macro expansion of the form at point.
The form is expanded with CL:MACROEXPAND-1 or, if a prefix
argument is given, with CL:MACROEXPAND."
(interactive "P")
(sly-eval-macroexpand-inplace
(if repeatedly
'slynk:slynk-expand
'slynk:slynk-expand-1)))
(defun sly-format-string-expand (&optional string)
"Expand the format-string at point and display it.
With prefix arg, or if no string at point, prompt the user for a
string to expand.
"
(interactive (list (or (and (not current-prefix-arg)
(sly-string-at-point))
(sly-read-from-minibuffer "Expand format: "
(sly-string-at-point)))))
(sly-eval-macroexpand 'slynk:slynk-format-string-expand
string))
;;;; Subprocess control
(defun sly-interrupt ()
"Interrupt Lisp."
(interactive)
(cond ((sly-use-sigint-for-interrupt) (sly-send-sigint))
(t (sly-dispatch-event `(:emacs-interrupt ,sly-current-thread)))))
(defun sly-quit ()
(error "Not implemented properly. Use `sly-interrupt' instead."))
(defun sly-quit-lisp (&optional kill interactive)
"Quit lisp, kill the inferior process and associated buffers."
(interactive (list current-prefix-arg t))
(let ((connection (if interactive
(sly-prompt-for-connection "Connection to quit: ")
(sly-current-connection))))
(sly-quit-lisp-internal connection 'sly-quit-sentinel kill)))
(defun sly-quit-lisp-internal (connection sentinel kill)
"Kill SLY socket connection CONNECTION.
Do this by evaluating (SLYNK:QUIT-LISP) in it, and don't wait for
it to reply as usual with other evaluations. If it's non-nil,
setup SENTINEL to run on CONNECTION when it finishes dying. If
KILL is t, and there is such a thing, also kill the inferior lisp
process associated with CONNECTION."
(let ((sly-dispatching-connection connection))
(sly-eval-async '(slynk:quit-lisp))
(set-process-filter connection nil)
(let ((attempt 0)
(dying-p nil))
(set-process-sentinel
connection
(lambda (connection status)
(setq dying-p t)
(sly-message "Connection %s is dying (%s)" connection status)
(let ((inf-process (sly-inferior-process connection)))
(cond ((and kill
inf-process
(not (memq (process-status inf-process) '(exit signal))))
(sly-message "Quitting %s: also killing the inferior process %s"
connection inf-process)
(kill-process inf-process))
((and kill
inf-process)
(sly-message "Quitting %s: inferior process was already dead"
connection
inf-process))
((and
kill
(not inf-process))
(sly-message "Quitting %s: No inferior process to kill!"
connection
inf-process))))
(when sentinel
(funcall sentinel connection status))))
(sly-message
"Waiting for connection %s to die by itself..." connection)
(while (and (< (cl-incf attempt) 30)
(not dying-p))
(sleep-for 0.1))
(unless dying-p
(sly-message
"Connection %s didn't die by itself. Killing it." connection)
(delete-process connection)))))
(defun sly-quit-sentinel (process _message)
(cl-assert (process-status process) 'closed)
(let* ((inferior (sly-inferior-process process))
(inferior-buffer (if inferior (process-buffer inferior))))
(when inferior (delete-process inferior))
(when inferior-buffer (kill-buffer inferior-buffer))
(sly-net-close process "Quitting lisp")
(sly-message "Connection closed.")))
;;;; Debugger (SLY-DB)
(defvar sly-db-hook nil
"Hook run on entry to the debugger.")
(defcustom sly-db-initial-restart-limit 6
"Maximum number of restarts to display initially."
:group 'sly-debugger
:type 'integer)
;;;;; Local variables in the debugger buffer
;; Small helper.
(defun sly-make-variables-buffer-local (&rest variables)
(mapcar #'make-variable-buffer-local variables))
(sly-make-variables-buffer-local
(defvar sly-db-condition nil
"A list (DESCRIPTION TYPE) describing the condition being debugged.")
(defvar sly-db-restarts nil
"List of (NAME DESCRIPTION) for each available restart.")
(defvar sly-db-level nil
"Current debug level (recursion depth) displayed in buffer.")
(defvar sly-db-backtrace-start-marker nil
"Marker placed at the first frame of the backtrace.")
(defvar sly-db-restart-list-start-marker nil
"Marker placed at the first restart in the restart list.")
(defvar sly-db-continuations nil
"List of ids for pending continuation."))
;;;;; SLY-DB macros
;; some macros that we need to define before the first use
(defmacro sly-db-in-face (name string)
"Return STRING propertised with face sly-db-NAME-face."
(declare (indent 1))
(let ((facename (intern (format "sly-db-%s-face" (symbol-name name))))
(var (cl-gensym "string")))
`(let ((,var ,string))
(sly-add-face ',facename ,var)
,var)))
;;;;; sly-db-mode
(defvar sly-db-mode-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 enables autodoc-mode to match
;; #<unreadable> actual arguments in the backtraces with formal
;; arguments of the function. (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 SLY-DB mode.")
(defvar sly-db-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "n" 'sly-db-down)
(define-key map "p" 'sly-db-up)
(define-key map "\M-n" 'sly-db-details-down)
(define-key map "\M-p" 'sly-db-details-up)
(define-key map "<" 'sly-db-beginning-of-backtrace)
(define-key map ">" 'sly-db-end-of-backtrace)
(define-key map "a" 'sly-db-abort)
(define-key map "q" 'sly-db-abort)
(define-key map "c" 'sly-db-continue)
(define-key map "A" 'sly-db-break-with-system-debugger)
(define-key map "B" 'sly-db-break-with-default-debugger)
(define-key map "P" 'sly-db-print-condition)
(define-key map "I" 'sly-db-invoke-restart-by-name)
(define-key map "C" 'sly-db-inspect-condition)
(define-key map ":" 'sly-interactive-eval)
(define-key map "Q" 'sly-db-quit)
(set-keymap-parent map button-buffer-map)
map))
(define-derived-mode sly-db-mode fundamental-mode "sly-db"
"Superior lisp debugger mode.
In addition to ordinary SLY commands, the following are
available:\\<sly-db-mode-map>
Commands to invoke restarts:
\\[sly-db-quit] - quit
\\[sly-db-abort] - abort
\\[sly-db-continue] - continue
\\[sly-db-invoke-restart-0]-\\[sly-db-invoke-restart-9] - restart shortcuts
\\[sly-db-invoke-restart-by-name] - invoke restart by name
Navigation commands:
\\[forward-button] - next interactive button
\\[sly-db-down] - down
\\[sly-db-up] - up
\\[sly-db-details-down] - down, with details
\\[sly-db-details-up] - up, with details
\\[sly-db-beginning-of-backtrace] - beginning of backtrace
\\[sly-db-end-of-backtrace] - end of backtrace
Commands to examine and operate on the selected frame:\\<sly-db-frame-map>
\\[sly-db-show-frame-source] - show frame source
\\[sly-db-goto-source] - go to frame source
\\[sly-db-toggle-details] - toggle details
\\[sly-db-disassemble] - dissassemble frame
\\[sly-db-eval-in-frame] - prompt for a form to eval in frame
\\[sly-db-pprint-eval-in-frame] - eval in frame and pretty print result
\\[sly-db-inspect-in-frame] - inspect in frame's context
\\[sly-db-restart-frame] - restart frame
\\[sly-db-return-from-frame] - return from frame
Miscellaneous commands:\\<sly-db-mode-map>
\\[sly-db-step] - step
\\[sly-db-break-with-default-debugger] - switch to native debugger
\\[sly-db-break-with-system-debugger] - switch to system debugger (gdb)
\\[sly-interactive-eval] - eval
\\[sly-db-inspect-condition] - inspect signalled condition
Full list of commands:
\\{sly-db-mode-map}
Full list of frame-specific commands:
\\{sly-db-frame-map}"
(erase-buffer)
(set-syntax-table sly-db-mode-syntax-table)
(sly-set-truncate-lines)
;; Make original sly-connection "sticky" for SLY-DB commands in this buffer
(setq sly-buffer-connection (sly-connection))
(setq buffer-read-only t)
(sly-mode 1)
(sly-interactive-buttons-mode 1))
;; Keys 0-9 are shortcuts to invoke particular restarts.
(dotimes (number 10)
(let ((fname (intern (format "sly-db-invoke-restart-%S" number)))
(docstring (format "Invoke restart numbered %S." number)))
;; FIXME: In Emacs≥25, you could avoid `eval' and use
;; (defalias .. (lambda .. (:documentation docstring) ...))
;; instead!
(eval `(defun ,fname ()
,docstring
(interactive)
(sly-db-invoke-restart ,number))
t)
(define-key sly-db-mode-map (number-to-string number) fname)))
;;;;; SLY-DB buffer creation & update
(defcustom sly-db-focus-debugger 'auto
"Control if debugger window gets focus immediately.
If nil, the window is never focused automatically; if the symbol
`auto', the window is only focused if the user has performed no
other commands in the meantime (i.e. he/she is expecting a
possible debugger); any other non-nil value means to always
automatically focus the debugger window."
:group 'sly-debugger
:type '(choice (const always) (const never) (const auto)))
(defun sly-filter-buffers (predicate)
"Return a list of where PREDICATE returns true.
PREDICATE is executed in the buffer to test."
(cl-remove-if-not (lambda (%buffer)
(with-current-buffer %buffer
(funcall predicate)))
(buffer-list)))
(defun sly-db-buffers (&optional connection)
"Return a list of all sly-db buffers (belonging to CONNECTION.)"
(if connection
(sly-filter-buffers (lambda ()
(and (eq sly-buffer-connection connection)
(eq major-mode 'sly-db-mode))))
(sly-filter-buffers (lambda () (eq major-mode 'sly-db-mode)))))
(defun sly-db-find-buffer (thread &optional connection)
(let ((connection (or connection (sly-connection))))
(cl-find-if (lambda (buffer)
(with-current-buffer buffer
(and (eq sly-buffer-connection connection)
(eq sly-current-thread thread))))
(sly-db-buffers))))
(defun sly-db-pop-to-debugger-maybe (&optional _button)
"Maybe pop to *sly-db* buffer for current context."
(interactive)
(let ((b (sly-db-find-buffer sly-current-thread)))
(if b (pop-to-buffer b)
(sly-error "Can't find a *sly-db* debugger for this context"))))
(defsubst sly-db-get-default-buffer ()
"Get a sly-db buffer.
The chosen buffer the default connection's it if exists."
(car (sly-db-buffers (sly-current-connection))))
(defun sly-db-pop-to-debugger ()
"Pop to the first *sly-db* buffer if at least one exists."
(interactive)
(let ((b (sly-db-get-default-buffer)))
(if b (pop-to-buffer b)
(sly-error "No *sly-db* debugger buffers for this connection"))))
(defun sly-db-get-buffer (thread &optional connection)
"Find or create a sly-db-buffer for THREAD."
(let ((connection (or connection (sly-connection))))
(or (sly-db-find-buffer thread connection)
(let ((name (sly-buffer-name :db :connection connection
:suffix (format "thread %d" thread))))
(with-current-buffer (generate-new-buffer name)
(setq sly-buffer-connection connection
sly-current-thread thread)
(current-buffer))))))
(defun sly-db-debugged-continuations (connection)
"Return the all debugged continuations for CONNECTION across SLY-DB buffers."
(cl-loop for b in (sly-db-buffers)
append (with-current-buffer b
(and (eq sly-buffer-connection connection)
sly-db-continuations))))
(defun sly-db-confirm-buffer-kill ()
(when (or (not (process-live-p sly-buffer-connection))
(sly-y-or-n-p "Really kill sly-db buffer and throw to toplevel?"))
(ignore-errors (sly-db-quit))
t))
(defun sly-db--display-debugger (_thread)
"Display (or pop to) sly-db for THREAD as appropriate.
Also mark the window as a debugger window."
(let* ((action '(sly-db--display-in-prev-sly-db-window))
(buffer (current-buffer))
(win
(if (cond ((eq sly-db-focus-debugger 'auto)
(eq sly--send-last-command last-command))
(t sly-db-focus-debugger))
(progn
(pop-to-buffer buffer action)
(selected-window))
(display-buffer buffer action))))
(set-window-parameter win 'sly-db buffer)
win))
(defun sly-db-setup (thread level condition restarts frame-specs conts)
"Setup a new SLY-DB buffer.
CONDITION is a string describing the condition to debug.
RESTARTS is a list of strings (NAME DESCRIPTION) for each
available restart. FRAME-SPECS is a list of (NUMBER DESCRIPTION
&optional PLIST) describing the initial portion of the
backtrace. Frames are numbered from 0. CONTS is a list of
pending Emacs continuations."
(with-current-buffer (sly-db-get-buffer thread)
(cl-assert (if (equal sly-db-level level)
(equal sly-db-condition condition)
t)
() "Bug: sly-db-level is equal but condition differs\n%s\n%s"
sly-db-condition condition)
(with-selected-window (sly-db--display-debugger thread)
(unless (equal sly-db-level level)
(let ((inhibit-read-only t))
(sly-db-mode)
(add-hook 'kill-buffer-query-functions
#'sly-db-confirm-buffer-kill
nil t)
(setq sly-current-thread thread)
(setq sly-db-level level)
(setq mode-name (format "sly-db[%d]" sly-db-level))
(setq sly-db-condition condition)
(setq sly-db-restarts restarts)
(setq sly-db-continuations conts)
(sly-db-insert-condition condition)
(insert "\n\n" (sly-db-in-face section "Restarts:") "\n")
(setq sly-db-restart-list-start-marker (point-marker))
(sly-db-insert-restarts restarts 0 sly-db-initial-restart-limit)
(insert "\n" (sly-db-in-face section "Backtrace:") "\n")
(setq sly-db-backtrace-start-marker (point-marker))
(save-excursion
(if frame-specs
(sly-db-insert-frames (sly-db-prune-initial-frames frame-specs) t)
(insert "[No backtrace]")))
(run-hooks 'sly-db-hook)
(set-syntax-table lisp-mode-syntax-table)))
(sly-recenter (point-min) 'allow-moving-point)
(when sly--stack-eval-tags
(sly-message "Entering recursive edit..")
(recursive-edit)))))
(defun sly-db--display-in-prev-sly-db-window (buffer _alist)
(let ((window
(get-window-with-predicate
#'(lambda (w)
(let ((value (window-parameter w 'sly-db)))
(and value
(not (buffer-live-p value))))))))
(when window
(display-buffer-record-window 'reuse window buffer)
(set-window-buffer window buffer)
window)))
(defun sly-db--ensure-initialized (thread level)
"Initialize debugger buffer for THREAD.
If such a buffer exists for LEVEL, it is assumed to have been
sufficiently initialized, and this function does nothing."
(let ((buffer (sly-db-find-buffer thread)))
(unless (and buffer
(with-current-buffer buffer
(equal sly-db-level level)))
(sly-rex ()
('(slynk:debugger-info-for-emacs 0 10)
nil thread)
((:ok result)
(apply #'sly-db-setup thread level result))))))
(defvar sly-db-exit-hook nil
"Hooks run in the debugger buffer just before exit")
(defun sly-db-exit (thread _level &optional stepping)
"Exit from the debug level LEVEL."
(sly--when-let (sly-db (sly-db-find-buffer thread))
(with-current-buffer sly-db
(setq kill-buffer-query-functions
(remove 'sly-db-confirm-buffer-kill kill-buffer-query-functions))
(run-hooks 'sly-db-exit-hook)
(cond (stepping
(setq sly-db-level nil)
(run-with-timer 0.4 nil 'sly-db-close-step-buffer sly-db))
((not (eq sly-db (window-buffer (selected-window))))
;; A different window selection means an indirect,
;; non-interactive exit, we just kill the sly-db buffer.
(kill-buffer))
(t
(quit-window t))))))
(defun sly-db-close-step-buffer (buffer)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(when (not sly-db-level)
(quit-window t)))))
;;;;;; SLY-DB buffer insertion
(defun sly-db-insert-condition (condition)
"Insert the text for CONDITION.
CONDITION should be a list (MESSAGE TYPE EXTRAS).
EXTRAS is currently used for the stepper."
(cl-destructuring-bind (msg type extras) condition
(insert (sly-db-in-face topline msg)
"\n"
(sly-db-in-face condition type))
(sly-db-dispatch-extras extras)))
(defvar sly-db-extras-hooks nil
"Handlers for the extra options sent in a debugger invocation.
Each function is called with one argument, a list (OPTION
VALUE). It should return non-nil iff it can handle OPTION, and
thus preventing other handlers from trying.
Functions are run in the SLDB buffer.")
(defun sly-db-dispatch-extras (extras)
;; this is (mis-)used for the stepper
(dolist (extra extras)
(sly-dcase extra
((:show-frame-source n)
(sly-db-show-frame-source n))
(t
(or (run-hook-with-args-until-success 'sly-db-extras-hooks extra)
;;(error "Unhandled extra element:" extra)
)))))
(defun sly-db-insert-restarts (restarts start count)
"Insert RESTARTS and add the needed text props
RESTARTS should be a list ((NAME DESCRIPTION) ...)."
(let* ((len (length restarts))
(end (if count (min (+ start count) len) len)))
(cl-loop for (name string) in (cl-subseq restarts start end)
for number from start
do (insert
" " (sly-db-in-face restart-number (number-to-string number))
": " (sly-make-action-button (format "[%s]" name)
(let ((n number))
#'(lambda (_button)
(sly-db-invoke-restart n)))
'restart-number number)
" " (sly-db-in-face restart string))
(insert "\n"))
(when (< end len)
(insert (sly-make-action-button
" --more--"
#'(lambda (button)
(let ((inhibit-read-only t))
(delete-region (button-start button)
(1+ (button-end button)))
(sly-db-insert-restarts restarts end nil)
(sly--when-let (win (get-buffer-window (current-buffer)))
(with-selected-window win
(sly-recenter (point-max))))))
'point-entered #'(lambda (_ new) (push-button new)))
"\n"))))
(defun sly-db-frame-restartable-p (frame-spec)
(and (plist-get (cl-caddr frame-spec) :restartable) t))
(defun sly-db-prune-initial-frames (frame-specs)
"Return the prefix of FRAMES-SPECS to initially present to the user.
Regexp heuristics are used to avoid showing SLYNK-internal frames."
(let* ((case-fold-search t)
(rx "^\\([() ]\\|lambda\\)*slynk\\>"))
(or (cl-loop for frame-spec in frame-specs
until (string-match rx (cadr frame-spec))
collect frame-spec)
frame-specs)))
(defun sly-db-insert-frames (frame-specs more)
"Insert frames for FRAME-SPECS into buffer.
If MORE is non-nil, more frames are on the Lisp stack."
(cl-loop
for frame-spec in frame-specs
do (sly-db-insert-frame frame-spec)
finally
(when more
(insert (sly-make-action-button
" --more--\n"
(lambda (button)
(let* ((inhibit-read-only t)
(count 40)
(from (1+ (car frame-spec)))
(to (+ from count))
(frames (sly-eval `(slynk:backtrace ,from ,to)))
(more (sly-length= frames count)))
(delete-region (button-start button)
(button-end button))
(save-excursion
(sly-db-insert-frames frames more))
(sly--when-let (win (get-buffer-window (current-buffer)))
(with-selected-window win
(sly-recenter (point-max))))))
'point-entered #'(lambda (_ new) (push-button new)))))))
(defvar sly-db-frame-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "t") 'sly-db-toggle-details)
(define-key map (kbd "v") 'sly-db-show-frame-source)
(define-key map (kbd ".") 'sly-db-goto-source)
(define-key map (kbd "D") 'sly-db-disassemble)
(define-key map (kbd "e") 'sly-db-eval-in-frame)
(define-key map (kbd "d") 'sly-db-pprint-eval-in-frame)
(define-key map (kbd "i") 'sly-db-inspect-in-frame)
(define-key map (kbd "r") 'sly-db-restart-frame)
(define-key map (kbd "R") 'sly-db-return-from-frame)
(define-key map (kbd "RET") 'sly-db-toggle-details)
(define-key map "s" 'sly-db-step)
(define-key map "x" 'sly-db-next)
(define-key map "o" 'sly-db-out)
(define-key map "b" 'sly-db-break-on-return)
(define-key map "\C-c\C-c" 'sly-db-recompile-frame-source)
(set-keymap-parent map sly-part-button-keymap)
map))
(defvar sly-db-frame-menu-map
(let ((map (make-sparse-keymap)))
(cl-macrolet ((item (label sym)
`(define-key map [,sym] '(menu-item ,label ,sym))))
(item "Dissassemble" sly-db-disassemble)
(item "Eval In Context" sly-db-eval-in-frame)
(item "Eval and Pretty Print In Context" sly-db-pprint-eval-in-frame)
(item "Inspect In Context" sly-db-inspect-in-frame)
(item "Restart" sly-db-restart-frame)
(item "Return Value" sly-db-return-from-frame)
(item "Toggle Details" sly-db-toggle-details)
(item "Show Source" sly-db-show-frame-source)
(item "Go To Source" sly-db-goto-source))
(set-keymap-parent map sly-button-popup-part-menu-keymap)
map))
(define-button-type 'sly-db-frame :supertype 'sly-part
'keymap sly-db-frame-map
'part-menu-keymap sly-db-frame-menu-map
'action 'sly-db-toggle-details
'mouse-action 'sly-db-toggle-details)
(defun sly-db--guess-frame-function (frame)
(ignore-errors
(car (car (read-from-string
(replace-regexp-in-string "#" ""
(cadr frame)))))))
(defun sly-db-frame-button (label frame face &rest props)
(apply #'sly--make-text-button label nil :type 'sly-db-frame
'face face
'field (car frame)
'frame-number (car frame)
'frame-string (cadr frame)
'part-args (list (car frame)
(sly-db--guess-frame-function frame))
'part-label (format "Frame %d" (car frame))
props))
(defun sly-db-frame-number-at-point ()
(let ((button (sly-db-frame-button-near-point)))
(button-get button 'frame-number)))
(defun sly-db-frame-button-near-point ()
(or (sly-button-at nil 'sly-db-frame 'no-error)
(get-text-property (point) 'nearby-frame-button)
(error "No frame button here")))
(defun sly-db-insert-frame (frame-spec)
"Insert a frame for FRAME-SPEC."
(let* ((number (car frame-spec))
(label (cadr frame-spec))
(origin (point)))
(insert
(propertize (format "%2d: " number)
'face 'sly-db-frame-label-face)
(sly-db-frame-button label frame-spec
(if (sly-db-frame-restartable-p frame-spec)
'sly-db-restartable-frame-line-face
'sly-db-frame-line-face))
"\n")
(add-text-properties
origin (point)
(list 'field number
'keymap sly-db-frame-map
'nearby-frame-button (button-at (- (point) 2))))))
;;;;;; SLY-DB examining text props
(defun sly-db--goto-last-visible-frame ()
(goto-char (point-max))
(while (not (get-text-property (point) 'frame-string))
(goto-char (previous-single-property-change (point) 'frame-string))))
(defun sly-db-beginning-of-backtrace ()
"Goto the first frame."
(interactive)
(goto-char sly-db-backtrace-start-marker))
;;;;; SLY-DB commands
(defun sly-db-cycle ()
"Cycle between restart list and backtrace."
(interactive)
(let ((pt (point)))
(cond ((< pt sly-db-restart-list-start-marker)
(goto-char sly-db-restart-list-start-marker))
((< pt sly-db-backtrace-start-marker)
(goto-char sly-db-backtrace-start-marker))
(t
(goto-char sly-db-restart-list-start-marker)))))
(defun sly-db-end-of-backtrace ()
"Fetch the entire backtrace and go to the last frame."
(interactive)
(sly-db--fetch-all-frames)
(sly-db--goto-last-visible-frame))
(defun sly-db--fetch-all-frames ()
(let ((inhibit-read-only t)
(inhibit-point-motion-hooks t))
(sly-db--goto-last-visible-frame)
(let ((last (sly-db-frame-number-at-point)))
(goto-char (next-single-char-property-change (point) 'frame-string))
(delete-region (point) (point-max))
(save-excursion
(insert "\n")
(sly-db-insert-frames (sly-eval `(slynk:backtrace ,(1+ last) nil))
nil)))))
;;;;;; SLY-DB show source
(defun sly-db-show-frame-source (frame-number)
"Highlight FRAME-NUMBER's expression in a source code buffer."
(interactive (list (sly-db-frame-number-at-point)))
(sly-eval-async
`(slynk:frame-source-location ,frame-number)
(lambda (source-location)
(sly-dcase source-location
((:error message)
(sly-message "%s" message)
(ding))
(t
(sly--display-source-location source-location))))))
;;;;;; SLY-DB toggle details
(define-button-type 'sly-db-local-variable :supertype 'sly-part
'sly-button-inspect
#'(lambda (frame-id var-id)
(sly-eval-for-inspector `(slynk:inspect-frame-var ,frame-id
,var-id)) )
'sly-button-pretty-print
#'(lambda (frame-id var-id)
(sly-eval-describe `(slynk:pprint-frame-var ,frame-id
,var-id)))
'sly-button-describe
#'(lambda (frame-id var-id)
(sly-eval-describe `(slynk:describe-frame-var ,frame-id
,var-id))))
(defun sly-db-local-variable-button (label frame-number var-id &rest props)
(apply #'sly--make-text-button label nil
:type 'sly-db-local-variable
'part-args (list frame-number var-id)
'part-label (format "Local Variable %d" var-id) props))
(defun sly-db-frame-details-region (frame-button)
"Get (BEG END) for FRAME-BUTTON's details, or nil if hidden"
(let ((beg (button-end frame-button))
(end (1- (field-end (button-start frame-button) 'escape))))
(unless (= beg end) (list beg end))))
(defun sly-db-toggle-details (frame-button)
"Toggle display of details for the current frame.
The details include local variable bindings and CATCH-tags."
(interactive (list (sly-db-frame-button-near-point)))
(if (sly-db-frame-details-region frame-button)
(sly-db-hide-frame-details frame-button)
(sly-db-show-frame-details frame-button)))
(defun sly-db-show-frame-details (frame-button)
"Show details for FRAME-BUTTON"
(interactive (list (sly-db-frame-button-near-point)))
(cl-destructuring-bind (locals catches)
(sly-eval `(slynk:frame-locals-and-catch-tags
,(button-get frame-button 'frame-number)))
(let ((inhibit-read-only t)
(inhibit-point-motion-hooks t))
(save-excursion
(goto-char (button-end frame-button))
(let ((indent1 " ")
(indent2 " "))
(insert "\n" indent1
(sly-db-in-face section (if locals "Locals:" "[No Locals]")))
(cl-loop for i from 0
for var in locals
with frame-number = (button-get frame-button 'frame-number)
do
(cl-destructuring-bind (&key name id value) var
(insert "\n"
indent2
(sly-db-in-face local-name
(concat name (if (zerop id)
""
(format "#%d" id))))
" = "
(sly-db-local-variable-button value
frame-number
i))))
(when catches
(insert "\n" indent1 (sly-db-in-face section "Catch-tags:"))
(dolist (tag catches)
(sly-propertize-region `(catch-tag ,tag)
(insert "\n" indent2 (sly-db-in-face catch-tag
(format "%s" tag))))))
;; The whole details field is propertized accordingly...
;;
(add-text-properties (button-start frame-button) (point)
(list 'field (button-get frame-button 'field)
'keymap sly-db-frame-map
'nearby-frame-button frame-button))
;; ...but we must remember to remove the 'keymap property from
;; any buttons inside the field
;;
(cl-loop for pos = (point) then (button-start button)
for button = (previous-button pos)
while (and button
(> (button-start button)
(button-start frame-button)))
do (remove-text-properties (button-start button)
(button-end button)
'(keymap nil))))))
(sly-recenter (field-end (button-start frame-button) 'escape))))
(defun sly-db-hide-frame-details (frame-button)
(interactive (list (sly-db-frame-button-near-point)))
(let* ((inhibit-read-only t)
(to-delete (sly-db-frame-details-region frame-button)))
(cl-assert to-delete)
(when (and (< (car to-delete) (point))
(< (point) (cadr to-delete)))
(goto-char (button-start frame-button)))
(apply #'delete-region to-delete)))
(defun sly-db-disassemble (frame-number)
"Disassemble the code for frame with FRAME-NUMBER."
(interactive (list (sly-db-frame-number-at-point)))
(sly-eval-async `(slynk:sly-db-disassemble ,frame-number)
(lambda (result)
(sly-show-description result nil))))
;;;;;; SLY-DB eval and inspect
(defun sly-db-eval-in-frame (frame-number string package)
"Prompt for an expression and evaluate it in the selected frame."
(interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> "))
(sly-eval-async `(slynk:eval-string-in-frame ,string ,frame-number ,package)
'sly-display-eval-result))
(defun sly-db-pprint-eval-in-frame (frame-number string package)
"Prompt for an expression, evaluate in selected frame, pretty-print result."
(interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> "))
(sly-eval-async
`(slynk:pprint-eval-string-in-frame ,string ,frame-number ,package)
(lambda (result)
(sly-show-description result nil))))
(defun sly-db-frame-eval-interactive (fstring)
(let* ((frame-number (sly-db-frame-number-at-point))
(pkg (sly-eval `(slynk:frame-package-name ,frame-number))))
(list frame-number
(let ((sly-buffer-package pkg))
(sly-read-from-minibuffer (format fstring pkg)))
pkg)))
(defun sly-db-inspect-in-frame (frame-number string)
"Prompt for an expression and inspect it in the selected frame."
(interactive (list
(sly-db-frame-number-at-point)
(sly-read-from-minibuffer
"Inspect in frame (evaluated): "
(sly-sexp-at-point))))
(sly-eval-for-inspector `(slynk:inspect-in-frame ,string ,frame-number)))
(defun sly-db-inspect-condition ()
"Inspect the current debugger condition."
(interactive)
(sly-eval-for-inspector '(slynk:inspect-current-condition)))
(defun sly-db-print-condition ()
(interactive)
(sly-eval-describe `(slynk:sdlb-print-condition)))
;;;;;; SLY-DB movement
(defun sly-db-down (arg)
"Move down ARG frames. With negative ARG, move up."
(interactive "p")
(cl-loop
for i from 0 below (abs arg)
do (cl-loop
for tries from 0 below 2
for pos = (point) then next-change
for next-change = (funcall (if (cl-minusp arg)
#'previous-single-char-property-change
#'next-single-char-property-change)
pos 'frame-number)
for prop-value = (get-text-property next-change 'frame-number)
when prop-value do (goto-char next-change)
until prop-value)))
(defun sly-db-up (arg)
"Move up ARG frames. With negative ARG, move down."
(interactive "p")
(sly-db-down (- (or arg 1))))
(defun sly-db-sugar-move (move-fn arg)
(let ((current-frame-button (sly-db-frame-button-near-point)))
(when (and current-frame-button
(sly-db-frame-details-region current-frame-button))
(sly-db-hide-frame-details current-frame-button)))
(funcall move-fn arg)
(let ((frame-button (sly-db-frame-button-near-point)))
(when frame-button
(sly-db-show-frame-source (button-get frame-button 'frame-number))
(sly-db-show-frame-details frame-button))))
(defun sly-db-details-up (arg)
"Move up ARG frames and show details."
(interactive "p")
(sly-db-sugar-move 'sly-db-up arg))
(defun sly-db-details-down (arg)
"Move down ARG frames and show details."
(interactive "p")
(sly-db-sugar-move 'sly-db-down arg))
;;;;;; SLY-DB restarts
(defun sly-db-quit ()
"Quit to toplevel."
(interactive)
(cl-assert sly-db-restarts () "sly-db-quit called outside of sly-db buffer")
(sly-rex () ('(slynk:throw-to-toplevel))
((:ok x) (error "sly-db-quit returned [%s]" x))
((:abort _))))
(defun sly-db-continue ()
"Invoke the \"continue\" restart."
(interactive)
(cl-assert sly-db-restarts () "sly-db-continue called outside of sly-db buffer")
(sly-rex ()
('(slynk:sly-db-continue))
((:ok _)
(sly-message "No restart named continue")
(ding))
((:abort _))))
(defun sly-db-abort ()
"Invoke the \"abort\" restart."
(interactive)
(sly-eval-async '(slynk:sly-db-abort)
(lambda (v) (sly-message "Restart returned: %S" v))))
(defun sly-db-invoke-restart (restart-number)
"Invoke the restart number NUMBER.
Interactively get the number from a button at point."
(interactive (button-get (sly-button-at (point)) 'restart-number))
(sly-rex ()
((list 'slynk:invoke-nth-restart-for-emacs sly-db-level restart-number))
((:ok value) (sly-message "Restart returned: %s" value))
((:abort _))))
(defun sly-db-invoke-restart-by-name (restart-name)
(interactive (list (let ((completion-ignore-case t))
(completing-read "Restart: " sly-db-restarts nil t
""
'sly-db-invoke-restart-by-name))))
(sly-db-invoke-restart (cl-position restart-name sly-db-restarts
:test 'string= :key #'cl-first)))
(defun sly-db-break-with-default-debugger (&optional dont-unwind)
"Enter default debugger."
(interactive "P")
(sly-rex ()
((list 'slynk:sly-db-break-with-default-debugger
(not (not dont-unwind)))
nil sly-current-thread)
((:abort _))))
(defun sly-db-break-with-system-debugger (&optional lightweight)
"Enter system debugger (gdb)."
(interactive "P")
(sly-attach-gdb sly-buffer-connection lightweight))
(defun sly-attach-gdb (connection &optional lightweight)
"Run `gud-gdb'on the connection with PID `pid'.
If `lightweight' is given, do not send any request to the
inferior Lisp (e.g. to obtain default gdb config) but only
operate from the Emacs side; intended for cases where the Lisp is
truly screwed up."
(interactive
(list (sly-read-connection "Attach gdb to: " (sly-connection)) "P"))
(let ((pid (sly-pid connection))
(file (sly-lisp-implementation-program connection))
(commands (unless lightweight
(let ((sly-dispatching-connection connection))
(sly-eval `(slynk:gdb-initial-commands))))))
(gud-gdb (format "gdb -p %d %s" pid (or file "")))
(with-current-buffer gud-comint-buffer
(dolist (cmd commands)
;; First wait until gdb was initialized, then wait until current
;; command was processed.
(while (not (looking-back comint-prompt-regexp (line-beginning-position)
nil))
(sit-for 0.01))
;; We do not use `gud-call' because we want the initial commands
;; to be displayed by the user so he knows what he's got.
(insert cmd)
(comint-send-input)))))
(defun sly-read-connection (prompt &optional initial-value)
"Read a connection from the minibuffer.
Return the net process, or nil."
(cl-assert (memq initial-value sly-net-processes))
(let* ((to-string (lambda (p)
(format "%s (pid %d)"
(sly-connection-name p) (sly-pid p))))
(candidates (mapcar (lambda (p) (cons (funcall to-string p) p))
sly-net-processes)))
(cdr (assoc (completing-read prompt candidates
nil t (funcall to-string initial-value))
candidates))))
(defun sly-db-step (frame-number)
"Step to next basic-block boundary."
(interactive (list (sly-db-frame-number-at-point)))
(sly-eval-async `(slynk:sly-db-step ,frame-number)))
(defun sly-db-next (frame-number)
"Step over call."
(interactive (list (sly-db-frame-number-at-point)))
(sly-eval-async `(slynk:sly-db-next ,frame-number)))
(defun sly-db-out (frame-number)
"Resume stepping after returning from this function."
(interactive (list (sly-db-frame-number-at-point)))
(sly-eval-async `(slynk:sly-db-out ,frame-number)))
(defun sly-db-break-on-return (frame-number)
"Set a breakpoint at the current frame.
The debugger is entered when the frame exits."
(interactive (list (sly-db-frame-number-at-point)))
(sly-eval-async `(slynk:sly-db-break-on-return ,frame-number)
(lambda (msg) (sly-message "%s" msg))))
(defun sly-db-break (name)
"Set a breakpoint at the start of the function NAME."
(interactive (list (sly-read-symbol-name "Function: " t)))
(sly-eval-async `(slynk:sly-db-break ,name)
(lambda (msg) (sly-message "%s" msg))))
(defun sly-db-return-from-frame (frame-number string)
"Reads an expression in the minibuffer and causes the function to
return that value, evaluated in the context of the frame."
(interactive (list (sly-db-frame-number-at-point)
(sly-read-from-minibuffer "Return from frame: ")))
(sly-rex ()
((list 'slynk:sly-db-return-from-frame frame-number string))
((:ok value) (sly-message "%s" value))
((:abort _))))
(defun sly-db-restart-frame (frame-number)
"Causes the frame to restart execution with the same arguments as it
was called originally."
(interactive (list (sly-db-frame-number-at-point)))
(sly-rex ()
((list 'slynk:restart-frame frame-number))
((:ok value) (sly-message "%s" value))
((:abort _))))
(defun sly-toggle-break-on-signals ()
"Toggle the value of *break-on-signals*."
(interactive)
(sly-eval-async `(slynk:toggle-break-on-signals)
(lambda (msg) (sly-message "%s" msg))))
;;;;;; SLY-DB recompilation commands
(defun sly-db-recompile-frame-source (frame-number &optional raw-prefix-arg)
(interactive
(list (sly-db-frame-number-at-point) current-prefix-arg))
(sly-eval-async
`(slynk:frame-source-location ,frame-number)
(let ((policy (sly-compute-policy raw-prefix-arg)))
(lambda (source-location)
(sly-dcase source-location
((:error message)
(sly-message "%s" message)
(ding))
(t
(let ((sly-compilation-policy policy))
(sly-recompile-location source-location))))))))
;;;; Thread control panel
(defvar sly-threads-buffer-timer nil)
(defcustom sly-threads-update-interval nil
"Interval at which the list of threads will be updated."
:type '(choice
(number :value 0.5)
(const nil))
:group 'sly-ui)
(defun sly-list-threads ()
"Display a list of threads."
(interactive)
(let ((name (sly-buffer-name :threads
:connection t)))
(sly-with-popup-buffer (name :connection t
:mode 'sly-thread-control-mode)
(sly-update-threads-buffer (current-buffer))
(goto-char (point-min))
(when sly-threads-update-interval
(when sly-threads-buffer-timer
(cancel-timer sly-threads-buffer-timer))
(setq sly-threads-buffer-timer
(run-with-timer
sly-threads-update-interval
sly-threads-update-interval
'sly-update-threads-buffer
(current-buffer))))
(add-hook 'kill-buffer-hook 'sly--threads-buffer-teardown
'append 'local))))
(defun sly--threads-buffer-teardown ()
(when sly-threads-buffer-timer
(cancel-timer sly-threads-buffer-timer))
(when (process-live-p sly-buffer-connection)
(sly-eval-async `(slynk:quit-thread-browser))))
(defun sly-update-threads-buffer (&optional buffer)
(interactive)
(with-current-buffer (or buffer
(current-buffer))
(sly-eval-async '(slynk:list-threads)
#'(lambda (threads)
(with-current-buffer (current-buffer)
(sly--display-threads threads))))))
(defun sly-move-point (position)
"Move point in the current buffer and in the window the buffer is displayed."
(let ((window (get-buffer-window (current-buffer) t)))
(goto-char position)
(when window
(set-window-point window position))))
(defun sly--display-threads (threads)
(let* ((inhibit-read-only t)
(old-thread-id (get-text-property (point) 'thread-id))
(old-line (line-number-at-pos))
(old-column (current-column)))
(erase-buffer)
(sly-insert-threads threads)
(let ((new-line (cl-position old-thread-id (cdr threads)
:key #'car :test #'equal)))
(goto-char (point-min))
(forward-line (or new-line old-line))
(move-to-column old-column)
(sly-move-point (point)))))
(defun sly-transpose-lists (list-of-lists)
(let ((ncols (length (car list-of-lists))))
(cl-loop for col-index below ncols
collect (cl-loop for row in list-of-lists
collect (elt row col-index)))))
(defun sly-insert-table-row (line line-props col-props col-widths)
(sly-propertize-region line-props
(cl-loop for string in line
for col-prop in col-props
for width in col-widths do
(sly-insert-propertized col-prop string)
(insert-char ?\ (- width (length string))))))
(defun sly-insert-table (rows header row-properties column-properties)
"Insert a \"table\" so that the columns are nicely aligned."
(let* ((ncols (length header))
(lines (cons header rows))
(widths (cl-loop for columns in (sly-transpose-lists lines)
collect (1+ (cl-loop for cell in columns
maximize (length cell)))))
(header-line (with-temp-buffer
(sly-insert-table-row
header nil (make-list ncols nil) widths)
(buffer-string))))
(cond ((boundp 'header-line-format)
(setq header-line-format header-line))
(t (insert header-line "\n")))
(cl-loop for line in rows for line-props in row-properties do
(sly-insert-table-row line line-props column-properties widths)
(insert "\n"))))
(defvar sly-threads-table-properties
'(nil (face bold)))
(defun sly-insert-threads (threads)
(let* ((labels (car threads))
(threads (cdr threads))
(header (cl-loop for label in labels collect
(capitalize (substring (symbol-name label) 1))))
(rows (cl-loop for thread in threads collect
(cl-loop for prop in thread collect
(format "%s" prop))))
(line-props (cl-loop for (id) in threads for i from 0
collect `(thread-index ,i thread-id ,id)))
(col-props (cl-loop for nil in labels for i from 0 collect
(nth i sly-threads-table-properties))))
(sly-insert-table rows header line-props col-props)))
;;;;; Major mode
(defvar sly-thread-control-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "a" 'sly-thread-attach)
(define-key map "d" 'sly-thread-debug)
(define-key map "g" 'sly-update-threads-buffer)
(define-key map "k" 'sly-thread-kill)
(define-key map "q" 'quit-window)
map))
(define-derived-mode sly-thread-control-mode fundamental-mode
"Threads"
"SLY Thread Control Panel Mode.
\\{sly-thread-control-mode-map}"
(when sly-truncate-lines
(set (make-local-variable 'truncate-lines) t))
(read-only-mode 1)
(sly-mode 1)
(setq buffer-undo-list t))
(defun sly-thread-kill ()
(interactive)
(sly-eval `(cl:mapc 'slynk:kill-nth-thread
',(sly-get-properties 'thread-index)))
(call-interactively 'sly-update-threads-buffer))
(defun sly-get-region-properties (prop start end)
(cl-loop for position = (if (get-text-property start prop)
start
(next-single-property-change start prop))
then (next-single-property-change position prop)
while (<= position end)
collect (get-text-property position prop)))
(defun sly-get-properties (prop)
(if (use-region-p)
(sly-get-region-properties prop
(region-beginning)
(region-end))
(let ((value (get-text-property (point) prop)))
(when value
(list value)))))
(defun sly-thread-attach ()
(interactive)
(let ((id (get-text-property (point) 'thread-index))
(file (sly-slynk-port-file)))
(sly-eval-async `(slynk:start-slynk-server-in-thread ,id ,file)))
(sly-read-port-and-connect nil))
(defun sly-thread-debug ()
(interactive)
(let ((id (get-text-property (point) 'thread-index)))
(sly-eval-async `(slynk:debug-nth-thread ,id))))
;;;;; Connection listing
(defvar sly-connection-list-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "d" 'sly-connection-list-make-default)
(define-key map "g" 'sly-update-connection-list)
(define-key map (kbd "RET") 'sly-connection-list-default-action)
(define-key map (kbd "C-m") 'sly-connection-list-default-action)
(define-key map (kbd "C-k") 'sly-quit-connection-at-point)
(define-key map (kbd "R") 'sly-restart-connection-at-point)
(define-key map (kbd "q") 'quit-window)
map))
(define-derived-mode sly-connection-list-mode tabulated-list-mode
"SLY-Connections"
"SLY Connection List Mode.
\\{sly-connection-list-mode-map}"
(set (make-local-variable 'tabulated-list-format)
`[("Default" 8) ("Name" 24 t) ("Host" 12)
("Port" 6) ("Pid" 6 t) ("Type" 1000 t)])
(tabulated-list-init-header))
(defun sly--connection-at-point ()
(or (get-text-property (point) 'tabulated-list-id)
(error "No connection at point")))
(defvar sly-connection-list-button-action nil)
(defun sly-connection-list-default-action (connection)
(interactive (list (sly--connection-at-point)))
(funcall sly-connection-list-button-action connection))
(defun sly-update-connection-list ()
(interactive)
(set (make-local-variable 'tabulated-list-entries)
(mapcar
#'(lambda (p)
(list p
`[,(if (eq sly-default-connection p) "*" " ")
(,(file-name-nondirectory (or (sly-connection-name p)
"unknown"))
action
,#'(lambda (_button)
(and sly-connection-list-button-action
(funcall sly-connection-list-button-action p))))
,(car (process-contact p))
,(format "%s" (cl-second (process-contact p)))
,(format "%s" (sly-pid p))
,(or (sly-lisp-implementation-type p)
"unknown")]))
(reverse sly-net-processes)))
(let ((p (point)))
(tabulated-list-print)
(goto-char p)))
(defun sly-quit-connection-at-point (connection)
(interactive (list (sly--connection-at-point)))
(let ((sly-dispatching-connection connection)
(end (time-add (current-time) (seconds-to-time 3))))
(sly-quit-lisp t)
(while (memq connection sly-net-processes)
(when (time-less-p end (current-time))
(sly-message "Quit timeout expired. Disconnecting.")
(delete-process connection))
(sit-for 0.1)))
(sly-update-connection-list))
(defun sly-restart-connection-at-point (connection)
(interactive (list (sly--connection-at-point)))
(when (sly-y-or-n-p "Really restart '%s'" (sly-connection-name connection))
(let ((sly-dispatching-connection connection))
(sly-restart-inferior-lisp))))
(defun sly-connection-list-make-default ()
"Make the connection at point the default connection."
(interactive)
(sly-select-connection (sly--connection-at-point))
(sly-update-connection-list))
(defun sly-list-connections ()
"Display a list of all connections."
(interactive)
(sly-with-popup-buffer ((sly-buffer-name :connections)
:mode 'sly-connection-list-mode)
(sly-update-connection-list)))
;;;; Inspector
(defgroup sly-inspector nil
"Options for the SLY inspector."
:prefix "sly-inspector-"
:group 'sly)
(defvar sly--this-inspector-name nil
"Buffer-local inspector name (a string), or nil")
(cl-defun sly-eval-for-inspector (slyfun-and-args
&key (error-message "Couldn't inspect")
restore-point
save-selected-window
(inspector-name sly--this-inspector-name)
opener)
(if (cl-some #'listp slyfun-and-args)
(sly-warning
"`sly-eval-for-inspector' not meant to be passed a generic form"))
(let ((pos (and (eq major-mode 'sly-inspector-mode)
(sly-inspector-position))))
(sly-eval-async `(slynk:eval-for-inspector
,sly--this-inspector-name ; current inspector, if any
,inspector-name ; target inspector, if any
',(car slyfun-and-args)
,@(cdr slyfun-and-args))
(or opener
(lambda (results)
(let ((opener (lambda ()
(sly--open-inspector
results
:point (and restore-point pos)
:inspector-name inspector-name
:switch (not save-selected-window)))))
(cond (results
(funcall opener))
(t
(sly-message error-message)))))))))
(defun sly-read-inspector-name ()
(let* ((names (cl-loop for b in (buffer-list)
when (with-current-buffer b
(and (eq sly-buffer-connection
(sly-current-connection))
(eq major-mode 'sly-inspector-mode)))
when (buffer-local-value 'sly--this-inspector-name b)
collect it))
(result (completing-read "Inspector name: " (cons "default"
names)
nil nil nil nil "default")))
(unless (string= result "default")
result)))
(defun sly-maybe-read-inspector-name ()
(or (and current-prefix-arg
(sly-read-inspector-name))
sly--this-inspector-name))
(defun sly-inspect (string &optional inspector-name)
"Eval an expression and inspect the result."
(interactive
(let* ((name (sly-maybe-read-inspector-name))
(string (sly-read-from-minibuffer
(concat "Inspect value"
(and name
(format " in inspector \"%s\"" name))
" (evaluated): ")
(sly-sexp-at-point 'interactive nil nil))))
(list string name)))
(sly-eval-for-inspector `(slynk:init-inspector ,string)
:inspector-name inspector-name))
(defvar sly-inspector-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "l" 'sly-inspector-pop)
(define-key map "n" 'sly-inspector-next)
(define-key map [mouse-6] 'sly-inspector-pop)
(define-key map [mouse-7] 'sly-inspector-next)
(define-key map " " 'sly-inspector-next)
(define-key map "D" 'sly-inspector-describe-inspectee)
(define-key map "e" 'sly-inspector-eval)
(define-key map "h" 'sly-inspector-history)
(define-key map "g" 'sly-inspector-reinspect)
(define-key map ">" 'sly-inspector-fetch-all)
(define-key map "q" 'sly-inspector-quit)
(set-keymap-parent map button-buffer-map)
map))
(define-derived-mode sly-inspector-mode fundamental-mode
"SLY-Inspector"
"
\\{sly-inspector-mode-map}"
(set-syntax-table lisp-mode-syntax-table)
(sly-set-truncate-lines)
(setq buffer-read-only t)
(sly-mode 1))
(define-button-type 'sly-inspector-part :supertype 'sly-part
'sly-button-inspect
#'(lambda (id)
(sly-eval-for-inspector `(slynk:inspect-nth-part ,id)
:inspector-name (sly-maybe-read-inspector-name)))
'sly-button-pretty-print
#'(lambda (id)
(sly-eval-describe `(slynk:pprint-inspector-part ,id)))
'sly-button-describe
#'(lambda (id)
(sly-eval-describe `(slynk:describe-inspector-part ,id)))
'sly-button-show-source
#'(lambda (id)
(sly-eval-async
`(slynk:find-source-location-for-emacs '(:inspector ,id))
#'(lambda (result)
(sly--display-source-location result 'noerror)))))
(defun sly-inspector-part-button (label id &rest props)
(apply #'sly--make-text-button
label nil
:type 'sly-inspector-part
'part-args (list id)
'part-label "Inspector Object"
props))
(defmacro sly-inspector-fontify (face string)
`(sly-add-face ',(intern (format "sly-inspector-%s-face" face)) ,string))
(cl-defun sly--open-inspector (inspected-parts
&key point kill-hook inspector-name (switch t))
"Display INSPECTED-PARTS in a new inspector window.
Optionally set point to POINT. If KILL-HOOK is provided, it is
added to local KILL-BUFFER hooks for the inspector
buffer. INSPECTOR-NAME is the name of the target inspector, or
nil if the default one is to be used. SWITCH indicates the
buffer should be switched to (defaults to t)"
(sly-with-popup-buffer ((sly-buffer-name :inspector
:connection t
:suffix inspector-name)
:mode 'sly-inspector-mode
:select switch
:same-window-p
(and (eq major-mode 'sly-inspector-mode)
(or (null inspector-name)
(eq sly--this-inspector-name inspector-name)))
:connection t)
(when kill-hook
(add-hook 'kill-buffer-hook kill-hook t t))
(set (make-local-variable 'sly--this-inspector-name) inspector-name)
(cl-destructuring-bind (&key id title content) inspected-parts
(cl-macrolet ((fontify (face string)
`(sly-inspector-fontify ,face ,string)))
(insert (sly-inspector-part-button title id 'skip t))
(while (eq (char-before) ?\n)
(backward-delete-char 1))
(insert "\n" (fontify label "--------------------") "\n")
(save-excursion
(sly-inspector-insert-content content))
(when point
(cl-check-type point cons)
(ignore-errors
(goto-char (point-min))
(forward-line (1- (car point)))
(move-to-column (cdr point))))))
(buffer-disable-undo)))
(defvar sly-inspector-limit 500)
(defun sly-inspector-insert-content (content)
(sly-inspector-fetch-chunk
content nil
(lambda (chunk)
(let ((inhibit-read-only t))
(sly-inspector-insert-chunk chunk t t)))))
(defun sly-inspector-insert-chunk (chunk prev next)
"Insert CHUNK at point.
If PREV resp. NEXT are true insert more-buttons as needed."
(cl-destructuring-bind (ispecs len start end) chunk
(when (and prev (> start 0))
(sly-inspector-insert-more-button start t))
(mapc #'sly-inspector-insert-ispec ispecs)
(when (and next (< end len))
(sly-inspector-insert-more-button end nil))))
(defun sly-inspector-insert-ispec (ispec)
(insert
(if (stringp ispec) ispec
(sly-dcase ispec
((:value string id)
(sly-inspector-part-button string id))
((:label string)
(sly-inspector-fontify label string))
((:action string id)
(sly-make-action-button
string
#'(lambda (_button)
(sly-eval-for-inspector `(slynk::inspector-call-nth-action ,id)
:restore-point t))))))))
(defun sly-inspector-position ()
"Return a pair (Y-POSITION X-POSITION) representing the
position of point in the current buffer."
;; We make sure we return absolute coordinates even if the user has
;; narrowed the buffer.
;; FIXME: why would somebody narrow the buffer?
(save-restriction
(widen)
(cons (line-number-at-pos)
(current-column))))
(defun sly-inspector-pop ()
"Reinspect the previous object."
(interactive)
(sly-eval-for-inspector `(slynk:inspector-pop)
:error-message "No previous object"))
(defun sly-inspector-next ()
"Inspect the next object in the history."
(interactive)
(sly-eval-for-inspector `(slynk:inspector-next)
:error-message "No next object"))
(defun sly-inspector-quit (&optional reset)
"Quit the inspector. If RESET, clear Lisp-side history.
If RESET, any references to inspectee's that may be holding up
garbage collection are released. If RESET, the buffer is
killed (since it would become useless otherwise), else it is just
buried."
(interactive "P")
(when reset (sly-eval-async `(slynk:quit-inspector)))
(quit-window reset))
(defun sly-inspector-describe-inspectee ()
"Describe the currently inspected object"
(interactive)
(sly-eval-describe `(slynk:describe-inspectee)))
(defun sly-inspector-eval (string)
"Eval an expression in the context of the inspected object.
The `*' variable will be bound to the inspected object."
(interactive (list (sly-read-from-minibuffer "Inspector eval: ")))
(sly-eval-with-transcript `(slynk:inspector-eval ,string)))
(defun sly-inspector-history ()
"Show the previously inspected objects."
(interactive)
(sly-eval-describe `(slynk:inspector-history)))
(defun sly-inspector-reinspect (&optional inspector-name)
(interactive (list (sly-maybe-read-inspector-name)))
(sly-eval-for-inspector `(slynk:inspector-reinspect)
:inspector-name inspector-name))
(defun sly-inspector-toggle-verbose ()
(interactive)
(sly-eval-for-inspector `(slynk:inspector-toggle-verbose)))
(defun sly-inspector-insert-more-button (index previous)
(insert (sly-make-action-button
(if previous " [--more--]\n" " [--more--]")
#'sly-inspector-fetch-more
'range-args (list index previous))))
(defun sly-inspector-fetch-all ()
"Fetch all inspector contents and go to the end."
(interactive)
(let ((button (button-at (1- (point-max)))))
(cond ((and button
(button-get button 'range-args))
(let (sly-inspector-limit)
(sly-inspector-fetch-more button)))
(t
(sly-error "No more elements to fetch")))))
(defun sly-inspector-fetch-more (button)
(cl-destructuring-bind (index prev) (button-get button 'range-args)
(sly-inspector-fetch-chunk
(list '() (1+ index) index index) prev
(sly-rcurry
(lambda (chunk prev)
(let ((inhibit-read-only t))
(delete-region (button-start button) (button-end button))
(sly-inspector-insert-chunk chunk prev (not prev))))
prev))))
(defun sly-inspector-fetch-chunk (chunk prev cont)
(sly-inspector-fetch chunk sly-inspector-limit prev cont))
(defun sly-inspector-fetch (chunk limit prev cont)
(cl-destructuring-bind (from to)
(sly-inspector-next-range chunk limit prev)
(cond ((and from to)
(sly-eval-for-inspector
`(slynk:inspector-range ,from ,to)
:opener (sly-rcurry (lambda (chunk2 chunk1 limit prev cont)
(sly-inspector-fetch
(sly-inspector-join-chunks chunk1 chunk2)
limit prev cont))
chunk limit prev cont)))
(t (funcall cont chunk)))))
(defun sly-inspector-next-range (chunk limit prev)
(cl-destructuring-bind (_ len start end) chunk
(let ((count (- end start)))
(cond ((and prev (< 0 start) (or (not limit) (< count limit)))
(list (if limit (max (- end limit) 0) 0) start))
((and (not prev) (< end len) (or (not limit) (< count limit)))
(list end (if limit (+ start limit) most-positive-fixnum)))
(t '(nil nil))))))
(defun sly-inspector-join-chunks (chunk1 chunk2)
(cl-destructuring-bind (i1 _l1 s1 e1) chunk1
(cl-destructuring-bind (i2 l2 s2 e2) chunk2
(cond ((= e1 s2)
(list (append i1 i2) l2 s1 e2))
((= e2 s1)
(list (append i2 i1) l2 s2 e1))
(t (error "Invalid chunks"))))))
;;;; Indentation
(defun sly-update-indentation ()
"Update indentation for all macros defined in the Lisp system."
(interactive)
(sly-eval-async '(slynk:update-indentation-information)))
(defvar sly-indentation-update-hooks)
(defun sly-intern-indentation-spec (spec)
(cond ((consp spec)
(cons (sly-intern-indentation-spec (car spec))
(sly-intern-indentation-spec (cdr spec))))
((stringp spec)
(intern spec))
(t
spec)))
;; FIXME: restore the old version without per-package
;; stuff. sly-indentation.el should be able tho disable the simple
;; version if needed.
(defun sly-handle-indentation-update (alist)
"Update Lisp indent information.
ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation
settings for `sly-common-lisp-indent-function'. The appropriate property
is setup, unless the user already set one explicitly."
(dolist (info alist)
(let ((symbol (intern (car info)))
(indent (sly-intern-indentation-spec (cl-second info)))
(packages (cl-third info)))
(if (and (boundp 'sly-common-lisp-system-indentation)
(fboundp 'sly-update-system-indentation))
;; A table provided by sly-cl-indent.el.
(funcall #'sly-update-system-indentation symbol indent packages)
;; Does the symbol have an indentation value that we set?
(when (equal (get symbol 'sly-common-lisp-indent-function)
(get symbol 'sly-indent))
(put symbol 'sly-common-lisp-indent-function indent)
(put symbol 'sly-indent indent)))
(run-hook-with-args 'sly-indentation-update-hooks
symbol indent packages))))
;;;; Contrib modules
(defun sly-contrib--load-slynk-dependencies ()
(let ((needed (cl-remove-if (lambda (s)
(cl-find (symbol-name s)
(sly-lisp-modules)
:key #'downcase
:test #'string=))
sly-contrib--required-slynk-modules
:key #'car)))
(when needed
;; No asynchronous request because with :SPAWN that could result
;; in the attempt to load modules concurrently which may not be
;; supported by the host Lisp.
(sly-eval `(slynk:slynk-add-load-paths ',(cl-remove-duplicates
(mapcar #'cl-second needed)
:test #'string=)))
(let* ((result (sly-eval
`(slynk:slynk-require
',(mapcar #'symbol-name (mapcar #'cl-first needed)))))
(all-modules (cl-first result))
(loaded-now (cl-second result)))
;; check if everything went OK
;;
(cl-loop for n in needed
unless (cl-find (cl-first n) loaded-now :test #'string=)
;; string= compares symbols and strings nicely
;;
do (when (y-or-n-p (format
"\
Watch out! SLY failed to load SLYNK module %s for contrib %s!\n
Disable it?" (cl-first n) (cl-third n)))
(sly-disable-contrib (cl-third n))
(sly-temp-message 3 3 "\
You'll need to re-enable %s manually with `sly-enable-contrib'\
if/when you fix the error" (cl-third n))))
;; Update the connection-local list of all *MODULES*
;;
(setf (sly-lisp-modules) all-modules)))))
(cl-defstruct (sly-contrib
(:conc-name sly-contrib--))
enabled-p
name
sly-dependencies
slynk-dependencies
enable
disable
authors
license)
(defmacro define-sly-contrib (name _docstring &rest clauses)
(declare (indent 1))
(cl-destructuring-bind (&key sly-dependencies
slynk-dependencies
on-load
on-unload
authors
license)
(cl-loop for (key . value) in clauses append `(,key ,value))
(cl-labels
((enable-fn (c) (intern (concat (symbol-name c) "-init")))
(disable-fn (c) (intern (concat (symbol-name c) "-unload")))
(path-sym (c) (intern (concat (symbol-name c) "--path")))
(contrib-sym (c) (intern (concat (symbol-name c) "--contrib"))))
`(progn
(defvar ,(path-sym name))
(defvar ,(contrib-sym name))
(setq ,(path-sym name) (and load-file-name
(file-name-directory load-file-name)))
(eval-when-compile
(when byte-compile-current-file; protect against eager macro expansion
(add-to-list 'load-path
(file-name-as-directory
(file-name-directory byte-compile-current-file)))))
(setq ,(contrib-sym name)
(put 'sly-contribs ',name
(make-sly-contrib
:name ',name :authors ',authors :license ',license
:sly-dependencies ',sly-dependencies
:slynk-dependencies ',slynk-dependencies
:enable ',(enable-fn name) :disable ',(disable-fn name))))
,@(mapcar (lambda (d) `(require ',d)) sly-dependencies)
(defun ,(enable-fn name) ()
(mapc #'funcall (mapcar
#'sly-contrib--enable
(cl-remove-if #'sly-contrib--enabled-p
(list ,@(mapcar #'contrib-sym
sly-dependencies)))))
(cl-loop for dep in ',slynk-dependencies
do (cl-pushnew (list dep ,(path-sym name) ',name)
sly-contrib--required-slynk-modules
:key #'cl-first))
;; FIXME: It's very tricky to do Slynk calls like
;; `sly-contrib--load-slynk-dependencies' here, and it this
;; should probably loop all connections. Anyway, we try
;; ensure this can only happen from an interactive
;; `sly-setup' call.
;;
(when (and (eq this-command 'sly-setup)
(sly-connected-p))
(sly-contrib--load-slynk-dependencies))
,@on-load
(setf (sly-contrib--enabled-p ,(contrib-sym name)) t))
(defun ,(disable-fn name) ()
,@on-unload
(cl-loop for dep in ',slynk-dependencies
do (setq sly-contrib--required-slynk-modules
(cl-remove dep sly-contrib--required-slynk-modules
:key #'cl-first)))
(sly-warning "Disabling contrib %s" ',name)
(mapc #'funcall (mapcar
#'sly-contrib--disable
(cl-remove-if-not #'sly-contrib--enabled-p
(list ,@(mapcar #'contrib-sym
sly-dependencies)))))
(setf (sly-contrib--enabled-p ,(contrib-sym name)) nil))))))
(defun sly-contrib--all-contribs ()
"All defined `sly-contrib' objects."
(cl-loop for (nil val) on (symbol-plist 'sly-contribs) by #'cddr
when (sly-contrib-p val)
collect val))
(defun sly-contrib--all-dependencies (contrib)
"Contrib names recursively needed by CONTRIB, including self."
(sly--contrib-safe contrib
(cons contrib
(cl-mapcan #'sly-contrib--all-dependencies
(sly-contrib--sly-dependencies
(sly-contrib--find-contrib contrib))))))
(defun sly-contrib--find-contrib (designator)
(if (sly-contrib-p designator)
designator
(or (get 'sly-contribs designator)
(error "Unknown contrib: %S" designator))))
(defun sly-contrib--read-contrib-name ()
(let ((names (cl-loop for c in (sly-contrib--all-contribs) collect
(symbol-name (sly-contrib--name c)))))
(intern (completing-read "Contrib: " names nil t))))
(defun sly-enable-contrib (name)
"Attempt to enable contrib NAME."
(interactive (list (sly-contrib--read-contrib-name)))
(sly--contrib-safe name
(funcall (sly-contrib--enable (sly-contrib--find-contrib name)))))
(defun sly-disable-contrib (name)
"Attempt to disable contrib NAME."
(interactive (list (sly-contrib--read-contrib-name)))
(sly--contrib-safe name
(funcall (sly-contrib--disable (sly-contrib--find-contrib name)))))
;;;;; Pull-down menu
(easy-menu-define sly-menu sly-mode-map "SLY"
(let ((C '(sly-connected-p)))
`("SLY"
[ "Edit Definition..." sly-edit-definition ,C ]
[ "Return From Definition" sly-pop-find-definition-stack ,C ]
[ "Complete Symbol" sly-complete-symbol ,C ]
"--"
("Evaluation"
[ "Eval Defun" sly-eval-defun ,C ]
[ "Eval Last Expression" sly-eval-last-expression ,C ]
[ "Eval And Pretty-Print" sly-pprint-eval-last-expression ,C ]
[ "Eval Region" sly-eval-region ,C ]
[ "Eval Region And Pretty-Print" sly-pprint-eval-region ,C ]
[ "Interactive Eval..." sly-interactive-eval ,C ]
[ "Edit Lisp Value..." sly-edit-value ,C ]
[ "Call Defun" sly-call-defun ,C ])
("Debugging"
[ "Inspect..." sly-inspect ,C ]
[ "Macroexpand Once..." sly-macroexpand-1 ,C ]
[ "Macroexpand All..." sly-macroexpand-all ,C ]
[ "Disassemble..." sly-disassemble-symbol ,C ])
("Compilation"
[ "Compile Defun" sly-compile-defun ,C ]
[ "Compile and Load File" sly-compile-and-load-file ,C ]
[ "Compile File" sly-compile-file ,C ]
[ "Compile Region" sly-compile-region ,C ]
"--"
[ "Next Note" sly-next-note t ]
[ "Previous Note" sly-previous-note t ]
[ "Remove Notes" sly-remove-notes t ]
[ "List notes" sly-show-compilation-log t ])
("Cross Reference"
[ "Who Calls..." sly-who-calls ,C ]
[ "Who References... " sly-who-references ,C ]
[ "Who Sets..." sly-who-sets ,C ]
[ "Who Binds..." sly-who-binds ,C ]
[ "Who Macroexpands..." sly-who-macroexpands ,C ]
[ "Who Specializes..." sly-who-specializes ,C ]
[ "List Callers..." sly-list-callers ,C ]
[ "List Callees..." sly-list-callees ,C ]
[ "Next Location" sly-next-location t ])
("Editing"
[ "Check Parens" check-parens t]
[ "Update Indentation" sly-update-indentation ,C])
("Documentation"
[ "Describe Symbol..." sly-describe-symbol ,C ]
[ "Lookup Documentation..." sly-documentation-lookup t ]
[ "Apropos..." sly-apropos ,C ]
[ "Apropos all..." sly-apropos-all ,C ]
[ "Apropos Package..." sly-apropos-package ,C ]
[ "Hyperspec..." sly-hyperspec-lookup t ])
"--"
[ "Interrupt Command" sly-interrupt ,C ]
[ "Abort Async. Command" sly-quit ,C ])))
(easy-menu-define sly-sly-db-menu sly-db-mode-map "SLY-DB Menu"
(let ((C '(sly-connected-p)))
`("SLY-DB"
[ "Next Frame" sly-db-down t ]
[ "Previous Frame" sly-db-up t ]
[ "Toggle Frame Details" sly-db-toggle-details t ]
[ "Next Frame (Details)" sly-db-details-down t ]
[ "Previous Frame (Details)" sly-db-details-up t ]
"--"
[ "Eval Expression..." sly-interactive-eval ,C ]
[ "Eval in Frame..." sly-db-eval-in-frame ,C ]
[ "Eval in Frame (pretty print)..." sly-db-pprint-eval-in-frame ,C ]
[ "Inspect In Frame..." sly-db-inspect-in-frame ,C ]
[ "Inspect Condition Object" sly-db-inspect-condition ,C ]
"--"
[ "Restart Frame" sly-db-restart-frame ,C ]
[ "Return from Frame..." sly-db-return-from-frame ,C ]
("Invoke Restart"
[ "Continue" sly-db-continue ,C ]
[ "Abort" sly-db-abort ,C ]
[ "Step" sly-db-step ,C ]
[ "Step next" sly-db-next ,C ]
[ "Step out" sly-db-out ,C ]
)
"--"
[ "Quit (throw)" sly-db-quit ,C ]
[ "Break With Default Debugger" sly-db-break-with-default-debugger ,C ])))
(easy-menu-define sly-inspector-menu sly-inspector-mode-map
"Menu for the SLY Inspector"
(let ((C '(sly-connected-p)))
`("SLY-Inspector"
[ "Pop Inspectee" sly-inspector-pop ,C ]
[ "Next Inspectee" sly-inspector-next ,C ]
[ "Describe this Inspectee" sly-inspector-describe ,C ]
[ "Eval in context" sly-inspector-eval ,C ]
[ "Show history" sly-inspector-history ,C ]
[ "Reinspect" sly-inspector-reinspect ,C ]
[ "Fetch all parts" sly-inspector-fetch-all ,C ]
[ "Quit" sly-inspector-quit ,C ])))
;;;; Utilities (no not Paul Graham style)
;;; FIXME: this looks almost sly `sly-alistify', perhaps the two
;;; functions can be merged.
(defun sly-group-similar (similar-p list)
"Return the list of lists of 'similar' adjacent elements of LIST.
The function SIMILAR-P is used to test for similarity.
The order of the input list is preserved."
(if (null list)
nil
(let ((accumulator (list (list (car list)))))
(dolist (x (cdr list))
(if (funcall similar-p x (caar accumulator))
(push x (car accumulator))
(push (list x) accumulator)))
(nreverse (mapcar #'nreverse accumulator)))))
(defun sly-alistify (list key test)
"Partition the elements of LIST into an alist.
KEY extracts the key from an element and TEST is used to compare
keys."
(let ((alist '()))
(dolist (e list)
(let* ((k (funcall key e))
(probe (cl-assoc k alist :test test)))
(if probe
(push e (cdr probe))
(push (cons k (list e)) alist))))
;; Put them back in order.
(nreverse (mapc (lambda (ent)
(setcdr ent (nreverse (cdr ent))))
alist))))
;;;;; Misc.
(defun sly-length= (list n)
"Return (= (length LIST) N)."
(if (zerop n)
(null list)
(let ((tail (nthcdr (1- n) list)))
(and tail (null (cdr tail))))))
(defun sly-length> (seq n)
"Return (> (length SEQ) N)."
(cl-etypecase seq
(list (nthcdr n seq))
(sequence (> (length seq) n))))
(defun sly-trim-whitespace (str)
"Chomp leading and tailing whitespace from STR."
;; lited from http://www.emacswiki.org/emacs/ElispCookbook
(replace-regexp-in-string (rx (or (: bos (* (any " \t\n")))
(: (* (any " \t\n")) eos)))
""
str))
;;;;; Buffer related
(defun sly-column-max ()
(save-excursion
(goto-char (point-min))
(cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line))
until (= (point) (point-max))
maximizing column)))
;;;;; CL symbols vs. Elisp symbols.
(defun sly-cl-symbol-name (symbol)
(let ((n (if (stringp symbol) symbol (symbol-name symbol))))
(if (string-match ":\\([^:]*\\)$" n)
(let ((symbol-part (match-string 1 n)))
(if (string-match "^|\\(.*\\)|$" symbol-part)
(match-string 1 symbol-part)
symbol-part))
n)))
(defun sly-cl-symbol-package (symbol &optional default)
(let ((n (if (stringp symbol) symbol (symbol-name symbol))))
(if (string-match "^\\([^:]*\\):" n)
(match-string 1 n)
default)))
(defun sly-qualify-cl-symbol-name (symbol-or-name)
"Return a package-qualified string for SYMBOL-OR-NAME.
If SYMBOL-OR-NAME doesn't already have a package prefix the
current package is used."
(let ((s (if (stringp symbol-or-name)
symbol-or-name
(symbol-name symbol-or-name))))
(if (sly-cl-symbol-package s)
s
(format "%s::%s"
(let* ((package (sly-current-package)))
;; package is a string like ":cl-user"
;; or "CL-USER", or "\"CL-USER\"".
(if package
(sly--pretty-package-name package)
"CL-USER"))
(sly-cl-symbol-name s)))))
;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.)
(defmacro sly-point-moves-p (&rest body)
"Execute BODY and return true if the current buffer's point moved."
(declare (indent 0))
(let ((pointvar (cl-gensym "point-")))
`(let ((,pointvar (point)))
(save-current-buffer ,@body)
(/= ,pointvar (point)))))
(defun sly-forward-sexp (&optional count)
"Like `forward-sexp', but understands reader-conditionals (#- and #+),
and skips comments."
(dotimes (_i (or count 1))
(sly-forward-cruft)
(forward-sexp)))
(defconst sly-reader-conditionals-regexp
;; #!+, #!- are SBCL specific reader-conditional syntax.
;; We need this for the source files of SBCL itself.
(regexp-opt '("#+" "#-" "#!+" "#!-")))
(defsubst sly-forward-reader-conditional ()
"Move past any reader conditional (#+ or #-) at point."
(when (looking-at sly-reader-conditionals-regexp)
(goto-char (match-end 0))
(let* ((plus-conditional-p (eq (char-before) ?+))
(result (sly-eval-feature-expression
(condition-case e
(read (current-buffer))
(invalid-read-syntax
(signal 'sly-unknown-feature-expression (cdr e)))))))
(unless (if plus-conditional-p result (not result))
;; skip this sexp
(sly-forward-sexp)))))
(defun sly-forward-cruft ()
"Move forward over whitespace, comments, reader conditionals."
(while (sly-point-moves-p (skip-chars-forward " \t\n")
(forward-comment (buffer-size))
(sly-forward-reader-conditional))))
(defun sly-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)))))
(put 'sly-incorrect-feature-expression
'error-conditions '(sly-incorrect-feature-expression error))
(put 'sly-unknown-feature-expression
'error-conditions '(sly-unknown-feature-expression
sly-incorrect-feature-expression
error))
;; FIXME: let it crash
;; FIXME: the (null (cdr l)) constraint is bogus
(defun sly-eval-feature-expression (e)
"Interpret a reader conditional expression."
(cond ((symbolp e)
(memq (sly-keywordify e) (sly-lisp-features)))
((and (consp e) (symbolp (car e)))
(funcall (let ((head (sly-keywordify (car e))))
(cl-case head
(:and #'cl-every)
(:or #'cl-some)
(:not
(let ((feature-expression e))
(lambda (f l)
(cond ((null l) t)
((null (cdr l)) (not (apply f l)))
(t (signal 'sly-incorrect-feature-expression
feature-expression))))))
(t (signal 'sly-unknown-feature-expression head))))
#'sly-eval-feature-expression
(cdr e)))
(t (signal 'sly-incorrect-feature-expression e))))
;;;;; Extracting Lisp forms from the buffer or user
(defun sly-region-for-defun-at-point (&optional pos)
"Return a list (START END) for the positions of defun at POS.
POS defaults to point"
(save-excursion
(save-match-data
(goto-char (or pos (point)))
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(list (point) end)))))
(defun sly-beginning-of-symbol ()
"Move to the beginning of the CL-style symbol at point."
(while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\="
(when (> (point) 2000) (- (point) 2000))
t))
(re-search-forward "\\=#[-+.<|]" nil t)
(when (and (eq (char-after) ?@) (eq (char-before) ?\,))
(forward-char)))
(defsubst sly-end-of-symbol ()
"Move to the end of the CL-style symbol at point."
(re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*"))
(put 'sly-symbol 'end-op 'sly-end-of-symbol)
(put 'sly-symbol 'beginning-op 'sly-beginning-of-symbol)
(defun sly-symbol-start-pos ()
"Return the starting position of the symbol under point.
The result is unspecified if there isn't a symbol under the point."
(save-excursion (sly-beginning-of-symbol) (point)))
(defun sly-symbol-end-pos ()
(save-excursion (sly-end-of-symbol) (point)))
(defun sly-bounds-of-symbol-at-point ()
"Return the bounds of the symbol around point.
The returned bounds are either nil or non-empty."
(let ((bounds (bounds-of-thing-at-point 'sly-symbol)))
(if (and bounds
(< (car bounds)
(cdr bounds)))
bounds)))
(defun sly-symbol-at-point (&optional interactive)
"Return the name of the symbol at point, otherwise nil."
;; (thing-at-point 'symbol) returns "" in empty buffers
(let ((bounds (sly-bounds-of-symbol-at-point)))
(when bounds
(let ((beg (car bounds)) (end (cdr bounds)))
(when interactive (sly-flash-region beg end))
(buffer-substring-no-properties beg end)))))
(defun sly-bounds-of-sexp-at-point (&optional interactive)
"Return the bounds sexp near point as a pair (or nil).
With non-nil INTERACTIVE, error if can't find such a thing."
(or (sly-bounds-of-symbol-at-point)
(and (equal (char-after) ?\()
(member (char-before) '(?\' ?\, ?\@))
;; hide stuff before ( to avoid quirks with '( etc.
(save-restriction
(narrow-to-region (point) (point-max))
(bounds-of-thing-at-point 'sexp)))
(bounds-of-thing-at-point 'sexp)
(and (save-excursion
(and (ignore-errors
(backward-sexp 1)
t)
(bounds-of-thing-at-point 'sexp))))
(when interactive
(user-error "No sexp near point"))))
(cl-defun sly-sexp-at-point (&optional interactive stringp (errorp t))
"Return the sexp at point as a string, otherwise nil.
With non-nil INTERACTIVE, flash the region and also error if no
sexp can be found, unless ERRORP, which defaults to t, is passed
as nil. With non-nil STRINGP, only look for strings"
(catch 'return
(let ((bounds (sly-bounds-of-sexp-at-point (and interactive
errorp))))
(when bounds
(when (and stringp
(not (eq (syntax-class (syntax-after (car bounds)))
(char-syntax ?\"))))
(if (and interactive
interactive)
(user-error "No string at point")
(throw 'return nil)))
(when interactive
(sly-flash-region (car bounds) (cdr bounds)))
(buffer-substring-no-properties (car bounds)
(cdr bounds))))))
(defun sly-string-at-point (&optional interactive)
"Returns the string near point as a string, otherwise nil.
With non-nil INTERACTIVE, flash the region and error if no string
can be found."
(sly-sexp-at-point interactive 'stringp))
(defun sly-input-complete-p (start end)
"Return t if the region from START to END contains a complete sexp."
(save-excursion
(goto-char start)
(cond ((looking-at "\\s *['`#]?[(\"]")
(ignore-errors
(save-restriction
(narrow-to-region start end)
;; Keep stepping over blanks and sexps until the end of
;; buffer is reached or an error occurs. Tolerate extra
;; close parens.
(cl-loop do (skip-chars-forward " \t\r\n)")
until (eobp)
do (forward-sexp))
t)))
(t t))))
;;;; sly.el in pretty colors
(cl-loop for sym in (list 'sly-def-connection-var
'sly-define-channel-type
'sly-define-channel-method
'define-sly-contrib)
for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"
sym)
do (font-lock-add-keywords
'emacs-lisp-mode
`((,regexp (1 font-lock-keyword-face)
(2 font-lock-variable-name-face)))))
;;;; Finishing up
(defun sly--byte-compile (symbol)
(require 'bytecomp) ;; tricky interaction between autoload and let.
(let ((byte-compile-warnings '()))
(byte-compile symbol)))
(defun sly-byte-compile-hotspots (syms)
(mapc (lambda (sym)
(cond ((fboundp sym)
(unless (or (byte-code-function-p (symbol-function sym))
(subrp (symbol-function sym)))
(sly--byte-compile sym)))
(t (error "%S is not fbound" sym))))
syms))
(sly-byte-compile-hotspots
'(sly-alistify
sly-log-event
sly--events-buffer
sly-process-available-input
sly-dispatch-event
sly-net-filter
sly-net-have-input-p
sly-net-decode-length
sly-net-read
sly-print-apropos
sly-insert-propertized
sly-beginning-of-symbol
sly-end-of-symbol
sly-eval-feature-expression
sly-forward-sexp
sly-forward-cruft
sly-forward-reader-conditional))
;;;###autoload
(add-hook 'lisp-mode-hook 'sly-editing-mode)
(cond
((or (not (memq 'slime-lisp-mode-hook lisp-mode-hook))
noninteractive
(prog1
(y-or-n-p "[sly] SLIME detected in `lisp-mode-hook', causes keybinding conflicts. Remove it for this Emacs session?")
(warn "To restore SLIME in this session, customize `lisp-mode-hook'
and replace `sly-editing-mode' with `slime-lisp-mode-hook'.")))
(remove-hook 'lisp-mode-hook 'slime-lisp-mode-hook)
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (eq major-mode 'lisp-mode)
(unless sly-editing-mode (sly-editing-mode 1))
(ignore-errors (and (featurep 'slime) (funcall 'slime-mode -1)))))))
(t
(warn
"`sly.el' loaded OK. To use SLY, customize `lisp-mode-hook' and remove `slime-lisp-mode-hook'.")))
(provide 'sly)
;;; sly.el ends here
;; Local Variables:
;; coding: utf-8
;; End:
(define-package "sly" "20231213.1030" "Sylvester the Cat's Common Lisp IDE"
'((emacs "24.3"))
:commit "ed17d2c2bd7aead0fbb09c3d22861c80a522a097" :keywords
'("languages" "lisp" "sly")
:url "https://github.com/joaotavora/sly")
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; sly-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from sly.el
(define-obsolete-variable-alias 'sly-setup-contribs 'sly-contribs "\
2.3.2")
(defvar sly-contribs '(sly-fancy) "\
A list of contrib packages to load with SLY.")
(autoload 'sly-setup "sly" "\
Have SLY load and use extension modules CONTRIBS.
CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...)
symbols of `provide'd and `require'd Elisp libraries.
If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise
it is set to CONTRIBS.
However, after `require'ing LIB1, LIB2 ..., this command invokes
additional initialization steps associated with each element
LIB1, LIB2, which can theoretically be reverted by
`sly-disable-contrib.'
Notably, one of the extra initialization steps is affecting the
value of `sly-required-modules' (which see) thus affecting the
libraries loaded in the Slynk servers.
If SLY is currently connected to a Slynk and a contrib in
CONTRIBS has never been loaded, that Slynk is told to load the
associated Slynk extension module.
To ensure that a particular contrib is loaded, use
`sly-enable-contrib' instead.
(fn &optional CONTRIBS)" t)
(autoload 'sly-mode "sly" "\
Minor mode for horizontal SLY functionality.
This is a minor mode. If called interactively, toggle the `Sly
mode' mode. If the prefix argument is positive, enable the mode,
and if it is zero or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `sly-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
(fn &optional ARG)" t)
(autoload 'sly-editing-mode "sly" "\
Minor mode for editing `lisp-mode' buffers.
This is a minor mode. If called interactively, toggle the
`Sly-Editing mode' mode. If the prefix argument is positive,
enable the mode, and if it is zero or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `sly-editing-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
(fn &optional ARG)" t)
(autoload 'sly "sly" "\
Start a Lisp implementation and connect to it.
COMMAND designates a the Lisp implementation to start as an
\"inferior\" process to the Emacs process. It is either a
pathname string pathname to a lisp executable, a list (EXECUTABLE
ARGS...), or a symbol indexing
`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding
`sly-net-coding-system'.
Interactively, both COMMAND and CODING-SYSTEM are nil and the
prefix argument controls the precise behaviour:
- With no prefix arg, try to automatically find a Lisp. First
consult `sly-command-switch-to-existing-lisp' and analyse open
connections to maybe switch to one of those. If a new lisp is
to be created, first lookup `sly-lisp-implementations', using
`sly-default-lisp' as a default strategy. Then try
`inferior-lisp-program' if it looks like it points to a valid
lisp. Failing that, guess the location of a lisp
implementation.
- With a positive prefix arg (one C-u), prompt for a command
string that starts a Lisp implementation.
- With a negative prefix arg (M-- M-x sly, for example) prompt
for a symbol indexing one of the entries in
`sly-lisp-implementations'
(fn &optional COMMAND CODING-SYSTEM INTERACTIVE)" t)
(autoload 'sly-connect "sly" "\
Connect to a running Slynk server. Return the connection.
With prefix arg, asks if all connections should be closed
before.
(fn HOST PORT &optional CODING-SYSTEM INTERACTIVE-P)" t)
(autoload 'sly-hyperspec-lookup "sly" "\
A wrapper for `hyperspec-lookup'
(fn SYMBOL-NAME)" t)
(autoload 'sly-info "sly" "\
Read SLY manual
(fn FILE &optional NODE)" t)
(add-hook 'lisp-mode-hook 'sly-editing-mode)
(register-definition-prefixes "sly" '("define-sly-" "inferior-lisp-program" "make-sly-" "sly-" "topline"))
;;; End of scraped data
(provide 'sly-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; sly-autoloads.el ends here
;;; sly-tests.el --- Automated tests for sly.el -*- lexical-binding: t; -*-
;;
;;;; License
;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler
;; Copyright (C) 2013
;;
;; For a detailed list of contributors, see the manual.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;; MA 02111-1307, USA.
;;;; Tests
(require 'sly)
(require 'ert nil t)
(require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23
(require 'cl-lib)
(require 'bytecomp) ; byte-compile-current-file
(defun sly-shuffle-list (list)
(let* ((len (length list))
(taken (make-vector len nil))
(result (make-vector len nil)))
(dolist (e list)
(while (let ((i (random len)))
(cond ((aref taken i))
(t (aset taken i t)
(aset result i e)
nil)))))
(append result '())))
(defun sly-batch-test (&optional test-name randomize)
"Run the test suite in batch-mode.
Exits Emacs when finished. The exit code is the number of failed tests."
(interactive)
(let ((ert-debug-on-error nil)
(timeout 30))
(sly)
;; Block until we are up and running.
(let (timed-out)
(run-with-timer timeout nil
(lambda () (setq timed-out t)))
(while (not (sly-connected-p))
(sit-for 1)
(when timed-out
(when noninteractive
(kill-emacs 252)))))
(sly-sync-to-top-level 5)
(let* ((selector (if randomize
`(member ,@(sly-shuffle-list
(ert-select-tests (or test-name t) t)))
(or test-name t)))
(ert-fun (if noninteractive
'ert-run-tests-batch
'ert)))
(let ((stats (funcall ert-fun selector)))
(if noninteractive
(kill-emacs (ert-stats-completed-unexpected stats)))))))
(defun sly-skip-test (message)
;; ERT for Emacs 23 and earlier doesn't have `ert-skip'
(if (fboundp 'ert-skip)
(ert-skip message)
(message (concat "SKIPPING: " message))
(ert-pass)))
(defun sly-tests--undefine-all ()
(dolist (test (ert-select-tests t t))
(let ((sym (ert-test-name test)))
(cl-assert (eq (get sym 'ert--test) test))
(cl-remprop sym 'ert--test))))
(sly-tests--undefine-all)
(eval-and-compile
(defun sly-tests-auto-tags ()
(append '(sly)
(let ((file-name (or load-file-name
byte-compile-current-file)))
(if (and (stringp file-name)
(string-match "test/sly-\\(.*\\)\.elc?$" file-name))
(list 'contrib (intern (match-string 1 file-name)))
'(core)))))
(defmacro define-sly-ert-test (name &rest args)
"Like `ert-deftest', but set tags automatically.
Also don't error if `ert.el' is missing."
(declare (debug (&define name sexp sexp &rest def-form)))
(let* ((docstring (and (stringp (cl-second args))
(cl-second args)))
(args (if docstring
(cddr args)
(cdr args)))
(tags (sly-tests-auto-tags)))
`(ert-deftest ,name () ,(or docstring "No docstring for this test.")
:tags ',tags
,@args)))
(defun sly-test-ert-test-for (name input i doc _body fails-for style fname)
`(define-sly-ert-test
,(intern (format "%s-%d" name i)) ()
,(format "For input %s, %s" (truncate-string-to-width
(format "%s" input)
15 nil nil 'ellipsis)
(replace-regexp-in-string "^.??\\(\\w+\\)"
(lambda (s) (downcase s))
doc
t))
,@(if fails-for
`(:expected-result
'(satisfies
(lambda (result)
(ert-test-result-type-p
result
(if (cl-find-if
(lambda (impl)
(unless (listp impl)
(setq impl (list impl #'(lambda (&rest _ign) t))))
(and (equal (car impl) (sly-lisp-implementation-name))
(funcall
(cadr impl)
;; Appease `version-to-list' for
;; SBCL. `version-regexp-alist'
;; doesn't work here.
(replace-regexp-in-string
"[-._+ ]?[[:alnum:]]\\{7,9\\}$"
"-snapshot"
(sly-lisp-implementation-version))
(caddr impl))))
',fails-for)
:failed
:passed))))))
,@(when style
`((let ((style (sly-communication-style)))
(when (not (member style ',style))
(sly-skip-test (format "test not applicable for style %s"
style))))))
(apply #',fname ',input))))
(defmacro def-sly-test (name args doc inputs &rest body)
"Define a test case.
NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test.
OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*)
ARGS is a lambda-list.
DOC is a docstring.
INPUTS is a list of argument lists, each tested separately.
BODY is the test case. The body can use `sly-check' to test
conditions (assertions)."
(declare (debug (&define name sexp sexp sexp &rest def-form))
(indent 4))
(if (not (featurep 'ert))
(warn "No ert.el found: not defining test %s"
name)
`(progn
,@(cl-destructuring-bind (name &rest options)
(if (listp name) name (list name))
(let ((fname (intern (format "sly-test-%s" name))))
(cons `(defun ,fname ,args
(sly-sync-to-top-level 0.3)
,@body
(sly-sync-to-top-level 0.3))
(cl-loop for input in (eval inputs)
for i from 1
with fails-for = (cdr (assoc :fails-for options))
with style = (cdr (assoc :style options))
collect (sly-test-ert-test-for name
input
i
doc
body
fails-for
style
fname))))))))
(defmacro sly-check (check &rest body)
(declare (indent defun))
`(unless (progn ,@body)
(ert-fail ,(cl-etypecase check
(cons `(concat "Ooops, " ,(cons 'format check)))
(string `(concat "Check failed: " ,check))
(symbol `(concat "Check failed: " ,(symbol-name check)))))))
;;;;; Test case definitions
(defun sly-check-top-level () ;(&optional _test-name)
(accept-process-output nil 0.001)
(sly-check "At the top level (no debugging or pending RPCs)"
(sly-at-top-level-p)))
(defun sly-at-top-level-p ()
(and (not (sly-db-get-default-buffer))
(null (sly-rex-continuations))))
(defun sly-wait-condition (name predicate timeout &optional cleanup)
(let ((end (time-add (current-time) (seconds-to-time timeout))))
(while (not (funcall predicate))
(sly-message "waiting for condition: %s [%s]" name
(format-time-string "%H:%M:%S.%6N"))
(cond ((time-less-p end (current-time))
(unwind-protect
(error "Timeout waiting for condition: %S" name)
(funcall cleanup)))
(t
;; XXX if a process-filter enters a recursive-edit, we
;; hang forever
(accept-process-output nil 0.1))))))
(defun sly-sync-to-top-level (timeout)
(sly-wait-condition "top-level" #'sly-at-top-level-p timeout
(lambda ()
(let ((sly-db-buffer
(sly-db-get-default-buffer)))
(when (bufferp sly-db-buffer)
(with-current-buffer sly-db-buffer
(sly-db-quit)))))))
;; XXX: unused function
(defun sly-check-sly-db-level (expected)
(let ((sly-db-level (let ((sly-db (sly-db-get-default-buffer)))
(if sly-db
(with-current-buffer sly-db
sly-db-level)))))
(sly-check ("SLY-DB level (%S) is %S" expected sly-db-level)
(equal expected sly-db-level))))
(defun sly-test-expect (_name expected actual &optional test)
(when (stringp expected) (setq expected (substring-no-properties expected)))
(when (stringp actual) (setq actual (substring-no-properties actual)))
(if test
(should (funcall test expected actual))
(should (equal expected actual))))
(defun sly-db-level ()
(let ((sly-db (sly-db-get-default-buffer)))
(if sly-db
(with-current-buffer sly-db
sly-db-level))))
(defun sly-sly-db-level= (level)
(equal level (sly-db-level)))
(eval-when-compile
(defvar sly-test-symbols
'(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar")
("|asdf||foo||bar|")
("\\#<Foo@Bar>")
("\\(setf\\ car\\)"))))
(defun sly-check-symbol-at-point (prefix symbol suffix)
;; We test that `sly-symbol-at-point' works at every
;; character of the symbol name.
(with-temp-buffer
(lisp-mode)
(insert prefix)
(let ((start (point)))
(insert symbol suffix)
(dotimes (i (length symbol))
(goto-char (+ start i))
(sly-test-expect (format "Check `%s' (at %d)..."
(buffer-string) (point))
symbol
(sly-symbol-at-point)
#'equal)))))
(def-sly-test symbol-at-point.2 (sym)
"fancy symbol-name _not_ at BOB/EOB"
sly-test-symbols
(sly-check-symbol-at-point "(foo " sym " bar)"))
(def-sly-test symbol-at-point.3 (sym)
"fancy symbol-name with leading ,"
(cl-remove-if (lambda (s) (eq (aref (car s) 0) ?@)) sly-test-symbols)
(sly-check-symbol-at-point "," sym ""))
(def-sly-test symbol-at-point.4 (sym)
"fancy symbol-name with leading ,@"
sly-test-symbols
(sly-check-symbol-at-point ",@" sym ""))
(def-sly-test symbol-at-point.5 (sym)
"fancy symbol-name with leading `"
sly-test-symbols
(sly-check-symbol-at-point "`" sym ""))
(def-sly-test symbol-at-point.6 (sym)
"fancy symbol-name wrapped in ()"
sly-test-symbols
(sly-check-symbol-at-point "(" sym ")"))
(def-sly-test symbol-at-point.7 (sym)
"fancy symbol-name wrapped in #< {DEADBEEF}>"
sly-test-symbols
(sly-check-symbol-at-point "#<" sym " {DEADBEEF}>"))
;;(def-sly-test symbol-at-point.8 (sym)
;; "fancy symbol-name wrapped in #<>"
;; sly-test-symbols
;; (sly-check-symbol-at-point "#<" sym ">"))
(def-sly-test symbol-at-point.9 (sym)
"fancy symbol-name wrapped in #| ... |#"
sly-test-symbols
(sly-check-symbol-at-point "#|\n" sym "\n|#"))
(def-sly-test symbol-at-point.10 (sym)
"fancy symbol-name after #| )))(( |# (1)"
sly-test-symbols
(sly-check-symbol-at-point "#| )))(( #|\n" sym ""))
(def-sly-test symbol-at-point.11 (sym)
"fancy symbol-name after #| )))(( |# (2)"
sly-test-symbols
(sly-check-symbol-at-point "#| )))(( #|" sym ""))
(def-sly-test symbol-at-point.12 (sym)
"fancy symbol-name wrapped in \"...\""
sly-test-symbols
(sly-check-symbol-at-point "\"\n" sym "\"\n"))
(def-sly-test symbol-at-point.13 (sym)
"fancy symbol-name wrapped in \" )))(( \" (1)"
sly-test-symbols
(sly-check-symbol-at-point "\" )))(( \"\n" sym ""))
(def-sly-test symbol-at-point.14 (sym)
"fancy symbol-name wrapped in \" )))(( \" (1)"
sly-test-symbols
(sly-check-symbol-at-point "\" )))(( \"" sym ""))
(def-sly-test symbol-at-point.15 (sym)
"symbol-at-point after #."
sly-test-symbols
(sly-check-symbol-at-point "#." sym ""))
(def-sly-test symbol-at-point.16 (sym)
"symbol-at-point after #+"
sly-test-symbols
(sly-check-symbol-at-point "#+" sym ""))
(def-sly-test sexp-at-point.1 (string)
"symbol-at-point after #'"
'(("foo")
("#:foo")
("#'foo")
("#'(lambda (x) x)")
("()"))
(with-temp-buffer
(lisp-mode)
(insert string)
(goto-char (point-min))
(sly-test-expect (format "Check sexp `%s' (at %d)..."
(buffer-string) (point))
string
(sly-sexp-at-point)
#'equal)))
(def-sly-test narrowing ()
"Check that narrowing is properly sustained."
'()
(sly-check-top-level)
(let ((random-buffer-name (symbol-name (cl-gensym)))
(defun-pos) (tmpbuffer))
(with-temp-buffer
(dotimes (i 100) (insert (format ";;; %d. line\n" i)))
(setq tmpbuffer (current-buffer))
(setq defun-pos (point))
(insert (concat "(defun __foo__ (x y)" "\n"
" 'nothing)" "\n"))
(dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i))))
(sly-check "Checking that newly created buffer is not narrowed."
(not (buffer-narrowed-p)))
(goto-char defun-pos)
(narrow-to-defun)
(sly-check "Checking that narrowing succeeded."
(buffer-narrowed-p))
(sly-with-popup-buffer (random-buffer-name)
(sly-check ("Checking that we're in Sly's temp buffer `%s'"
random-buffer-name)
(equal (buffer-name (current-buffer)) random-buffer-name)))
(with-current-buffer random-buffer-name
;; Notice that we cannot quit the buffer within the extent
;; of sly-with-output-to-temp-buffer.
(quit-window t))
(sly-check ("Checking that we've got back from `%s'"
random-buffer-name)
(and (eq (current-buffer) tmpbuffer)
(= (point) defun-pos)))
(sly-check "Checking that narrowing sustained \
after quitting Sly's temp buffer."
(buffer-narrowed-p))
(let ((sly-buffer-package "SLYNK")
(symbol '*buffer-package*))
(sly-edit-definition (symbol-name symbol))
(sly-check ("Checking that we've got M-. into slynk.lisp. %S" symbol)
(string= (file-name-nondirectory (buffer-file-name))
"slynk.lisp"))
(sly-pop-find-definition-stack)
(sly-check ("Checking that we've got back.")
(and (eq (current-buffer) tmpbuffer)
(= (point) defun-pos)))
(sly-check "Checking that narrowing sustained after M-,"
(buffer-narrowed-p)))
))
(sly-check-top-level))
(defun sly-test--pos-at-line (line)
(save-excursion
(goto-char (point-min))
(forward-line (1- line))
(line-beginning-position)))
(def-sly-test recenter
(pos-line target expected-window-start)
"Test `sly-recenter'."
;; numbers are actually lines numbers
'(;; region visible, point in region
(2 4 1)
;; end not visible
(2 (+ wh 2) 2)
;; end and start not visible
((+ wh 2) (+ wh 500) (+ wh 2)))
(when noninteractive
(sly-skip-test "Can't test sly-recenter in batch mode"))
(with-temp-buffer
(cl-loop for i from 1 upto 1000
do (insert (format "%09d\n" i)))
(let* ((win (display-buffer (current-buffer))))
(cl-flet ((eval-with-wh (form)
(eval `(let ((wh ,(window-text-height win)))
,form))))
(with-selected-window win
(goto-char (sly-test--pos-at-line (eval-with-wh pos-line)))
(sly-recenter (sly-test--pos-at-line (eval-with-wh target)))
(redisplay)
(should (= (eval-with-wh expected-window-start)
(line-number-at-pos (window-start)))))))))
(def-sly-test find-definition
(name buffer-package snippet)
"Find the definition of a function or macro in slynk.lisp."
'(("start-server" "SLYNK" "(defun start-server ")
("slynk::start-server" "CL-USER" "(defun start-server ")
("slynk:start-server" "CL-USER" "(defun start-server ")
("slynk::connection" "CL-USER" "(defstruct (connection")
("slynk::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*")
)
(switch-to-buffer "*scratch*") ; not buffer of definition
(sly-check-top-level)
(let ((orig-buffer (current-buffer))
(orig-pos (point))
(enable-local-variables nil) ; don't get stuck on -*- eval: -*-
(sly-buffer-package buffer-package))
(sly-edit-definition name)
;; Postconditions
(sly-check ("Definition of `%S' is in slynk.lisp." name)
(string= (file-name-nondirectory (buffer-file-name)) "slynk.lisp"))
(sly-check ("Looking at '%s'." snippet) (looking-at snippet))
(sly-pop-find-definition-stack)
(sly-check "Returning from definition restores original buffer/position."
(and (eq orig-buffer (current-buffer))
(= orig-pos (point)))))
(sly-check-top-level))
(def-sly-test (find-definition.2 (:fails-for "allegro" "lispworks"))
(buffer-content buffer-package snippet)
"Check that we're able to find definitions even when
confronted with nasty #.-fu."
'(("#.(prog1 nil (defvar *foobar* 42))
(defun .foo. (x)
(+ x #.*foobar*))
#.(prog1 nil (makunbound '*foobar*))
"
"SLYNK"
"[ \t]*(defun .foo. "
)
("#.(prog1 nil (defvar *foobar* 42))
;; some comment
(defun .foo. (x)
(+ x #.*foobar*))
#.(prog1 nil (makunbound '*foobar*))
"
"SLYNK"
"[ \t]*(defun .foo. "
)
("(in-package slynk)
(eval-when (:compile-toplevel) (defparameter *bar* 456))
(eval-when (:load-toplevel :execute) (makunbound '*bar*))
(defun bar () #.*bar*)
(defun .foo. () 123)"
"SLYNK"
"[ \t]*(defun .foo. () 123)"))
(let ((sly-buffer-package buffer-package))
(with-temp-buffer
(insert buffer-content)
(sly-check-top-level)
(sly-eval
`(slynk:compile-string-for-emacs
,buffer-content
,(buffer-name)
'((:position 0) (:line 1 1))
,nil
,nil))
(let ((bufname (buffer-name)))
(sly-edit-definition ".foo.")
(sly-check ("Definition of `.foo.' is in buffer `%s'." bufname)
(string= (buffer-name) bufname))
(sly-check "Definition now at point." (looking-at snippet)))
)))
(def-sly-test (find-definition.3
(:fails-for "abcl" "allegro" "clisp" "lispworks"
("sbcl" version< "1.3.0")
"ecl"))
(name source regexp)
"Extra tests for defstruct."
'(("slynk::foo-struct"
"(progn
(defun foo-fun ())
(defstruct (foo-struct (:constructor nil) (:predicate nil)))
)"
"(defstruct (foo-struct"))
(switch-to-buffer "*scratch*")
(with-temp-buffer
(insert source)
(let ((sly-buffer-package "SLYNK"))
(sly-eval
`(slynk:compile-string-for-emacs
,source
,(buffer-name)
'((:position 0) (:line 1 1))
,nil
,nil)))
(let ((temp-buffer (current-buffer)))
(with-current-buffer "*scratch*"
(sly-edit-definition name)
(sly-check ("Definition of %S is in buffer `%s'."
name temp-buffer)
(eq (current-buffer) temp-buffer))
(sly-check "Definition now at point." (looking-at regexp)))
)))
(def-sly-test complete-symbol
(prefix expected-completions)
"Find the completions of a symbol-name prefix."
'(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname"
"cl:compiled-function" "cl:compiled-function-p"
"cl:compiler-macro" "cl:compiler-macro-function")
"cl:compile"))
("cl:foobar" (nil ""))
("slynk::compile-file" (("slynk::compile-file"
"slynk::compile-file-for-emacs"
"slynk::compile-file-if-needed"
"slynk::compile-file-output"
"slynk::compile-file-pathname")
"slynk::compile-file"))
("cl:m-v-l" (nil "")))
(let ((completions (sly-simple-completions prefix)))
(sly-test-expect "Completion set" expected-completions completions)))
(def-sly-test flex-complete-symbol
(prefix expectations)
"Find the flex completions of a symbol-name prefix."
'(("m-v-b" (("multiple-value-bind" 1)))
("mvbind" (("multiple-value-bind" 1)))
("mvcall" (("multiple-value-call" 1)))
("mvlist" (("multiple-value-list" 3)))
("echonumberlist" (("slynk:*echo-number-alist*" 1))))
(let* ((sly-buffer-package "COMMON-LISP")
(completions (car (sly-flex-completions prefix))))
(cl-loop for (completion before-or-at) in expectations
for pos = (cl-position completion completions :test #'string=)
unless pos
do (ert-fail (format "Didn't find %s in the completions for %s" completion prefix))
unless (< pos before-or-at)
do (ert-fail (format "Expected to find %s in the first %s completions for %s, but it came in %s
=> %s"
completion before-or-at prefix (1+ pos)
(cl-subseq completions 0 (1+ pos)))))))
(def-sly-test basic-completion
(input-keys expected-result)
"Test `sly-read-from-minibuffer' with INPUT-KEYS as events."
'(("( r e v e TAB TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET"
"(reverse '(1 2 3))")
("( c l : c o n TAB s t a n t l TAB TAB SPC 4 2 ) RET"
"(cl:constantly 42)"))
(when noninteractive
(sly-skip-test "Can't use unread-command-events in batch mode"))
(setq unread-command-events (listify-key-sequence (kbd input-keys)))
(let ((actual-result (sly-read-from-minibuffer "Test: ")))
(sly-test-expect "Completed string" expected-result actual-result)))
(def-sly-test arglist
;; N.B. Allegro apparently doesn't return the default values of
;; optional parameters. Thus the regexp in the start-server
;; expected value. In a perfect world we'd find a way to smooth
;; over this difference between implementations--perhaps by
;; convincing Franz to provide a function that does what we want.
(function-name expected-arglist)
"Lookup the argument list for FUNCTION-NAME.
Confirm that EXPECTED-ARGLIST is displayed."
'(("slynk::operator-arglist" "(slynk::operator-arglist name package)")
("slynk::compute-backtrace" "(slynk::compute-backtrace start end)")
("slynk::emacs-connected" "(slynk::emacs-connected)")
("slynk::compile-string-for-emacs"
"(slynk::compile-string-for-emacs \
string buffer position filename policy)")
("slynk::connection-socket-io"
"(slynk::connection-socket-io \
\\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))")
("cl:lisp-implementation-type" "(cl:lisp-implementation-type)")
("cl:class-name"
"(cl:class-name \\(class\\|object\\|instance\\|structure\\))"))
(let ((arglist (sly-eval `(slynk:operator-arglist ,function-name
"slynk"))))
(sly-test-expect "Argument list is as expected"
expected-arglist (and arglist (downcase arglist))
(lambda (pattern arglist)
(and arglist (string-match pattern arglist))))))
(defun sly-test--compile-defun (program subform)
(sly-check-top-level)
(with-temp-buffer
(lisp-mode)
(insert program)
(let ((font-lock-verbose nil))
(setq sly-buffer-package ":slynk")
(sly-compile-string (buffer-string) 1)
(setq sly-buffer-package ":cl-user")
(sly-sync-to-top-level 5)
(goto-char (point-max))
(call-interactively 'sly-previous-note)
(sly-check error-location-correct
(equal (read (current-buffer)) subform))))
(sly-check-top-level))
(def-sly-test (compile-defun (:fails-for "allegro" "lispworks" "clisp"))
(program subform)
"Compile PROGRAM containing errors.
Confirm that the EXPECTED subform is correctly located."
'(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar))
("(defun cl-user::foo ()
#\\space
;;Sdf
(cl-user::bar))"
(cl-user::bar))
("(defun cl-user::foo ()
#+(or)skipped
#| #||#
#||# |#
(cl-user::bar))"
(cl-user::bar))
("(defun cl-user::foo ()
\"\\\" bla bla \\\"\"
(cl-user::bar))"
(cl-user::bar))
("(defun cl-user::foo ()
#.*log-events*
(cl-user::bar))"
(cl-user::bar))
("#.'(defun x () (/ 1 0))
(defun foo ()
(cl-user::bar))
"
(cl-user::bar)))
(sly-test--compile-defun program subform))
;; This test ideally would be collapsed into the previous
;; compile-defun test, but only 1 case fails for ccl--and that's here
(def-sly-test (compile-defun-with-reader-conditionals
(:fails-for "allegro" "lispworks" "clisp" "ccl"))
(program expected)
"Compile PROGRAM containing errors.
Confirm that the EXPECTED subform is correctly located."
'(("(defun foo ()
#+#.'(:and) (/ 1 0))"
(/ 1 0)))
(sly-test--compile-defun program expected))
;; SBCL used to pass this one but since 1.2.2 the backquote/unquote
;; reader was changed. See
;; https://bugs.launchpad.net/sbcl/+bug/1361502
(def-sly-test (compile-defun-with-backquote
(:fails-for "sbcl" "allegro" "lispworks" "clisp"))
(program subform)
"Compile PROGRAM containing errors.
Confirm that SUBFORM is correctly located."
'(("(defun cl-user::foo ()
(list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3
,(cl-user::bar))))"
(cl-user::bar)))
(sly-test--compile-defun program subform))
(def-sly-test (compile-file (:fails-for "allegro" "lispworks" "clisp"))
(string)
"Insert STRING in a file, and compile it."
`((,(pp-to-string '(defun foo () nil))))
(let ((filename "/tmp/sly-tmp-file.lisp"))
(with-temp-file filename
(insert string))
(let ((cell (cons nil nil)))
(sly-eval-async
`(slynk:compile-file-for-emacs ,filename nil)
(sly-rcurry (lambda (result cell)
(setcar cell t)
(setcdr cell result))
cell))
(sly-wait-condition "Compilation finished" (lambda () (car cell))
0.5)
(let ((result (cdr cell)))
(sly-check "Compilation successfull"
(eq (sly-compilation-result.successp result) t))))))
(def-sly-test utf-8-source
(input output)
"Source code containing utf-8 should work"
(list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206")
;;(encode-coding-string (string #x304a #x306f #x3088 #x3046)
;; 'utf-8)
(string (decode-coding-string bytes 'utf-8-unix)))
(cl-assert (equal bytes (encode-coding-string string 'utf-8-unix)))
(list (concat "(defun cl-user::foo () \"" string "\")")
string)))
(sly-eval `(cl:eval (cl:read-from-string ,input)))
(sly-test-expect "Eval result correct"
output (sly-eval '(cl-user::foo)))
(let ((cell (cons nil nil)))
(let ((hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell)))
(add-hook 'sly-compilation-finished-hook hook)
(unwind-protect
(progn
(sly-compile-string input 0)
(sly-wait-condition "Compilation finished"
(lambda () (car cell))
0.5)
(sly-test-expect "Compile-string result correct"
output (sly-eval '(cl-user::foo))))
(remove-hook 'sly-compilation-finished-hook hook))
(let ((filename "/tmp/sly-tmp-file.lisp"))
(setcar cell nil)
(add-hook 'sly-compilation-finished-hook hook)
(unwind-protect
(with-temp-buffer
(when (fboundp 'set-buffer-multibyte)
(set-buffer-multibyte t))
(setq buffer-file-coding-system 'utf-8-unix)
(setq buffer-file-name filename)
(insert ";; -*- coding: utf-8-unix -*- \n")
(insert input)
(let ((coding-system-for-write 'utf-8-unix))
(write-region nil nil filename nil t))
(let ((sly-load-failed-fasl 'always))
(sly-compile-and-load-file)
(sly-wait-condition "Compilation finished"
(lambda () (car cell))
0.5))
(sly-test-expect "Compile-file result correct"
output (sly-eval '(cl-user::foo))))
(remove-hook 'sly-compilation-finished-hook hook)
(ignore-errors (delete-file filename)))))))
(def-sly-test async-eval-debugging (depth)
"Test recursive debugging of asynchronous evaluation requests."
'((1) (2) (3))
(let ((depth depth)
(debug-hook-max-depth 0))
(let ((debug-hook
(lambda ()
(with-current-buffer (sly-db-get-default-buffer)
(when (> sly-db-level debug-hook-max-depth)
(setq debug-hook-max-depth sly-db-level)
(if (= sly-db-level depth)
;; We're at maximum recursion - time to unwind
(sly-db-quit)
;; Going down - enter another recursive debug
;; Recursively debug.
(sly-eval-async '(error))))))))
(let ((sly-db-hook (cons debug-hook sly-db-hook)))
(sly-eval-async '(error))
(sly-sync-to-top-level 5)
(sly-check ("Maximum depth reached (%S) is %S."
debug-hook-max-depth depth)
(= debug-hook-max-depth depth))))))
(def-sly-test unwind-to-previous-sly-db-level (level2 level1)
"Test recursive debugging and returning to lower SLY-DB levels."
'((2 1) (4 2))
(sly-check-top-level)
(let ((level2 level2)
(level1 level1)
(state 'enter)
(max-depth 0))
(let ((debug-hook
(lambda ()
(with-current-buffer (sly-db-get-default-buffer)
(setq max-depth (max sly-db-level max-depth))
(cl-ecase state
(enter
(cond ((= sly-db-level level2)
(setq state 'leave)
(sly-db-invoke-restart (sly-db-first-abort-restart)))
(t
(sly-eval-async `(cl:aref cl:nil ,sly-db-level)))))
(leave
(cond ((= sly-db-level level1)
(setq state 'ok)
(sly-db-quit))
(t
(sly-db-invoke-restart (sly-db-first-abort-restart))
))))))))
(let ((sly-db-hook (cons debug-hook sly-db-hook)))
(sly-eval-async `(cl:aref cl:nil 0))
(sly-sync-to-top-level 15)
(sly-check-top-level)
(sly-check ("Maximum depth reached (%S) is %S." max-depth level2)
(= max-depth level2))
(sly-check ("Final state reached.")
(eq state 'ok))))))
(defun sly-db-first-abort-restart ()
(let ((case-fold-search t))
(cl-position-if (lambda (x) (string-match "abort" (car x))) sly-db-restarts)))
(def-sly-test loop-interrupt-quit
()
"Test interrupting a loop."
'(())
(sly-check-top-level)
(sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER")
(accept-process-output nil 1)
(sly-check "In eval state." (sly-busy-p))
(sly-interrupt)
(sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-quit))
(sly-sync-to-top-level 5)
(sly-check-top-level))
(def-sly-test loop-interrupt-continue-interrupt-quit
()
"Test interrupting a previously interrupted but continued loop."
'(())
(sly-check-top-level)
(sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER")
(sleep-for 1)
(sly-wait-condition "running" #'sly-busy-p 5)
(sly-interrupt)
(sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-continue))
(sly-wait-condition "running" (lambda ()
(and (sly-busy-p)
(not (sly-db-get-default-buffer)))) 5)
(sly-interrupt)
(sly-wait-condition "Second interrupt" (lambda () (sly-sly-db-level= 1)) 5)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-quit))
(sly-sync-to-top-level 5)
(sly-check-top-level))
(def-sly-test interactive-eval
()
"Test interactive eval and continuing from the debugger."
'(())
(sly-check-top-level)
(let ((sly-db-hook (lambda ()
(sly-db-continue))))
(sly-interactive-eval
"(progn\
(cerror \"foo\" \"restart\")\
(cerror \"bar\" \"restart\")\
(+ 1 2))")
(sly-sync-to-top-level 5)
(current-message))
(unless noninteractive
(should (equal "=> 3 (2 bits, #x3, #o3, #b11)"
(current-message)))))
(def-sly-test report-condition-with-circular-list
(format-control format-argument)
"Test conditions involving circular lists."
'(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))")
("~a" "(let ((x (cons nil nil))) (setf (car x) x))")
("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\
(setf (cdr x) x))"))
(sly-check-top-level)
(let ((done nil))
(let ((sly-db-hook (lambda () (sly-db-continue) (setq done t))))
(sly-interactive-eval
(format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))"
format-control format-argument))
(while (not done) (accept-process-output))
(sly-sync-to-top-level 5)
(sly-check-top-level)
(unless noninteractive
(let ((message (current-message)))
(sly-check "Minibuffer contains: \"3\""
(equal "=> 3 (2 bits, #x3, #o3, #b11)" message)))))))
(def-sly-test interrupt-bubbling-idiot
()
"Test interrupting a loop that sends a lot of output to Emacs."
'(())
(accept-process-output nil 1)
(sly-check-top-level)
(sly-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i)
(cl:finish-output)))
(lambda (_) )
"CL-USER")
(sleep-for 1)
(sly-interrupt)
(sly-wait-condition "Debugger visible"
(lambda ()
(and (sly-sly-db-level= 1)
(get-buffer-window (sly-db-get-default-buffer))))
30)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-quit))
(sly-sync-to-top-level 5))
(def-sly-test (interrupt-encode-message (:style :sigio))
()
"Test interrupt processing during slynk::encode-message"
'(())
(sly-eval-async '(cl:loop :for i :from 0
:do (slynk::background-message "foo ~d" i)))
(sleep-for 1)
(sly-eval-async '(cl:/ 1 0))
(sly-wait-condition "Debugger visible"
(lambda ()
(and (sly-sly-db-level= 1)
(get-buffer-window (sly-db-get-default-buffer))))
30)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-quit))
(sly-sync-to-top-level 5))
(def-sly-test inspector
(exp)
"Test basic inspector workingness."
'(((let ((h (make-hash-table)))
(loop for i below 10 do (setf (gethash i h) i))
h))
((make-array 10))
((make-list 10))
('cons)
(#'cons))
(sly-inspect (prin1-to-string exp))
(cl-assert (not (sly-inspector-visible-p)))
(sly-wait-condition "Inspector visible" #'sly-inspector-visible-p 5)
(with-current-buffer (window-buffer (selected-window))
(sly-inspector-quit))
(sly-wait-condition "Inspector closed"
(lambda () (not (sly-inspector-visible-p)))
5)
(sly-sync-to-top-level 1))
(defun sly-buffer-visible-p (name)
(let ((buffer (window-buffer (selected-window))))
(string-match name (buffer-name buffer))))
(defun sly-inspector-visible-p ()
(sly-buffer-visible-p (sly-buffer-name :inspector :connection t)))
(defun sly-execute-as-command (name)
"Execute `name' as if it was done by the user through the
Command Loop. Similiar to `call-interactively' but also pushes on
the buffer's undo-list."
(undo-boundary)
(call-interactively name))
(def-sly-test macroexpand
(macro-defs bufcontent expansion1 search-str expansion2)
"foo"
'((("(defmacro qwertz (&body body) `(list :qwertz ',body))"
"(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))")
"(yxcv :A :B :C)"
"(list :yxcv (qwertz :a :b :c))"
"(qwertz"
"(list :yxcv (list :qwertz '(:a :b :c)))"))
(sly-check-top-level)
(setq sly-buffer-package ":slynk")
(with-temp-buffer
(lisp-mode)
(dolist (def macro-defs)
(sly-compile-string def 0)
(sly-sync-to-top-level 5))
(insert bufcontent)
(goto-char (point-min))
(sly-execute-as-command 'sly-macroexpand-1)
(sly-wait-condition "Macroexpansion buffer visible"
(lambda ()
(sly-buffer-visible-p
(sly-buffer-name :macroexpansion)))
5)
(with-current-buffer (get-buffer (sly-buffer-name :macroexpansion))
(sly-test-expect "Initial macroexpansion is correct"
expansion1
(downcase (buffer-string))
#'sly-test-macroexpansion=)
(search-forward search-str)
(backward-up-list)
(sly-execute-as-command 'sly-macroexpand-1-inplace)
(sly-sync-to-top-level 3)
(sly-test-expect "In-place macroexpansion is correct"
expansion2
(downcase (buffer-string))
#'sly-test-macroexpansion=)
(sly-execute-as-command 'sly-macroexpand-undo)
(sly-test-expect "Expansion after undo is correct"
expansion1
(downcase (buffer-string))
#'sly-test-macroexpansion=)))
(setq sly-buffer-package ":cl-user"))
(defun sly-test-macroexpansion= (string1 string2 &optional ignore-case)
(let ((string1 (replace-regexp-in-string " *\n *" " " string1))
(string2 (replace-regexp-in-string " *\n *" " " string2)))
(compare-strings string1 nil nil
string2 nil nil
ignore-case)))
(def-sly-test indentation (buffer-content point-markers)
"Check indentation update to work correctly."
'(("
\(in-package :slynk)
\(defmacro with-lolipop (&body body)
`(progn ,@body))
\(defmacro lolipop (&body body)
`(progn ,@body))
\(with-lolipop
1
2
42)
\(lolipop
1
2
23)
"
("23" "42")))
(with-temp-buffer
(lisp-mode)
(sly-editing-mode 1)
(insert buffer-content)
(sly-compile-region (point-min) (point-max))
(sly-sync-to-top-level 3)
(sly-update-indentation)
(sly-sync-to-top-level 3)
(dolist (marker point-markers)
(search-backward marker)
(beginning-of-defun)
(indent-region (point) (progn (end-of-defun) (point))))
(sly-test-expect "Correct buffer content"
buffer-content
(substring-no-properties (buffer-string)))))
(def-sly-test break
(times exp)
"Test whether BREAK invokes SLY-DB."
(let ((exp1 '(break)))
`((1 ,exp1) (2 ,exp1) (3 ,exp1)))
(accept-process-output nil 0.2)
(sly-check-top-level)
(sly-eval-async
`(cl:eval (cl:read-from-string
,(prin1-to-string `(dotimes (i ,times)
(unless (= i 0)
(slynk::sleep-for 1))
,exp)))))
(dotimes (_i times)
(sly-wait-condition "Debugger visible"
(lambda ()
(and (sly-sly-db-level= 1)
(get-buffer-window
(sly-db-get-default-buffer))))
3)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-continue))
(sly-wait-condition "sly-db closed"
(lambda () (not (sly-db-get-default-buffer)))
0.5))
(sly-sync-to-top-level 1))
(def-sly-test (break2 (:fails-for "cmucl" "allegro"))
(times exp)
"Backends should arguably make sure that BREAK does not depend
on *DEBUGGER-HOOK*."
(let ((exp2
'(block outta
(let ((*debugger-hook* (lambda (c h) (return-from outta 42))))
(break)))))
`((1 ,exp2) (2 ,exp2) (3 ,exp2)))
(sly-test-break times exp))
(def-sly-test locally-bound-debugger-hook
()
"Test that binding *DEBUGGER-HOOK* locally works properly."
'(())
(accept-process-output nil 1)
(sly-check-top-level)
(sly-compile-string
(prin1-to-string `(defun cl-user::quux ()
(block outta
(let ((*debugger-hook*
(lambda (c hook)
(declare (ignore c hook))
(return-from outta 42))))
(error "FOO")))))
0)
(sly-sync-to-top-level 2)
(sly-eval-async '(cl-user::quux))
;; FIXME: sly-wait-condition returns immediately if the test returns true
(sly-wait-condition "Checking that Debugger does not popup"
(lambda ()
(not (sly-db-get-default-buffer)))
3)
(sly-sync-to-top-level 5))
(def-sly-test end-of-file
(expr)
"Signalling END-OF-FILE should invoke the debugger."
'(((cl:read-from-string ""))
((cl:error 'cl:end-of-file)))
(let ((value (sly-eval
`(cl:let ((condition nil))
(cl:with-simple-restart
(cl:continue "continue")
(cl:let ((cl:*debugger-hook*
(cl:lambda (c h)
(cl:setq condition c)
(cl:continue))))
,expr))
(cl:and (cl:typep condition 'cl:end-of-file))))))
(sly-test-expect "Debugger invoked" t value)))
(def-sly-test interrupt-at-toplevel
()
"Let's see what happens if we send a user interrupt at toplevel."
'(())
(sly-check-top-level)
(unless (and (eq (sly-communication-style) :spawn)
(not (featurep 'sly-repl)))
(sly-interrupt)
(sly-wait-condition
"Debugger visible"
(lambda ()
(and (sly-sly-db-level= 1)
(get-buffer-window (sly-db-get-default-buffer))))
5)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-quit))
(sly-sync-to-top-level 5)))
(def-sly-test interrupt-in-debugger (interrupts continues)
"Let's see what happens if we interrupt the debugger.
INTERRUPTS ... number of nested interrupts
CONTINUES ... how often the continue restart should be invoked"
'((1 0) (2 1) (4 2))
(sly-check "No debugger" (not (sly-db-get-default-buffer)))
(when (and (eq (sly-communication-style) :spawn)
(not (featurep 'sly-repl)))
(sly-eval-async '(slynk::without-sly-interrupts
(slynk::receive)))
(sit-for 0.2))
(dotimes (i interrupts)
(sly-interrupt)
(let ((level (1+ i)))
(sly-wait-condition (format "Debug level %d reachend" level)
(lambda () (equal (sly-db-level) level))
2)))
(dotimes (i continues)
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-continue))
(let ((level (- interrupts (1+ i))))
(sly-wait-condition (format "Return to debug level %d" level)
(lambda () (equal (sly-db-level) level))
2)))
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-quit))
(sly-sync-to-top-level 1))
(def-sly-test flow-control
(n delay interrupts)
"Let Lisp produce output faster than Emacs can consume it."
`((300 0.03 3))
(when noninteractive
(sly-skip-test "test is currently unstable"))
(sly-check "No debugger" (not (sly-db-get-default-buffer)))
(sly-eval-async `(slynk:flow-control-test ,n ,delay))
(sleep-for 0.2)
(dotimes (_i interrupts)
(sly-interrupt)
(sly-wait-condition "In debugger" (lambda () (sly-sly-db-level= 1)) 5)
(sly-check "In debugger" (sly-sly-db-level= 1))
(with-current-buffer (sly-db-get-default-buffer)
(sly-db-continue))
(sly-wait-condition "No debugger" (lambda () (sly-sly-db-level= nil)) 3)
(sly-check "Debugger closed" (sly-sly-db-level= nil)))
(sly-sync-to-top-level 10))
(def-sly-test sbcl-world-lock
(n delay)
"Print something from *MACROEXPAND-HOOK*.
In SBCL, the compiler grabs a lock which can be problematic because
no method dispatch code can be generated for other threads.
This test will fail more likely before dispatch caches are warmed up."
'((10 0.03)
;;((cl:+ slynk::send-counter-limit 10) 0.03)
)
(sly-test-expect "no error"
123
(sly-eval
`(cl:let ((cl:*macroexpand-hook*
(cl:lambda (fun form env)
(slynk:flow-control-test ,n ,delay)
(cl:funcall fun form env))))
(cl:eval '(cl:macrolet ((foo () 123))
(foo)))))))
(def-sly-test (disconnect-one-connection (:style :spawn)) ()
"`sly-disconnect' should disconnect only the current connection"
'(())
(let ((connection-count (length sly-net-processes))
(old-connection sly-default-connection)
(sly-connected-hook nil))
(unwind-protect
(let ((sly-dispatching-connection
(sly-connect "localhost"
;; Here we assume that the request will
;; be evaluated in its own thread.
(sly-eval `(slynk:create-server
:port 0 ; use random port
:style :spawn
:dont-close nil)))))
(sly-sync-to-top-level 3)
(sly-disconnect)
(sly-test-expect "Number of connections must remane the same"
connection-count
(length sly-net-processes)))
(sly-select-connection old-connection))))
(def-sly-test disconnect-and-reconnect
()
"Close the connetion.
Confirm that the subprocess continues gracefully.
Reconnect afterwards."
'(())
(sly-check-top-level)
(let* ((c (sly-connection))
(p (sly-inferior-process c)))
(with-current-buffer (process-buffer p)
(erase-buffer))
(delete-process c)
(cl-assert (equal (process-status c) 'closed) nil "Connection not closed")
(accept-process-output nil 0.1)
(cl-assert (equal (process-status p) 'run) nil "Subprocess not running")
(with-current-buffer (process-buffer p)
(cl-assert (< (buffer-size) 500) nil "Unusual output"))
(sly-inferior-connect p (sly-inferior-lisp-args p))
(let ((hook nil) (p p))
(setq hook (lambda ()
(sly-test-expect
"We are connected again" p (sly-inferior-process))
(remove-hook 'sly-connected-hook hook)))
(add-hook 'sly-connected-hook hook)
(sly-wait-condition "Lisp restarted"
(lambda ()
(not (member hook sly-connected-hook)))
5))))
;;;; SLY-loading tests that launch separate Emacsen
;;;;
(defvar sly-test-check-repl-forms
`((unless (and (featurep 'sly-mrepl)
(assq 'slynk/mrepl sly-contrib--required-slynk-modules))
(die "`sly-repl' contrib not properly setup"))
(let ((mrepl-buffer (sly-mrepl--find-buffer)))
(unless mrepl-buffer
(die "MREPL buffer not setup!"))
(with-current-buffer mrepl-buffer
;; FIXME: suboptimal: wait one second for the lisp
;; to reply.
(sit-for 1)
(unless (and (string-match "^; +SLY" (buffer-string))
(string-match "CL-USER> *$" (buffer-string)))
(die (format "MREPL prompt: %s" (buffer-string))))))))
(defvar sly-test-check-asdf-loader-forms
`((when (sly-eval '(cl:and (cl:find-package :slynk-loader) t))
(die "Didn't expect SLY to be loaded with slynk-loader.lisp"))))
(cl-defun sly-test-recipe-test-for
(&key preflight
(takeoff `((call-interactively 'sly)))
(landing (append sly-test-check-repl-forms
sly-test-check-asdf-loader-forms)))
(let ((success nil)
(test-file (make-temp-file "sly-recipe-" nil ".el"))
(test-forms
`((require 'cl)
(labels
((die (reason &optional more)
(princ reason)
(terpri)
(and more (pp more))
(kill-emacs 254)))
(condition-case err
(progn ,@preflight
,@takeoff
,(when (null landing) '(kill-emacs 0))
(add-hook
'sly-connected-hook
#'(lambda ()
(condition-case err
(progn
,@landing
(kill-emacs 0))
(error
(die "Unexpected error running landing forms"
err))))
t))
(error
(die "Unexpected error running preflight/takeoff forms" err)))
(with-timeout
(30
(die "Timeout waiting for recipe test to finish."))
(while t (sit-for 1)))))))
(unwind-protect
(progn
(with-temp-buffer
(mapc #'insert (mapcar #'pp-to-string test-forms))
(write-file test-file))
(with-temp-buffer
(let ((retval
(call-process (concat invocation-directory invocation-name)
nil (list t nil) nil
"-Q" "--batch"
"-l" test-file)))
(unless (= 0 retval)
(ert-fail (buffer-string)))))
(setq success t))
(if success (delete-file test-file)
(message "Test failed: keeping %s for inspection" test-file)))))
(define-sly-ert-test readme-recipe ()
"Test the README.md's autoload recipe."
(sly-test-recipe-test-for
:preflight `((add-to-list 'load-path ,sly-path)
(setq inferior-lisp-program ,inferior-lisp-program)
(require 'sly-autoloads))))
(define-sly-ert-test traditional-recipe ()
"Test the README.md's traditional recipe."
(sly-test-recipe-test-for
:preflight `((add-to-list 'load-path ,sly-path)
(setq inferior-lisp-program ,inferior-lisp-program)
(require 'sly)
(sly-setup '(sly-fancy)))))
(define-sly-ert-test slynk-loader-fallback ()
"Test `sly-init-using-slynk-loader'"
;; TODO: another useful test would be to test
;; `sly-init-using-asdf's fallback to slynk-loader.lisp."
(sly-test-recipe-test-for
:preflight `((add-to-list 'load-path ,sly-path)
(setq inferior-lisp-program ,inferior-lisp-program)
(require 'sly-autoloads)
(setq sly-contribs '(sly-fancy))
(setq sly-init-function 'sly-init-using-slynk-loader)
(sly-setup '(sly-fancy)))
:landing `((unless (sly-eval '(cl:and (cl:find-package :slynk-loader) t))
(die "Expected SLY to be loaded with slynk-loader.lisp"))
,@sly-test-check-repl-forms)))
;;; xref recompilation
;;;
(defun sly-test--eval-now (string)
(cl-second (sly-eval `(slynk:eval-and-grab-output ,string))))
(def-sly-test (sly-recompile-all-xrefs (:fails-for "cmucl")) ()
"Test recompilation of all references within an xref buffer."
'(())
(let* ((cell (cons nil nil))
(hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell))
(filename (make-temp-file "sly-recompile-all-xrefs" nil ".lisp"))
(xref-buffer))
(add-hook 'sly-compilation-finished-hook hook)
(unwind-protect
(with-temp-file filename
(set-visited-file-name filename)
(sly-test--eval-now "(defparameter slynk::*.var.* nil)")
(insert "(in-package :slynk)
(defun .fn1. ())
(defun .fn2. () (.fn1.) #.*.var.*)
(defun .fn3. () (.fn1.) #.*.var.*)")
(save-buffer)
(sly-compile-and-load-file)
(sly-wait-condition "Compilation finished"
(lambda () (car cell))
0.5)
(sly-test--eval-now "(setq *.var.* t)")
(setcar cell nil)
(sly-xref :calls ".fn1."
(lambda (&rest args)
(setq xref-buffer (apply #'sly-xref--show-results args))
(setcar cell t)))
(sly-wait-condition "Xrefs computed and displayed"
(lambda () (car cell))
0.5)
(setcar cell nil)
(should (cl-equalp (list (sly-test--eval-now "(.fn2.)")
(sly-test--eval-now "(.fn3.)"))
'("nil" "nil")))
;; Recompile now
;;
(with-current-buffer xref-buffer
(sly-recompile-all-xrefs)
(sly-wait-condition "Compilation finished"
(lambda () (car cell))
0.5))
(should (cl-equalp (list (sly-test--eval-now "(.fn2.)")
(sly-test--eval-now "(.fn3.)"))
'("T" "T"))))
(remove-hook 'sly-compilation-finished-hook hook)
(when xref-buffer
(kill-buffer xref-buffer)))))
;;; window management after M-.
;;;
(cl-defmacro sly-test--with-find-definition-window-checker (fn
(window-splits
total-windows
starting-buffer-sym
starting-window-sym)
&rest body)
(declare (indent 2))
(let ((temp-frame-sym (cl-gensym "temp-frame-")))
`(progn
(sly-check-top-level)
(let ((,temp-frame-sym nil))
(unwind-protect
(progn
(setq ,temp-frame-sym (if noninteractive
(selected-frame)
(make-frame)))
;; too large a frame will exhibit slightly different
;; window-popping behaviour
(set-frame-width ,temp-frame-sym 100)
(set-frame-height ,temp-frame-sym 40)
(with-selected-frame ,temp-frame-sym
(with-temp-buffer
(delete-other-windows)
(switch-to-buffer (current-buffer))
(let ((,starting-window-sym (selected-window))
(,starting-buffer-sym (current-buffer)))
(dotimes (_i ,window-splits)
(split-window))
(funcall ,fn "cl:print-object")
(should (= ,total-windows (length (window-list ,temp-frame-sym))))
(with-current-buffer
(window-buffer (selected-window))
(should (eq major-mode 'sly-xref-mode))
(forward-line 1)
(sly-xref-goto))
,@body))))
(unless noninteractive
(delete-frame ,temp-frame-sym t)))))))
(def-sly-test find-definition-same-window (window-splits total-windows)
"Test `sly-edit-definition' windows"
'((0 2)
(1 2)
(2 3))
(sly-test--with-find-definition-window-checker
'sly-edit-definition
(window-splits
total-windows
temp-buffer
original-window)
(with-current-buffer
(window-buffer (selected-window))
(should-not (eq temp-buffer (current-buffer)))
(should (eq (selected-window) original-window)))
(should (= (if (zerop window-splits)
1
total-windows)
(length (window-list (selected-frame)))))))
(def-sly-test find-definition-other-window (window-splits total-windows)
"Test `sly-edit-definition-other-window' windows"
'((0 2)
(1 2)
(2 3))
(sly-test--with-find-definition-window-checker
'sly-edit-definition-other-window
(window-splits
total-windows
temp-buffer
original-window)
(with-current-buffer
(window-buffer (selected-window))
(should (window-live-p original-window))
(should (eq temp-buffer (window-buffer original-window)))
(should-not (eq (selected-window) original-window)))
(should (= total-windows
(length (window-list (selected-frame)))))))
(provide 'sly-tests)
;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'cl-lib)
(defun sly-parse-form-until (limit form-suffix)
"Parses form from point to `limit'."
;; For performance reasons, this function does not use recursion.
(let ((todo (list (point))) ; stack of positions
(sexps) ; stack of expressions
(cursexp)
(curpos)
(depth 1)) ; This function must be called from the
; start of the sexp to be parsed.
(while (and (setq curpos (pop todo))
(progn
(goto-char curpos)
;; (Here we also move over suppressed
;; reader-conditionalized code! Important so CL-side
;; of autodoc won't see that garbage.)
(ignore-errors (sly-forward-cruft))
(< (point) limit)))
(setq cursexp (pop sexps))
(cond
;; End of an sexp?
((and (or (looking-at "\\s)") (eolp)) sexps)
(cl-decf depth)
(push (nreverse cursexp) (car sexps)))
;; Start of a new sexp?
((looking-at "\\(\\s'\\|@\\)*\\s(")
(let ((subpt (match-end 0)))
(ignore-errors
(forward-sexp)
;; (In case of error, we're at an incomplete sexp, and
;; nothing's left todo after it.)
(push (point) todo))
(push cursexp sexps)
(push subpt todo) ; to descend into new sexp
(push nil sexps)
(cl-incf depth)))
;; In mid of an sexp..
(t
(let ((pt1 (point))
(pt2 (condition-case e
(progn (forward-sexp) (point))
(scan-error
(cl-fourth e))))) ; end of sexp
(push (buffer-substring-no-properties pt1 pt2) cursexp)
(push pt2 todo)
(push cursexp sexps)))))
(when sexps
(setf (car sexps) (cl-nreconc form-suffix (car sexps)))
(while (> depth 1)
(push (nreverse (pop sexps)) (car sexps))
(cl-decf depth))
(nreverse (car sexps)))))
(defun sly-compare-char-syntax (get-char-fn syntax &optional unescaped)
"Returns t if the character that `get-char-fn' yields has
characer syntax of `syntax'. If `unescaped' is true, it's ensured
that the character is not escaped."
(let ((char (funcall get-char-fn (point)))
(char-before (funcall get-char-fn (1- (point)))))
(if (and char (eq (char-syntax char) (aref syntax 0)))
(if unescaped
(or (null char-before)
(not (eq (char-syntax char-before) ?\\)))
t)
nil)))
(defconst sly-cursor-marker 'slynk::%cursor-marker%)
;; FIXME: stop this madness and just use `syntax-ppss'
;;
(defun sly-parse-form-upto-point (&optional max-levels)
(save-restriction
(let ((ppss (syntax-ppss)))
;; Don't parse more than 500 lines before point, so we don't spend
;; too much time. NB. Make sure to go to beginning of line, and
;; not possibly anywhere inside comments or strings.
(narrow-to-region (line-beginning-position -500) (point-max))
(save-excursion
(let ((suffix (list sly-cursor-marker)))
(cond ((sly-compare-char-syntax #'char-after "(" t)
;; We're at the start of some expression, so make sure
;; that SLYNK::%CURSOR-MARKER% will come after that
;; expression. If the expression is not balanced, make
;; still sure that the marker does *not* come directly
;; after the preceding expression.
(or (ignore-errors (forward-sexp) t)
(push "" suffix)))
((or (bolp) (sly-compare-char-syntax #'char-before " " t))
;; We're after some expression, so we have to make sure
;; that %CURSOR-MARKER% does *not* come directly after
;; that expression.
(push "" suffix))
((sly-compare-char-syntax #'char-before "(" t)
;; We're directly after an opening parenthesis, so we
;; have to make sure that something comes before
;; %CURSOR-MARKER%.
(push "" suffix))
(t
;; We're at a symbol, so make sure we get the whole symbol.
(sly-end-of-symbol)))
(let ((pt (point)))
(unless (zerop (car ppss))
(ignore-errors (up-list (if max-levels (- max-levels) -5))))
(ignore-errors (down-list))
(sly-parse-form-until pt suffix)))))))
;;;; Test cases
(defun sly-extract-context ()
"Parse the context for the symbol at point.
Nil is returned if there's no symbol at point. Otherwise we detect
the following cases (the . shows the point position):
(defun n.ame (...) ...) -> (:defun name)
(defun (setf n.ame) (...) ...) -> (:defun (setf name))
(defmethod n.ame (...) ...) -> (:defmethod name (...))
(defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name)
(defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name)
(defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name)
(defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name))
(defmacro n.ame (...) ...) -> (:defmacro name)
(defsetf n.ame (...) ...) -> (:defsetf name)
(define-setf-expander n.ame (...) ...) -> (:define-setf-expander name)
(define-modify-macro n.ame (...) ...) -> (:define-modify-macro name)
(define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
(defvar n.ame (...) ...) -> (:defvar name)
(defparameter n.ame ...) -> (:defparameter name)
(defconstant n.ame ...) -> (:defconstant name)
(defclass n.ame ...) -> (:defclass name)
(defstruct n.ame ...) -> (:defstruct name)
(defpackage n.ame ...) -> (:defpackage name)
For other contexts we return the symbol at point."
(let ((name (sly-symbol-at-point)))
(if name
(let ((symbol (read name)))
(or (progn ;;ignore-errors
(sly-parse-context symbol))
symbol)))))
(defun sly-parse-context (name)
(save-excursion
(cond ((sly-in-expression-p '(defun *)) `(:defun ,name))
((sly-in-expression-p '(defmacro *)) `(:defmacro ,name))
((sly-in-expression-p '(defgeneric *)) `(:defgeneric ,name))
((sly-in-expression-p '(setf *))
;;a setf-definition, but which?
(backward-up-list 1)
(sly-parse-context `(setf ,name)))
((sly-in-expression-p '(defmethod *))
(unless (looking-at "\\s ")
(forward-sexp 1)) ; skip over the methodname
(let (qualifiers arglist)
(cl-loop for e = (read (current-buffer))
until (listp e) do (push e qualifiers)
finally (setq arglist e))
`(:defmethod ,name ,@qualifiers
,(sly-arglist-specializers arglist))))
((and (symbolp name)
(sly-in-expression-p `(,name)))
;; looks like a regular call
(let ((toplevel (ignore-errors (sly-parse-toplevel-form))))
(cond ((sly-in-expression-p `(setf (*))) ;a setf-call
(if toplevel
`(:call ,toplevel (setf ,name))
`(setf ,name)))
((not toplevel)
name)
((sly-in-expression-p `(labels ((*))))
`(:labels ,toplevel ,name))
((sly-in-expression-p `(flet ((*))))
`(:flet ,toplevel ,name))
(t
`(:call ,toplevel ,name)))))
((sly-in-expression-p '(define-compiler-macro *))
`(:define-compiler-macro ,name))
((sly-in-expression-p '(define-modify-macro *))
`(:define-modify-macro ,name))
((sly-in-expression-p '(define-setf-expander *))
`(:define-setf-expander ,name))
((sly-in-expression-p '(defsetf *))
`(:defsetf ,name))
((sly-in-expression-p '(defvar *)) `(:defvar ,name))
((sly-in-expression-p '(defparameter *)) `(:defparameter ,name))
((sly-in-expression-p '(defconstant *)) `(:defconstant ,name))
((sly-in-expression-p '(defclass *)) `(:defclass ,name))
((sly-in-expression-p '(defpackage *)) `(:defpackage ,name))
((sly-in-expression-p '(defstruct *))
`(:defstruct ,(if (consp name)
(car name)
name)))
(t
name))))
(defun sly-in-expression-p (pattern)
"A helper function to determine the current context.
The pattern can have the form:
pattern ::= () ;matches always
| (*) ;matches inside a list
| (<symbol> <pattern>) ;matches if the first element in
; the current list is <symbol> and
; if <pattern> matches.
| ((<pattern>)) ;matches if we are in a nested list."
(save-excursion
(let ((path (reverse (sly-pattern-path pattern))))
(cl-loop for p in path
always (ignore-errors
(cl-etypecase p
(symbol (sly-beginning-of-list)
(eq (read (current-buffer)) p))
(number (backward-up-list p)
t)))))))
(defun sly-pattern-path (pattern)
;; Compute the path to the * in the pattern to make matching
;; easier. The path is a list of symbols and numbers. A number
;; means "(down-list <n>)" and a symbol "(look-at <sym>)")
(if (null pattern)
'()
(cl-etypecase (car pattern)
((member *) '())
(symbol (cons (car pattern) (sly-pattern-path (cdr pattern))))
(cons (cons 1 (sly-pattern-path (car pattern)))))))
(defun sly-beginning-of-list (&optional up)
"Move backward to the beginning of the current expression.
Point is placed before the first expression in the list."
(backward-up-list (or up 1))
(down-list 1)
(skip-syntax-forward " "))
(defun sly-end-of-list (&optional up)
(backward-up-list (or up 1))
(forward-list 1)
(down-list -1))
(defun sly-parse-toplevel-form ()
(ignore-errors ; (foo)
(save-excursion
(goto-char (car (sly-region-for-defun-at-point)))
(down-list 1)
(forward-sexp 1)
(sly-parse-context (read (current-buffer))))))
(defun sly-arglist-specializers (arglist)
(cond ((or (null arglist)
(member (cl-first arglist) '(&optional &key &rest &aux)))
(list))
((consp (cl-first arglist))
(cons (cl-second (cl-first arglist))
(sly-arglist-specializers (cl-rest arglist))))
(t
(cons 't
(sly-arglist-specializers (cl-rest arglist))))))
(defun sly-definition-at-point (&optional only-functional)
"Return object corresponding to the definition at point."
(let ((toplevel (sly-parse-toplevel-form)))
(if (or (symbolp toplevel)
(and only-functional
(not (member (car toplevel)
'(:defun :defgeneric :defmethod
:defmacro :define-compiler-macro)))))
(error "Not in a definition")
(sly-dcase toplevel
(((:defun :defgeneric) symbol)
(format "#'%s" symbol))
(((:defmacro :define-modify-macro) symbol)
(format "(macro-function '%s)" symbol))
((:define-compiler-macro symbol)
(format "(compiler-macro-function '%s)" symbol))
((:defmethod symbol &rest args)
(declare (ignore args))
(format "#'%s" symbol))
(((:defparameter :defvar :defconstant) symbol)
(format "'%s" symbol))
(((:defclass :defstruct) symbol)
(format "(find-class '%s)" symbol))
((:defpackage symbol)
(format "(or (find-package '%s) (error \"Package %s not found\"))"
symbol symbol))
(t
(error "Not in a definition"))))))
(defsubst sly-current-parser-state ()
;; `syntax-ppss' does not save match data as it invokes
;; `beginning-of-defun' implicitly which does not save match
;; data. This issue has been reported to the Emacs maintainer on
;; Feb27.
(syntax-ppss))
(defun sly-inside-string-p ()
(nth 3 (sly-current-parser-state)))
(defun sly-inside-comment-p ()
(nth 4 (sly-current-parser-state)))
(defun sly-inside-string-or-comment-p ()
(let ((state (sly-current-parser-state)))
(or (nth 3 state) (nth 4 state))))
;;; The following two functions can be handy when inspecting
;;; source-location while debugging `M-.'.
;;;
(defun sly-current-tlf-number ()
"Return the current toplevel number."
(interactive)
(let ((original-pos (car (sly-region-for-defun-at-point)))
(n 0))
(save-excursion
;; We use this and no repeated `beginning-of-defun's to get
;; reader conditionals right.
(goto-char (point-min))
(while (progn (sly-forward-sexp)
(< (point) original-pos))
(cl-incf n)))
n))
;;; This is similiar to `sly-enclosing-form-paths' in the
;;; `sly-parse' contrib except that this does not do any duck-tape
;;; parsing, and gets reader conditionals right.
(defun sly-current-form-path ()
"Returns the path from the beginning of the current toplevel
form to the atom at point, or nil if we're in front of a tlf."
(interactive)
(let ((source-path nil))
(save-excursion
;; Moving forward to get reader conditionals right.
(cl-loop for inner-pos = (point)
for outer-pos = (cl-nth-value 1 (sly-current-parser-state))
while outer-pos do
(goto-char outer-pos)
(unless (eq (char-before) ?#) ; when at #(...) continue.
(forward-char)
(let ((n 0))
(while (progn (sly-forward-sexp)
(< (point) inner-pos))
(cl-incf n))
(push n source-path)
(goto-char outer-pos)))))
source-path))
;;; Compile hotspots
;;;
(sly-byte-compile-hotspots
'(sly-parse-form-upto-point
sly-parse-form-until
sly-compare-char-syntax))
(provide 'sly-parse)
;;; sly-messages.el --- Messages, errors, echo-area and visual feedback utils for SLY -*- lexical-binding: t; -*-
;; Copyright (C) 2014 João Távora
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
(require 'cl-lib)
(defvar sly--last-message nil)
(defun sly-message (format-string &rest args)
"Like `message', but use a prefix."
(let ((body (apply #'format format-string args)))
(setq sly--last-message (format "[sly] %s" body))
(message "%s" sly--last-message)))
(add-hook 'echo-area-clear-hook
'sly--message-clear-last-message)
(defun sly--message-clear-last-message ()
(setq sly--last-message nil))
(defun sly-temp-message (wait sit-for format &rest args)
"Wait WAIT seconds then display a message for SIT-FOR seconds.
A nil value for WAIT means \"now\".
SIT-FOR is has the semantincs of `minibuffer-message-timeout', which see."
(run-with-timer
wait nil
#'(lambda ()
(let ((existing sly--last-message)
(text (apply #'format format args)))
(if (minibuffer-window-active-p (minibuffer-window))
(let ((minibuffer-message-timeout sit-for))
(minibuffer-message "[sly] %s" text))
(message "[sly] %s" text) ; don't sly-message here
(run-with-timer
sit-for
nil
#'(lambda ()
;; restore the message
(when existing
(message "%s" existing)))))))))
(defun sly-warning (format-string &rest args)
(display-warning '(sly warning) (apply #'format format-string args)))
(defun sly-error (format-string &rest args)
(apply #'error (format "[sly] %s" format-string) args))
(defun sly-user-error (format-string &rest args)
(apply #'user-error (format "[sly] %s" format-string) args))
(defun sly-display-oneliner (format-string &rest format-args)
(let* ((msg (apply #'format format-string format-args)))
(unless (minibuffer-window-active-p (minibuffer-window))
(sly-message (sly-oneliner msg)))))
(defun sly-oneliner (string)
"Return STRING truncated to fit in a single echo-area line."
(substring string 0 (min (length string)
(or (cl-position ?\n string) most-positive-fixnum)
(1- (window-width (minibuffer-window))))))
(defun sly-y-or-n-p (format-string &rest args)
(let ((prompt (apply #'format (concat "[sly] "
format-string)
args)))
(y-or-n-p prompt)))
;;; Flashing the region
;;;
(defvar sly-flash-inhibit nil
"If non-nil `sly-flash-region' does nothing")
(defvar sly--flash-overlay (make-overlay 0 0))
(overlay-put sly--flash-overlay 'priority 1000)
(cl-defun sly-flash-region (start end &key
timeout
face
times
(pattern '(0.2)))
"Temporarily highlight region from START to END."
(if pattern
(cl-assert (and (null times) (null timeout))
nil
"If PATTERN is supplied, don't supply TIMES or TIMEOUT")
(setq pattern (make-list (* 2 times) timeout)))
(unless sly-flash-inhibit
(let ((buffer (current-buffer)))
(move-overlay sly--flash-overlay start end buffer)
(cl-labels
((on () (overlay-put sly--flash-overlay 'face (or face 'highlight)))
(off () (overlay-put sly--flash-overlay 'face nil))
(relevant-p ()
(equal (list start end buffer)
(list (overlay-start sly--flash-overlay)
(overlay-end sly--flash-overlay)
(overlay-buffer sly--flash-overlay))))
(onoff ()
(when (and pattern (relevant-p))
(on)
(run-with-timer (pop pattern)
nil
(lambda ()
(when (relevant-p)
(off)
(when pattern
(run-with-timer
(pop pattern)
nil
(lambda () (onoff))))))))))
(onoff)))))
(provide 'sly-messages)
;;; sly-messages.el ends here
;;; sly-completion.el --- completion tricks and helpers -*- lexical-binding: t; -*-
;; Copyright (C) 2016 João Távora
;; Author: João Távora
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
;;;
(require 'cl-lib)
(require 'comint)
(require 'sly-messages "lib/sly-messages")
;;; Something to move to minibuffer.el, maybe
;;; Backend completion
;; This "completion style" delegates all the work to the completion
;; table which is then free to implement its own completion style.
;; Typically this is used to take advantage of some external tool which
;; already has its own completion system and doesn't give you efficient
;; access to the prefix completion needed by other completion styles.
(add-to-list 'completion-styles-alist
'(backend
completion-backend-try-completion
completion-backend-all-completions
"Ad-hoc completion style provided by the completion table"))
(defun completion--backend-call (op string table pred point)
(when (functionp table)
(let ((res (funcall table string pred (cons op point))))
(when (eq op (car-safe res))
(cdr res)))))
(defun completion-backend-try-completion (string table pred point)
(completion--backend-call 'try-completion string table pred point))
(defun completion-backend-all-completions (string table pred point)
(completion--backend-call 'all-completions string table pred point))
;;; Forward declarations (later replace with a `sly-common' lib)
;;;
(defvar sly-current-thread)
(declare-function sly-eval "sly" (sexp &optional package
cancel-on-input
cancel-on-input-retval))
(declare-function sly-symbol-at-point "sly")
(declare-function sly-buffer-name "sly")
(defvar sly-buffer-package)
(defvar sly-buffer-connection)
(declare-function sly-connection "sly")
(declare-function sly-recenter "sly")
(declare-function sly-symbol-start-pos "sly")
(declare-function sly-symbol-end-pos "sly")
(declare-function sly-current-package "sly")
(declare-function with-displayed-buffer-window "window")
;;; Backward compatibility shim for emacs < 25.
;;;
(eval-when-compile
(unless (fboundp 'with-displayed-buffer-window)
(defmacro with-displayed-buffer-window (buffer-or-name action quit-function &rest body)
"Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer.
This construct is like `with-current-buffer-window' but unlike that
displays the buffer specified by BUFFER-OR-NAME before running BODY."
(declare (debug t))
(let ((buffer (make-symbol "buffer"))
(window (make-symbol "window"))
(value (make-symbol "value")))
(macroexp-let2 nil vbuffer-or-name buffer-or-name
(macroexp-let2 nil vaction action
(macroexp-let2 nil vquit-function quit-function
`(let* ((,buffer (temp-buffer-window-setup ,vbuffer-or-name))
(standard-output ,buffer)
,window ,value)
(with-current-buffer ,buffer
(setq ,window (temp-buffer-window-show
,buffer
;; Remove window-height when it's handled below.
(if (functionp (cdr (assq 'window-height (cdr ,vaction))))
(assq-delete-all 'window-height (copy-sequence ,vaction))
,vaction))))
(let ((inhibit-read-only t)
(inhibit-modification-hooks t))
(setq ,value (progn ,@body)))
(set-window-point ,window (point-min))
(when (functionp (cdr (assq 'window-height (cdr ,vaction))))
(ignore-errors
(funcall (cdr (assq 'window-height (cdr ,vaction))) ,window)))
(if (functionp ,vquit-function)
(funcall ,vquit-function ,window ,value)
,value)))))))))
;;; Customization
;;;
(defcustom sly-complete-symbol-function 'sly-flex-completions
"Function reponsible for SLY completion.
When called with one argument, a pattern, returns a (possibly
propertized) list of strings the complete that pattern,
collected from the Slynk server."
:type 'function
:group 'sly-ui)
(cl-defmacro sly--responsive-eval ((var sexp
&optional
package
input-arrived-retval) &rest body)
"Use `sly-eval' on SEXP, PACKAGE, bind to VAR, run BODY.
If user input arrives in the meantime return INPUT-ARRIVED-RETVAL
immediately."
(declare (indent 1) (debug (sexp &rest form)))
(let ((sym (make-symbol "sly--responsive-eval")))
`(let* ((,sym (make-symbol "sly--responsive-eval-unique"))
(,var (sly-eval ,sexp ,package non-essential ,sym)))
(if (eq ,var ,sym)
,input-arrived-retval
,@body))))
;;; Completion calculation
;;;
(defun sly--completion-request-completions (pattern slyfun)
"Request completions for PATTERN using SLYFUN.
SLYFUN takes two arguments, a pattern and a package."
(when (sly-connected-p)
(let* ((sly-current-thread t))
(sly--responsive-eval
(completions `(,slyfun ,(substring-no-properties pattern)
',(sly-current-package)))
completions))))
(defun sly-simple-completions (prefix)
"Return (COMPLETIONS COMMON) where COMPLETIONS complete the PREFIX.
COMPLETIONS is a list of propertized strings.
COMMON a string, the common prefix."
(cl-loop with first-difference-pos = (length prefix)
with (completions common) =
(sly--completion-request-completions prefix 'slynk-completion:simple-completions)
for completion in completions
do (put-text-property first-difference-pos
(min (1+ first-difference-pos)
(1- (length completion)))
'face
'completions-first-difference
completion)
collect completion into formatted
finally return (list formatted common)))
(defun sly-flex-completions (pattern)
"Return (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN.
COMPLETIONS is a list of propertized strings."
(cl-loop with (completions _) =
(sly--completion-request-completions pattern 'slynk-completion:flex-completions)
for (completion score chunks classification suggestion) in completions
do
(cl-loop for (pos substring) in chunks
do (put-text-property pos (+ pos
(length substring))
'face
'completions-first-difference
completion)
collect `(,pos . ,(+ pos (length substring))) into chunks-2
finally (put-text-property 0 (length completion)
'sly-completion-chunks chunks-2
completion))
(add-text-properties 0
(length completion)
`(sly--annotation
,(format "%s %5.2f%%"
classification
(* score 100))
sly--suggestion
,suggestion)
completion)
collect completion into formatted
finally return (list formatted nil)))
(defun sly-completion-annotation (completion)
"Grab the annotation of COMPLETION, a string, if any"
(get-text-property 0 'sly--annotation completion))
;;; backward-compatibility
(defun sly-fuzzy-completions (pattern)
"This function is obsolete since 1.0.0-beta-2;
use ‘sly-flex-completions’ instead, but notice the updated protocol.
Returns (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN.
COMPLETIONS is a list of elements of the form (STRING NIL NIL
ANNOTATION) describing each completion possibility."
(let ((new (sly-flex-completions pattern)))
(list (mapcar (lambda (string)
(list string nil nil (sly-completion-annotation string)))
(car new))
(cadr new))))
(when (boundp 'completion-category-overrides)
(add-to-list 'completion-category-overrides
'(sly-completion (styles . (backend)))))
(defun sly--completion-function-wrapper (fn)
(let ((cache (make-hash-table :test #'equal)))
(lambda (string pred action)
(cl-labels ((all
()
(let ((probe (gethash string cache :missing)))
(if (eq probe :missing)
(puthash string (funcall fn string) cache)
probe)))
(try ()
(let ((all (all)))
(and (car all)
(if (and (null (cdr (car all)))
(string= string (caar all)))
t
string)))))
(pcase action
;; identify this to the custom `sly--completion-in-region-function'
(`sly--identify t)
;; identify this to other UI's
(`metadata '(metadata
(display-sort-function . identity)
(category . sly-completion)))
;; all completions
(`t (car (all)))
;; try completion
(`nil (try))
(`(try-completion . ,point)
(cons 'try-completion (cons string point)))
(`(all-completions . ,_point) (cons 'all-completions (car (all))))
(`(boundaries . ,thing)
(completion-boundaries string (all) pred thing))
;; boundaries or any other value
(_ nil))))))
;; This duplicates a function in sly-parse.el
(defun sly--completion-inside-string-or-comment-p ()
(let ((ppss (syntax-ppss))) (or (nth 3 ppss) (nth 4 ppss))))
(defun sly--completions-complete-symbol-1 (fn)
(let* ((beg (sly-symbol-start-pos))
(end (sly-symbol-end-pos)))
(list beg end
(sly--completion-function-wrapper fn)
:annotation-function #'sly-completion-annotation
:exit-function (lambda (obj _status)
(let ((suggestion
(get-text-property 0 'sly--suggestion
obj)))
(when suggestion
(delete-region (- (point) (length obj)) (point))
(insert suggestion))))
:company-docsig
(lambda (obj)
(when (sit-for 0.1)
(sly--responsive-eval (arglist `(slynk:operator-arglist
,(substring-no-properties obj)
,(sly-current-package)))
(or (and arglist
(sly-autodoc--fontify arglist))
"no autodoc information"))))
:company-no-cache t
:company-doc-buffer
(lambda (obj)
(when (sit-for 0.1)
(sly--responsive-eval (doc `(slynk:describe-symbol
,(substring-no-properties obj)))
(when doc
(with-current-buffer (get-buffer-create " *sly-completion doc*")
(erase-buffer)
(insert doc)
(current-buffer))))))
:company-require-match 'never
:company-match
(lambda (obj)
(get-text-property 0 'sly-completion-chunks obj))
:company-location
(lambda (obj)
(save-window-excursion
(let* ((buffer (sly-edit-definition
(substring-no-properties obj))))
(when (buffer-live-p buffer) ; on the safe side
(cons buffer (with-current-buffer buffer
(point)))))))
:company-prefix-length
(and (sly--completion-inside-string-or-comment-p) 0))))
(defun sly-simple-complete-symbol ()
"Prefix completion on the symbol at point.
Intended to go into `completion-at-point-functions'"
(sly--completions-complete-symbol-1 'sly-simple-completions))
(defun sly-flex-complete-symbol ()
"\"Flex\" completion on the symbol at point.
Intended to go into `completion-at-point-functions'"
(sly--completions-complete-symbol-1 'sly-flex-completions))
(defun sly-complete-symbol ()
"Completion on the symbol at point, using `sly-complete-symbol-function'
Intended to go into `completion-at-point-functions'"
(sly--completions-complete-symbol-1 sly-complete-symbol-function))
(defun sly-complete-filename-maybe ()
(when (nth 3 (syntax-ppss)) (comint-filename-completion)))
;;; Set `completion-at-point-functions' and a few other tricks
;;;
(defun sly--setup-completion ()
;; This one can be customized by a SLY user in `sly-mode-hook'
;;
(setq-local completion-at-point-functions '(sly-complete-filename-maybe
sly-complete-symbol))
(add-function :around (local 'completion-in-region-function)
(lambda (oldfun &rest args)
(if sly-symbol-completion-mode
(apply #'sly--completion-in-region-function args)
(apply oldfun args)))
'((name . sly--setup-completion))))
(define-minor-mode sly-symbol-completion-mode "Fancy SLY UI for Lisp symbols" t
:global t)
(add-hook 'sly-mode-hook 'sly--setup-completion)
;;; TODO: Most of the stuff emulates `completion--in-region' and its
;;; callees in Emacs's minibuffer.el
;;;
(defvar sly--completion-transient-data nil) ; similar to `completion-in-region--data'
(defvar sly--completion-transient-completions nil) ; not used
;;; TODO: not tested with other functions in `completion-at-point-functions'
;;;
(defun sly--completion-in-region-function (beg end function pred)
(cond
((funcall function nil nil 'sly--identify)
(let* ((pattern (buffer-substring-no-properties beg end))
(all
(all-completions pattern function pred))
(try
(try-completion pattern function pred)))
(setq this-command 'completion-at-point) ; even if we started with `minibuffer-complete'!
(setq sly--completion-transient-completions all)
(cond ((eq try t)
;; A unique completion
;;
(choose-completion-string (cl-first all)
(current-buffer)
(list beg end))
(sly-temp-message 0 2 "Sole completion"))
;; Incomplete
((stringp try)
(let ((pattern-overlay (make-overlay beg end nil nil nil)))
(setq sly--completion-transient-data
`(,pattern-overlay
,function
,pred))
(overlay-put pattern-overlay 'face 'highlight)
(sly--completion-pop-up-completions-buffer pattern all)
(sly-temp-message 0 2 "Not unique")
(sly--completion-transient-mode 1)))
((> (length pattern) 0)
(sly-temp-message 0 2 "No completions for %s" pattern)))))
(t
(funcall (default-value 'completion-in-region-function)
beg end function pred))))
(defvar sly--completion-in-region-overlay
(let ((ov (make-overlay 0 0)))
(overlay-put ov 'face 'highlight)
(delete-overlay ov)
ov)
"Highlights the currently selected completion candidate")
(defvar sly--completion-display-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [mouse-1] 'sly-choose-completion)
(define-key map [mouse-2] 'sly-choose-completion)
(define-key map [backtab] 'sly-prev-completion)
(define-key map (kbd "q") 'sly-completion-hide-completions)
(define-key map (kbd "C-g") 'sly-completion-hide-completions)
(define-key map (kbd "z") 'sly-completion-hide-completions)
(define-key map [remap previous-line] 'sly-prev-completion)
(define-key map [remap next-line] 'sly-next-completion)
(define-key map [left] 'sly-prev-completion)
(define-key map [right] 'sly-next-completion)
(define-key map (kbd "RET") 'sly-choose-completion)
map)
"Keymap used in the *sly-completions* buffer")
(define-derived-mode sly--completion-display-mode
fundamental-mode "SLY Completions"
"Major mode for presenting SLY completion results.")
(defun sly--completion-transient-mode-postch ()
"Determine whether to pop down the *sly completions* buffer."
(unless (or unread-command-events ; Don't pop down the completions in the middle of
; mouse-drag-region/mouse-set-point.
(let ((pattern-ov
(and sly--completion-transient-data
(car
sly--completion-transient-data))))
(and pattern-ov
;; check if we're in the same buffer
;;
(eq (overlay-buffer pattern-ov)
(current-buffer))
;; check if point is somewhere acceptably related
;; to the region data that originated the completion
;;
(<= (overlay-start pattern-ov)
(point)
(overlay-end pattern-ov)))))
(sly--completion-transient-mode -1)))
(defvar sly--completion-transient-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-n") 'sly-next-completion)
(define-key map (kbd "C-p") 'sly-prev-completion)
(define-key map (kbd "RET") 'sly-choose-completion)
(define-key map "\t" `(menu-item "" sly-choose-completion
:filter (lambda (original)
(when (memq last-command
'(completion-at-point
sly-next-completion
sly-prev-completion))
original))))
(define-key map (kbd "C-g") 'sly-quit-completing)
map)
"Keymap used in the buffer originating a *sly-completions* buffer")
(defvar sly--completion-transient-mode nil
"Explicit `defvar' for `sly--completion-transient-mode'")
(defun sly--completion-turn-off-transient-mode ()
(if (eq major-mode 'sly--completion-display-mode)
(sly-message "Choosing completions directly in %s" (current-buffer))
(sly-completion-hide-completions)))
(define-minor-mode sly--completion-transient-mode
"Minor mode when the \"*sly completions*\" buffer is showing"
;; :lighter " SLY transient completing"
:variable sly--completion-transient-mode
:global t
(remove-hook 'post-command-hook #'sly--completion-transient-mode-postch)
(setq display-buffer-alist
(delq (assq 'sly--completion-transient-mode-display-guard-p display-buffer-alist)
display-buffer-alist))
(setq minor-mode-overriding-map-alist
(delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist)
minor-mode-overriding-map-alist))
(if (null sly--completion-transient-mode)
(sly--completion-turn-off-transient-mode)
(add-hook 'post-command-hook #'sly--completion-transient-mode-postch)
(push `(sly--completion-transient-mode . ,sly--completion-transient-mode-map)
minor-mode-overriding-map-alist)
(push `(sly--completion-transient-mode-display-guard-p
(sly--completion-transient-mode-teardown-before-displaying
. ,display-buffer-alist))
display-buffer-alist)))
;; `define-minor-mode' added to `minor-mode-map-alist', but we wanted
;; `minor-mode-overriding-map-alist' instead, so undo changes to
;; `minor-mode-map-alist'
;;
(setq minor-mode-map-alist
(delq (assq 'sly--completion-transient-mode minor-mode-map-alist)
minor-mode-map-alist))
;; displaying other buffers with pop-to-buffer while in
;; `sly--completion-transient-mode' is problematic, because it
;; dedicates a window. Try some crazy `display-buffer-alist' shit to
;; prevent that.
;;
(defun sly--completion-transient-mode-display-guard-p (buffer-name _action)
(not (string-match-p "^*sly-completions*" buffer-name)))
(defun sly--completion-transient-mode-teardown-before-displaying (_buffer _alist)
(sly--completion-transient-mode -1)
;; returns nil, hoping some other function in alist will display the
;; buffer as intended.
nil)
(defun sly--completion-kill-transient-data ()
(when (overlayp (car sly--completion-transient-data))
(delete-overlay (car sly--completion-transient-data)))
(setq sly--completion-transient-data nil))
(defun sly-completion-hide-completions ()
(interactive)
(sly--completion-kill-transient-data)
(let* ((buffer (get-buffer (sly-buffer-name :completions)))
(win (and buffer
(get-buffer-window buffer 0))))
(when win (with-selected-window win (quit-window t)))))
(defvar sly--completion-reference-buffer nil
"Like `completion-reference-buffer', which see")
(defmacro sly--completion-with-displayed-buffer-window (buffer
action
quit-function
&rest body)
;;; WITH-DISPLAYED-BUFFER-WINDOW doesn't work noninteractively
(let ((original-sym (cl-gensym "original-buffer-")))
`(if noninteractive
(let ((,original-sym (current-buffer)))
(display-buffer (get-buffer-create ,buffer) ,action)
(let ((standard-output ,buffer))
(with-current-buffer ,original-sym
,@body)))
(with-displayed-buffer-window ,buffer ,action ,quit-function
,@body))))
(defun sly--completion-pop-up-completions-buffer (_pattern completions)
(let ((display-buffer-mark-dedicated 'soft)
(pop-up-windows nil)
completions-buffer first-completion-point)
(sly--completion-with-displayed-buffer-window
(sly-buffer-name :completions)
`((display-buffer--maybe-same-window
display-buffer-reuse-window
display-buffer--maybe-pop-up-frame-or-window
;; Use `display-buffer-below-selected' for inline completions,
;; but not in the minibuffer (e.g. in `eval-expression')
;; for which `display-buffer-at-bottom' is used.
,(if (eq (selected-window) (minibuffer-window))
'display-buffer-at-bottom
'display-buffer-below-selected))
,(if temp-buffer-resize-mode
'(window-height . resize-temp-buffer-window)
'(window-height . shrink-window-if-larger-than-buffer))
,(when temp-buffer-resize-mode
'(preserve-size . (nil . t))))
nil
(sly--completion-transient-mode)
(let ((reference (current-buffer)))
(with-current-buffer standard-output
(sly--completion-display-mode)
(set (make-local-variable 'cursor-type) nil)
(setq sly--completion-reference-buffer reference)
(sly--completion-fill-completions-buffer completions)
(setq completions-buffer standard-output
first-completion-point (point))
(add-hook 'kill-buffer-hook 'sly--completion-kill-transient-data t t))))
(with-current-buffer completions-buffer
(goto-char first-completion-point))))
(defvar sly--completion-explanation
(concat "Use \\[sly-next-completion] and \\[sly-prev-completion] to navigate completions."
" \\[sly-choose-completion] or [mouse-1] selects a completion."
"\n\nAnnotation flags: (b)oundp (f)boundp (g)eneric-function (c)lass (m)acro (s)pecial-operator\n\n"))
(defun sly--completion-fill-completions-buffer (completions)
(let ((inhibit-read-only t))
(erase-buffer)
(insert (substitute-command-keys
sly--completion-explanation))
(cl-loop with first = (point)
for completion in completions
for annotation = (or (get-text-property 0 'sly--annotation completion)
"")
for start = (point)
do
(cl-loop for (beg . end) in
(get-text-property 0 'sly-completion-chunks completion)
do (put-text-property beg
end
'face
'completions-common-part completion))
(insert (propertize completion
'mouse-face 'highlight
'sly--completion t))
(insert (make-string (max
1
(- (1- (window-width))
(length completion)
(length annotation)))
? )
annotation)
(put-text-property start (point) 'sly--completion completion)
(insert "\n")
finally (goto-char first) (sly-next-completion 0))))
(defun sly-next-completion (n &optional errorp)
(interactive "p")
(with-current-buffer (sly-buffer-name :completions)
(when (overlay-buffer sly--completion-in-region-overlay)
(goto-char (overlay-start sly--completion-in-region-overlay)))
(forward-line n)
(let* ((end (and (get-text-property (point) 'sly--completion)
(save-excursion
(skip-syntax-forward "^\s")
(point))
;; (next-single-char-property-change (point) 'sly--completion)
))
(beg (and end
(previous-single-char-property-change end 'sly--completion))))
(if (and beg end)
(progn
(move-overlay sly--completion-in-region-overlay
beg end)
(let ((win (get-buffer-window (current-buffer) 0)))
(when win
(with-selected-window win
(goto-char beg)
(sly-recenter beg)))))
(if errorp
(sly-error "No completion at point"))))))
(defun sly-prev-completion (n)
(interactive "p")
(sly-next-completion (- n)))
(defun sly-choose-completion (&optional event)
(interactive (list last-nonmenu-event))
;; In case this is run via the mouse, give temporary modes such as
;; isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
(with-current-buffer (sly-buffer-name :completions)
(when event
(goto-char (posn-point (event-start event)))
(sly-next-completion 0 t))
(let ((completion-text
(buffer-substring-no-properties (overlay-start sly--completion-in-region-overlay)
(overlay-end sly--completion-in-region-overlay))))
(unless (buffer-live-p sly--completion-reference-buffer)
(sly-error "Destination buffer is dead"))
(choose-completion-string completion-text
sly--completion-reference-buffer
(let ((pattern-ov
(car sly--completion-transient-data)))
(list (overlay-start pattern-ov)
(overlay-end pattern-ov))))
(sly--completion-transient-mode -1))))
(defun sly-quit-completing ()
(interactive)
(when sly--completion-transient-mode
(sly--completion-transient-mode -1))
(keyboard-quit))
;;;; Minibuffer reading
(defvar sly-minibuffer-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
(define-key map "\t" 'completion-at-point)
map)
"Minibuffer keymap used for reading CL expressions.")
(defvar sly-minibuffer-history '()
"History list of expressions read from the minibuffer.")
(defvar sly-minibuffer-symbol-history '()
"History list of symbols read from the minibuffer.")
(defmacro sly--with-sly-minibuffer (&rest body)
`(let* ((minibuffer-setup-hook
(cons (lambda ()
(set-syntax-table lisp-mode-syntax-table)
(sly--setup-completion))
minibuffer-setup-hook))
(sly-buffer-package (sly-current-package))
(sly-buffer-connection (sly-connection)))
,@body))
(defvar sly-minibuffer-setup-hook nil
"Setup SLY-specific minibuffer reads.
Used mostly (only?) by `sly-autodoc-mode'.")
(defun sly-read-from-minibuffer (prompt &optional initial-value history allow-empty keymap)
"Read a string from the minibuffer, prompting with PROMPT.
If INITIAL-VALUE is non-nil, it is inserted into the minibuffer
before reading input. The result is a string (\"\" if no input
was given and ALLOW-EMPTY is non-nil)."
(sly--with-sly-minibuffer
(cl-loop
with minibuffer-setup-hook = (cons
(lambda ()
(run-hooks 'sly-minibuffer-setup-hook))
minibuffer-setup-hook)
for i from 0
for read = (read-from-minibuffer
(concat "[sly] " (when (cl-plusp i)
"[can't be blank] ")
prompt)
(and (zerop i)
initial-value)
(or keymap sly-minibuffer-map)
nil (or history 'sly-minibuffer-history))
when (or (> (length read) 0)
allow-empty)
return read)))
(defun sly-read-symbol-name (prompt &optional query)
"Either read a symbol name or choose the one at point.
The user is prompted if a prefix argument is in effect, if there is no
symbol at point, or if QUERY is non-nil."
(let* ((sym-at-point (sly-symbol-at-point))
(completion-category-overrides
(cons '(sly-completion (styles . (backend)))
completion-category-overrides))
(wrapper (sly--completion-function-wrapper sly-complete-symbol-function))
(do-it (lambda () (completing-read prompt wrapper nil nil sym-at-point))))
(cond ((or current-prefix-arg query (not sym-at-point))
(cond (sly-symbol-completion-mode
(let ((icomplete-mode nil)
(completing-read-function #'completing-read-default))
(sly--with-sly-minibuffer (funcall do-it))))
(t (funcall do-it))))
(t sym-at-point))))
(defun sly--read-method (prompt-for-generic
prompt-for-method-within-generic)
"Read triplet (GENERIC-NAME QUALIFIERS SPECIALIZERS) for a method."
(let* ((generic-name (sly-read-symbol-name prompt-for-generic t))
(format-spec (lambda (spec)
(let ((qualifiers (car spec)))
(if (null qualifiers)
(format "%s" (cadr spec))
(format "%s %s" (string-join qualifiers " ")
(cadr spec))))))
(methods-by-formatted-name
(cl-loop for spec in (sly-eval `(slynk:generic-method-specs ,generic-name))
collect (cons (funcall format-spec spec) spec)))
(context-at-point (sly-parse-context generic-name))
(probe (and (eq :defmethod (car context-at-point))
(equal generic-name (cadr context-at-point))
(string-replace
"'" "" (mapconcat #'prin1-to-string (cddr context-at-point)
" "))))
default
(reordered
(cl-loop for e in methods-by-formatted-name
if (cl-equalp (car e) probe) do (setq default e)
else collect e into others
finally (cl-return (if default (cons default others)
others)))))
(unless reordered
(sly-user-error "Generic `%s' doesn't have any methods!" generic-name))
(cons generic-name
(cdr (assoc (completing-read
(concat (format prompt-for-method-within-generic generic-name)
(if default (format " (default %s)" (car default)))
": ")
(mapcar #'car reordered)
nil t nil nil (car default))
reordered)))))
(provide 'sly-completion)
;;; sly-completion.el ends here
;;; sly-common.el --- common utils for SLY and its contribs -*- lexical-binding: t; -*-
;; Copyright (C) 2016 João Távora
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Common utilities for SLY and its contribs
;;; Code:
(require 'cl-lib)
(defun sly--call-refreshing (buffer
overlay
dont-erase
recover-point-p
flash-p
fn)
(with-current-buffer buffer
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t)
(saved (point)))
(save-restriction
(when overlay
(narrow-to-region (overlay-start overlay)
(overlay-end overlay)))
(unwind-protect
(if dont-erase
(goto-char (point-max))
(delete-region (point-min) (point-max)))
(funcall fn)
(when recover-point-p
(goto-char saved)))
(when flash-p
(sly-flash-region (point-min) (point-max)))))
buffer))
(cl-defmacro sly-refreshing ((&key
overlay
dont-erase
(recover-point-p t)
flash-p
buffer)
&rest body)
"Delete a buffer region and run BODY which presumably refreshes it.
Region is OVERLAY or the whole buffer.
Recover point position if RECOVER-POINT-P.
Flash the resulting region if FLASH-P"
(declare (indent 1)
(debug (sexp &rest form)))
`(sly--call-refreshing ,(or buffer
`(current-buffer))
,overlay
,dont-erase
,recover-point-p
,flash-p
#'(lambda () ,@body)))
(provide 'sly-common)
;;; sly-common.el ends here
;;; sly-cl-indent.el --- enhanced lisp-indent mode -*- lexical-binding: t; -*-
;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@eddie.mit.edu>
;; Created: July 1987
;; Maintainer: FSF
;; Keywords: lisp, tools
;; Package: emacs
;; This file is forked from cl-indent.el, which is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This package supplies a single entry point, `sly-common-lisp-indent-function',
;; which performs indentation in the preferred style for Common Lisp code.
;; To enable it:
;;
;; (setq lisp-indent-function 'sly-common-lisp-indent-function)
;;
;; This file is substantially patched from original cl-indent.el,
;; which is in Emacs proper. Although it is named after the SLY
;; library, it DOES NOT require it. sly-cl-indent is instead required
;; by one of SLY's contribs, `sly-indentation'.
;;
;; Before making modifications to this file, consider adding them to
;; Emacs's own `cl-indent' and refactoring this file to be an
;; extension of Emacs's.
;;
;;; Code:
(require 'cl-lib)
(defgroup sly-lisp-indent nil
"Indentation in Common Lisp."
:group 'sly
:group 'lisp-indent)
(defcustom sly-lisp-indent-maximum-backtracking 6
"Maximum depth to backtrack out from a sublist for structured indentation.
If this variable is 0, no backtracking will occur and forms such as `flet'
may not be correctly indented if this value is less than 4."
:type 'integer
:group 'sly-lisp-indent)
(defcustom sly-lisp-tag-indentation 1
"Indentation of tags relative to containing list.
This variable is used by the function `sly--lisp-indent-tagbody'."
:type 'integer
:group 'sly-lisp-indent)
(defcustom sly-lisp-tag-body-indentation 3
"Indentation of non-tagged lines relative to containing list.
This variable is used by the function `sly--lisp-indent-tagbody' to indent normal
lines (lines without tags).
The indentation is relative to the indentation of the parenthesis enclosing
the special form. If the value is t, the body of tags will be indented
as a block at the same indentation as the first s-expression following
the tag. In this case, any forms before the first tag are indented
by `lisp-body-indent'."
:type 'integer
:group 'sly-lisp-indent)
(defcustom sly-lisp-backquote-indentation t
"Whether or not to indent backquoted lists as code.
If nil, indent backquoted lists as data, i.e., like quoted lists."
:type 'boolean
:group 'sly-lisp-indent)
(defcustom sly-lisp-loop-indent-subclauses t
"Whether or not to indent loop subclauses."
:type 'boolean
:group 'sly-lisp-indent)
(defcustom sly-lisp-simple-loop-indentation 2
"Indentation of forms in simple loop forms."
:type 'integer
:group 'sly-lisp-indent)
(defcustom sly-lisp-loop-clauses-indentation 2
"Indentation of loop clauses if `loop' is immediately followed by a newline."
:type 'integer
:group 'sly-lisp-indent)
(defcustom sly-lisp-loop-indent-body-forms-relative-to-loop-start nil
"When true, indent loop body clauses relative to the open paren of the loop
form, instead of the keyword position."
:type 'boolean
:group 'sly-lisp-indent)
(defcustom sly-lisp-loop-body-forms-indentation 3
"Indentation of loop body clauses."
:type 'integer
:group 'sly-lisp-indent)
(defcustom sly-lisp-loop-indent-forms-like-keywords nil
"Whether or not to indent loop subforms just like
loop keywords. Only matters when `sly-lisp-loop-indent-subclauses'
is nil."
:type 'boolean
:group 'sly-lisp-indent)
(defcustom sly-lisp-align-keywords-in-calls t
"Whether to align keyword arguments vertically or not.
If t (the default), keywords in contexts where no other
indentation rule takes precedence are aligned like this:
\(make-instance 'foo :bar t
:quux 42)
If nil, they are indented like any other function
call arguments:
\(make-instance 'foo :bar t
:quux 42)"
:type 'boolean
:group 'sly-lisp-indent)
(defcustom sly-lisp-lambda-list-indentation t
"Whether to indent lambda-lists specially. Defaults to t. Setting this to
nil makes `sly-lisp-lambda-list-keyword-alignment',
`sly-lisp-lambda-list-keyword-parameter-alignment', and
`sly-lisp-lambda-list-keyword-parameter-indentation' meaningless, causing
lambda-lists to be indented as if they were data:
\(defun example (a b &optional o1 o2
o3 o4
&rest r
&key k1 k2
k3 k4)
#|...|#)"
:type 'boolean
:group 'sly-lisp-indent)
(defcustom sly-lisp-lambda-list-keyword-alignment nil
"Whether to vertically align lambda-list keywords together.
If nil (the default), keyworded lambda-list parts are aligned
with the initial mandatory arguments, like this:
\(defun foo (arg1 arg2 &rest rest
&key key1 key2)
#|...|#)
If non-nil, alignment is done with the first keyword
\(or falls back to the previous case), as in:
\(defun foo (arg1 arg2 &rest rest
&key key1 key2)
#|...|#)"
:type 'boolean
:group 'sly-lisp-indent)
(defcustom sly-lisp-lambda-list-keyword-parameter-indentation 2
"Indentation of lambda list keyword parameters.
See `sly-lisp-lambda-list-keyword-parameter-alignment'
for more information."
:type 'integer
:group 'sly-lisp-indent)
(defcustom sly-lisp-lambda-list-keyword-parameter-alignment nil
"Whether to vertically align lambda-list keyword parameters together.
If nil (the default), the parameters are aligned
with their corresponding keyword, plus the value of
`sly-lisp-lambda-list-keyword-parameter-indentation', like this:
\(defun foo (arg1 arg2 &key key1 key2
key3 key4)
#|...|#)
If non-nil, alignment is done with the first parameter
\(or falls back to the previous case), as in:
\(defun foo (arg1 arg2 &key key1 key2
key3 key4)
#|...|#)"
:type 'boolean
:group 'sly-lisp-indent)
;; should this be a defcustom?
(defvar sly-lisp-indent-defun-method '(4 &lambda &body)
"Defun-like indentation method.
This applies when the value of the `sly-common-lisp-indent-function' property
is set to `defun'.")
;;;; Named styles.
;;;;
;;;; -*- common-lisp-style: foo -*-
;;;;
;;;; sets the style for the buffer.
;;;;
;;;; A Common Lisp style is a list of the form:
;;;;
;;;; (NAME INHERIT VARIABLES INDENTATION HOOK DOCSTRING)
;;;;
;;;; where NAME is a symbol naming the style, INHERIT is the name of the style
;;;; it inherits from, VARIABLES is an alist specifying buffer local variables
;;;; for the style, and INDENTATION is an alist specifying non-standard
;;;; indentations for Common Lisp symbols. HOOK is a function to call when
;;;; activating the style. DOCSTRING is the documentation for the style.
;;;;
;;;; Convenience accessors `sly--common-lisp-style-name', &co exist.
;;;;
;;;; `sly-common-lisp-style' stores the name of the current style.
;;;;
;;;; `sly-common-lisp-style-default' stores the name of the style to use when none
;;;; has been specified.
;;;;
;;;; `sly--lisp-indent-active-style' stores a cons of the list specifying the
;;;; current style, and a hash-table containing all indentation methods of that
;;;; style and any styles it inherits from. Whenever we're indenting, we check
;;;; that this is up to date, and recompute when necessary.
;;;;
;;;; Just setting the buffer local sly-common-lisp-style will be enough to have
;;;; the style take effect. `sly-common-lisp-set-style' can also be called
;;;; explicitly, however, and offers name completion, etc.
(cl-defstruct (sly--common-lisp-style
(:type list)
(:copier nil)
(:predicate nil)
(:constructor nil)
(:constructor sly--common-lisp-make-style
(name inherits variables
indentation hook docstring)))
name inherits variables indentation hook docstring)
;;; Convenience accessors
(defalias 'sly--lisp-indent-parse-state-start #'cl-second)
(defalias 'sly--lisp-indent-parse-state-prev #'cl-third)
(defvar-local sly-common-lisp-style nil)
;;; `sly-define-common-lisp-style' updates the docstring of
;;; `sly-common-lisp-style', using this as the base.
(put 'sly-common-lisp-style 'sly-common-lisp-style-base-doc
"Name of the Common Lisp indentation style used in the current buffer.
Set this by giving eg.
;; -*- common-lisp-style: sbcl -*-
in the first line of the file, or by calling `sly-common-lisp-set-style'. If
buffer has no style specified, but `sly-common-lisp-style-default' is set, that
style is used instead. Use `sly-define-common-lisp-style' to define new styles.")
;;; `lisp-mode' kills all buffer-local variables. Setting the
;;; `permanent-local' property allows us to retain the style.
(put 'sly-common-lisp-style 'permanent-local t)
;;; Mark as safe when the style doesn't evaluate arbitrary code.
(put 'sly-common-lisp-style 'safe-local-variable 'sly--lisp-indent-safe-style-p)
;;; Common Lisp indentation style specifications.
(defvar sly--common-lisp-styles (make-hash-table :test 'equal))
;; unused
(defsubst sly--lisp-indent-delete-style (stylename)
(remhash stylename sly--common-lisp-styles))
(defun sly--lisp-indent-find-style (stylename)
(let ((name (if (symbolp stylename)
(symbol-name stylename)
stylename)))
(or (gethash name sly--common-lisp-styles)
(error "Unknown Common Lisp style: %s" name))))
(defun sly--lisp-indent-safe-style-p (stylename)
"True for known Common Lisp style without an :EVAL option.
Ie. styles that will not evaluate arbitrary code on activation."
(let* ((style (ignore-errors (sly--lisp-indent-find-style stylename)))
(base (sly--common-lisp-style-inherits style)))
(and style
(not (sly--common-lisp-style-hook style))
(or (not base)
(sly--lisp-indent-safe-style-p base)))))
(defun sly--lisp-indent-add-style (stylename inherits variables
indentation hooks documentation)
;; Invalidate indentation methods cached in common-lisp-active-style.
(maphash (lambda (k v)
(puthash k (cl-copy-list v) sly--common-lisp-styles))
sly--common-lisp-styles)
;; Add/Redefine the specified style.
(puthash stylename
(sly--common-lisp-make-style
stylename inherits
variables indentation
hooks documentation)
sly--common-lisp-styles)
;; Frob `sly-common-lisp-style' docstring.
(let ((doc (get 'sly-common-lisp-style
'sly-common-lisp-style-base-doc))
(all nil))
(setq doc (concat doc "\n\nAvailable styles are:\n"))
(maphash (lambda (name style)
(push (list name (sly--common-lisp-style-docstring style)) all))
sly--common-lisp-styles)
(dolist (info (sort all (lambda (a b) (string< (car a) (car b)))))
(let ((style-name (cl-first info))
(style-doc (cl-second info)))
(if style-doc
(setq doc (concat doc
"\n " style-name "\n"
" " style-doc "\n"))
(setq doc (concat doc "\n " style-name " (undocumented)\n")))))
(put 'sly-common-lisp-style 'variable-documentation doc))
stylename)
;;; Activate STYLENAME, adding its indentation methods to METHODS -- and
;;; recurse on style inherited from.
(defun sly--lisp-indent-activate-style (stylename methods)
(let* ((style (sly--lisp-indent-find-style stylename))
(basename (sly--common-lisp-style-inherits style)))
;; Recurse on parent.
(when basename
(sly--lisp-indent-activate-style basename methods))
;; Copy methods
(dolist (spec (sly--common-lisp-style-indentation style))
(puthash (cl-first spec) (cl-second spec) methods))
;; Bind variables.
(dolist (var (sly--common-lisp-style-variables style))
(set (make-local-variable (cl-first var)) (cl-second var)))
;; Run hook.
(let ((hook (sly--common-lisp-style-hook style)))
(when hook
(funcall hook)))))
;;; When a style is being used, `sly--lisp-indent-active-style' holds a cons
;;;
;;; (STYLE . METHODS)
;;;
;;; where STYLE is the list specifying the currently active style, and
;;; METHODS is the table of indentation methods -- including inherited
;;; ones -- for it. `sly--lisp-indent-active-style-methods' is reponsible
;;; for keeping this up to date.
(defvar-local sly--lisp-indent-active-style nil)
;;; Makes sure sly--lisp-indent-active-style corresponds to sly-common-lisp-style, and
;;; pick up redefinitions, etc. Returns the method table for the currently
;;; active style.
(defun sly--lisp-indent-active-style-methods ()
(let* ((name (or sly-common-lisp-style (bound-and-true-p common-lisp-style)))
(style (when name (sly--lisp-indent-find-style name))))
(if (eq style (car sly--lisp-indent-active-style))
(cdr sly--lisp-indent-active-style)
(when style
(let ((methods (make-hash-table :test 'equal)))
(sly--lisp-indent-activate-style name methods)
(setq sly--lisp-indent-active-style (cons style methods))
methods)))))
(defvar sly--lisp-indent-set-style-history nil)
(defun sly--lisp-indent-style-names ()
(let (names)
(maphash (lambda (k v)
(push (cons k v) names))
sly--common-lisp-styles)
names))
;;;###autoload
(defun sly-common-lisp-set-style (stylename)
"Set current buffer to use the Common Lisp style STYLENAME.
STYLENAME, a string, must be an existing Common Lisp style. Styles
are added (and updated) using `sly-define-common-lisp-style'.
The buffer-local variable `sly-common-lisp-style' will get set to STYLENAME.
A Common Lisp style is composed of local variables, indentation
specifications, and may also contain arbitrary elisp code to run upon
activation."
(interactive
(list (let ((completion-ignore-case t)
(prompt "Specify Common Lisp indentation style: "))
(completing-read prompt
(sly--lisp-indent-style-names) nil t nil
'sly--lisp-indent-set-style-history))))
(setq sly-common-lisp-style (sly--common-lisp-style-name
(sly--lisp-indent-find-style stylename))
sly--lisp-indent-active-style nil)
;; Actually activates the style.
(sly--lisp-indent-active-style-methods)
stylename)
;;;###autoload
(defmacro sly-define-common-lisp-style (name documentation &rest options)
"Define a Common Lisp indentation style.
NAME is the name of the style.
DOCUMENTATION is the docstring for the style, automatically added to the
docstring of `sly-common-lisp-style'.
OPTIONS are:
(:variables (name value) ...)
Specifying the buffer local variables associated with the style.
(:indentation (symbol spec) ...)
Specifying custom indentations associated with the style. SPEC is
a normal `sly-common-lisp-indent-function' indentation specification.
(:inherit style)
Inherit variables and indentations from another Common Lisp style.
(:eval form ...)
Lisp code to evaluate when activating the style. This can be used to
eg. activate other modes. It is possible that over the lifetime of
a buffer same style gets activated multiple times, so code in :eval
option should cope with that.
"
(declare (indent 1))
(when (consp documentation)
(setq options (cons documentation options)
documentation nil))
`(sly--lisp-indent-add-style ,name
,(cadr (assoc :inherit options))
',(cdr (assoc :variables options))
',(cdr (assoc :indentation options))
,(when (assoc :eval options)
`(lambda ()
,@(cdr (assoc :eval options))))
,documentation))
(sly-define-common-lisp-style "basic-common"
(:variables
(sly-lisp-indent-maximum-backtracking 6)
(sly-lisp-tag-indentation 1)
(sly-lisp-tag-body-indentation 3)
(sly-lisp-backquote-indentation t)
(sly-lisp-loop-indent-subclauses t)
(sly-lisp-loop-indent-forms-like-keywords nil)
(sly-lisp-simple-loop-indentation 2)
(sly-lisp-align-keywords-in-calls t)
(sly-lisp-lambda-list-indentation t)
(sly-lisp-lambda-list-keyword-alignment nil)
(sly-lisp-lambda-list-keyword-parameter-indentation 2)
(sly-lisp-lambda-list-keyword-parameter-alignment nil)
(sly-lisp-indent-defun-method (4 &lambda &body))
(sly-lisp-loop-clauses-indentation 2)
(sly-lisp-loop-indent-body-forms-relative-to-loop-start nil)
(sly-lisp-loop-body-forms-indentation 3)))
(sly-define-common-lisp-style "basic-emacs25"
"This style adds a workaround needed for Emacs 25"
(:inherit "basic-common")
(:variables
;; Without these (;;foo would get a space inserted between
;; ( and ; by indent-sexp.
(comment-indent-function (lambda () nil))))
(sly-define-common-lisp-style "basic-emacs26"
"This style is the same as basic-common. It doesn't need or
want the workaround used in Emacs 25. In Emacs 26, that
workaround introduces a weird behavior where a single
semicolon breaks the mode and causes the cursor to move to the
start of the line after every character inserted."
(:inherit "basic-common"))
(sly-define-common-lisp-style "basic"
"This style merely gives all identation variables their default values,
making it easy to create new styles that are proof against user
customizations. It also adjusts comment indentation from default.
All other predefined modes inherit from basic."
(:inherit (if (>= emacs-major-version 26)
"basic-emacs26"
"basic-emacs25")))
(sly-define-common-lisp-style "classic"
"This style of indentation emulates the most striking features of 1995
vintage cl-indent.el once included as part of Slime: IF indented by two
spaces, and CASE clause bodies indentented more deeply than the keys."
(:inherit "basic")
(:variables
(sly-lisp-lambda-list-keyword-parameter-indentation 0))
(:indentation
(case (4 &rest (&whole 2 &rest 3)))
(if (4 2 2))))
(sly-define-common-lisp-style "modern"
"A good general purpose style. Turns on lambda-list keyword and keyword
parameter alignment, and turns subclause aware loop indentation off.
(Loop indentation so because simpler style is more prevalent in existing
sources, not because it is necessarily preferred.)"
(:inherit "basic")
(:variables
(sly-lisp-lambda-list-keyword-alignment t)
(sly-lisp-lambda-list-keyword-parameter-alignment t)
(sly-lisp-lambda-list-keyword-parameter-indentation 0)
(sly-lisp-loop-indent-subclauses nil)))
(sly-define-common-lisp-style "sbcl"
"Style used in SBCL sources. A good if somewhat intrusive general purpose
style based on the \"modern\" style. Adds indentation for a few SBCL
specific constructs, sets indentation to use spaces instead of tabs,
fill-column to 78, and activates whitespace-mode to show tabs and trailing
whitespace."
(:inherit "modern")
(:eval
(whitespace-mode 1))
(:variables
(whitespace-style (tabs trailing))
(indent-tabs-mode nil)
(comment-fill-column nil)
(fill-column 78))
(:indentation
(def!constant (as defconstant))
(def!macro (as defmacro))
(def!method (as defmethod))
(def!struct (as defstruct))
(def!type (as deftype))
(defmacro-mundanely (as defmacro))
(deftransform (as defmacro))
(define-source-transform (as defun))
(!def-type-translator (as defun))
(!def-debug-command (as defun))))
(defcustom sly-common-lisp-style-default nil
"Name of the Common Lisp indentation style to use in lisp-mode buffers if
none has been specified."
:type `(choice (const :tag "None" nil)
,@(mapcar (lambda (spec)
`(const :tag ,(car spec) ,(car spec)))
(sly--lisp-indent-style-names))
(string :tag "Other"))
:group 'sly-lisp-indent)
;;; If style is being used, that's a sufficient invitation to snag
;;; the indentation function.
(defun sly--lisp-indent-lisp-mode-hook ()
(let ((style (or sly-common-lisp-style
(bound-and-true-p common-lisp-style)
sly-common-lisp-style-default)))
(when style
(setq-local lisp-indent-function #'sly-common-lisp-indent-function)
(sly-common-lisp-set-style style))))
(add-hook 'lisp-mode-hook #'sly--lisp-indent-lisp-mode-hook)
;;;; The indentation specs are stored at three levels. In order of priority:
;;;;
;;;; 1. Indentation as set by current style, from the indentation table
;;;; in the current style.
;;;;
;;;; 2. Globally set indentation, from the `sly-common-lisp-indent-function'
;;;; property of the symbol.
;;;;
;;;; 3. Per-package indentation derived by the system. A live Common Lisp
;;;; system may (via Slime, eg.) add indentation specs to
;;;; sly-common-lisp-system-indentation, where they are associated with
;;;; the package of the symbol. Then we run some lossy heuristics and
;;;; find something that looks promising.
;;;;
;;;; FIXME: for non-system packages the derived indentation should probably
;;;; take precedence.
;;; This maps symbols into lists of (INDENT . PACKAGES) where INDENT is
;;; an indentation spec, and PACKAGES are the names of packages where this
;;; applies.
;;;
;;; We never add stuff here by ourselves: this is for things like Slime to
;;; fill.
(defvar sly-common-lisp-system-indentation (make-hash-table :test 'equal))
(defun sly--lisp-indent-guess-current-package ()
(save-excursion
(ignore-errors
(when (let ((case-fold-search t))
(search-backward "(in-package "))
(re-search-forward "[ :\"]+")
(let ((start (point)))
(re-search-forward "[\":)]")
(upcase (buffer-substring-no-properties
start (1- (point)))))))))
(defvar sly--lisp-indent-current-package-function
'sly--lisp-indent-guess-current-package
"Used to derive the package name to use for indentation at a
given point. Defaults to `sly--lisp-indent-guess-current-package'.")
(defun sly--lisp-indent-symbol-package (string)
(if (and (stringp string) (string-match ":" string))
(let ((p (match-beginning 0)))
(if (eq p 0)
"KEYWORD"
(upcase (substring string 0 p))))
(funcall sly--lisp-indent-current-package-function)))
(defun sly--lisp-indent-get-indentation (name &optional full)
"Retrieves the indentation information for NAME."
(let ((method
(or
;; From style
(let ((methods (sly--lisp-indent-active-style-methods)))
(and methods (gethash name methods)))
;; From global settings.
(get name 'sly-common-lisp-indent-function)
(get name 'common-lisp-indent-function)
;; From system derived information.
(let ((system-info (gethash name sly-common-lisp-system-indentation)))
(if (not (cdr system-info))
(caar system-info)
(let ((guess nil)
(guess-n 0)
(package (sly--lisp-indent-symbol-package full)))
(cl-dolist (info system-info guess)
(let* ((pkgs (cdr info))
(n (length pkgs)))
(cond ((member package pkgs)
;; This is it.
(cl-return (car info)))
((> n guess-n)
;; If we can't find the real thing, go with the one
;; accessible in most packages.
(setf guess (car info)
guess-n n)))))))))))
(if (eq 'as (car-safe method))
(sly--lisp-indent-get-indentation (cadr method))
method)))
;;;; LOOP indentation, the simple version
(defun sly--lisp-indent-loop-type (loop-start)
"Returns the type of the loop form at LOOP-START.
Possible types are SIMPLE, SIMPLE/SPLIT, EXTENDED, and EXTENDED/SPLIT. */SPLIT
refers to extended loops whose body does not start on the same line as the
opening parenthesis of the loop."
(let (comment-split)
(condition-case ()
(save-excursion
(goto-char loop-start)
(let ((line (line-number-at-pos))
(maybe-split t))
(forward-char 1)
(forward-sexp 1)
(save-excursion
(when (looking-at "\\s-*\\\n*;")
(search-forward ";")
(backward-char 1)
(if (= line (line-number-at-pos))
(setq maybe-split nil)
(setq comment-split t))))
(forward-sexp 1)
(backward-sexp 1)
(if (eq (char-after) ?\()
(if (or (not maybe-split) (= line (line-number-at-pos)))
'simple
'simple/split)
(if (or (not maybe-split) (= line (line-number-at-pos)))
'extended
'extended/split))))
(error
(if comment-split
'simple/split
'simple)))))
(defun sly--lisp-indent-trailing-comment ()
(ignore-errors
;; If we had a trailing comment just before this, find it.
(save-excursion
(backward-sexp)
(forward-sexp)
(when (looking-at "\\s-*;")
(search-forward ";")
(1- (current-column))))))
;;;###autoload
(defun sly-common-lisp-indent-function (indent-point state)
"Function to indent the arguments of a Lisp function call.
This is suitable for use as the value of the variable
`lisp-indent-function'. INDENT-POINT is the point at which the
indentation function is called, and STATE is the
`parse-partial-sexp' state at that position. Browse the
`sly-lisp-indent' customize group for options affecting the behavior
of this function.
If the indentation point is in a call to a Lisp function, that
function's `sly-common-lisp-indent-function' property specifies how
this function should indent it. Possible values for this
property are:
* defun, meaning indent according to
`sly-lisp-indent-defun-method'; i.e., like (4 &lambda &body),
as explained below.
* any other symbol, meaning a function to call. The function
should take the arguments: PATH STATE INDENT-POINT SEXP-COLUMN
NORMAL-INDENT. PATH is a list of integers describing the
position of point in terms of list-structure with respect to
the containing lists. For example, in
((a b c (d foo) f) g), foo has a path of (0 3 1). In other
words, to reach foo take the 0th element of the outermost list,
then the 3rd element of the next list, and finally the 1st
element. STATE and INDENT-POINT are as in the arguments to
`sly-common-lisp-indent-function'. SEXP-COLUMN is the column of
the open parenthesis of the innermost containing list.
NORMAL-INDENT is the column the indentation point was
originally in. This function should behave like
`sly--lisp-indent-259'.
* an integer N, meaning indent the first N arguments like
function arguments, and any further arguments like a body.
This is equivalent to (4 4 ... &body).
* a list starting with `as' specifies an indirection: indentation
is done as if the form being indented had started with the
second element of the list.
* any other list. The list element in position M specifies how
to indent the Mth function argument. If there are fewer
elements than function arguments, the last list element applies
to all remaining arguments. The accepted list elements are:
* nil, meaning the default indentation.
* an integer, specifying an explicit indentation.
* &lambda. Indent the argument (which may be a list) by 4.
* &rest. When used, this must be the penultimate element. The
element after this one applies to all remaining arguments.
* &body. This is equivalent to &rest lisp-body-indent, i.e., indent
all remaining elements by `lisp-body-indent'.
* &whole. This must be followed by nil, an integer, or a
function symbol. This indentation is applied to the
associated argument, and as a base indent for all remaining
arguments. For example, an integer P means indent this
argument by P, and all remaining arguments by P, plus the
value specified by their associated list element.
* a symbol. A function to call, with the 6 arguments specified above.
* a list, with elements as described above. This applies when the
associated function argument is itself a list. Each element of the list
specifies how to indent the associated argument.
For example, the function `case' has an indent property
\(4 &rest (&whole 2 &rest 1)), meaning:
* indent the first argument by 4.
* arguments after the first should be lists, and there may be any number
of them. The first list element has an offset of 2, all the rest
have an offset of 2+1=3."
(sly--lisp-indent-function-1 indent-point state))
(define-minor-mode sly-lisp-indent-compatibility-mode
"Replace the definition of `common-lisp-indent-function' with `sly-common-lisp-indent-function'.
For backwards compatibility with the old sly-cl-indent.el, which
used to do this by default."
:group 'sly-lisp-indent
(if sly-lisp-indent-compatibility-mode
(advice-add 'common-lisp-indent-function
:override 'sly-common-lisp-indent-function)
(advice-remove 'common-lisp-indent-function
'sly-common-lisp-indent-function)))
(defvar sly--lisp-indent-feature-expr-regexp "#!?\\(+\\|-\\)")
;;; Semi-feature-expression aware keyword check.
(defun sly--lisp-indent-looking-at-keyword ()
(or (looking-at ":")
(and (looking-at sly--lisp-indent-feature-expr-regexp)
(save-excursion
(forward-sexp)
(skip-chars-forward " \t\n")
(sly--lisp-indent-looking-at-keyword)))))
;;; Semi-feature-expression aware backwards movement for keyword
;;; argument pairs.
(defun sly--lisp-indent-backward-keyword-argument ()
(ignore-errors
(backward-sexp 2)
(when (looking-at sly--lisp-indent-feature-expr-regexp)
(cond ((ignore-errors
(save-excursion
(backward-sexp 2)
(looking-at sly--lisp-indent-feature-expr-regexp)))
(sly--lisp-indent-backward-keyword-argument))
((ignore-errors
(save-excursion
(backward-sexp 1)
(looking-at ":")))
(backward-sexp))))
t))
(defvar sly--lisp-indent-containing-sexp)
(defun sly--lisp-indent-function-1 (indent-point state)
;; If we're looking at a splice, move to the first comma.
(when (or (eq (char-before) ?,)
(and (eq (char-before) ?@)
(eq (char-before (1- (point))) ?,)))
(when (re-search-backward "[^,@'],")
(forward-char 1)))
(let ((normal-indent (current-column)))
;; Walk up list levels until we see something
;; which does special things with subforms.
(let ((depth 0)
;; Path describes the position of point in terms of
;; list-structure with respect to containing lists.
;; `foo' has a path of (0 3 1) in `((a b c (d foo) f) g)'.
(path ())
;; set non-nil when somebody works out the indentation to use
calculated
;; If non-nil, this is an indentation to use
;; if nothing else specifies it more firmly.
tentative-calculated
;; (last-point indent-point)
;; the position of the open-paren of the innermost containing list
(containing-form-start (sly--lisp-indent-parse-state-start state))
;; the column of the above
sexp-column)
;; Move to start of innermost containing list
(goto-char containing-form-start)
(setq sexp-column (current-column))
;; Look over successively less-deep containing forms
(while (and (not calculated)
(< depth sly-lisp-indent-maximum-backtracking))
(let ((sly--lisp-indent-containing-sexp (point)))
(forward-char 1)
(parse-partial-sexp (point) indent-point 1 t)
;; Move to the car of the relevant containing form
(let (tem full function method tentative-defun)
(if (not (looking-at "\\sw\\|\\s_"))
;; This form doesn't seem to start with a symbol
(setq function nil method nil full nil)
(setq tem (point))
(forward-sexp 1)
(setq full (downcase (buffer-substring-no-properties tem (point)))
function full)
(goto-char tem)
(setq tem (intern-soft function)
method (sly--lisp-indent-get-indentation tem))
(cond ((and (null method)
(string-match ":[^:]+" function))
;; The pleblisp package feature
(setq function (substring function (1+ (match-beginning 0)))
method (sly--lisp-indent-get-indentation
(intern-soft function) full)))
((and (null method))
;; backwards compatibility
(setq method (sly--lisp-indent-get-indentation tem)))))
(let ((n 0))
;; How far into the containing form is the current form?
(if (< (point) indent-point)
(while (ignore-errors
(forward-sexp 1)
(if (>= (point) indent-point)
nil
(parse-partial-sexp (point)
indent-point 1 t)
(setq n (1+ n))
t))))
(setq path (cons n path)))
;; Guess.
(when (and (not method) function (null (cdr path)))
;; (package prefix was stripped off above)
(cond ((and (string-match "\\`def" function)
(not (string-match "\\`default" function))
(not (string-match "\\`definition" function))
(not (string-match "\\`definer" function)))
(setq tentative-defun t))
((string-match
(eval-when-compile
(concat "\\`\\("
(regexp-opt '("with" "without" "do"))
"\\)-"))
function)
(setq method '(&lambda &body)))))
;; #+ and #- cleverness.
(save-excursion
(goto-char indent-point)
(backward-sexp)
(let ((indent (current-column)))
(when
(or (looking-at sly--lisp-indent-feature-expr-regexp)
(ignore-errors
(backward-sexp)
(when (looking-at sly--lisp-indent-feature-expr-regexp)
(setq indent (current-column))
(let ((line (line-number-at-pos)))
(while
(ignore-errors
(backward-sexp 2)
(and (= line (line-number-at-pos))
(looking-at sly--lisp-indent-feature-expr-regexp)))
(setq indent (current-column))))
t)))
(setq calculated (list indent containing-form-start)))))
(cond ((and (or (eq (char-after (1- sly--lisp-indent-containing-sexp)) ?\')
(and (not sly-lisp-backquote-indentation)
(eq (char-after (1- sly--lisp-indent-containing-sexp)) ?\`)))
(not (eq (char-after (- sly--lisp-indent-containing-sexp 2)) ?\#)))
;; No indentation for "'(...)" elements
(setq calculated (1+ sexp-column)))
((eq (char-after (1- sly--lisp-indent-containing-sexp)) ?\#)
;; "#(...)"
(setq calculated (1+ sexp-column)))
((null method)
;; If this looks like a call to a `def...' form,
;; think about indenting it as one, but do it
;; tentatively for cases like
;; (flet ((defunp ()
;; nil)))
;; Set both normal-indent and tentative-calculated.
;; The latter ensures this value gets used
;; if there are no relevant containing constructs.
;; The former ensures this value gets used
;; if there is a relevant containing construct
;; but we are nested within the structure levels
;; that it specifies indentation for.
(if tentative-defun
(setq tentative-calculated
(sly--lisp-indent-call-method
function sly-lisp-indent-defun-method
path state indent-point
sexp-column normal-indent)
normal-indent tentative-calculated)
(when sly-lisp-align-keywords-in-calls
;; No method so far. If we're looking at a keyword,
;; align with the first keyword in this expression.
;; This gives a reasonable indentation to most things
;; with keyword arguments.
(save-excursion
(goto-char indent-point)
(back-to-indentation)
(when (sly--lisp-indent-looking-at-keyword)
(while (sly--lisp-indent-backward-keyword-argument)
(when (sly--lisp-indent-looking-at-keyword)
(setq calculated
(list (current-column)
containing-form-start)))))))))
((integerp method)
;; convenient top-level hack.
;; (also compatible with lisp-indent-function)
;; The number specifies how many `distinguished'
;; forms there are before the body starts
;; Equivalent to (4 4 ... &body)
(setq calculated (cond ((cdr path) normal-indent)
((<= (car path) method)
;; `distinguished' form
(list (+ sexp-column 4)
containing-form-start))
((= (car path) (1+ method))
;; first body form.
(+ sexp-column lisp-body-indent))
(t
;; other body form
normal-indent))))
(t
(setq calculated
(sly--lisp-indent-call-method
function method path state indent-point
sexp-column normal-indent)))))
(goto-char sly--lisp-indent-containing-sexp)
;; (setq last-point sly--lisp-indent-containing-sexp)
(unless calculated
(condition-case ()
(progn (backward-up-list 1)
(setq depth (1+ depth)))
(error
(setq depth sly-lisp-indent-maximum-backtracking))))))
(or calculated tentative-calculated
;; Fallback.
;;
;; Instead of punting directly to calculate-lisp-indent we
;; handle a few of cases it doesn't deal with:
;;
;; A: (foo (
;; bar zot
;; quux))
;;
;; would align QUUX with ZOT.
;;
;; B:
;; (foo (or x
;; y) t
;; z)
;;
;; would align the Z with Y.
;;
;; C:
;; (foo ;; Comment
;; (bar)
;; ;; Comment 2
;; (quux))
;;
;; would indent BAR and QUUX by one.
(ignore-errors
(save-excursion
(goto-char indent-point)
(back-to-indentation)
(let ((p (point)))
(goto-char containing-form-start)
(down-list)
(let ((one (current-column)))
(skip-chars-forward " \t")
(if (or (eolp) (looking-at ";"))
;; A.
(list one containing-form-start)
(forward-sexp 2)
(backward-sexp)
(if (/= p (point))
;; B.
(list (current-column) containing-form-start)
(backward-sexp)
(forward-sexp)
(let ((tmp (+ (current-column) 1)))
(skip-chars-forward " \t")
(if (looking-at ";")
;; C.
(list tmp containing-form-start)))))))))))))
;; Dynamically bound in `sly--lisp-indent-call-method'.
(defvar sly--lisp-indent-error-function)
(defun sly--lisp-indent-call-method (function method path state indent-point
sexp-column normal-indent)
(let ((sly--lisp-indent-error-function function))
(if (symbolp method)
(funcall method
path state indent-point
sexp-column normal-indent)
(sly--lisp-indent-259 method path state indent-point
sexp-column normal-indent))))
(defun sly--lisp-indent-report-bad-format (m)
(error "%s has a badly-formed %s property: %s"
;; Love those free variable references!!
sly--lisp-indent-error-function
'sly-common-lisp-indent-function m))
;; Lambda-list indentation is now done in `sly--lisp-indent-lambda-list'.
;; See also `sly-lisp-lambda-list-keyword-alignment',
;; `sly-lisp-lambda-list-keyword-parameter-alignment' and
;; `sly-lisp-lambda-list-keyword-parameter-indentation' -- dvl
(defvar sly--lisp-indent-lambda-list-keywords-regexp
"&\\(\
optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|\
environment\\|more\
\\)\\>"
"Regular expression matching lambda-list keywords.")
(defun sly--lisp-indent-lambda-list
(indent-point sexp-column containing-form-start)
(if (not sly-lisp-lambda-list-indentation)
(1+ sexp-column)
(sly--lisp-indent-properly-indent-lambda-list
indent-point sexp-column containing-form-start)))
(defun sly--lisp-indent-properly-indent-lambda-list
(indent-point sexp-column containing-form-start)
(cond
((save-excursion
(goto-char indent-point)
(back-to-indentation)
(looking-at sly--lisp-indent-lambda-list-keywords-regexp))
;; We're facing a lambda-list keyword.
(if sly-lisp-lambda-list-keyword-alignment
;; Align to the first keyword if any, or to the beginning of
;; the lambda-list.
(save-excursion
(goto-char containing-form-start)
(down-list)
(let ((key-indent nil)
(next t))
(while (and next (< (point) indent-point))
(if (looking-at sly--lisp-indent-lambda-list-keywords-regexp)
(setq key-indent (current-column)
next nil)
(setq next (ignore-errors (forward-sexp) t))
(if next
(ignore-errors
(forward-sexp)
(backward-sexp)))))
(or key-indent
(1+ sexp-column))))
;; Align to the beginning of the lambda-list.
(1+ sexp-column)))
(t
;; Otherwise, align to the first argument of the last lambda-list
;; keyword, the keyword itself, or the beginning of the
;; lambda-list.
(save-excursion
(goto-char indent-point)
(let ((indent nil)
(next t))
(while (and next (> (point) containing-form-start))
(setq next (ignore-errors (backward-sexp) t))
(let* ((col (current-column))
(pos
(save-excursion
(ignore-errors (forward-sexp))
(skip-chars-forward " \t")
(if (eolp)
(+ col sly-lisp-lambda-list-keyword-parameter-indentation)
col))))
(if (looking-at sly--lisp-indent-lambda-list-keywords-regexp)
(setq indent
(if sly-lisp-lambda-list-keyword-parameter-alignment
(or indent pos)
(+ col sly-lisp-lambda-list-keyword-parameter-indentation))
next nil)
(setq indent col))))
(or indent (1+ sexp-column)))))))
(defun sly--lisp-indent-lambda-list-initial-value-form-p (point)
(let ((state 'x)
(point (save-excursion
(goto-char point)
(back-to-indentation)
(point))))
(save-excursion
(backward-sexp)
(ignore-errors (down-list 1))
(while (and point (< (point) point))
(cond ((looking-at "&\\(key\\|optional\\|aux\\)")
(setq state 'key))
((looking-at sly--lisp-indent-lambda-list-keywords-regexp)
(setq state 'x)))
(if (not (ignore-errors (forward-sexp) t))
(setq point nil)
(ignore-errors
(forward-sexp)
(backward-sexp))
(cond ((> (point) point)
(backward-sexp)
(when (eq state 'var)
(setq state 'x))
(or (ignore-errors
(down-list 1)
(cond ((> (point) point)
(backward-up-list))
((eq 'key state)
(setq state 'var)))
t)
(setq point nil)))
((eq state 'var)
(setq state 'form))))))
(eq 'form state)))
;; Blame the crufty control structure on dynamic scoping
;; -- not on me!
(defun sly--lisp-indent-259
(method path state indent-point sexp-column normal-indent)
(catch 'exit
(let* ((p (cdr path))
(containing-form-start (elt state 1))
(n (1- (car path)))
tem tail)
(if (not (consp method))
(sly--lisp-indent-report-bad-format method))
(while n
;; This while loop is for advancing along a method
;; until the relevant (possibly &rest/&body) pattern
;; is reached.
;; n is set to (1- n) and method to (cdr method)
;; each iteration.
(setq tem (car method))
(or (eq tem 'nil) ;default indentation
(eq tem '&lambda) ;lambda list
(and (eq tem '&body) (null (cdr method)))
(and (eq tem '&rest)
(consp (cdr method))
(null (cddr method)))
(integerp tem) ;explicit indentation specified
(and (consp tem) ;destructuring
(or (consp (car tem))
(and (eq (car tem) '&whole)
(or (symbolp (cadr tem))
(integerp (cadr tem))))))
(and (symbolp tem) ;a function to call to do the work.
(null (cdr method)))
(sly--lisp-indent-report-bad-format method))
(cond ((eq tem '&body)
;; &body means (&rest <lisp-body-indent>)
(throw 'exit
(if (null p)
(+ sexp-column lisp-body-indent)
normal-indent)))
((eq tem '&rest)
;; this pattern holds for all remaining forms
(setq tail (> n 0)
n 0
method (cdr method)))
((> n 0)
;; try next element of pattern
(setq n (1- n)
method (cdr method))
(if (< n 0)
;; Too few elements in pattern.
(throw 'exit normal-indent)))
((eq tem 'nil)
(throw 'exit (if (consp normal-indent)
normal-indent
(list normal-indent containing-form-start))))
((eq tem '&lambda)
(throw 'exit
(cond ((not (eq (char-before) ?\)))
;; If it's not a list at all, indent it
;; like body instead.
(if (null p)
(+ sexp-column lisp-body-indent)
normal-indent))
((sly--lisp-indent-lambda-list-initial-value-form-p indent-point)
(if (consp normal-indent)
normal-indent
(list normal-indent containing-form-start)))
((null p)
(list (+ sexp-column 4) containing-form-start))
(t
;; Indentation within a lambda-list. -- dvl
(list (sly--lisp-indent-lambda-list
indent-point
sexp-column
containing-form-start)
containing-form-start)))))
((integerp tem)
(throw 'exit
(if (null p) ;not in subforms
(list (+ sexp-column tem) containing-form-start)
normal-indent)))
((symbolp tem) ;a function to call
(throw 'exit
(funcall tem path state indent-point
sexp-column normal-indent)))
(t
;; must be a destructing frob
(if p
;; descend
(setq method (cddr tem)
n (car p)
p (cdr p)
tail nil)
(let ((wholep (eq '&whole (car tem))))
(setq tem (cadr tem))
(throw 'exit
(cond (tail
(if (and wholep (integerp tem)
(save-excursion
(goto-char indent-point)
(back-to-indentation)
(looking-at "\\sw")))
;; There's a further level of
;; destructuring, but we're looking at a
;; word -- indent to sexp.
(+ sexp-column tem)
normal-indent))
((not tem)
(list normal-indent
containing-form-start))
((integerp tem)
(list (+ sexp-column tem)
containing-form-start))
(t
(funcall tem path state indent-point
sexp-column normal-indent))))))))))))
(defun sly--lisp-indent-tagbody (path state indent-point sexp-column normal-indent)
(if (cdr path)
normal-indent
(save-excursion
(goto-char indent-point)
(back-to-indentation)
(list (cond ((looking-at "\\sw\\|\\s_")
;; a tagbody tag
(+ sexp-column sly-lisp-tag-indentation))
((integerp sly-lisp-tag-body-indentation)
(+ sexp-column sly-lisp-tag-body-indentation))
((eq sly-lisp-tag-body-indentation 't)
(condition-case ()
(progn (backward-sexp 1) (current-column))
(error (1+ sexp-column))))
(t (+ sexp-column lisp-body-indent)))
(nth 1 state)))))
(defun sly--lisp-indent-do (path state indent-point sexp-column normal-indent)
(if (>= (car path) 3)
(let ((sly-lisp-tag-body-indentation lisp-body-indent))
(sly--lisp-indent-tagbody
path state indent-point sexp-column normal-indent))
(sly--lisp-indent-259
'((&whole nil &rest
;; the following causes weird indentation
;;(&whole 1 1 2 nil)
)
(&whole nil &rest 1))
path state indent-point sexp-column normal-indent)))
(defun sly--lisp-indent-defsetf
(path state indent-point sexp-column normal-indent)
(ignore normal-indent)
(let ((form-start (nth 1 state)))
(list
(cond
;; Inside the lambda-list in a long-form defsetf.
((and (eq 2 (car path)) (cdr path))
(sly--lisp-indent-lambda-list indent-point sexp-column form-start))
;; Long form: has a lambda-list.
((or (cdr path)
(save-excursion
(goto-char form-start)
(ignore-errors
(down-list)
(forward-sexp 3)
(backward-sexp)
(looking-at "nil\\|("))))
(+ sexp-column (if (<= 1 (car path) 3) 4 2)))
;; Short form.
(t (+ sexp-column (if (<= 1 (car path) 2) 4 2))))
form-start)))
(defun sly--lisp-indent-beginning-of-defmethod-qualifiers ()
(let ((case-fold-search t)
(regexp "(\\(?:\\(def\\)\\|\\(:\\)\\)method"))
(ignore-errors
(while (not (looking-at regexp)) (backward-up-list))
(cond ((match-string 1)
(forward-char)
;; Skip name.
(forward-sexp 2)
1)
((match-string 2)
(forward-char)
(forward-sexp 1)
0)))))
;; LISP-INDENT-DEFMETHOD now supports the presence of more than one method
;; qualifier and indents the method's lambda list properly. -- dvl
(defun sly--lisp-indent-defmethod
(path state indent-point sexp-column normal-indent)
(sly--lisp-indent-259
(let ((nskip nil))
(if (save-excursion
(when (setq nskip (sly--lisp-indent-beginning-of-defmethod-qualifiers))
(skip-chars-forward " \t\n")
(while (looking-at "\\sw\\|\\s_")
(cl-incf nskip)
(forward-sexp)
(skip-chars-forward " \t\n"))
t))
(nconc (make-list nskip 4) '(&lambda &body))
(sly--lisp-indent-get-indentation 'defun)))
path state indent-point sexp-column normal-indent))
(defun sly--lisp-indent-function-lambda-hack (path state indent-point
sexp-column normal-indent)
(ignore indent-point state)
;; indent (function (lambda () <newline> <body-forms>)) kludgily.
(if (or (cdr path) ; wtf?
(> (car path) 3))
;; line up under previous body form
normal-indent
;; line up under function rather than under lambda in order to
;; conserve horizontal space. (Which is what #' is for.)
(condition-case ()
(save-excursion
(backward-up-list 2)
(forward-char 1)
(if (looking-at "\\(\\(common-lisp\\|cl\\)::?\\)?function\\(\\Sw\\|\\S_\\)")
(+ lisp-body-indent -1 (current-column))
(+ sexp-column lisp-body-indent)))
(error (+ sexp-column lisp-body-indent)))))
(defun sly--lisp-indent-loop (path state indent-point sexp-column normal-indent)
(ignore sexp-column)
(if (cdr path)
normal-indent
(let* ((loop-start (elt state 1))
(type (sly--lisp-indent-loop-type loop-start)))
(cond ((and sly-lisp-loop-indent-subclauses
(memq type '(extended extended/split)))
(list (sly--lisp-indent-loop-macro-1 state indent-point)
(sly--lisp-indent-parse-state-start state)))
(t
(sly--lisp-indent-loop-part-indentation indent-point state type))))))
;;;; LOOP indentation, the complex version -- handles subclause indentation
;; Regexps matching various varieties of loop macro keyword ...
(defvar sly--common-lisp-body-introducing-loop-macro-keyword
(concat "\\(?:\\_<\\|#?:\\)"
(regexp-opt '("do" "doing" "finally" "initially"))
"\\_>")
"Regexp matching loop macro keywords which introduce body forms.")
;; Not currently used
(defvar sly--common-lisp-accumulation-loop-macro-keyword
(concat "\\(?:\\_<\\|#?:\\)"
(regexp-opt '("collect" "collecting"
"append" "appending"
"nconc" "nconcing"
"sum" "summing"
"count" "counting"
"maximize" "maximizing"
"minimize" "minimizing"))
"\\_>")
"Regexp matching loop macro keywords which introduce accumulation clauses.")
;; This is so "and when" and "else when" get handled right
;; (not to mention "else do" !!!)
(defvar sly--common-lisp-prefix-loop-macro-keyword
(concat "\\(?:\\_<\\|#?:\\)" (regexp-opt '("and" "else")) "\\_>")
"Regexp matching loop macro keywords which are prefixes.")
(defvar sly--common-lisp-indent-clause-joining-loop-macro-keyword
"\\(?:\\_<\\|#?:\\)and\\_>"
"Regexp matching 'and', and anything else there ever comes to be like it.")
(defvar sly--common-lisp-indent-indented-loop-macro-keyword
(concat "\\(?:\\_<\\|#?:\\)"
(regexp-opt '("upfrom" "downfrom" "upto" "downto" "below" "above"
"into" "in" "on" "by" "from" "to" "by" "across" "being"
"each" "the" "then" "hash-key" "hash-keys" "hash-value"
"hash-values" "present-symbol" "present-symbols"
"external-symbol" "external-symbols" "using" "symbol"
"symbols" "float" "fixnum" "t" "nil" "of-type" "of" "="))
"\\_>")
"Regexp matching keywords introducing loop subclauses.
Always indented two.")
(defvar sly--common-lisp-indenting-loop-macro-keyword
(concat "\\(?:\\_<\\|#?:\\)" (regexp-opt '("when" "unless" "if")) "\\_>")
"Regexp matching keywords introducing conditional clauses.
Cause subsequent clauses to be indented.")
(defvar sly--lisp-indent-loop-macro-else-keyword
"\\(?:\\_<\\|#?:\\)else\\_>")
;;; Attempt to indent the loop macro ...
(defun sly--lisp-indent-loop-part-indentation (indent-point state type)
"Compute the indentation of loop form constituents."
(let* ((loop-start (nth 1 state))
(loop-indentation (save-excursion
(goto-char loop-start)
(if (eq type 'extended/split)
(- (current-column) 4)
(current-column))))
(indent nil)
(re "\\(\\(#?:\\)?\\sw+\\|)\\|\n\\)"))
(goto-char indent-point)
(back-to-indentation)
(cond ((eq type 'simple/split)
(+ loop-indentation sly-lisp-simple-loop-indentation))
((eq type 'simple)
(+ loop-indentation 6))
;; We are already in a body, with forms in it.
((and (not (looking-at re))
(save-excursion
(while (and (ignore-errors (backward-sexp) t)
(not (looking-at re)))
(setq indent (current-column)))
(and indent
(looking-at sly--common-lisp-body-introducing-loop-macro-keyword))))
(list indent loop-start))
;; Keyword-style or comment outside body
((or sly-lisp-loop-indent-forms-like-keywords
(looking-at re)
(looking-at ";"))
(if (and (looking-at ";")
(let ((p (sly--lisp-indent-trailing-comment)))
(when p
(setq loop-indentation p))))
(list loop-indentation loop-start)
(list (+ loop-indentation 6) loop-start)))
;; Form-style
(t
(list (+ loop-indentation 9) loop-start)))))
(defun sly--lisp-indent-loop-advance-past-keyword-on-line ()
(forward-word 1)
(while (and (looking-at "\\s-") (not (eolp)))
(forward-char 1))
(unless (eolp)
(current-column)))
(defun sly--lisp-indent-loop-macro-1 (parse-state indent-point)
(catch 'return-indentation
(save-excursion
;; Find first clause of loop macro, and use it to establish
;; base column for indentation
(goto-char (sly--lisp-indent-parse-state-start parse-state))
(let ((loop-start-column (current-column)))
(sly--lisp-indent-loop-advance-past-keyword-on-line)
(when (eolp)
(forward-line 1)
(end-of-line)
;; If indenting first line after "(loop <newline>"
;; cop out ...
(if (<= indent-point (point))
(throw 'return-indentation
(+ loop-start-column
sly-lisp-loop-clauses-indentation)))
(back-to-indentation))
(let* ((case-fold-search t)
(loop-macro-first-clause (point))
(previous-expression-start
(sly--lisp-indent-parse-state-prev parse-state))
(default-value (current-column))
(loop-body-p nil)
(loop-body-indentation nil)
(indented-clause-indentation (+ 2 default-value)))
;; Determine context of this loop clause, starting with the
;; expression immediately preceding the line we're trying to indent
(goto-char previous-expression-start)
;; Handle a body-introducing-clause which ends a line specially.
(if (looking-at sly--common-lisp-body-introducing-loop-macro-keyword)
(let ((keyword-position (current-column)))
(setq loop-body-p t)
(setq loop-body-indentation
(if (sly--lisp-indent-loop-advance-past-keyword-on-line)
(current-column)
(back-to-indentation)
(if (/= (current-column) keyword-position)
(+ 2 (current-column))
(+ sly-lisp-loop-body-forms-indentation
(if sly-lisp-loop-indent-body-forms-relative-to-loop-start
loop-start-column
keyword-position))))))
(back-to-indentation)
(if (< (point) loop-macro-first-clause)
(goto-char loop-macro-first-clause))
;; If there's an "and" or "else," advance over it.
;; If it is alone on the line, the next "cond" will treat it
;; as if there were a "when" and indent under it ...
(let ((exit nil))
(while (and (null exit)
(looking-at sly--common-lisp-prefix-loop-macro-keyword))
(if (null (sly--lisp-indent-loop-advance-past-keyword-on-line))
(progn (setq exit t)
(back-to-indentation)))))
;; Found start of loop clause preceding the one we're
;; trying to indent. Glean context ...
(cond
((looking-at "(")
;; We're in the middle of a clause body ...
(setq loop-body-p t)
(setq loop-body-indentation (current-column)))
((looking-at sly--common-lisp-body-introducing-loop-macro-keyword)
(setq loop-body-p t)
;; Know there's something else on the line (or would
;; have been caught above)
(sly--lisp-indent-loop-advance-past-keyword-on-line)
(setq loop-body-indentation (current-column)))
(t
(setq loop-body-p nil)
(if (or (looking-at sly--common-lisp-indenting-loop-macro-keyword)
(looking-at sly--common-lisp-prefix-loop-macro-keyword))
(setq default-value (+ 2 (current-column))))
(setq indented-clause-indentation (+ 2 (current-column)))
;; We still need loop-body-indentation for "syntax errors" ...
(goto-char previous-expression-start)
(setq loop-body-indentation (current-column)))))
;; Go to first non-blank character of the line we're trying
;; to indent. (if none, wind up poised on the new-line ...)
(goto-char indent-point)
(back-to-indentation)
(cond
((looking-at "(")
;; Clause body ...
loop-body-indentation)
((or (eolp) (looking-at ";"))
;; Blank line. If body-p, indent as body, else indent as
;; vanilla clause.
(if loop-body-p
loop-body-indentation
(or (and (looking-at ";") (sly--lisp-indent-trailing-comment))
default-value)))
((looking-at sly--common-lisp-indent-indented-loop-macro-keyword)
indented-clause-indentation)
((looking-at sly--common-lisp-indent-clause-joining-loop-macro-keyword)
(let ((stolen-indent-column nil))
(forward-line -1)
(while (and (null stolen-indent-column)
(> (point) loop-macro-first-clause))
(back-to-indentation)
(if (and (< (current-column) loop-body-indentation)
(looking-at "\\(#?:\\)?\\sw"))
(progn
(if (looking-at sly--lisp-indent-loop-macro-else-keyword)
(sly--lisp-indent-loop-advance-past-keyword-on-line))
(setq stolen-indent-column (current-column)))
(forward-line -1)))
(or stolen-indent-column default-value)))
(t default-value)))))))
(defalias 'sly--lisp-indent-if*-advance-past-keyword-on-line
#'sly--lisp-indent-loop-advance-past-keyword-on-line)
;;;; IF* is not standard, but a plague upon the land
;;;; ...let's at least try to indent it.
(defvar sly--lisp-indent-if*-keyword
"thenret\\|elseif\\|then\\|else"
"Regexp matching if* keywords")
(defun sly--lisp-indent-if*
(path parse-state indent-point sexp-column normal-indent)
(ignore normal-indent path sexp-column)
(list (sly--lisp-indent-if*-1 parse-state indent-point)
(sly--lisp-indent-parse-state-start parse-state)))
(defun sly--lisp-indent-if*-1 (parse-state indent-point)
(catch 'return-indentation
(save-excursion
;; Find first clause of if* macro, and use it to establish
;; base column for indentation
(goto-char (sly--lisp-indent-parse-state-start parse-state))
(let ((if*-start-column (current-column)))
(sly--lisp-indent-if*-advance-past-keyword-on-line)
(let* ((case-fold-search t)
(if*-first-clause (point))
(previous-expression-start
(sly--lisp-indent-parse-state-prev parse-state))
(default-value (current-column))
(if*-body-p nil)
(if*-body-indentation nil))
;; Determine context of this if* clause, starting with the
;; expression immediately preceding the line we're trying to indent
(goto-char previous-expression-start)
;; Handle a body-introducing-clause which ends a line specially.
(back-to-indentation)
(if (< (point) if*-first-clause)
(goto-char if*-first-clause))
;; Found start of if* clause preceding the one we're trying
;; to indent. Glean context ...
(cond
((looking-at sly--lisp-indent-if*-keyword)
(setq if*-body-p t)
;; Know there's something else on the line (or would
;; have been caught above)
(sly--lisp-indent-if*-advance-past-keyword-on-line)
(setq if*-body-indentation (current-column)))
((looking-at "#'\\|'\\|(")
;; We're in the middle of a clause body ...
(setq if*-body-p t)
(setq if*-body-indentation (current-column)))
(t
(setq if*-body-p nil)
;; We still need if*-body-indentation for "syntax errors" ...
(goto-char previous-expression-start)
(setq if*-body-indentation (current-column))))
;; Go to first non-blank character of the line we're trying
;; to indent. (if none, wind up poised on the new-line ...)
(goto-char indent-point)
(back-to-indentation)
(cond
((or (eolp) (looking-at ";"))
;; Blank line. If body-p, indent as body, else indent as
;; vanilla clause.
(if if*-body-p
if*-body-indentation
default-value))
((not (looking-at sly--lisp-indent-if*-keyword))
;; Clause body ...
if*-body-indentation)
(t (- (+ 7 if*-start-column)
(- (match-end 0) (match-beginning 0))))))))))
;;;; Indentation specs for standard symbols, and a few semistandard ones.
(defun sly--lisp-indent-init-standard-indentation ()
(let ((l '((block 1)
(case (4 &rest (&whole 2 &rest 1)))
(ccase (as case))
(ecase (as case))
(typecase (as case))
(etypecase (as case))
(ctypecase (as case))
(catch 1)
(cond (&rest (&whole 2 &rest nil)))
;; for DEFSTRUCT
(:constructor (4 &lambda))
(defvar (4 2 2))
(defclass (6 (&whole 4 &rest 1)
(&whole 2 &rest 1)
(&whole 2 &rest 1)))
(defconstant (as defvar))
(defcustom (4 2 2 2))
(defparameter (as defvar))
(defconst (as defcustom))
(define-condition (as defclass))
(define-modify-macro (4 &lambda &body))
(defsetf sly--lisp-indent-defsetf)
(defun (4 &lambda &body))
(defgeneric (4 &lambda &body))
(define-setf-method (as defun))
(define-setf-expander (as defun))
(defmacro (as defun))
(defsubst (as defun))
(deftype (as defun))
(defmethod sly--lisp-indent-defmethod)
(defpackage (4 2))
(defstruct ((&whole 4 &rest (&whole 2 &rest 1))
&rest (&whole 2 &rest 1)))
(destructuring-bind (&lambda 4 &body))
(do sly--lisp-indent-do)
(do* (as do))
(dolist ((&whole 4 2 1) &body))
(dotimes (as dolist))
(eval-when 1)
(flet ((&whole 4 &rest (&whole 1 4 &lambda &body)) &body))
(labels (as flet))
(macrolet (as flet))
(generic-flet (as flet))
(generic-labels (as flet))
(handler-case (4 &rest (&whole 2 &lambda &body)))
(restart-case (as handler-case))
;; single-else style (then and else equally indented)
(if (&rest nil))
(if* sly--lisp-indent-if*)
(lambda (&lambda &rest sly--lisp-indent-function-lambda-hack))
(let ((&whole 4 &rest (&whole 1 1 2)) &body))
(let* (as let))
(compiler-let (as let))
(handler-bind (as let))
(restart-bind (as let))
(locally 1)
(loop sly--lisp-indent-loop)
(:method sly--lisp-indent-defmethod) ; in `defgeneric'
(multiple-value-bind ((&whole 6 &rest 1) 4 &body))
(multiple-value-call (4 &body))
(multiple-value-prog1 1)
(multiple-value-setq (4 2))
(multiple-value-setf (as multiple-value-setq))
(named-lambda (4 &lambda &rest sly--lisp-indent-function-lambda-hack))
(pprint-logical-block (4 2))
(print-unreadable-object ((&whole 4 1 &rest 1) &body))
;; Combines the worst features of BLOCK, LET and TAGBODY
(prog (&lambda &rest sly--lisp-indent-tagbody))
(prog* (as prog))
(prog1 1)
(prog2 2)
(progn 0)
(progv (4 4 &body))
(return 0)
(return-from (nil &body))
(symbol-macrolet (as let))
(tagbody sly--lisp-indent-tagbody)
(throw 1)
(unless 1)
(unwind-protect (5 &body))
(when 1)
(with-slots (as multiple-value-bind))
(with-accessors (as multiple-value-bind))
(with-condition-restarts (as multiple-value-bind))
(with-compilation-unit ((&whole 4 &rest 1) &body))
(with-output-to-string (4 2))
(with-standard-io-syntax (2)))))
(dolist (el l)
(let* ((name (car el))
(indentation (cadr el)))
(put name 'sly-common-lisp-indent-function indentation)))))
(sly--lisp-indent-init-standard-indentation)
(provide 'sly-cl-indent)
;;; sly-cl-indent.el ends here
;;; sly-buttons.el --- Button-related utils for SLY -*- lexical-binding: t; -*-
;;;
(require 'cl-lib)
(require 'sly-messages "lib/sly-messages")
(defvar sly-part-button-keymap
(let ((map (make-sparse-keymap)))
(set-keymap-parent map button-map)
(define-key map [down-mouse-3] 'sly-button-popup-part-menu)
(define-key map [mouse-3] 'sly-button-popup-part-menu)
(define-key map [mouse-1] 'push-button)
(define-key map [return] 'push-button)
map))
(defvar sly-button-popup-part-menu-keymap
(let ((map (make-sparse-keymap)))
map))
(defun sly-button-popup-part-menu (event)
"Popup a menu for a `sly-part' button"
(interactive "@e")
(let* ((button (button-at (posn-point (event-end event))))
(label (button-get button 'part-label))
(items (cdr (button-get button 'part-menu-keymap))))
(popup-menu
`(keymap
,@(when label
`(,(truncate-string-to-width label 30 nil nil t)))
,@items))))
(defun sly-button-at (&optional pos type no-error)
(let ((button (button-at (or pos
(if (mouse-event-p last-input-event)
(posn-point (event-start last-input-event))
(point))))))
(cond ((and button type
(button-type-subtype-p (button-type button) type))
button)
((and button type)
(unless no-error
(error "[sly] Button at point is not of expected type %s" type)))
(button
button)
(t
(unless no-error
(error "[sly] No button at point"))))))
(defun sly-button-buttons-in (beg end)
(save-excursion
(goto-char (point-min))
(cl-loop for count-current = t then nil
for button = (next-button (point) count-current)
while button
do (goto-char (button-start button))
collect button)))
(defmacro sly-button-define-part-action (action label key)
`(progn
(defun ,action (button)
,(format "%s the object under BUTTON."
label)
(interactive (list (sly-button-at)))
(let ((fn (button-get button ',action))
(args (button-get button 'part-args)))
(if (and
(sly-current-connection)
(eq (button-get button 'sly-connection)
(sly-current-connection)))
(cond ((and fn args)
(apply fn args))
(args
(sly-error "button of type `%s' doesn't implement `%s'"
(button-type button) ',action))
(fn
(sly-error "button %s doesn't have the `part-args' property"
button)))
(sly-error (format "button is from an older connection")))))
,@(when key
`((define-key sly-part-button-keymap ,key
'(menu-item "" ,action
:filter (lambda (cmd)
(let ((button (sly-button-at nil nil 'no-error)))
(and button
(button-get button ',action)
cmd)))))))
(define-key sly-button-popup-part-menu-keymap
[,action] '(menu-item ,label ,action
:visible (let ((button (sly-button-at nil nil 'no-error)))
(and button
(button-get button ',action)))))))
(sly-button-define-part-action sly-button-inspect "Inspect" (kbd "i"))
(sly-button-define-part-action sly-button-describe "Describe" (kbd "d"))
(sly-button-define-part-action sly-button-pretty-print "Pretty Print" (kbd "p"))
(sly-button-define-part-action sly-button-show-source "Show Source" (kbd "v"))
(sly-button-define-part-action sly-button-goto-source "Go To Source" (kbd "."))
(defun sly--make-text-button (beg end &rest properties)
"Just like `make-text-button', but add sly-specifics."
(apply #'make-text-button beg end
'sly-connection (sly-current-connection)
properties))
(defun sly-make-action-button (label action &rest props)
(apply #'sly--make-text-button
label nil :type 'sly-action
'action action
'mouse-action action
props))
(defface sly-action-face
`((t (:inherit warning)))
"Face for SLY buttons."
:group 'sly)
(define-button-type 'sly-button
'sly-button-search-id 'regular-button)
(define-button-type 'sly-action :supertype 'sly-button
'face 'sly-action-face
'mouse-face 'highlight
'sly-button-echo 'sly-button-echo-button)
(defface sly-part-button-face
'((t (:inherit font-lock-constant-face)))
"Face for things which be interactively inspected, etc"
:group 'sly)
(define-button-type 'sly-part :supertype 'sly-button
'face 'sly-part-button-face
'action 'sly-button-inspect
'mouse-action 'sly-button-inspect
'keymap sly-part-button-keymap
'sly-button-echo 'sly-button-echo-part
'part-menu-keymap sly-button-popup-part-menu-keymap
'help-echo "RET, mouse-2: Inspect object; mouse-3: Context menu"
;; these are ajust here for clarity
;;
'sly-button-inspect nil
'sly-button-describe nil
'sly-button-pretty-print nil
'sly-button-show-source nil)
(cl-defun sly-button-flash (button &key
(face 'highlight)
(pattern '(0.07 0.07 0.07 0.07))
times
timeout)
(sly-flash-region (button-start button) (button-end button)
:timeout timeout
:pattern pattern
:times times
:face face))
(defun sly-button-echo-button (button) (sly-message "A sly button"))
(defun sly-button-echo-part (button)
(sly-button-flash button)
(sly-message (button-get button 'part-label)))
;;; Overlay-button specifics
;;;
(defun sly-button--overlays-in (beg end &optional filter)
"Return overlays overlapping positions BEG and END"
(cl-remove-if-not #'(lambda (button)
(and
;; Workaround fragility in Emacs' buttons:
;; `button-type-subtype-p' errors when
;; `button' is not actually a button. A
;; straightforward predicate for this doesn't
;; seem to exist yet.
(ignore-errors
(button-type-subtype-p (button-type button) 'sly-button))
(or (not filter)
(funcall filter button))))
(overlays-in beg end)))
(defun sly-button--overlays-between (beg end &optional filter)
"Return overlays contained entirely between BEG and END"
(cl-remove-if-not #'(lambda (button)
(and (>= (button-start button) beg)
(<= (button-end button) end)))
(sly-button--overlays-in beg end filter)))
(defun sly-button--overlays-exactly-at (beg end &optional filter)
"Return overlays exactly between BEG and END"
(cl-remove-if-not #'(lambda (button)
(and (= (button-start button) beg)
(= (button-end button) end)))
(sly-button--overlays-in beg end filter)))
(defun sly-button--overlays-at (&optional point filter)
"Return overlays near POINT"
(let ((point (or point (point))))
(cl-sort (sly-button--overlays-in (1- point) (1+ point) filter)
#'> :key #'sly-button--level)))
(gv-define-setter sly-button--level (level button)
`(overlay-put ,button 'sly-button-level ,level))
(defun sly-button--level (button)
(or (overlay-get button 'sly-button-level) 0))
;;; Button navigation
;;;
(defvar sly-button--next-search-id 0)
(defun sly-button-next-search-id ()
(cl-incf sly-button--next-search-id))
(defun sly-button--searchable-buttons-at (pos filter)
(let* ((probe (sly-button-at pos 'sly-button 'no-error))
(non-overlay-button (and probe
(not (overlayp probe))
probe)))
(cl-remove-duplicates
(append (sly-button--overlays-at pos filter)
(if (and non-overlay-button
(or (not filter)
(funcall filter non-overlay-button)))
(list non-overlay-button))))))
(defun sly-button--searchable-buttons-starting-at (&optional point filter)
(let ((point (or point (point))))
(cl-remove-if-not #'(lambda (button)
(= (button-start button) point))
(sly-button--searchable-buttons-at point filter))))
(defun sly-button--search-1 (n filter)
(cl-loop with off-by-one = (if (cl-plusp n) -1 +1)
for search-start = (point) then pos
for preval = (and (not (cond ((cl-plusp n)
(= search-start (point-min)))
(t
(= search-start (point-max)))))
(get-char-property (+ off-by-one
search-start)
'sly-button-search-id))
for pos = (funcall
(if (cl-plusp n)
#'next-single-char-property-change
#'previous-single-char-property-change)
search-start
'sly-button-search-id)
for newval = (get-char-property pos 'sly-button-search-id)
until (cond ((cl-plusp n)
(= pos (point-max)))
(t
(= pos (point-min))))
for buttons = (sly-button--searchable-buttons-at
pos (or filter #'identity))
when (and buttons
newval
(not (eq newval preval))
(eq pos (button-start (car buttons))))
return buttons))
(put 'sly-button-forward 'sly-button-navigation-command t)
(put 'sly-button-backward 'sly-button-navigation-command t)
(defun sly-button-search (n &optional filter)
"Go forward to Nth buttons verifying FILTER and echo it.
With negative N, go backward. Visiting is done via the
`sly-button-echo' property.
If more than one button overlap the same region, the button
starting before is visited first. If more than one button start
at exactly the same spot, they are both visited simultaneously,
`sly-button-echo' being passed a variable number of button arguments."
(cl-loop for i from 0 below (abs n)
for buttons =
(or (and (not (and
;; (symbolp last-command)
(get last-command 'sly-button-navigation-command)))
(sly-button--searchable-buttons-starting-at (point) filter))
(sly-button--search-1 n filter))
for button = (car buttons)
while buttons
finally
(cond (buttons
(goto-char (button-start (car buttons)))
(apply (button-get button 'sly-button-echo)
button
(cl-remove-if-not
#'(lambda (b)
(= (button-start b) (button-start button)))
(cdr buttons))))
(t
(sly-user-error "No more buttons!")))))
(defvar sly-button-filter-function #'identity
"Filter buttons considered by `sly-button-forward'
Set to `sly-note-button-p' to only navigate compilation notes,
or leave at `identity' to visit every `sly-button' in the buffer.'")
(defun sly-button-forward (n)
"Go to and describe the next button in the buffer."
(interactive "p")
(sly-button-search n sly-button-filter-function))
(defun sly-button-backward (n)
"Go to and describe the previous button in the buffer."
(interactive "p")
(sly-button-forward (- n)))
(define-minor-mode sly-interactive-buttons-mode
"Minor mode where text property SLY buttons exist"
nil nil nil
;; Prevent strings copied from SLY buffers and yanked to source
;; buffers to land with misleading `sly-' properties.
(when (fboundp 'add-function)
(add-function :filter-return (local 'filter-buffer-substring-function)
#'substring-no-properties
'((name . sly-remove-string-properties)))))
(provide 'sly-buttons)
;;; sly-buttons.el ends here
;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec -*- lexical-binding: t; -*-
;; Copyright 1997 Naggum Software
;; Author: Erik Naggum <erik@naggum.no>
;; Keywords: lisp
;; This file is not part of GNU Emacs, but distributed under the same
;; conditions as GNU Emacs, and is useless without GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Kent Pitman and Xanalys Inc. have made the text of American National
;; Standard for Information Technology -- Programming Language -- Common
;; Lisp, ANSI X3.226-1994 available on the WWW, in the form of the Common
;; Lisp HyperSpec. This package makes it convenient to peruse this
;; documentation from within Emacs.
;;; Code:
(require 'cl-lib nil t)
(require 'cl-lib "lib/cl-lib")
(require 'browse-url) ;you need the Emacs 20 version
(require 'thingatpt)
(defvar common-lisp-hyperspec-root
"http://www.lispworks.com/reference/HyperSpec/"
"The root of the Common Lisp HyperSpec URL.
If you copy the HyperSpec to your local system, set this variable to
something like \"file://usr/local/doc/HyperSpec/\".")
;;; Added variable for CLHS symbol table. See details below.
;;;
;;; 20011201 Edi Weitz
(defvar common-lisp-hyperspec-symbol-table nil
"The HyperSpec symbol table file.
If you copy the HyperSpec to your local system, set this variable to
the location of the symbol table which is usually \"Map_Sym.txt\"
or \"Symbol-Table.text\".")
(defvar common-lisp-hyperspec-history nil
"History of symbols looked up in the Common Lisp HyperSpec.")
(defvar common-lisp-hyperspec--symbols (make-hash-table :test 'equal)
"Map a symbol name to its list of relative URLs.")
;; Lookup NAME in 'common-lisp-hyperspec--symbols´
(defun common-lisp-hyperspec--find (name)
"Get the relative url of a Common Lisp symbol NAME."
(gethash name common-lisp-hyperspec--symbols))
(defun common-lisp-hyperspec--insert (name relative-url)
"Insert CL symbol NAME and RELATIVE-URL into master table."
(cl-pushnew relative-url
(gethash name common-lisp-hyperspec--symbols)
:test #'equal))
(defun common-lisp-hyperspec--strip-cl-package (name)
(if (string-match "^\\([^:]*\\)::?\\([^:]*\\)$" name)
(let ((package-name (match-string 1 name))
(symbol-name (match-string 2 name)))
(if (member (downcase package-name)
'("cl" "common-lisp"))
symbol-name
name))
name))
;; Choose the symbol at point or read symbol-name from the minibuffer.
(defun common-lisp-hyperspec-read-symbol-name (&optional symbol-at-point)
(let* ((symbol-at-point (or symbol-at-point (thing-at-point 'symbol)))
(stripped-symbol (and symbol-at-point
(common-lisp-hyperspec--strip-cl-package
(downcase symbol-at-point)))))
(cond ((and stripped-symbol
(common-lisp-hyperspec--find stripped-symbol))
stripped-symbol)
(t
(completing-read "Look up symbol in Common Lisp HyperSpec: "
common-lisp-hyperspec--symbols nil t
stripped-symbol
'common-lisp-hyperspec-history)))))
;; FIXME: is the (sleep-for 1.5) a actually needed?
(defun common-lisp-hyperspec (symbol-name)
"View the documentation on SYMBOL-NAME from the Common Lisp HyperSpec.
If SYMBOL-NAME has more than one definition, all of them are displayed with
your favorite browser in sequence. The browser should have a \"back\"
function to view the separate definitions.
The Common Lisp HyperSpec is the full ANSI Standard Common Lisp, provided
by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is
visited to retrieve the information. Xanalys Inc. allows you to transfer
the entire Common Lisp HyperSpec to your own site under certain conditions.
Visit http://www.lispworks.com/reference/HyperSpec/ for more information.
If you copy the HyperSpec to another location, customize the variable
`common-lisp-hyperspec-root' to point to that location."
(interactive (list (common-lisp-hyperspec-read-symbol-name)))
(let ((name (common-lisp-hyperspec--strip-cl-package
(downcase symbol-name))))
(cl-maplist (lambda (entry)
(browse-url (concat common-lisp-hyperspec-root "Body/"
(car entry)))
(when (cdr entry)
(sleep-for 1.5)))
(or (common-lisp-hyperspec--find name)
(error "The symbol `%s' is not defined in Common Lisp"
symbol-name)))))
;;; Added dynamic lookup of symbol in CLHS symbol table
;;;
;;; 20011202 Edi Weitz
;;; Replaced symbol table for v 4.0 with the one for v 6.0
;;; (which is now online at Xanalys' site)
;;;
;;; 20020213 Edi Weitz
(defun common-lisp-hyperspec--get-one-line ()
(prog1
(cl-delete ?\n (thing-at-point 'line))
(forward-line)))
(defun common-lisp-hyperspec--parse-map-file (file)
(with-current-buffer (find-file-noselect file)
(goto-char (point-min))
(let ((result '()))
(while (< (point) (point-max))
(let* ((symbol-name (downcase (common-lisp-hyperspec--get-one-line)))
(relative-url (common-lisp-hyperspec--get-one-line))
(file (file-name-nondirectory relative-url)))
(push (list symbol-name file)
result)))
(reverse result))))
(mapc (lambda (entry)
(common-lisp-hyperspec--insert (car entry) (cadr entry)))
(if common-lisp-hyperspec-symbol-table
(common-lisp-hyperspec--parse-map-file
common-lisp-hyperspec-symbol-table)
'(("&allow-other-keys" "03_da.htm")
("&aux" "03_da.htm")
("&body" "03_dd.htm")
("&environment" "03_dd.htm")
("&key" "03_da.htm")
("&optional" "03_da.htm")
("&rest" "03_da.htm")
("&whole" "03_dd.htm")
("*" "a_st.htm")
("**" "v__stst_.htm")
("***" "v__stst_.htm")
("*break-on-signals*" "v_break_.htm")
("*compile-file-pathname*" "v_cmp_fi.htm")
("*compile-file-truename*" "v_cmp_fi.htm")
("*compile-print*" "v_cmp_pr.htm")
("*compile-verbose*" "v_cmp_pr.htm")
("*debug-io*" "v_debug_.htm")
("*debugger-hook*" "v_debugg.htm")
("*default-pathname-defaults*" "v_defaul.htm")
("*error-output*" "v_debug_.htm")
("*features*" "v_featur.htm")
("*gensym-counter*" "v_gensym.htm")
("*load-pathname*" "v_ld_pns.htm")
("*load-print*" "v_ld_prs.htm")
("*load-truename*" "v_ld_pns.htm")
("*load-verbose*" "v_ld_prs.htm")
("*macroexpand-hook*" "v_mexp_h.htm")
("*modules*" "v_module.htm")
("*package*" "v_pkg.htm")
("*print-array*" "v_pr_ar.htm")
("*print-base*" "v_pr_bas.htm")
("*print-case*" "v_pr_cas.htm")
("*print-circle*" "v_pr_cir.htm")
("*print-escape*" "v_pr_esc.htm")
("*print-gensym*" "v_pr_gen.htm")
("*print-length*" "v_pr_lev.htm")
("*print-level*" "v_pr_lev.htm")
("*print-lines*" "v_pr_lin.htm")
("*print-miser-width*" "v_pr_mis.htm")
("*print-pprint-dispatch*" "v_pr_ppr.htm")
("*print-pretty*" "v_pr_pre.htm")
("*print-radix*" "v_pr_bas.htm")
("*print-readably*" "v_pr_rda.htm")
("*print-right-margin*" "v_pr_rig.htm")
("*query-io*" "v_debug_.htm")
("*random-state*" "v_rnd_st.htm")
("*read-base*" "v_rd_bas.htm")
("*read-default-float-format*" "v_rd_def.htm")
("*read-eval*" "v_rd_eva.htm")
("*read-suppress*" "v_rd_sup.htm")
("*readtable*" "v_rdtabl.htm")
("*standard-input*" "v_debug_.htm")
("*standard-output*" "v_debug_.htm")
("*terminal-io*" "v_termin.htm")
("*trace-output*" "v_debug_.htm")
("+" "a_pl.htm")
("++" "v_pl_plp.htm")
("+++" "v_pl_plp.htm")
("-" "a__.htm")
("/" "a_sl.htm")
("//" "v_sl_sls.htm")
("///" "v_sl_sls.htm")
("/=" "f_eq_sle.htm")
("1+" "f_1pl_1_.htm")
("1-" "f_1pl_1_.htm")
("<" "f_eq_sle.htm")
("<=" "f_eq_sle.htm")
("=" "f_eq_sle.htm")
(">" "f_eq_sle.htm")
(">=" "f_eq_sle.htm")
("abort" "a_abort.htm")
("abs" "f_abs.htm")
("acons" "f_acons.htm")
("acos" "f_asin_.htm")
("acosh" "f_sinh_.htm")
("add-method" "f_add_me.htm")
("adjoin" "f_adjoin.htm")
("adjust-array" "f_adjust.htm")
("adjustable-array-p" "f_adju_1.htm")
("allocate-instance" "f_alloca.htm")
("alpha-char-p" "f_alpha_.htm")
("alphanumericp" "f_alphan.htm")
("and" "a_and.htm")
("append" "f_append.htm")
("apply" "f_apply.htm")
("apropos" "f_apropo.htm")
("apropos-list" "f_apropo.htm")
("aref" "f_aref.htm")
("arithmetic-error" "e_arithm.htm")
("arithmetic-error-operands" "f_arithm.htm")
("arithmetic-error-operation" "f_arithm.htm")
("array" "t_array.htm")
("array-dimension" "f_ar_dim.htm")
("array-dimension-limit" "v_ar_dim.htm")
("array-dimensions" "f_ar_d_1.htm")
("array-displacement" "f_ar_dis.htm")
("array-element-type" "f_ar_ele.htm")
("array-has-fill-pointer-p" "f_ar_has.htm")
("array-in-bounds-p" "f_ar_in_.htm")
("array-rank" "f_ar_ran.htm")
("array-rank-limit" "v_ar_ran.htm")
("array-row-major-index" "f_ar_row.htm")
("array-total-size" "f_ar_tot.htm")
("array-total-size-limit" "v_ar_tot.htm")
("arrayp" "f_arrayp.htm")
("ash" "f_ash.htm")
("asin" "f_asin_.htm")
("asinh" "f_sinh_.htm")
("assert" "m_assert.htm")
("assoc" "f_assocc.htm")
("assoc-if" "f_assocc.htm")
("assoc-if-not" "f_assocc.htm")
("atan" "f_asin_.htm")
("atanh" "f_sinh_.htm")
("atom" "a_atom.htm")
("base-char" "t_base_c.htm")
("base-string" "t_base_s.htm")
("bignum" "t_bignum.htm")
("bit" "a_bit.htm")
("bit-and" "f_bt_and.htm")
("bit-andc1" "f_bt_and.htm")
("bit-andc2" "f_bt_and.htm")
("bit-eqv" "f_bt_and.htm")
("bit-ior" "f_bt_and.htm")
("bit-nand" "f_bt_and.htm")
("bit-nor" "f_bt_and.htm")
("bit-not" "f_bt_and.htm")
("bit-orc1" "f_bt_and.htm")
("bit-orc2" "f_bt_and.htm")
("bit-vector" "t_bt_vec.htm")
("bit-vector-p" "f_bt_vec.htm")
("bit-xor" "f_bt_and.htm")
("block" "s_block.htm")
("boole" "f_boole.htm")
("boole-1" "v_b_1_b.htm")
("boole-2" "v_b_1_b.htm")
("boole-and" "v_b_1_b.htm")
("boole-andc1" "v_b_1_b.htm")
("boole-andc2" "v_b_1_b.htm")
("boole-c1" "v_b_1_b.htm")
("boole-c2" "v_b_1_b.htm")
("boole-clr" "v_b_1_b.htm")
("boole-eqv" "v_b_1_b.htm")
("boole-ior" "v_b_1_b.htm")
("boole-nand" "v_b_1_b.htm")
("boole-nor" "v_b_1_b.htm")
("boole-orc1" "v_b_1_b.htm")
("boole-orc2" "v_b_1_b.htm")
("boole-set" "v_b_1_b.htm")
("boole-xor" "v_b_1_b.htm")
("boolean" "t_ban.htm")
("both-case-p" "f_upper_.htm")
("boundp" "f_boundp.htm")
("break" "f_break.htm")
("broadcast-stream" "t_broadc.htm")
("broadcast-stream-streams" "f_broadc.htm")
("built-in-class" "t_built_.htm")
("butlast" "f_butlas.htm")
("byte" "f_by_by.htm")
("byte-position" "f_by_by.htm")
("byte-size" "f_by_by.htm")
("caaaar" "f_car_c.htm")
("caaadr" "f_car_c.htm")
("caaar" "f_car_c.htm")
("caadar" "f_car_c.htm")
("caaddr" "f_car_c.htm")
("caadr" "f_car_c.htm")
("caar" "f_car_c.htm")
("cadaar" "f_car_c.htm")
("cadadr" "f_car_c.htm")
("cadar" "f_car_c.htm")
("caddar" "f_car_c.htm")
("cadddr" "f_car_c.htm")
("caddr" "f_car_c.htm")
("cadr" "f_car_c.htm")
("call-arguments-limit" "v_call_a.htm")
("call-method" "m_call_m.htm")
("call-next-method" "f_call_n.htm")
("car" "f_car_c.htm")
("case" "m_case_.htm")
("catch" "s_catch.htm")
("ccase" "m_case_.htm")
("cdaaar" "f_car_c.htm")
("cdaadr" "f_car_c.htm")
("cdaar" "f_car_c.htm")
("cdadar" "f_car_c.htm")
("cdaddr" "f_car_c.htm")
("cdadr" "f_car_c.htm")
("cdar" "f_car_c.htm")
("cddaar" "f_car_c.htm")
("cddadr" "f_car_c.htm")
("cddar" "f_car_c.htm")
("cdddar" "f_car_c.htm")
("cddddr" "f_car_c.htm")
("cdddr" "f_car_c.htm")
("cddr" "f_car_c.htm")
("cdr" "f_car_c.htm")
("ceiling" "f_floorc.htm")
("cell-error" "e_cell_e.htm")
("cell-error-name" "f_cell_e.htm")
("cerror" "f_cerror.htm")
("change-class" "f_chg_cl.htm")
("char" "f_char_.htm")
("char-code" "f_char_c.htm")
("char-code-limit" "v_char_c.htm")
("char-downcase" "f_char_u.htm")
("char-equal" "f_chareq.htm")
("char-greaterp" "f_chareq.htm")
("char-int" "f_char_i.htm")
("char-lessp" "f_chareq.htm")
("char-name" "f_char_n.htm")
("char-not-equal" "f_chareq.htm")
("char-not-greaterp" "f_chareq.htm")
("char-not-lessp" "f_chareq.htm")
("char-upcase" "f_char_u.htm")
("char/=" "f_chareq.htm")
("char<" "f_chareq.htm")
("char<=" "f_chareq.htm")
("char=" "f_chareq.htm")
("char>" "f_chareq.htm")
("char>=" "f_chareq.htm")
("character" "a_ch.htm")
("characterp" "f_chp.htm")
("check-type" "m_check_.htm")
("cis" "f_cis.htm")
("class" "t_class.htm")
("class-name" "f_class_.htm")
("class-of" "f_clas_1.htm")
("clear-input" "f_clear_.htm")
("clear-output" "f_finish.htm")
("close" "f_close.htm")
("clrhash" "f_clrhas.htm")
("code-char" "f_code_c.htm")
("coerce" "f_coerce.htm")
("compilation-speed" "d_optimi.htm")
("compile" "f_cmp.htm")
("compile-file" "f_cmp_fi.htm")
("compile-file-pathname" "f_cmp__1.htm")
("compiled-function" "t_cmpd_f.htm")
("compiled-function-p" "f_cmpd_f.htm")
("compiler-macro" "f_docume.htm")
("compiler-macro-function" "f_cmp_ma.htm")
("complement" "f_comple.htm")
("complex" "a_comple.htm")
("complexp" "f_comp_3.htm")
("compute-applicable-methods" "f_comput.htm")
("compute-restarts" "f_comp_1.htm")
("concatenate" "f_concat.htm")
("concatenated-stream" "t_concat.htm")
("concatenated-stream-streams" "f_conc_1.htm")
("cond" "m_cond.htm")
("condition" "e_cnd.htm")
("conjugate" "f_conjug.htm")
("cons" "a_cons.htm")
("consp" "f_consp.htm")
("constantly" "f_cons_1.htm")
("constantp" "f_consta.htm")
("continue" "a_contin.htm")
("control-error" "e_contro.htm")
("copy-alist" "f_cp_ali.htm")
("copy-list" "f_cp_lis.htm")
("copy-pprint-dispatch" "f_cp_ppr.htm")
("copy-readtable" "f_cp_rdt.htm")
("copy-seq" "f_cp_seq.htm")
("copy-structure" "f_cp_stu.htm")
("copy-symbol" "f_cp_sym.htm")
("copy-tree" "f_cp_tre.htm")
("cos" "f_sin_c.htm")
("cosh" "f_sinh_.htm")
("count" "f_countc.htm")
("count-if" "f_countc.htm")
("count-if-not" "f_countc.htm")
("ctypecase" "m_tpcase.htm")
("debug" "d_optimi.htm")
("decf" "m_incf_.htm")
("declaim" "m_declai.htm")
("declaration" "d_declar.htm")
("declare" "s_declar.htm")
("decode-float" "f_dec_fl.htm")
("decode-universal-time" "f_dec_un.htm")
("defclass" "m_defcla.htm")
("defconstant" "m_defcon.htm")
("defgeneric" "m_defgen.htm")
("define-compiler-macro" "m_define.htm")
("define-condition" "m_defi_5.htm")
("define-method-combination" "m_defi_4.htm")
("define-modify-macro" "m_defi_2.htm")
("define-setf-expander" "m_defi_3.htm")
("define-symbol-macro" "m_defi_1.htm")
("defmacro" "m_defmac.htm")
("defmethod" "m_defmet.htm")
("defpackage" "m_defpkg.htm")
("defparameter" "m_defpar.htm")
("defsetf" "m_defset.htm")
("defstruct" "m_defstr.htm")
("deftype" "m_deftp.htm")
("defun" "m_defun.htm")
("defvar" "m_defpar.htm")
("delete" "f_rm_rm.htm")
("delete-duplicates" "f_rm_dup.htm")
("delete-file" "f_del_fi.htm")
("delete-if" "f_rm_rm.htm")
("delete-if-not" "f_rm_rm.htm")
("delete-package" "f_del_pk.htm")
("denominator" "f_numera.htm")
("deposit-field" "f_deposi.htm")
("describe" "f_descri.htm")
("describe-object" "f_desc_1.htm")
("destructuring-bind" "m_destru.htm")
("digit-char" "f_digit_.htm")
("digit-char-p" "f_digi_1.htm")
("directory" "f_dir.htm")
("directory-namestring" "f_namest.htm")
("disassemble" "f_disass.htm")
("division-by-zero" "e_divisi.htm")
("do" "m_do_do.htm")
("do*" "m_do_do.htm")
("do-all-symbols" "m_do_sym.htm")
("do-external-symbols" "m_do_sym.htm")
("do-symbols" "m_do_sym.htm")
("documentation" "f_docume.htm")
("dolist" "m_dolist.htm")
("dotimes" "m_dotime.htm")
("double-float" "t_short_.htm")
("double-float-epsilon" "v_short_.htm")
("double-float-negative-epsilon" "v_short_.htm")
("dpb" "f_dpb.htm")
("dribble" "f_dribbl.htm")
("dynamic-extent" "d_dynami.htm")
("ecase" "m_case_.htm")
("echo-stream" "t_echo_s.htm")
("echo-stream-input-stream" "f_echo_s.htm")
("echo-stream-output-stream" "f_echo_s.htm")
("ed" "f_ed.htm")
("eighth" "f_firstc.htm")
("elt" "f_elt.htm")
("encode-universal-time" "f_encode.htm")
("end-of-file" "e_end_of.htm")
("endp" "f_endp.htm")
("enough-namestring" "f_namest.htm")
("ensure-directories-exist" "f_ensu_1.htm")
("ensure-generic-function" "f_ensure.htm")
("eq" "f_eq.htm")
("eql" "a_eql.htm")
("equal" "f_equal.htm")
("equalp" "f_equalp.htm")
("error" "a_error.htm")
("etypecase" "m_tpcase.htm")
("eval" "f_eval.htm")
("eval-when" "s_eval_w.htm")
("evenp" "f_evenpc.htm")
("every" "f_everyc.htm")
("exp" "f_exp_e.htm")
("export" "f_export.htm")
("expt" "f_exp_e.htm")
("extended-char" "t_extend.htm")
("fboundp" "f_fbound.htm")
("fceiling" "f_floorc.htm")
("fdefinition" "f_fdefin.htm")
("ffloor" "f_floorc.htm")
("fifth" "f_firstc.htm")
("file-author" "f_file_a.htm")
("file-error" "e_file_e.htm")
("file-error-pathname" "f_file_e.htm")
("file-length" "f_file_l.htm")
("file-namestring" "f_namest.htm")
("file-position" "f_file_p.htm")
("file-stream" "t_file_s.htm")
("file-string-length" "f_file_s.htm")
("file-write-date" "f_file_w.htm")
("fill" "f_fill.htm")
("fill-pointer" "f_fill_p.htm")
("find" "f_find_.htm")
("find-all-symbols" "f_find_a.htm")
("find-class" "f_find_c.htm")
("find-if" "f_find_.htm")
("find-if-not" "f_find_.htm")
("find-method" "f_find_m.htm")
("find-package" "f_find_p.htm")
("find-restart" "f_find_r.htm")
("find-symbol" "f_find_s.htm")
("finish-output" "f_finish.htm")
("first" "f_firstc.htm")
("fixnum" "t_fixnum.htm")
("flet" "s_flet_.htm")
("float" "a_float.htm")
("float-digits" "f_dec_fl.htm")
("float-precision" "f_dec_fl.htm")
("float-radix" "f_dec_fl.htm")
("float-sign" "f_dec_fl.htm")
("floating-point-inexact" "e_floa_1.htm")
("floating-point-invalid-operation" "e_floati.htm")
("floating-point-overflow" "e_floa_2.htm")
("floating-point-underflow" "e_floa_3.htm")
("floatp" "f_floatp.htm")
("floor" "f_floorc.htm")
("fmakunbound" "f_fmakun.htm")
("force-output" "f_finish.htm")
("format" "f_format.htm")
("formatter" "m_format.htm")
("fourth" "f_firstc.htm")
("fresh-line" "f_terpri.htm")
("fround" "f_floorc.htm")
("ftruncate" "f_floorc.htm")
("ftype" "d_ftype.htm")
("funcall" "f_funcal.htm")
("function" "a_fn.htm")
("function-keywords" "f_fn_kwd.htm")
("function-lambda-expression" "f_fn_lam.htm")
("functionp" "f_fnp.htm")
("gcd" "f_gcd.htm")
("generic-function" "t_generi.htm")
("gensym" "f_gensym.htm")
("gentemp" "f_gentem.htm")
("get" "f_get.htm")
("get-decoded-time" "f_get_un.htm")
("get-dispatch-macro-character" "f_set__1.htm")
("get-internal-real-time" "f_get_in.htm")
("get-internal-run-time" "f_get__1.htm")
("get-macro-character" "f_set_ma.htm")
("get-output-stream-string" "f_get_ou.htm")
("get-properties" "f_get_pr.htm")
("get-setf-expansion" "f_get_se.htm")
("get-universal-time" "f_get_un.htm")
("getf" "f_getf.htm")
("gethash" "f_gethas.htm")
("go" "s_go.htm")
("graphic-char-p" "f_graphi.htm")
("handler-bind" "m_handle.htm")
("handler-case" "m_hand_1.htm")
("hash-table" "t_hash_t.htm")
("hash-table-count" "f_hash_1.htm")
("hash-table-p" "f_hash_t.htm")
("hash-table-rehash-size" "f_hash_2.htm")
("hash-table-rehash-threshold" "f_hash_3.htm")
("hash-table-size" "f_hash_4.htm")
("hash-table-test" "f_hash_5.htm")
("host-namestring" "f_namest.htm")
("identity" "f_identi.htm")
("if" "s_if.htm")
("ignorable" "d_ignore.htm")
("ignore" "d_ignore.htm")
("ignore-errors" "m_ignore.htm")
("imagpart" "f_realpa.htm")
("import" "f_import.htm")
("in-package" "m_in_pkg.htm")
("incf" "m_incf_.htm")
("initialize-instance" "f_init_i.htm")
("inline" "d_inline.htm")
("input-stream-p" "f_in_stm.htm")
("inspect" "f_inspec.htm")
("integer" "t_intege.htm")
("integer-decode-float" "f_dec_fl.htm")
("integer-length" "f_intege.htm")
("integerp" "f_inte_1.htm")
("interactive-stream-p" "f_intera.htm")
("intern" "f_intern.htm")
("internal-time-units-per-second" "v_intern.htm")
("intersection" "f_isec_.htm")
("invalid-method-error" "f_invali.htm")
("invoke-debugger" "f_invoke.htm")
("invoke-restart" "f_invo_1.htm")
("invoke-restart-interactively" "f_invo_2.htm")
("isqrt" "f_sqrt_.htm")
("keyword" "t_kwd.htm")
("keywordp" "f_kwdp.htm")
("labels" "s_flet_.htm")
("lambda" "a_lambda.htm")
("lambda-list-keywords" "v_lambda.htm")
("lambda-parameters-limit" "v_lamb_1.htm")
("last" "f_last.htm")
("lcm" "f_lcm.htm")
("ldb" "f_ldb.htm")
("ldb-test" "f_ldb_te.htm")
("ldiff" "f_ldiffc.htm")
("least-negative-double-float" "v_most_1.htm")
("least-negative-long-float" "v_most_1.htm")
("least-negative-normalized-double-float" "v_most_1.htm")
("least-negative-normalized-long-float" "v_most_1.htm")
("least-negative-normalized-short-float" "v_most_1.htm")
("least-negative-normalized-single-float" "v_most_1.htm")
("least-negative-short-float" "v_most_1.htm")
("least-negative-single-float" "v_most_1.htm")
("least-positive-double-float" "v_most_1.htm")
("least-positive-long-float" "v_most_1.htm")
("least-positive-normalized-double-float" "v_most_1.htm")
("least-positive-normalized-long-float" "v_most_1.htm")
("least-positive-normalized-short-float" "v_most_1.htm")
("least-positive-normalized-single-float" "v_most_1.htm")
("least-positive-short-float" "v_most_1.htm")
("least-positive-single-float" "v_most_1.htm")
("length" "f_length.htm")
("let" "s_let_l.htm")
("let*" "s_let_l.htm")
("lisp-implementation-type" "f_lisp_i.htm")
("lisp-implementation-version" "f_lisp_i.htm")
("list" "a_list.htm")
("list*" "f_list_.htm")
("list-all-packages" "f_list_a.htm")
("list-length" "f_list_l.htm")
("listen" "f_listen.htm")
("listp" "f_listp.htm")
("load" "f_load.htm")
("load-logical-pathname-translations" "f_ld_log.htm")
("load-time-value" "s_ld_tim.htm")
("locally" "s_locall.htm")
("log" "f_log.htm")
("logand" "f_logand.htm")
("logandc1" "f_logand.htm")
("logandc2" "f_logand.htm")
("logbitp" "f_logbtp.htm")
("logcount" "f_logcou.htm")
("logeqv" "f_logand.htm")
("logical-pathname" "a_logica.htm")
("logical-pathname-translations" "f_logica.htm")
("logior" "f_logand.htm")
("lognand" "f_logand.htm")
("lognor" "f_logand.htm")
("lognot" "f_logand.htm")
("logorc1" "f_logand.htm")
("logorc2" "f_logand.htm")
("logtest" "f_logtes.htm")
("logxor" "f_logand.htm")
("long-float" "t_short_.htm")
("long-float-epsilon" "v_short_.htm")
("long-float-negative-epsilon" "v_short_.htm")
("long-site-name" "f_short_.htm")
("loop" "m_loop.htm")
("loop-finish" "m_loop_f.htm")
("lower-case-p" "f_upper_.htm")
("machine-instance" "f_mach_i.htm")
("machine-type" "f_mach_t.htm")
("machine-version" "f_mach_v.htm")
("macro-function" "f_macro_.htm")
("macroexpand" "f_mexp_.htm")
("macroexpand-1" "f_mexp_.htm")
("macrolet" "s_flet_.htm")
("make-array" "f_mk_ar.htm")
("make-broadcast-stream" "f_mk_bro.htm")
("make-concatenated-stream" "f_mk_con.htm")
("make-condition" "f_mk_cnd.htm")
("make-dispatch-macro-character" "f_mk_dis.htm")
("make-echo-stream" "f_mk_ech.htm")
("make-hash-table" "f_mk_has.htm")
("make-instance" "f_mk_ins.htm")
("make-instances-obsolete" "f_mk_i_1.htm")
("make-list" "f_mk_lis.htm")
("make-load-form" "f_mk_ld_.htm")
("make-load-form-saving-slots" "f_mk_l_1.htm")
("make-method" "m_call_m.htm")
("make-package" "f_mk_pkg.htm")
("make-pathname" "f_mk_pn.htm")
("make-random-state" "f_mk_rnd.htm")
("make-sequence" "f_mk_seq.htm")
("make-string" "f_mk_stg.htm")
("make-string-input-stream" "f_mk_s_1.htm")
("make-string-output-stream" "f_mk_s_2.htm")
("make-symbol" "f_mk_sym.htm")
("make-synonym-stream" "f_mk_syn.htm")
("make-two-way-stream" "f_mk_two.htm")
("makunbound" "f_makunb.htm")
("map" "f_map.htm")
("map-into" "f_map_in.htm")
("mapc" "f_mapc_.htm")
("mapcan" "f_mapc_.htm")
("mapcar" "f_mapc_.htm")
("mapcon" "f_mapc_.htm")
("maphash" "f_maphas.htm")
("mapl" "f_mapc_.htm")
("maplist" "f_mapc_.htm")
("mask-field" "f_mask_f.htm")
("max" "f_max_m.htm")
("member" "a_member.htm")
("member-if" "f_mem_m.htm")
("member-if-not" "f_mem_m.htm")
("merge" "f_merge.htm")
("merge-pathnames" "f_merge_.htm")
("method" "t_method.htm")
("method-combination" "a_method.htm")
("method-combination-error" "f_meth_1.htm")
("method-qualifiers" "f_method.htm")
("min" "f_max_m.htm")
("minusp" "f_minusp.htm")
("mismatch" "f_mismat.htm")
("mod" "a_mod.htm")
("most-negative-double-float" "v_most_1.htm")
("most-negative-fixnum" "v_most_p.htm")
("most-negative-long-float" "v_most_1.htm")
("most-negative-short-float" "v_most_1.htm")
("most-negative-single-float" "v_most_1.htm")
("most-positive-double-float" "v_most_1.htm")
("most-positive-fixnum" "v_most_p.htm")
("most-positive-long-float" "v_most_1.htm")
("most-positive-short-float" "v_most_1.htm")
("most-positive-single-float" "v_most_1.htm")
("muffle-warning" "a_muffle.htm")
("multiple-value-bind" "m_multip.htm")
("multiple-value-call" "s_multip.htm")
("multiple-value-list" "m_mult_1.htm")
("multiple-value-prog1" "s_mult_1.htm")
("multiple-value-setq" "m_mult_2.htm")
("multiple-values-limit" "v_multip.htm")
("name-char" "f_name_c.htm")
("namestring" "f_namest.htm")
("nbutlast" "f_butlas.htm")
("nconc" "f_nconc.htm")
("next-method-p" "f_next_m.htm")
("nil" "a_nil.htm")
("nintersection" "f_isec_.htm")
("ninth" "f_firstc.htm")
("no-applicable-method" "f_no_app.htm")
("no-next-method" "f_no_nex.htm")
("not" "a_not.htm")
("notany" "f_everyc.htm")
("notevery" "f_everyc.htm")
("notinline" "d_inline.htm")
("nreconc" "f_revapp.htm")
("nreverse" "f_revers.htm")
("nset-difference" "f_set_di.htm")
("nset-exclusive-or" "f_set_ex.htm")
("nstring-capitalize" "f_stg_up.htm")
("nstring-downcase" "f_stg_up.htm")
("nstring-upcase" "f_stg_up.htm")
("nsublis" "f_sublis.htm")
("nsubst" "f_substc.htm")
("nsubst-if" "f_substc.htm")
("nsubst-if-not" "f_substc.htm")
("nsubstitute" "f_sbs_s.htm")
("nsubstitute-if" "f_sbs_s.htm")
("nsubstitute-if-not" "f_sbs_s.htm")
("nth" "f_nth.htm")
("nth-value" "m_nth_va.htm")
("nthcdr" "f_nthcdr.htm")
("null" "a_null.htm")
("number" "t_number.htm")
("numberp" "f_nump.htm")
("numerator" "f_numera.htm")
("nunion" "f_unionc.htm")
("oddp" "f_evenpc.htm")
("open" "f_open.htm")
("open-stream-p" "f_open_s.htm")
("optimize" "d_optimi.htm")
("or" "a_or.htm")
("otherwise" "m_case_.htm")
("output-stream-p" "f_in_stm.htm")
("package" "t_pkg.htm")
("package-error" "e_pkg_er.htm")
("package-error-package" "f_pkg_er.htm")
("package-name" "f_pkg_na.htm")
("package-nicknames" "f_pkg_ni.htm")
("package-shadowing-symbols" "f_pkg_sh.htm")
("package-use-list" "f_pkg_us.htm")
("package-used-by-list" "f_pkg__1.htm")
("packagep" "f_pkgp.htm")
("pairlis" "f_pairli.htm")
("parse-error" "e_parse_.htm")
("parse-integer" "f_parse_.htm")
("parse-namestring" "f_pars_1.htm")
("pathname" "a_pn.htm")
("pathname-device" "f_pn_hos.htm")
("pathname-directory" "f_pn_hos.htm")
("pathname-host" "f_pn_hos.htm")
("pathname-match-p" "f_pn_mat.htm")
("pathname-name" "f_pn_hos.htm")
("pathname-type" "f_pn_hos.htm")
("pathname-version" "f_pn_hos.htm")
("pathnamep" "f_pnp.htm")
("peek-char" "f_peek_c.htm")
("phase" "f_phase.htm")
("pi" "v_pi.htm")
("plusp" "f_minusp.htm")
("pop" "m_pop.htm")
("position" "f_pos_p.htm")
("position-if" "f_pos_p.htm")
("position-if-not" "f_pos_p.htm")
("pprint" "f_wr_pr.htm")
("pprint-dispatch" "f_ppr_di.htm")
("pprint-exit-if-list-exhausted" "m_ppr_ex.htm")
("pprint-fill" "f_ppr_fi.htm")
("pprint-indent" "f_ppr_in.htm")
("pprint-linear" "f_ppr_fi.htm")
("pprint-logical-block" "m_ppr_lo.htm")
("pprint-newline" "f_ppr_nl.htm")
("pprint-pop" "m_ppr_po.htm")
("pprint-tab" "f_ppr_ta.htm")
("pprint-tabular" "f_ppr_fi.htm")
("prin1" "f_wr_pr.htm")
("prin1-to-string" "f_wr_to_.htm")
("princ" "f_wr_pr.htm")
("princ-to-string" "f_wr_to_.htm")
("print" "f_wr_pr.htm")
("print-not-readable" "e_pr_not.htm")
("print-not-readable-object" "f_pr_not.htm")
("print-object" "f_pr_obj.htm")
("print-unreadable-object" "m_pr_unr.htm")
("probe-file" "f_probe_.htm")
("proclaim" "f_procla.htm")
("prog" "m_prog_.htm")
("prog*" "m_prog_.htm")
("prog1" "m_prog1c.htm")
("prog2" "m_prog1c.htm")
("progn" "s_progn.htm")
("program-error" "e_progra.htm")
("progv" "s_progv.htm")
("provide" "f_provid.htm")
("psetf" "m_setf_.htm")
("psetq" "m_psetq.htm")
("push" "m_push.htm")
("pushnew" "m_pshnew.htm")
("quote" "s_quote.htm")
("random" "f_random.htm")
("random-state" "t_rnd_st.htm")
("random-state-p" "f_rnd_st.htm")
("rassoc" "f_rassoc.htm")
("rassoc-if" "f_rassoc.htm")
("rassoc-if-not" "f_rassoc.htm")
("ratio" "t_ratio.htm")
("rational" "a_ration.htm")
("rationalize" "f_ration.htm")
("rationalp" "f_rati_1.htm")
("read" "f_rd_rd.htm")
("read-byte" "f_rd_by.htm")
("read-char" "f_rd_cha.htm")
("read-char-no-hang" "f_rd_c_1.htm")
("read-delimited-list" "f_rd_del.htm")
("read-from-string" "f_rd_fro.htm")
("read-line" "f_rd_lin.htm")
("read-preserving-whitespace" "f_rd_rd.htm")
("read-sequence" "f_rd_seq.htm")
("reader-error" "e_rder_e.htm")
("readtable" "t_rdtabl.htm")
("readtable-case" "f_rdtabl.htm")
("readtablep" "f_rdta_1.htm")
("real" "t_real.htm")
("realp" "f_realp.htm")
("realpart" "f_realpa.htm")
("reduce" "f_reduce.htm")
("reinitialize-instance" "f_reinit.htm")
("rem" "f_mod_r.htm")
("remf" "m_remf.htm")
("remhash" "f_remhas.htm")
("remove" "f_rm_rm.htm")
("remove-duplicates" "f_rm_dup.htm")
("remove-if" "f_rm_rm.htm")
("remove-if-not" "f_rm_rm.htm")
("remove-method" "f_rm_met.htm")
("remprop" "f_rempro.htm")
("rename-file" "f_rn_fil.htm")
("rename-package" "f_rn_pkg.htm")
("replace" "f_replac.htm")
("require" "f_provid.htm")
("rest" "f_rest.htm")
("restart" "t_rst.htm")
("restart-bind" "m_rst_bi.htm")
("restart-case" "m_rst_ca.htm")
("restart-name" "f_rst_na.htm")
("return" "m_return.htm")
("return-from" "s_ret_fr.htm")
("revappend" "f_revapp.htm")
("reverse" "f_revers.htm")
("room" "f_room.htm")
("rotatef" "m_rotate.htm")
("round" "f_floorc.htm")
("row-major-aref" "f_row_ma.htm")
("rplaca" "f_rplaca.htm")
("rplacd" "f_rplaca.htm")
("safety" "d_optimi.htm")
("satisfies" "t_satisf.htm")
("sbit" "f_bt_sb.htm")
("scale-float" "f_dec_fl.htm")
("schar" "f_char_.htm")
("search" "f_search.htm")
("second" "f_firstc.htm")
("sequence" "t_seq.htm")
("serious-condition" "e_seriou.htm")
("set" "f_set.htm")
("set-difference" "f_set_di.htm")
("set-dispatch-macro-character" "f_set__1.htm")
("set-exclusive-or" "f_set_ex.htm")
("set-macro-character" "f_set_ma.htm")
("set-pprint-dispatch" "f_set_pp.htm")
("set-syntax-from-char" "f_set_sy.htm")
("setf" "a_setf.htm")
("setq" "s_setq.htm")
("seventh" "f_firstc.htm")
("shadow" "f_shadow.htm")
("shadowing-import" "f_shdw_i.htm")
("shared-initialize" "f_shared.htm")
("shiftf" "m_shiftf.htm")
("short-float" "t_short_.htm")
("short-float-epsilon" "v_short_.htm")
("short-float-negative-epsilon" "v_short_.htm")
("short-site-name" "f_short_.htm")
("signal" "f_signal.htm")
("signed-byte" "t_sgn_by.htm")
("signum" "f_signum.htm")
("simple-array" "t_smp_ar.htm")
("simple-base-string" "t_smp_ba.htm")
("simple-bit-vector" "t_smp_bt.htm")
("simple-bit-vector-p" "f_smp_bt.htm")
("simple-condition" "e_smp_cn.htm")
("simple-condition-format-arguments" "f_smp_cn.htm")
("simple-condition-format-control" "f_smp_cn.htm")
("simple-error" "e_smp_er.htm")
("simple-string" "t_smp_st.htm")
("simple-string-p" "f_smp_st.htm")
("simple-type-error" "e_smp_tp.htm")
("simple-vector" "t_smp_ve.htm")
("simple-vector-p" "f_smp_ve.htm")
("simple-warning" "e_smp_wa.htm")
("sin" "f_sin_c.htm")
("single-float" "t_short_.htm")
("single-float-epsilon" "v_short_.htm")
("single-float-negative-epsilon" "v_short_.htm")
("sinh" "f_sinh_.htm")
("sixth" "f_firstc.htm")
("sleep" "f_sleep.htm")
("slot-boundp" "f_slt_bo.htm")
("slot-exists-p" "f_slt_ex.htm")
("slot-makunbound" "f_slt_ma.htm")
("slot-missing" "f_slt_mi.htm")
("slot-unbound" "f_slt_un.htm")
("slot-value" "f_slt_va.htm")
("software-type" "f_sw_tpc.htm")
("software-version" "f_sw_tpc.htm")
("some" "f_everyc.htm")
("sort" "f_sort_.htm")
("space" "d_optimi.htm")
("special" "d_specia.htm")
("special-operator-p" "f_specia.htm")
("speed" "d_optimi.htm")
("sqrt" "f_sqrt_.htm")
("stable-sort" "f_sort_.htm")
("standard" "07_ffb.htm")
("standard-char" "t_std_ch.htm")
("standard-char-p" "f_std_ch.htm")
("standard-class" "t_std_cl.htm")
("standard-generic-function" "t_std_ge.htm")
("standard-method" "t_std_me.htm")
("standard-object" "t_std_ob.htm")
("step" "m_step.htm")
("storage-condition" "e_storag.htm")
("store-value" "a_store_.htm")
("stream" "t_stream.htm")
("stream-element-type" "f_stm_el.htm")
("stream-error" "e_stm_er.htm")
("stream-error-stream" "f_stm_er.htm")
("stream-external-format" "f_stm_ex.htm")
("streamp" "f_stmp.htm")
("string" "a_string.htm")
("string-capitalize" "f_stg_up.htm")
("string-downcase" "f_stg_up.htm")
("string-equal" "f_stgeq_.htm")
("string-greaterp" "f_stgeq_.htm")
("string-left-trim" "f_stg_tr.htm")
("string-lessp" "f_stgeq_.htm")
("string-not-equal" "f_stgeq_.htm")
("string-not-greaterp" "f_stgeq_.htm")
("string-not-lessp" "f_stgeq_.htm")
("string-right-trim" "f_stg_tr.htm")
("string-stream" "t_stg_st.htm")
("string-trim" "f_stg_tr.htm")
("string-upcase" "f_stg_up.htm")
("string/=" "f_stgeq_.htm")
("string<" "f_stgeq_.htm")
("string<=" "f_stgeq_.htm")
("string=" "f_stgeq_.htm")
("string>" "f_stgeq_.htm")
("string>=" "f_stgeq_.htm")
("stringp" "f_stgp.htm")
("structure" "f_docume.htm")
("structure-class" "t_stu_cl.htm")
("structure-object" "t_stu_ob.htm")
("style-warning" "e_style_.htm")
("sublis" "f_sublis.htm")
("subseq" "f_subseq.htm")
("subsetp" "f_subset.htm")
("subst" "f_substc.htm")
("subst-if" "f_substc.htm")
("subst-if-not" "f_substc.htm")
("substitute" "f_sbs_s.htm")
("substitute-if" "f_sbs_s.htm")
("substitute-if-not" "f_sbs_s.htm")
("subtypep" "f_subtpp.htm")
("svref" "f_svref.htm")
("sxhash" "f_sxhash.htm")
("symbol" "t_symbol.htm")
("symbol-function" "f_symb_1.htm")
("symbol-macrolet" "s_symbol.htm")
("symbol-name" "f_symb_2.htm")
("symbol-package" "f_symb_3.htm")
("symbol-plist" "f_symb_4.htm")
("symbol-value" "f_symb_5.htm")
("symbolp" "f_symbol.htm")
("synonym-stream" "t_syn_st.htm")
("synonym-stream-symbol" "f_syn_st.htm")
("t" "a_t.htm")
("tagbody" "s_tagbod.htm")
("tailp" "f_ldiffc.htm")
("tan" "f_sin_c.htm")
("tanh" "f_sinh_.htm")
("tenth" "f_firstc.htm")
("terpri" "f_terpri.htm")
("the" "s_the.htm")
("third" "f_firstc.htm")
("throw" "s_throw.htm")
("time" "m_time.htm")
("trace" "m_tracec.htm")
("translate-logical-pathname" "f_tr_log.htm")
("translate-pathname" "f_tr_pn.htm")
("tree-equal" "f_tree_e.htm")
("truename" "f_tn.htm")
("truncate" "f_floorc.htm")
("two-way-stream" "t_two_wa.htm")
("two-way-stream-input-stream" "f_two_wa.htm")
("two-way-stream-output-stream" "f_two_wa.htm")
("type" "a_type.htm")
("type-error" "e_tp_err.htm")
("type-error-datum" "f_tp_err.htm")
("type-error-expected-type" "f_tp_err.htm")
("type-of" "f_tp_of.htm")
("typecase" "m_tpcase.htm")
("typep" "f_typep.htm")
("unbound-slot" "e_unboun.htm")
("unbound-slot-instance" "f_unboun.htm")
("unbound-variable" "e_unbo_1.htm")
("undefined-function" "e_undefi.htm")
("unexport" "f_unexpo.htm")
("unintern" "f_uninte.htm")
("union" "f_unionc.htm")
("unless" "m_when_.htm")
("unread-char" "f_unrd_c.htm")
("unsigned-byte" "t_unsgn_.htm")
("untrace" "m_tracec.htm")
("unuse-package" "f_unuse_.htm")
("unwind-protect" "s_unwind.htm")
("update-instance-for-different-class" "f_update.htm")
("update-instance-for-redefined-class" "f_upda_1.htm")
("upgraded-array-element-type" "f_upgr_1.htm")
("upgraded-complex-part-type" "f_upgrad.htm")
("upper-case-p" "f_upper_.htm")
("use-package" "f_use_pk.htm")
("use-value" "a_use_va.htm")
("user-homedir-pathname" "f_user_h.htm")
("values" "a_values.htm")
("values-list" "f_vals_l.htm")
("variable" "f_docume.htm")
("vector" "a_vector.htm")
("vector-pop" "f_vec_po.htm")
("vector-push" "f_vec_ps.htm")
("vector-push-extend" "f_vec_ps.htm")
("vectorp" "f_vecp.htm")
("warn" "f_warn.htm")
("warning" "e_warnin.htm")
("when" "m_when_.htm")
("wild-pathname-p" "f_wild_p.htm")
("with-accessors" "m_w_acce.htm")
("with-compilation-unit" "m_w_comp.htm")
("with-condition-restarts" "m_w_cnd_.htm")
("with-hash-table-iterator" "m_w_hash.htm")
("with-input-from-string" "m_w_in_f.htm")
("with-open-file" "m_w_open.htm")
("with-open-stream" "m_w_op_1.htm")
("with-output-to-string" "m_w_out_.htm")
("with-package-iterator" "m_w_pkg_.htm")
("with-simple-restart" "m_w_smp_.htm")
("with-slots" "m_w_slts.htm")
("with-standard-io-syntax" "m_w_std_.htm")
("write" "f_wr_pr.htm")
("write-byte" "f_wr_by.htm")
("write-char" "f_wr_cha.htm")
("write-line" "f_wr_stg.htm")
("write-sequence" "f_wr_seq.htm")
("write-string" "f_wr_stg.htm")
("write-to-string" "f_wr_to_.htm")
("y-or-n-p" "f_y_or_n.htm")
("yes-or-no-p" "f_y_or_n.htm")
("zerop" "f_zerop.htm"))))
;;; Added entries for reader macros.
;;;
;;; 20090302 Tobias C Rittweiler, and Stas Boukarev
(defvar common-lisp-hyperspec--reader-macros (make-hash-table :test #'equal))
;;; Data/Map_Sym.txt in does not contain entries for the reader
;;; macros. So we have to enumerate these explicitly.
(mapc (lambda (entry)
(puthash (car entry) (cadr entry)
common-lisp-hyperspec--reader-macros))
'(("#" "02_dh.htm")
("##" "02_dhp.htm")
("#'" "02_dhb.htm")
("#(" "02_dhc.htm")
("#*" "02_dhd.htm")
("#:" "02_dhe.htm")
("#." "02_dhf.htm")
("#=" "02_dho.htm")
("#+" "02_dhq.htm")
("#-" "02_dhr.htm")
("#<" "02_dht.htm")
("#A" "02_dhl.htm")
("#B" "02_dhg.htm")
("#C" "02_dhk.htm")
("#O" "02_dhh.htm")
("#P" "02_dhn.htm")
("#R" "02_dhj.htm")
("#S" "02_dhm.htm")
("#X" "02_dhi.htm")
("#\\" "02_dha.htm")
("#|" "02_dhs.htm")
("\"" "02_de.htm")
("'" "02_dc.htm")
("`" "02_df.htm")
("," "02_dg.htm")
("(" "02_da.htm")
(")" "02_db.htm")
(";" "02_dd.htm")))
(defun common-lisp-hyperspec-lookup-reader-macro (macro)
"Browse the CLHS entry for the reader-macro MACRO."
(interactive
(list
(let ((completion-ignore-case t))
(completing-read "Look up reader-macro: "
common-lisp-hyperspec--reader-macros nil t
(common-lisp-hyperspec-reader-macro-at-point)))))
(browse-url
(concat common-lisp-hyperspec-root "Body/"
(gethash macro common-lisp-hyperspec--reader-macros))))
(defun common-lisp-hyperspec-reader-macro-at-point ()
(let ((regexp "\\(#.?\\)\\|\\([\"',`';()]\\)"))
(when (looking-back regexp nil t)
(match-string-no-properties 0))))
;;; FORMAT character lookup by Frode Vatvedt Fjeld <frodef@acm.org> 20030902
;;;
;;; adjusted for ILISP by Nikodemus Siivola 20030903
(defvar common-lisp-hyperspec-format-history nil
"History of format characters looked up in the Common Lisp HyperSpec.")
(defun common-lisp-hyperspec-section-6.0 (indices)
(let ((string (format "%sBody/%s_"
common-lisp-hyperspec-root
(let ((base (pop indices)))
(if (< base 10)
(format "0%s" base)
base)))))
(concat string
(mapconcat (lambda (n)
(make-string 1 (+ ?a (- n 1))))
indices
"")
".htm")))
(defun common-lisp-hyperspec-section-4.0 (indices)
(let ((string (format "%sBody/sec_"
common-lisp-hyperspec-root)))
(concat string
(mapconcat (lambda (n)
(format "%d" n))
indices
"-")
".html")))
(defvar common-lisp-hyperspec-section-fun 'common-lisp-hyperspec-section-6.0)
(defun common-lisp-hyperspec-section (indices)
(funcall common-lisp-hyperspec-section-fun indices))
(defvar common-lisp-hyperspec--format-characters
(make-hash-table :test 'equal))
(defun common-lisp-hyperspec--read-format-character ()
(let ((char-at-point
(ignore-errors (char-to-string (char-after (point))))))
(if (and char-at-point
(gethash (upcase char-at-point)
common-lisp-hyperspec--format-characters))
char-at-point
(completing-read
"Look up format control character in Common Lisp HyperSpec: "
common-lisp-hyperspec--format-characters nil t nil
'common-lisp-hyperspec-format-history))))
(defun common-lisp-hyperspec-format (character-name)
(interactive (list (common-lisp-hyperspec--read-format-character)))
(cl-maplist (lambda (entry)
(browse-url (common-lisp-hyperspec-section (car entry))))
(or (gethash character-name
common-lisp-hyperspec--format-characters)
(error "The symbol `%s' is not defined in Common Lisp"
character-name))))
;;; Previously there were entries for "C" and "C: Character",
;;; which unpleasingly crowded the completion buffer, so I made
;;; it show one entry ("C - Character") only.
;;;
;;; 20100131 Tobias C Rittweiler
(defun common-lisp-hyperspec--insert-format-directive (char section
&optional summary)
(let* ((designator (if summary (format "%s - %s" char summary) char)))
(cl-pushnew section (gethash designator
common-lisp-hyperspec--format-characters)
:test #'equal)))
(mapc (lambda (entry)
(cl-destructuring-bind (char section &optional summary) entry
(common-lisp-hyperspec--insert-format-directive char section summary)
(when (and (= 1 (length char))
(not (string-equal char (upcase char))))
(common-lisp-hyperspec--insert-format-directive
(upcase char) section summary))))
'(("c" (22 3 1 1) "Character")
("%" (22 3 1 2) "Newline")
("&" (22 3 1 3) "Fresh-line")
("|" (22 3 1 4) "Page")
("~" (22 3 1 5) "Tilde")
("r" (22 3 2 1) "Radix")
("d" (22 3 2 2) "Decimal")
("b" (22 3 2 3) "Binary")
("o" (22 3 2 4) "Octal")
("x" (22 3 2 5) "Hexadecimal")
("f" (22 3 3 1) "Fixed-Format Floating-Point")
("e" (22 3 3 2) "Exponential Floating-Point")
("g" (22 3 3 3) "General Floating-Point")
("$" (22 3 3 4) "Monetary Floating-Point")
("a" (22 3 4 1) "Aesthetic")
("s" (22 3 4 2) "Standard")
("w" (22 3 4 3) "Write")
("_" (22 3 5 1) "Conditional Newline")
("<" (22 3 5 2) "Logical Block")
("i" (22 3 5 3) "Indent")
("/" (22 3 5 4) "Call Function")
("t" (22 3 6 1) "Tabulate")
("<" (22 3 6 2) "Justification")
(">" (22 3 6 3) "End of Justification")
("*" (22 3 7 1) "Go-To")
("[" (22 3 7 2) "Conditional Expression")
("]" (22 3 7 3) "End of Conditional Expression")
("{" (22 3 7 4) "Iteration")
("}" (22 3 7 5) "End of Iteration")
("?" (22 3 7 6) "Recursive Processing")
("(" (22 3 8 1) "Case Conversion")
(")" (22 3 8 2) "End of Case Conversion")
("p" (22 3 8 3) "Plural")
(";" (22 3 9 1) "Clause Separator")
("^" (22 3 9 2) "Escape Upward")
("Newline: Ignored Newline" (22 3 9 3))
("Nesting of FORMAT Operations" (22 3 10 1))
("Missing and Additional FORMAT Arguments" (22 3 10 2))
("Additional FORMAT Parameters" (22 3 10 3))))
;;;; Glossary
(defvar common-lisp-hyperspec-glossary-function 'common-lisp-glossary-6.0
"Function that creates a URL for a glossary term.")
(define-obsolete-variable-alias 'common-lisp-glossary-fun
'common-lisp-hyperspec-glossary-function "Dec 2015")
(defvar common-lisp-hyperspec--glossary-terms (make-hash-table :test #'equal)
"Collection of glossary terms and relative URLs.")
;;; Functions
;;; The functions below are used to collect glossary terms and page anchors
;;; from CLHS. They are commented out because they are not needed unless the
;;; list of terms/anchors need to be updated.
;; (defun common-lisp-hyperspec-glossary-pages ()
;; "List of CLHS glossary pages."
;; (mapcar (lambda (end)
;; (format "%sBody/26_glo_%s.htm"
;; common-lisp-hyperspec-root
;; end))
;; (cons "9" (mapcar #'char-to-string
;; (number-sequence ?a ?z)))))
;; (defun common-lisp-hyperspec-glossary-download ()
;; "Download CLHS glossary pages to temporary files and return a
;; list of file names."
;; (mapcar (lambda (url)
;; (url-file-local-copy url))
;; (common-lisp-hyperspec-glossary-pages)))
;; (defun common-lisp-hyperspec-glossary-entries (file)
;; "Given a CLHS glossary file FILE, return a list of
;; term-anchor pairs.
;; Term is the glossary term and anchor is the term's anchor on the
;; page."
;; (let (entries)
;; (save-excursion
;; (set-buffer (find-file-noselect file))
;; (goto-char (point-min))
;; (while (search-forward-regexp "<a\\ name=\"\\(.*?\\)\"><b>\\(.*?\\)</b>" nil t)
;; (setq entries (cons (list (match-string-no-properties 2)
;; (match-string-no-properties 1))
;; entries))))
;; (sort entries (lambda (a b)
;; (string< (car a) (car b))))))
;; ;; Add glossary terms by downloading and parsing glossary pages from CLHS
;; (mapc (lambda (entry)
;; (puthash (car entry) (cadr entry)
;; common-lisp-hyperspec--glossary-terms))
;; (cl-reduce (lambda (a b)
;; (append a b))
;; (mapcar #'common-lisp-hyperspec-glossary-entries
;; (common-lisp-hyperspec-glossary-download))))
;; Add glossary entries to the master hash table
(mapc (lambda (entry)
(puthash (car entry) (cadr entry)
common-lisp-hyperspec--glossary-terms))
'(("()" "OPCP")
("absolute" "absolute")
("access" "access")
("accessibility" "accessibility")
("accessible" "accessible")
("accessor" "accessor")
("active" "active")
("actual adjustability" "actual_adjustability")
("actual argument" "actual_argument")
("actual array element type" "actual_array_element_type")
("actual complex part type" "actual_complex_part_type")
("actual parameter" "actual_parameter")
("actually adjustable" "actually_adjustable")
("adjustability" "adjustability")
("adjustable" "adjustable")
("after method" "after_method")
("alist" "alist")
("alphabetic" "alphabetic")
("alphanumeric" "alphanumeric")
("ampersand" "ampersand")
("anonymous" "anonymous")
("apparently uninterned" "apparently_uninterned")
("applicable" "applicable")
("applicable handler" "applicable_handler")
("applicable method" "applicable_method")
("applicable restart" "applicable_restart")
("apply" "apply")
("argument" "argument")
("argument evaluation order" "argument_evaluation_order")
("argument precedence order" "argument_precedence_order")
("around method" "around_method")
("array" "array")
("array element type" "array_element_type")
("array total size" "array_total_size")
("assign" "assign")
("association list" "association_list")
("asterisk" "asterisk")
("at-sign" "at-sign")
("atom" "atom")
("atomic" "atomic")
("atomic type specifier" "atomic_type_specifier")
("attribute" "attribute")
("aux variable" "aux_variable")
("auxiliary method" "auxiliary_method")
("backquote" "backquote")
("backslash" "backslash")
("base character" "base_character")
("base string" "base_string")
("before method" "before_method")
("bidirectional" "bidirectional")
("binary" "binary")
("bind" "bind")
("binding" "binding")
("bit" "bit")
("bit array" "bit_array")
("bit vector" "bit_vector")
("bit-wise logical operation specifier" "bit-wise_logical_operation_specifier")
("block" "block")
("block tag" "block_tag")
("boa lambda list" "boa_lambda_list")
("body parameter" "body_parameter")
("boolean" "boolean")
("boolean equivalent" "boolean_equivalent")
("bound" "bound")
("bound declaration" "bound_declaration")
("bounded" "bounded")
("bounding index" "bounding_index")
("bounding index designator" "bounding_index_designator")
("break loop" "break_loop")
("broadcast stream" "broadcast_stream")
("built-in class" "built-in_class")
("built-in type" "built-in_type")
("byte" "byte")
("byte specifier" "byte_specifier")
("cadr" "cadr")
("call" "call")
("captured initialization form" "captured_initialization_form")
("car" "car")
("case" "case")
("case sensitivity mode" "case_sensitivity_mode")
("catch" "catch")
("catch tag" "catch_tag")
("cddr" "cddr")
("cdr" "cdr")
("cell" "cell")
("character" "character")
("character code" "character_code")
("character designator" "character_designator")
("circular" "circular")
("circular list" "circular_list")
("class" "class")
("class designator" "class_designator")
("class precedence list" "class_precedence_list")
("close" "close")
("closed" "closed")
("closure" "closure")
("coalesce" "coalesce")
("code" "code")
("coerce" "coerce")
("colon" "colon")
("comma" "comma")
("compilation" "compilation")
("compilation environment" "compilation_environment")
("compilation unit" "compilation_unit")
("compile" "compile")
("compile time" "compile_time")
("compile-time definition" "compile-time_definition")
("compiled code" "compiled_code")
("compiled file" "compiled_file")
("compiled function" "compiled_function")
("compiler" "compiler")
("compiler macro" "compiler_macro")
("compiler macro expansion" "compiler_macro_expansion")
("compiler macro form" "compiler_macro_form")
("compiler macro function" "compiler_macro_function")
("complex" "complex")
("complex float" "complex_float")
("complex part type" "complex_part_type")
("complex rational" "complex_rational")
("complex single float" "complex_single_float")
("composite stream" "composite_stream")
("compound form" "compound_form")
("compound type specifier" "compound_type_specifier")
("concatenated stream" "concatenated_stream")
("condition" "condition")
("condition designator" "condition_designator")
("condition handler" "condition_handler")
("condition reporter" "condition_reporter")
("conditional newline" "conditional_newline")
("conformance" "conformance")
("conforming code" "conforming_code")
("conforming implementation" "conforming_implementation")
("conforming processor" "conforming_processor")
("conforming program" "conforming_program")
("congruent" "congruent")
("cons" "cons")
("constant" "constant")
("constant form" "constant_form")
("constant object" "constant_object")
("constant variable" "constant_variable")
("constituent" "constituent")
("constituent trait" "constituent_trait")
("constructed stream" "constructed_stream")
("contagion" "contagion")
("continuable" "continuable")
("control form" "control_form")
("copy" "copy")
("correctable" "correctable")
("current input base" "current_input_base")
("current logical block" "current_logical_block")
("current output base" "current_output_base")
("current package" "current_package")
("current pprint dispatch table" "current_pprint_dispatch_table")
("current random state" "current_random_state")
("current readtable" "current_readtable")
("data type" "data_type")
("debug I/O" "debug_iSLo")
("debugger" "debugger")
("declaration" "declaration")
("declaration identifier" "declaration_identifier")
("declaration specifier" "declaration_specifier")
("declare" "declare")
("decline" "decline")
("decoded time" "decoded_time")
("default method" "default_method")
("defaulted initialization argument list" "defaulted_initialization_argument_list")
("define-method-combination arguments lambda list" "define-method-combination_arguments_lambda_list")
("define-modify-macro lambda list" "define-modify-macro_lambda_list")
("defined name" "defined_name")
("defining form" "defining_form")
("defsetf lambda list" "defsetf_lambda_list")
("deftype lambda list" "deftype_lambda_list")
("denormalized" "denormalized")
("derived type" "derived_type")
("derived type specifier" "derived_type_specifier")
("designator" "designator")
("destructive" "destructive")
("destructuring lambda list" "destructuring_lambda_list")
("different" "different")
("digit" "digit")
("dimension" "dimension")
("direct instance" "direct_instance")
("direct subclass" "direct_subclass")
("direct superclass" "direct_superclass")
("disestablish" "disestablish")
("disjoint" "disjoint")
("dispatching macro character" "dispatching_macro_character")
("displaced array" "displaced_array")
("distinct" "distinct")
("documentation string" "documentation_string")
("dot" "dot")
("dotted list" "dotted_list")
("dotted pair" "dotted_pair")
("double float" "double_float")
("double-quote" "double-quote")
("dynamic binding" "dynamic_binding")
("dynamic environment" "dynamic_environment")
("dynamic extent" "dynamic_extent")
("dynamic scope" "dynamic_scope")
("dynamic variable" "dynamic_variable")
("echo stream" "echo_stream")
("effective method" "effective_method")
("element" "element")
("element type" "element_type")
("em" "em")
("empty list" "empty_list")
("empty type" "empty_type")
("end of file" "end_of_file")
("environment" "environment")
("environment object" "environment_object")
("environment parameter" "environment_parameter")
("error" "error")
("error output" "error_output")
("escape" "escape")
("establish" "establish")
("evaluate" "evaluate")
("evaluation" "evaluation")
("evaluation environment" "evaluation_environment")
("execute" "execute")
("execution time" "execution_time")
("exhaustive partition" "exhaustive_partition")
("exhaustive union" "exhaustive_union")
("exit point" "exit_point")
("explicit return" "explicit_return")
("explicit use" "explicit_use")
("exponent marker" "exponent_marker")
("export" "export")
("exported" "exported")
("expressed adjustability" "expressed_adjustability")
("expressed array element type" "expressed_array_element_type")
("expressed complex part type" "expressed_complex_part_type")
("expression" "expression")
("expressly adjustable" "expressly_adjustable")
("extended character" "extended_character")
("extended function designator" "extended_function_designator")
("extended lambda list" "extended_lambda_list")
("extension" "extension")
("extent" "extent")
("external file format" "external_file_format")
("external file format designator" "external_file_format_designator")
("external symbol" "external_symbol")
("externalizable object" "externalizable_object")
("false" "false")
("fbound" "fbound")
("feature" "feature")
("feature expression" "feature_expression")
("features list" "features_list")
("file" "file")
("file compiler" "file_compiler")
("file position" "file_position")
("file position designator" "file_position_designator")
("file stream" "file_stream")
("file system" "file_system")
("filename" "filename")
("fill pointer" "fill_pointer")
("finite" "finite")
("fixnum" "fixnum")
("float" "float")
("for-value" "for-value")
("form" "form")
("formal argument" "formal_argument")
("formal parameter" "formal_parameter")
("format" "format")
("format argument" "format_argument")
("format control" "format_control")
("format directive" "format_directive")
("format string" "format_string")
("free declaration" "free_declaration")
("fresh" "fresh")
("freshline" "freshline")
("funbound" "funbound")
("function" "function")
("function block name" "function_block_name")
("function cell" "function_cell")
("function designator" "function_designator")
("function form" "function_form")
("function name" "function_name")
("functional evaluation" "functional_evaluation")
("functional value" "functional_value")
("further compilation" "further_compilation")
("general" "general")
("generalized boolean" "generalized_boolean")
("generalized instance" "generalized_instance")
("generalized reference" "generalized_reference")
("generalized synonym stream" "generalized_synonym_stream")
("generic function" "generic_function")
("generic function lambda list" "generic_function_lambda_list")
("gensym" "gensym")
("global declaration" "global_declaration")
("global environment" "global_environment")
("global variable" "global_variable")
("glyph" "glyph")
("go" "go")
("go point" "go_point")
("go tag" "go_tag")
("graphic" "graphic")
("handle" "handle")
("handler" "handler")
("hash table" "hash_table")
("home package" "home_package")
("I/O customization variable" "iSLo_customization_variable")
("identical" "identical")
("identifier" "identifier")
("immutable" "immutable")
("implementation" "implementation")
("implementation limit" "implementation_limit")
("implementation-defined" "implementation-defined")
("implementation-dependent" "implementation-dependent")
("implementation-independent" "implementation-independent")
("implicit block" "implicit_block")
("implicit compilation" "implicit_compilation")
("implicit progn" "implicit_progn")
("implicit tagbody" "implicit_tagbody")
("import" "import")
("improper list" "improper_list")
("inaccessible" "inaccessible")
("indefinite extent" "indefinite_extent")
("indefinite scope" "indefinite_scope")
("indicator" "indicator")
("indirect instance" "indirect_instance")
("inherit" "inherit")
("initial pprint dispatch table" "initial_pprint_dispatch_table")
("initial readtable" "initial_readtable")
("initialization argument list" "initialization_argument_list")
("initialization form" "initialization_form")
("input" "input")
("instance" "instance")
("integer" "integer")
("interactive stream" "interactive_stream")
("intern" "intern")
("internal symbol" "internal_symbol")
("internal time" "internal_time")
("internal time unit" "internal_time_unit")
("interned" "interned")
("interpreted function" "interpreted_function")
("interpreted implementation" "interpreted_implementation")
("interval designator" "interval_designator")
("invalid" "invalid")
("iteration form" "iteration_form")
("iteration variable" "iteration_variable")
("key" "key")
("keyword" "keyword")
("keyword parameter" "keyword_parameter")
("keyword/value pair" "keywordSLvalue_pair")
("Lisp image" "lisp_image")
("Lisp printer" "lisp_printer")
("Lisp read-eval-print loop" "lisp_read-eval-print_loop")
("Lisp reader" "lisp_reader")
("lambda combination" "lambda_combination")
("lambda expression" "lambda_expression")
("lambda form" "lambda_form")
("lambda list" "lambda_list")
("lambda list keyword" "lambda_list_keyword")
("lambda variable" "lambda_variable")
("leaf" "leaf")
("leap seconds" "leap_seconds")
("left-parenthesis" "left-parenthesis")
("length" "length")
("lexical binding" "lexical_binding")
("lexical closure" "lexical_closure")
("lexical environment" "lexical_environment")
("lexical scope" "lexical_scope")
("lexical variable" "lexical_variable")
("list" "list")
("list designator" "list_designator")
("list structure" "list_structure")
("literal" "literal")
("load" "load")
("load time" "load_time")
("load time value" "load_time_value")
("loader" "loader")
("local declaration" "local_declaration")
("local precedence order" "local_precedence_order")
("local slot" "local_slot")
("logical block" "logical_block")
("logical host" "logical_host")
("logical host designator" "logical_host_designator")
("logical pathname" "logical_pathname")
("long float" "long_float")
("loop keyword" "loop_keyword")
("lowercase" "lowercase")
("Metaobject Protocol" "metaobject_protocol")
("macro" "macro")
("macro character" "macro_character")
("macro expansion" "macro_expansion")
("macro form" "macro_form")
("macro function" "macro_function")
("macro lambda list" "macro_lambda_list")
("macro name" "macro_name")
("macroexpand hook" "macroexpand_hook")
("mapping" "mapping")
("metaclass" "metaclass")
("method" "method")
("method combination" "method_combination")
("method-defining form" "method-defining_form")
("method-defining operator" "method-defining_operator")
("minimal compilation" "minimal_compilation")
("modified lambda list" "modified_lambda_list")
("most recent" "most_recent")
("multiple escape" "multiple_escape")
("multiple values" "multiple_values")
("name" "name")
("named constant" "named_constant")
("namespace" "namespace")
("namestring" "namestring")
("newline" "newline")
("next method" "next_method")
("nickname" "nickname")
("nil" "nil")
("non-atomic" "non-atomic")
("non-constant variable" "non-constant_variable")
("non-correctable" "non-correctable")
("non-empty" "non-empty")
("non-generic function" "non-generic_function")
("non-graphic" "non-graphic")
("non-list" "non-list")
("non-local exit" "non-local_exit")
("non-nil" "non-nil")
("non-null lexical environment" "non-null_lexical_environment")
("non-simple" "non-simple")
("non-terminating" "non-terminating")
("non-top-level form" "non-top-level_form")
("normal return" "normal_return")
("normalized" "normalized")
("null" "null")
("null lexical environment" "null_lexical_environment")
("number" "number")
("numeric" "numeric")
("object" "object")
("object-traversing" "object-traversing")
("open" "open")
("operator" "operator")
("optimize quality" "optimize_quality")
("optional parameter" "optional_parameter")
("ordinary function" "ordinary_function")
("ordinary lambda list" "ordinary_lambda_list")
("otherwise inaccessible part" "otherwise_inaccessible_part")
("output" "output")
("package" "package")
("package cell" "package_cell")
("package designator" "package_designator")
("package marker" "package_marker")
("package prefix" "package_prefix")
("package registry" "package_registry")
("pairwise" "pairwise")
("parallel" "parallel")
("parameter" "parameter")
("parameter specializer" "parameter_specializer")
("parameter specializer name" "parameter_specializer_name")
("pathname" "pathname")
("pathname designator" "pathname_designator")
("physical pathname" "physical_pathname")
("place" "place")
("plist" "plist")
("portable" "portable")
("potential copy" "potential_copy")
("potential number" "potential_number")
("pprint dispatch table" "pprint_dispatch_table")
("predicate" "predicate")
("present" "present")
("pretty print" "pretty_print")
("pretty printer" "pretty_printer")
("pretty printing stream" "pretty_printing_stream")
("primary method" "primary_method")
("primary value" "primary_value")
("principal" "principal")
("print name" "print_name")
("printer control variable" "printer_control_variable")
("printer escaping" "printer_escaping")
("printing" "printing")
("process" "process")
("processor" "processor")
("proclaim" "proclaim")
("proclamation" "proclamation")
("prog tag" "prog_tag")
("program" "program")
("programmer" "programmer")
("programmer code" "programmer_code")
("proper list" "proper_list")
("proper name" "proper_name")
("proper sequence" "proper_sequence")
("proper subtype" "proper_subtype")
("property" "property")
("property indicator" "property_indicator")
("property list" "property_list")
("property value" "property_value")
("purports to conform" "purports_to_conform")
("qualified method" "qualified_method")
("qualifier" "qualifier")
("query I/O" "query_iSLo")
("quoted object" "quoted_object")
("radix" "radix")
("random state" "random_state")
("rank" "rank")
("ratio" "ratio")
("ratio marker" "ratio_marker")
("rational" "rational")
("read" "read")
("readably" "readably")
("reader" "reader")
("reader macro" "reader_macro")
("reader macro function" "reader_macro_function")
("readtable" "readtable")
("readtable case" "readtable_case")
("readtable designator" "readtable_designator")
("recognizable subtype" "recognizable_subtype")
("reference" "reference")
("registered package" "registered_package")
("relative" "relative")
("repertoire" "repertoire")
("report" "report")
("report message" "report_message")
("required parameter" "required_parameter")
("rest list" "rest_list")
("rest parameter" "rest_parameter")
("restart" "restart")
("restart designator" "restart_designator")
("restart function" "restart_function")
("return" "return")
("return value" "return_value")
("right-parenthesis" "right-parenthesis")
("run time" "run_time")
("run-time compiler" "run-time_compiler")
("run-time definition" "run-time_definition")
("run-time environment" "run-time_environment")
("safe" "safe")
("safe call" "safe_call")
("same" "same")
("satisfy the test" "satisfy_the_test")
("scope" "scope")
("script" "script")
("secondary value" "secondary_value")
("section" "section")
("self-evaluating object" "self-evaluating_object")
("semi-standard" "semi-standard")
("semicolon" "semicolon")
("sequence" "sequence")
("sequence function" "sequence_function")
("sequential" "sequential")
("sequentially" "sequentially")
("serious condition" "serious_condition")
("session" "session")
("set" "set")
("setf expander" "setf_expander")
("setf expansion" "setf_expansion")
("setf function" "setf_function")
("setf function name" "setf_function_name")
("shadow" "shadow")
("shadowing symbol" "shadowing_symbol")
("shadowing symbols list" "shadowing_symbols_list")
("shared slot" "shared_slot")
("sharpsign" "sharpsign")
("short float" "short_float")
("sign" "sign")
("signal" "signal")
("signature" "signature")
("similar" "similar")
("similarity" "similarity")
("simple" "simple")
("simple array" "simple_array")
("simple bit array" "simple_bit_array")
("simple bit vector" "simple_bit_vector")
("simple condition" "simple_condition")
("simple general vector" "simple_general_vector")
("simple string" "simple_string")
("simple vector" "simple_vector")
("single escape" "single_escape")
("single float" "single_float")
("single-quote" "single-quote")
("singleton" "singleton")
("situation" "situation")
("slash" "slash")
("slot" "slot")
("slot specifier" "slot_specifier")
("source code" "source_code")
("source file" "source_file")
("space" "space")
("special form" "special_form")
("special operator" "special_operator")
("special variable" "special_variable")
("specialize" "specialize")
("specialized" "specialized")
("specialized lambda list" "specialized_lambda_list")
("spreadable argument list designator" "spreadable_argument_list_designator")
("stack allocate" "stack_allocate")
("stack-allocated" "stack-allocated")
("standard character" "standard_character")
("standard class" "standard_class")
("standard generic function" "standard_generic_function")
("standard input" "standard_input")
("standard method combination" "standard_method_combination")
("standard object" "standard_object")
("standard output" "standard_output")
("standard pprint dispatch table" "standard_pprint_dispatch_table")
("standard readtable" "standard_readtable")
("standard syntax" "standard_syntax")
("standardized" "standardized")
("startup environment" "startup_environment")
("step" "step")
("stream" "stream")
("stream associated with a file" "stream_associated_with_a_file")
("stream designator" "stream_designator")
("stream element type" "stream_element_type")
("stream variable" "stream_variable")
("stream variable designator" "stream_variable_designator")
("string" "string")
("string designator" "string_designator")
("string equal" "string_equal")
("string stream" "string_stream")
("structure" "structure")
("structure class" "structure_class")
("structure name" "structure_name")
("style warning" "style_warning")
("subclass" "subclass")
("subexpression" "subexpression")
("subform" "subform")
("subrepertoire" "subrepertoire")
("subtype" "subtype")
("superclass" "superclass")
("supertype" "supertype")
("supplied-p parameter" "supplied-p_parameter")
("symbol" "symbol")
("symbol macro" "symbol_macro")
("synonym stream" "synonym_stream")
("synonym stream symbol" "synonym_stream_symbol")
("syntax type" "syntax_type")
("system class" "system_class")
("system code" "system_code")
("t" "t")
("tag" "tag")
("tail" "tail")
("target" "target")
("terminal I/O" "terminal_iSLo")
("terminating" "terminating")
("tertiary value" "tertiary_value")
("throw" "throw")
("tilde" "tilde")
("time" "time")
("time zone" "time_zone")
("token" "token")
("top level form" "top_level_form")
("trace output" "trace_output")
("tree" "tree")
("tree structure" "tree_structure")
("true" "true")
("truename" "truename")
("two-way stream" "two-way_stream")
("type" "type")
("type declaration" "type_declaration")
("type equivalent" "type_equivalent")
("type expand" "type_expand")
("type specifier" "type_specifier")
("unbound" "unbound")
("unbound variable" "unbound_variable")
("undefined function" "undefined_function")
("unintern" "unintern")
("uninterned" "uninterned")
("universal time" "universal_time")
("unqualified method" "unqualified_method")
("unregistered package" "unregistered_package")
("unsafe" "unsafe")
("unsafe call" "unsafe_call")
("upgrade" "upgrade")
("upgraded array element type" "upgraded_array_element_type")
("upgraded complex part type" "upgraded_complex_part_type")
("uppercase" "uppercase")
("use" "use")
("use list" "use_list")
("user" "user")
("valid array dimension" "valid_array_dimension")
("valid array index" "valid_array_index")
("valid array row-major index" "valid_array_row-major_index")
("valid fill pointer" "valid_fill_pointer")
("valid logical pathname host" "valid_logical_pathname_host")
("valid pathname device" "valid_pathname_device")
("valid pathname directory" "valid_pathname_directory")
("valid pathname host" "valid_pathname_host")
("valid pathname name" "valid_pathname_name")
("valid pathname type" "valid_pathname_type")
("valid pathname version" "valid_pathname_version")
("valid physical pathname host" "valid_physical_pathname_host")
("valid sequence index" "valid_sequence_index")
("value" "value")
("value cell" "value_cell")
("variable" "variable")
("vector" "vector")
("vertical-bar" "vertical-bar")
("whitespace" "whitespace")
("wild" "wild")
("write" "write")
("writer" "writer")
("yield" "yield")))
(defun common-lisp-hyperspec-glossary-term (term)
"View the definition of TERM on the Common Lisp Hyperspec."
(interactive
(list
(completing-read "Look up glossary term: "
common-lisp-hyperspec--glossary-terms nil t)))
(browse-url (funcall common-lisp-hyperspec-glossary-function term)))
(defun common-lisp-glossary-6.0 (term)
"Get a URL for a glossary term TERM."
(let ((anchor (gethash term common-lisp-hyperspec--glossary-terms)))
(if (not anchor)
(message "Unknown glossary term: %s" term)
(format "%sBody/26_glo_%s.htm#%s"
common-lisp-hyperspec-root
(let ((char (string-to-char term)))
(if (and (<= ?a char)
(<= char ?z))
(make-string 1 char)
"9"))
anchor))))
;; Tianxiang Xiong 20151229
;; Is this function necessary? The link does created does not work.
(defun common-lisp-glossary-4.0 (string)
(format "%sBody/glo_%s.html#%s"
common-lisp-hyperspec-root
(let ((char (string-to-char string)))
(if (and (<= ?a char)
(<= char ?z))
(make-string 1 char)
"9"))
(subst-char-in-string ?\ ?_ string)))
;;;; Issuex
;; FIXME: the issuex stuff is not used
(defvar common-lisp-hyperspec-issuex-table nil
"The HyperSpec IssueX table file. If you copy the HyperSpec to your
local system, set this variable to the location of the Issue
cross-references table which is usually \"Map_IssX.txt\" or
\"Issue-Cross-Refs.text\".")
(defvar common-lisp-hyperspec--issuex-symbols
(make-hash-table :test 'equal))
(mapc
(lambda (entry)
(puthash (car entry) (cadr entry) common-lisp-hyperspec--issuex-symbols))
(if common-lisp-hyperspec-issuex-table
(common-lisp-hyperspec--parse-map-file
common-lisp-hyperspec-issuex-table)
'(("&environment-binding-order:first" "iss001.htm")
("access-error-name" "iss002.htm")
("adjust-array-displacement" "iss003.htm")
("adjust-array-fill-pointer" "iss004.htm")
("adjust-array-not-adjustable:implicit-copy" "iss005.htm")
("allocate-instance:add" "iss006.htm")
("allow-local-inline:inline-notinline" "iss007.htm")
("allow-other-keys-nil:permit" "iss008.htm")
("aref-1d" "iss009.htm")
("argument-mismatch-error-again:consistent" "iss010.htm")
("argument-mismatch-error-moon:fix" "iss011.htm")
("argument-mismatch-error:more-clarifications" "iss012.htm")
("arguments-underspecified:specify" "iss013.htm")
("array-dimension-limit-implications:all-fixnum" "iss014.htm")
("array-type-element-type-semantics:unify-upgrading" "iss015.htm")
("assert-error-type:error" "iss016.htm")
("assoc-rassoc-if-key" "iss017.htm")
("assoc-rassoc-if-key:yes" "iss018.htm")
("boa-aux-initialization:error-on-read" "iss019.htm")
("break-on-warnings-obsolete:remove" "iss020.htm")
("broadcast-stream-return-values:clarify-minimally" "iss021.htm")
("butlast-negative:should-signal" "iss022.htm")
("change-class-initargs:permit" "iss023.htm")
("char-name-case:x3j13-mar-91" "iss024.htm")
("character-loose-ends:fix" "iss025.htm")
("character-proposal:2" "iss026.htm")
("character-proposal:2-1-1" "iss027.htm")
("character-proposal:2-1-2" "iss028.htm")
("character-proposal:2-2-1" "iss029.htm")
("character-proposal:2-3-1" "iss030.htm")
("character-proposal:2-3-2" "iss031.htm")
("character-proposal:2-3-3" "iss032.htm")
("character-proposal:2-3-4" "iss033.htm")
("character-proposal:2-3-5" "iss034.htm")
("character-proposal:2-3-6" "iss035.htm")
("character-proposal:2-4-1" "iss036.htm")
("character-proposal:2-4-2" "iss037.htm")
("character-proposal:2-4-3" "iss038.htm")
("character-proposal:2-5-2" "iss039.htm")
("character-proposal:2-5-6" "iss040.htm")
("character-proposal:2-5-7" "iss041.htm")
("character-proposal:2-6-1" "iss042.htm")
("character-proposal:2-6-2" "iss043.htm")
("character-proposal:2-6-3" "iss044.htm")
("character-proposal:2-6-5" "iss045.htm")
("character-vs-char:less-inconsistent-short" "iss046.htm")
("class-object-specializer:affirm" "iss047.htm")
("clos-conditions-again:allow-subset" "iss048.htm")
("clos-conditions:integrate" "iss049.htm")
("clos-error-checking-order:no-applicable-method-first" "iss050.htm")
("clos-macro-compilation:minimal" "iss051.htm")
("close-constructed-stream:argument-stream-only" "iss052.htm")
("closed-stream-operations:allow-inquiry" "iss053.htm")
("coercing-setf-name-to-function:all-function-names" "iss054.htm")
("colon-number" "iss055.htm")
("common-features:specify" "iss056.htm")
("common-type:remove" "iss057.htm")
("compile-argument-problems-again:fix" "iss058.htm")
("compile-file-handling-of-top-level-forms:clarify" "iss059.htm")
("compile-file-output-file-defaults:input-file" "iss060.htm")
("compile-file-package" "iss061.htm")
("compile-file-pathname-arguments:make-consistent" "iss062.htm")
("compile-file-symbol-handling:new-require-consistency" "iss063.htm")
("compiled-function-requirements:tighten" "iss064.htm")
("compiler-diagnostics:use-handler" "iss065.htm")
("compiler-let-confusion:eliminate" "iss066.htm")
("compiler-verbosity:like-load" "iss067.htm")
("compiler-warning-stream" "iss068.htm")
("complex-atan-branch-cut:tweak" "iss069.htm")
("complex-atanh-bogus-formula:tweak-more" "iss070.htm")
("complex-rational-result:extend" "iss071.htm")
("compute-applicable-methods:generic" "iss072.htm")
("concatenate-sequence:signal-error" "iss073.htm")
("condition-accessors-setfable:no" "iss074.htm")
("condition-restarts:buggy" "iss075.htm")
("condition-restarts:permit-association" "iss076.htm")
("condition-slots:hidden" "iss077.htm")
("cons-type-specifier:add" "iss078.htm")
("constant-circular-compilation:yes" "iss079.htm")
("constant-collapsing:generalize" "iss080.htm")
("constant-compilable-types:specify" "iss081.htm")
("constant-function-compilation:no" "iss082.htm")
("constant-modification:disallow" "iss083.htm")
("constantp-definition:intentional" "iss084.htm")
("constantp-environment:add-arg" "iss085.htm")
("contagion-on-numerical-comparisons:transitive" "iss086.htm")
("copy-symbol-copy-plist:copy-list" "iss087.htm")
("copy-symbol-print-name:equal" "iss088.htm")
("data-io:add-support" "iss089.htm")
("data-types-hierarchy-underspecified" "iss090.htm")
("debugger-hook-vs-break:clarify" "iss091.htm")
("declaration-scope:no-hoisting" "iss092.htm")
("declare-array-type-element-references:restrictive" "iss093.htm")
("declare-function-ambiguity:delete-ftype-abbreviation" "iss094.htm")
("declare-macros:flush" "iss095.htm")
("declare-type-free:lexical" "iss096.htm")
("decls-and-doc" "iss097.htm")
("decode-universal-time-daylight:like-encode" "iss098.htm")
("defconstant-special:no" "iss099.htm")
("defgeneric-declare:allow-multiple" "iss100.htm")
("define-compiler-macro:x3j13-nov89" "iss101.htm")
("define-condition-syntax:\
incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm")
("define-method-combination-behavior:clarify" "iss103.htm")
("defining-macros-non-top-level:allow" "iss104.htm")
("defmacro-block-scope:excludes-bindings" "iss105.htm")
("defmacro-lambda-list:tighten-description" "iss106.htm")
("defmethod-declaration-scope:corresponds-to-bindings" "iss107.htm")
("defpackage:addition" "iss108.htm")
("defstruct-constructor-key-mixture:allow-key" "iss109.htm")
("defstruct-constructor-options:explicit" "iss110.htm")
("defstruct-constructor-slot-variables:not-bound" "iss111.htm")
("defstruct-copier-argument-type:restrict" "iss112.htm")
("defstruct-copier:argument-type" "iss113.htm")
("defstruct-default-value-evaluation:iff-needed" "iss114.htm")
("defstruct-include-deftype:explicitly-undefined" "iss115.htm")
("defstruct-print-function-again:x3j13-mar-93" "iss116.htm")
("defstruct-print-function-inheritance:yes" "iss117.htm")
("defstruct-redefinition:error" "iss118.htm")
("defstruct-slots-constraints-name:duplicates-error" "iss119.htm")
("defstruct-slots-constraints-number" "iss120.htm")
("deftype-destructuring:yes" "iss121.htm")
("deftype-key:allow" "iss122.htm")
("defvar-documentation:unevaluated" "iss123.htm")
("defvar-init-time:not-delayed" "iss124.htm")
("defvar-initialization:conservative" "iss125.htm")
("deprecation-position:limited" "iss126.htm")
("describe-interactive:no" "iss127.htm")
("describe-underspecified:describe-object" "iss128.htm")
("destructive-operations:specify" "iss129.htm")
("destructuring-bind:new-macro" "iss130.htm")
("disassemble-side-effect:do-not-install" "iss131.htm")
("displaced-array-predicate:add" "iss132.htm")
("do-symbols-block-scope:entire-form" "iss133.htm")
("do-symbols-duplicates" "iss134.htm")
("documentation-function-bugs:fix" "iss135.htm")
("documentation-function-tangled:require-argument" "iss136.htm")
("dotimes-ignore:x3j13-mar91" "iss137.htm")
("dotted-list-arguments:clarify" "iss138.htm")
("dotted-macro-forms:allow" "iss139.htm")
("dribble-technique" "iss140.htm")
("dynamic-extent-function:extend" "iss141.htm")
("dynamic-extent:new-declaration" "iss142.htm")
("equal-structure:maybe-status-quo" "iss143.htm")
("error-terminology-warning:might" "iss144.htm")
("eval-other:self-evaluate" "iss145.htm")
("eval-top-level:load-like-compile-file" "iss146.htm")
("eval-when-non-top-level:generalize-eval-new-keywords" "iss147.htm")
("eval-when-obsolete-keywords:x3j13-mar-1993" "iss148.htm")
("evalhook-step-confusion:fix" "iss149.htm")
("evalhook-step-confusion:x3j13-nov-89" "iss150.htm")
("exit-extent-and-condition-system:like-dynamic-bindings" "iss151.htm")
("exit-extent:minimal" "iss152.htm")
("expt-ratio:p.211" "iss153.htm")
("extensions-position:documentation" "iss154.htm")
("external-format-for-every-file-connection:minimum" "iss155.htm")
("extra-return-values:no" "iss156.htm")
("file-open-error:signal-file-error" "iss157.htm")
("fixnum-non-portable:tighten-definition" "iss158.htm")
("flet-declarations" "iss159.htm")
("flet-declarations:allow" "iss160.htm")
("flet-implicit-block:yes" "iss161.htm")
("float-underflow:add-variables" "iss162.htm")
("floating-point-condition-names:x3j13-nov-89" "iss163.htm")
("format-atsign-colon" "iss164.htm")
("format-colon-uparrow-scope" "iss165.htm")
("format-comma-interval" "iss166.htm")
("format-e-exponent-sign:force-sign" "iss167.htm")
("format-op-c" "iss168.htm")
("format-pretty-print:yes" "iss169.htm")
("format-string-arguments:specify" "iss170.htm")
("function-call-evaluation-order:more-unspecified" "iss171.htm")
("function-composition:jan89-x3j13" "iss172.htm")
("function-definition:jan89-x3j13" "iss173.htm")
("function-name:large" "iss174.htm")
("function-type" "iss175.htm")
("function-type-argument-type-semantics:restrictive" "iss176.htm")
("function-type-key-name:specify-keyword" "iss177.htm")
("function-type-rest-list-element:use-actual-argument-type" "iss178.htm")
("function-type:x3j13-march-88" "iss179.htm")
("generalize-pretty-printer:unify" "iss180.htm")
("generic-flet-poorly-designed:delete" "iss181.htm")
("gensym-name-stickiness:like-teflon" "iss182.htm")
("gentemp-bad-idea:deprecate" "iss183.htm")
("get-macro-character-readtable:nil-standard" "iss184.htm")
("get-setf-method-environment:add-arg" "iss185.htm")
("hash-table-access:x3j13-mar-89" "iss186.htm")
("hash-table-key-modification:specify" "iss187.htm")
("hash-table-package-generators:add-with-wrapper" "iss188.htm")
("hash-table-rehash-size-integer" "iss189.htm")
("hash-table-size:intended-entries" "iss190.htm")
("hash-table-tests:add-equalp" "iss191.htm")
("ieee-atan-branch-cut:split" "iss192.htm")
("ignore-use-terminology:value-only" "iss193.htm")
("import-setf-symbol-package" "iss194.htm")
("in-package-functionality:mar89-x3j13" "iss195.htm")
("in-syntax:minimal" "iss196.htm")
("initialization-function-keyword-checking" "iss197.htm")
("iso-compatibility:add-substrate" "iss198.htm")
("jun90-trivial-issues:11" "iss199.htm")
("jun90-trivial-issues:14" "iss200.htm")
("jun90-trivial-issues:24" "iss201.htm")
("jun90-trivial-issues:25" "iss202.htm")
("jun90-trivial-issues:27" "iss203.htm")
("jun90-trivial-issues:3" "iss204.htm")
("jun90-trivial-issues:4" "iss205.htm")
("jun90-trivial-issues:5" "iss206.htm")
("jun90-trivial-issues:9" "iss207.htm")
("keyword-argument-name-package:any" "iss208.htm")
("last-n" "iss209.htm")
("lcm-no-arguments:1" "iss210.htm")
("lexical-construct-global-definition:undefined" "iss211.htm")
("lisp-package-name:common-lisp" "iss212.htm")
("lisp-symbol-redefinition-again:more-fixes" "iss213.htm")
("lisp-symbol-redefinition:mar89-x3j13" "iss214.htm")
("load-objects:make-load-form" "iss215.htm")
("load-time-eval:r**2-new-special-form" "iss216.htm")
("load-time-eval:r**3-new-special-form" "iss217.htm")
("load-truename:new-pathname-variables" "iss218.htm")
("locally-top-level:special-form" "iss219.htm")
("loop-and-discrepancy:no-reiteration" "iss220.htm")
("loop-for-as-on-typo:fix-typo" "iss221.htm")
("loop-initform-environment:partial-interleaving-vague" "iss222.htm")
("loop-miscellaneous-repairs:fix" "iss223.htm")
("loop-named-block-nil:override" "iss224.htm")
("loop-present-symbols-typo:flush-wrong-words" "iss225.htm")
("loop-syntax-overhaul:repair" "iss226.htm")
("macro-as-function:disallow" "iss227.htm")
("macro-declarations:make-explicit" "iss228.htm")
("macro-environment-extent:dynamic" "iss229.htm")
("macro-function-environment" "iss230.htm")
("macro-function-environment:yes" "iss231.htm")
("macro-subforms-top-level-p:add-constraints" "iss232.htm")
("macroexpand-hook-default:explicitly-vague" "iss233.htm")
("macroexpand-hook-initial-value:implementation-dependent" "iss234.htm")
("macroexpand-return-value:true" "iss235.htm")
("make-load-form-confusion:rewrite" "iss236.htm")
("make-load-form-saving-slots:no-initforms" "iss237.htm")
("make-package-use-default:implementation-dependent" "iss238.htm")
("map-into:add-function" "iss239.htm")
("mapping-destructive-interaction:explicitly-vague" "iss240.htm")
("metaclass-of-system-class:unspecified" "iss241.htm")
("method-combination-arguments:clarify" "iss242.htm")
("method-initform:forbid-call-next-method" "iss243.htm")
("muffle-warning-condition-argument" "iss244.htm")
("multiple-value-setq-order:like-setf-of-values" "iss245.htm")
("multiple-values-limit-on-variables:undefined" "iss246.htm")
("nintersection-destruction" "iss247.htm")
("nintersection-destruction:revert" "iss248.htm")
("not-and-null-return-value:x3j13-mar-93" "iss249.htm")
("nth-value:add" "iss250.htm")
("optimize-debug-info:new-quality" "iss251.htm")
("package-clutter:reduce" "iss252.htm")
("package-deletion:new-function" "iss253.htm")
("package-function-consistency:more-permissive" "iss254.htm")
("parse-error-stream:split-types" "iss255.htm")
("pathname-component-case:keyword-argument" "iss256.htm")
("pathname-component-value:specify" "iss257.htm")
("pathname-host-parsing:recognize-logical-host-names" "iss258.htm")
("pathname-logical:add" "iss259.htm")
("pathname-print-read:sharpsign-p" "iss260.htm")
("pathname-stream" "iss261.htm")
("pathname-stream:files-or-synonym" "iss262.htm")
("pathname-subdirectory-list:new-representation" "iss263.htm")
("pathname-symbol" "iss264.htm")
("pathname-syntax-error-time:explicitly-vague" "iss265.htm")
("pathname-unspecific-component:new-token" "iss266.htm")
("pathname-wild:new-functions" "iss267.htm")
("peek-char-read-char-echo:first-read-char" "iss268.htm")
("plist-duplicates:allow" "iss269.htm")
("pretty-print-interface" "iss270.htm")
("princ-readably:x3j13-dec-91" "iss271.htm")
("print-case-behavior:clarify" "iss272.htm")
("print-case-print-escape-interaction:vertical-bar-rule-no-upcase"
"iss273.htm")
("print-circle-shared:respect-print-circle" "iss274.htm")
("print-circle-structure:user-functions-work" "iss275.htm")
("print-readably-behavior:clarify" "iss276.htm")
("printer-whitespace:just-one-space" "iss277.htm")
("proclaim-etc-in-compile-file:new-macro" "iss278.htm")
("push-evaluation-order:first-item" "iss279.htm")
("push-evaluation-order:item-first" "iss280.htm")
("pushnew-store-required:unspecified" "iss281.htm")
("quote-semantics:no-copying" "iss282.htm")
("range-of-count-keyword:nil-or-integer" "iss283.htm")
("range-of-start-and-end-parameters:integer-and-integer-nil" "iss284.htm")
("read-and-write-bytes:new-functions" "iss285.htm")
("read-case-sensitivity:readtable-keywords" "iss286.htm")
("read-modify-write-evaluation-order:delayed-access-stores" "iss287.htm")
("read-suppress-confusing:generalize" "iss288.htm")
("reader-error:new-type" "iss289.htm")
("real-number-type:x3j13-mar-89" "iss290.htm")
("recursive-deftype:explicitly-vague" "iss291.htm")
("reduce-argument-extraction" "iss292.htm")
("remf-destruction-unspecified:x3j13-mar-89" "iss293.htm")
("require-pathname-defaults-again:x3j13-dec-91" "iss294.htm")
("require-pathname-defaults-yet-again:restore-argument" "iss295.htm")
("require-pathname-defaults:eliminate" "iss296.htm")
("rest-list-allocation:may-share" "iss297.htm")
("result-lists-shared:specify" "iss298.htm")
("return-values-unspecified:specify" "iss299.htm")
("room-default-argument:new-value" "iss300.htm")
("self-modifying-code:forbid" "iss301.htm")
("sequence-type-length:must-match" "iss302.htm")
("setf-apply-expansion:ignore-expander" "iss303.htm")
("setf-find-class:allow-nil" "iss304.htm")
("setf-functions-again:minimal-changes" "iss305.htm")
("setf-get-default:evaluated-but-ignored" "iss306.htm")
("setf-macro-expansion:last" "iss307.htm")
("setf-method-vs-setf-method:rename-old-terms" "iss308.htm")
("setf-multiple-store-variables:allow" "iss309.htm")
("setf-of-apply:only-aref-and-friends" "iss310.htm")
("setf-of-values:add" "iss311.htm")
("setf-sub-methods:delayed-access-stores" "iss312.htm")
("shadow-already-present" "iss313.htm")
("shadow-already-present:works" "iss314.htm")
("sharp-comma-confusion:remove" "iss315.htm")
("sharp-o-foobar:consequences-undefined" "iss316.htm")
("sharp-star-delimiter:normal-delimiter" "iss317.htm")
("sharpsign-plus-minus-package:keyword" "iss318.htm")
("slot-missing-values:specify" "iss319.htm")
("slot-value-metaclasses:less-minimal" "iss320.htm")
("special-form-p-misnomer:rename" "iss321.htm")
("special-type-shadowing:clarify" "iss322.htm")
("standard-input-initial-binding:defined-contracts" "iss323.htm")
("standard-repertoire-gratuitous:rename" "iss324.htm")
("step-environment:current" "iss325.htm")
("step-minimal:permit-progn" "iss326.htm")
("stream-access:add-types-accessors" "iss327.htm")
("stream-capabilities:interactive-stream-p" "iss328.htm")
("string-coercion:make-consistent" "iss329.htm")
("string-output-stream-bashing:undefined" "iss330.htm")
("structure-read-print-syntax:keywords" "iss331.htm")
("subseq-out-of-bounds" "iss332.htm")
("subseq-out-of-bounds:is-an-error" "iss333.htm")
("subsetting-position:none" "iss334.htm")
("subtypep-environment:add-arg" "iss335.htm")
("subtypep-too-vague:clarify-more" "iss336.htm")
("sxhash-definition:similar-for-sxhash" "iss337.htm")
("symbol-macrolet-declare:allow" "iss338.htm")
("symbol-macrolet-semantics:special-form" "iss339.htm")
("symbol-macrolet-type-declaration:no" "iss340.htm")
("symbol-macros-and-proclaimed-specials:signals-an-error" "iss341.htm")
("symbol-print-escape-behavior:clarify" "iss342.htm")
("syntactic-environment-access:retracted-mar91" "iss343.htm")
("tagbody-tag-expansion:no" "iss344.htm")
("tailp-nil:t" "iss345.htm")
("test-not-if-not:flush-all" "iss346.htm")
("the-ambiguity:for-declaration" "iss347.htm")
("the-values:return-number-received" "iss348.htm")
("time-zone-non-integer:allow" "iss349.htm")
("type-declaration-abbreviation:allow-all" "iss350.htm")
("type-of-and-predefined-classes:type-of-handles-floats" "iss351.htm")
("type-of-and-predefined-classes:unify-and-extend" "iss352.htm")
("type-of-underconstrained:add-constraints" "iss353.htm")
("type-specifier-abbreviation:x3j13-jun90-guess" "iss354.htm")
("undefined-variables-and-functions:compromise" "iss355.htm")
("uninitialized-elements:consequences-undefined" "iss356.htm")
("unread-char-after-peek-char:dont-allow" "iss357.htm")
("unsolicited-messages:not-to-system-user-streams" "iss358.htm")
("variable-list-asymmetry:symmetrize" "iss359.htm")
("with-added-methods:delete" "iss360.htm")
("with-compilation-unit:new-macro" "iss361.htm")
("with-open-file-does-not-exist:stream-is-nil" "iss362.htm")
("with-open-file-setq:explicitly-vague" "iss363.htm")
("with-open-file-stream-extent:dynamic-extent" "iss364.htm")
("with-output-to-string-append-style:vector-push-extend" "iss365.htm")
("with-standard-io-syntax-readtable:x3j13-mar-91" "iss366.htm"))))
(defun common-lisp-issuex (issue-name)
(let ((entry (gethash (downcase issue-name)
common-lisp-hyperspec--issuex-symbols)))
(concat common-lisp-hyperspec-root "Issues/" entry)))
;;; Added the following just to provide a common entry point according
;;; to the various 'hyperspec' implementations.
;;;
;;; 19990820 Marco Antoniotti
(defalias 'hyperspec-lookup 'common-lisp-hyperspec)
(defalias 'hyperspec-lookup-reader-macro
'common-lisp-hyperspec-lookup-reader-macro)
(defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format)
(provide 'hyperspec)
;;; hyperspec.el ends here
;; normal-top-level-add-subdirs-to-load-path needs this file
This is the file .../info/dir, which contains the
topmost node of the Info hierarchy, called (dir)Top.
The first time you invoke Info you start off looking at this node.
File: dir, Node: Top This is the top of the INFO tree
This (the Directory node) gives a menu of major topics.
Typing "q" exits, "H" lists all Info commands, "d" returns here,
"h" gives a primer for first-timers,
"mEmacs<Return>" visits the Emacs manual, etc.
In Emacs, you can click mouse button 2 on a menu item or cross reference
to select it.
* Menu:
Emacs
* SLY: (sly). Common-Lisp IDE
This is contributors.info, produced by makeinfo version 6.7 from
contributors.texi.
Helmut Eller João Távora Luke Gorrie
Tobias C. Rittweiler Stas Boukarev Marco Baringer
Matthias Koeppe Nikodemus Siivola Alan Ruttenberg
Attila Lendvai Luís Borges de Dan Barlow
Oliveira
Andras Simon Martin Simmons Geo Carncross
Christophe Rhodes Peter Seibel Mark Evenson
Juho Snellman Douglas Crosher Wolfgang Jenkner
R Primus Javier Olaechea Edi Weitz
Zach Shaftel James Bielman Daniel Kochmanski
Terje Norderhaug Vladimir Sedach Juan Jose Garcia
Ripoll
Alexander Artemenko Spenser Truex Nathan Trapuzzano
Brian Downing Mark Jeffrey Cunningham
Espen Wiborg Paul M. Rodriguez Masataro Asai
Jan Moringen Sébastien Villemot Samuel Freilich
Raymond Toy Pierre Neidhardt Phil Hargett
Paulo Madeira Kris Katterjohn Jonas Bernoulli
Ivan Shvedunov Gábor Melis Francois-Rene Rideau
Christophe Junke Bozhidar Batsov Bart Botta
Wilfredo Tianxiang Xiong Syohei YOSHIDA
Velázquez-Rodríguez
Stefan Monnier Rommel MARTINEZ Pavel Kulyov
Paul A. Patience Olof-Joachim Frahm Mike Clarke
Michał Herda Mark H. David Mario Lang
Manfred Bergmann Leo Liu Koga Kazuo
Jon Oddie John Stracke Joe Robertson
Grant Shangreaux Graham Dobbins Eric Timmons
Douglas Katzman Dmitry Igrishin Dmitrii Korobeinikov
Deokhwan Kim Denis Budyak Chunyang Xu
Cayman Angelo Rossi Andrew Kirkpatrick
Tag Table:
End Tag Table
Local Variables:
coding: utf-8
End:
( \
\ \
/ / |\\
/ / .-`````-. / ^`-.
\ \ / \_/ {|} `o
\ \ / .---. \\ _ ,--'
\ \/ / \, \( `^^^ @@@@
\ \/\ (\ )
\ ) \ ) \ \
) /__ \__ ) (\ \___
jgs (___)))__))(__))(__)))
_,'| _.-''``-...___..--';)
/_ \'. __..-' , ,--...--'''
<\ .`--''' ` /'
fxlee `-';' ; ; ;
__...--'' ___...--_..' .;.'
(,__....----''' (,..--'' @@@@
@@@@
.
("`-''-/").___..--''"`-._
`6_ 6 ) `-. ( ).`-.__.`)
(_Y_.)' ._ ) `._ `. ``-..-'
_..`--'_..-_/ /--'_.' ,'
(il),-'' (li),' ((!.-' fxlee
@@@@
|\ _,,,---,,_
/,`.-'`' -. ;-;;,_
|,4- ) )-,_..;\ ( `'-'
'---''(_/--' `-'\_)
fxlee
@@@@
.
__..--''``\--....___ _..,_
_.-' .-/"; ` ``<._ ``-+'~=.
_.-' _..--.'_ \ `(^) )
((..-' (< _ ;_..__ ; `'
`-._,_)' ``--...____..-'
fxlee
(`.-,')
.-' ;
_.-' , `,-
fxlee _ _.-' .' /._
.' ` _.-. / ,'._;)
( . )-| (
)`,_ ,'_,' \_;) @@@@
('_ _,'.' (___,))
`-:;.-'
|\___/|
) ( . '
=\ /=
)===( *
/ \
| | @@@@
/ \
\ /
jgs_/\_/\__ _/_/\_/\_/\_/\_/\_/\_/\_/\_/\_
| | | |( ( | | | | | | | | | |
| | | | ) ) | | | | | | | | | |
| | | |(_( | | | | | | | | | |
| | | | | | | | | | | | | | |
| | | | | | | | | | | | | | |
|\___/|
=) ^Y^ (= . '
\ ^ /
)=*=( *
/ \
| |
/| | | |\ @@@@
\| | |_|/\
jgs_/\_//_// ___/\_/\_/\_/\_/\_/\_/\_/\_/\_
| | | | \_) | | | | | | | | | |
| | | | | | | | | | | | | | |
| | | | | | | | | | | | | | |
| | | | | | | | | | | | | | |
| | | | | | | | | | | | | | |
*
@@@@
. .
* _
|\___/| \\
=) ^Y^ (= |\_/| || '
\ ^ / )a a '._.-""""-. //
)=*=( =\T_= / ~ ~ \//
/ \ `"`\ ~ / ~ /
| | |~ \ | ~/
/| | | |\ \ ~/- \ ~\
\| | |_|/| || | // /`
jgs_/\_//_// __//\_/\_/\_((_|\((_//\_/\_/\_
| | | | \_) | | | | | | | | | |
| | | | | | | | | | | | | | |
| | | | | | | | | | | | | | |
| | | | | | | | | | | | | | |
| | | | | | | | | | | | | | |
*
@@@@
. .
*
|\___/| /\___/\
) ( ) ~( . '
=\ /= =\~ /=
)===( ) ~ (
/ \ / \
| | ) ~ (
/ \ / ~ \
\ / \~ ~/
jgs_/\_/\__ _/_/\_/\__~__/_/\_/\_/\_/\_/\_
| | | |( ( | | | )) | | | | | |
| | | | ) ) | | |//| | | | | | |
| | | |(_( | | (( | | | | | | |
| | | | | | | |\)| | | | | | |
| | | | | | | | | | | | | | |
*
@@@@
. .
*
/\/|_ __/\\
/ -\ /- ~\ . '
\ = Y =T_ = /
)==*(` `) ~ \
/ \ / \
| | ) ~ (
/ \ / ~ \
\ / \~ ~/
jgs_/\_/\__ _/_/\_/\__~__/_/\_/\_/\_/\_/\_
| | | | ) ) | | | (( | | | | | |
| | | |( ( | | | \\ | | | | | |
| | | | )_) | | | |))| | | | | |
| | | | | | | | (/ | | | | | |
| | | | | | | | | | | | | | |
|\_._/|
| o o |
( T )
.^`-^-'^. @@@@
`. ; .'
| | | | |
((_((|))_))
hjw
|,\__/|
| o o|
( T ) @@@@
.^`--^'^.
`. ; .'
| | | | |
((_((|))_))
hjw
|\__/,|
|o o |
( T )
.^`^--'^. @@@@
`. ; .'
| | | | |
((_((|))_))
hjw
|\_._/|
| 0 0 |
( T ) @@@@
.^`-^-'^.
`. ; .'
| | | | |
((_((|))_))
hjw
(defpackage :slynk-trace-dialog
(:use :cl :slynk-api)
(:export #:clear-trace-tree
#:dialog-toggle-trace
#:dialog-trace
#:dialog-traced-p
#:dialog-untrace
#:dialog-untrace-all
#:inspect-trace-part
#:report-partial-tree
#:report-specs
#:report-total
#:report-specs
#:trace-format
#:still-inside
#:exited-non-locally
#:*record-backtrace*
#:*traces-per-report*
#:*dialog-trace-follows-trace*
#:instrument
#:pprint-trace-part
#:describe-trace-part
#:trace-part-or-lose
#:inspect-trace
#:trace-or-lose
#:trace-arguments-or-lose
#:trace-location))
(in-package :slynk-trace-dialog)
(defparameter *record-backtrace* nil
"Record a backtrace of the last 20 calls for each trace.
Beware that this may have a drastic performance impact on your
program.")
(defparameter *traces-per-report* 150
"Number of traces to report to emacs in each batch.")
(defparameter *dialog-trace-follows-trace* nil)
(defvar *traced-specs* '())
(defparameter *visitor-idx* 0)
(defparameter *visitor-key* nil)
(defvar *unfinished-traces* '())
;;;; `trace-entry' model
;;;;
(defvar *traces* (make-array 1000 :fill-pointer 0
:adjustable t))
(defvar *trace-lock* (slynk-backend:make-lock :name "slynk-trace-dialog lock"))
(defvar *current-trace-by-thread* (make-hash-table))
(defclass trace-entry ()
((id :reader id-of)
(children :accessor children-of :initform nil)
(backtrace :accessor backtrace-of :initform (when *record-backtrace*
(useful-backtrace)))
(spec :initarg :spec :accessor spec-of
:initform (error "must provide a spec"))
(function :initarg :function :accessor function-of)
(args :initarg :args :reader args-of
:initform (error "must provide args"))
(printed-args)
(parent :initarg :parent :reader parent-of
:initform (error "must provide a parent, even if nil"))
(retlist :initarg :retlist :accessor retlist-of
:initform 'still-inside)
(printed-retlist :initform ":STILL-INSIDE")))
(defmethod initialize-instance :after ((entry trace-entry) &key)
(with-slots (parent id printed-args args) entry
(if parent
(nconc (children-of parent) (list entry)))
(setf printed-args
(mapcar (lambda (arg)
(present-for-emacs arg #'slynk-pprint-to-line))
args))
(slynk-backend:call-with-lock-held
*trace-lock*
#'(lambda ()
(setf (slot-value entry 'id) (fill-pointer *traces*))
(vector-push-extend entry *traces*)))))
(defmethod print-object ((entry trace-entry) stream)
(print-unreadable-object (entry stream)
(format stream "~a=~a" (id-of entry) (spec-of entry))))
(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside)))
(defun trace-arguments (trace-id)
(values-list (args-of (trace-or-lose trace-id))))
(defun useful-backtrace ()
(slynk-backend:call-with-debugging-environment
#'(lambda ()
(loop for i from 0
for frame in (slynk-backend:compute-backtrace 0 20)
collect (list i (slynk::frame-to-string frame))))))
(defun current-trace ()
(gethash (slynk-backend:current-thread) *current-trace-by-thread*))
(defun (setf current-trace) (trace)
(setf (gethash (slynk-backend:current-thread) *current-trace-by-thread*)
trace))
;;;; Helpers
;;;;
(defun describe-trace-for-emacs (trace)
(with-slots (id args parent spec printed-args retlist printed-retlist) trace
`(,id
,(and parent (id-of parent))
,(cons (string-downcase (present-for-emacs spec)) spec)
,(loop for arg in args
for printed-arg in printed-args
for i from 0
collect (list i printed-arg))
,(loop for retval in (slynk::ensure-list retlist)
for printed-retval in (slynk::ensure-list printed-retlist)
for i from 0
collect (list i printed-retval)))))
;;;; slyfuns
;;;;
(defslyfun trace-format (format-spec &rest format-args)
"Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace."
(let* ((line (apply #'format nil format-spec format-args)))
(make-instance 'trace-entry :spec line
:args format-args
:parent (current-trace)
:retlist nil)))
(defslyfun trace-or-lose (id)
(when (<= 0 id (1- (length *traces*)))
(or (aref *traces* id)
(error "No trace with id ~a" id))))
(defslyfun report-partial-tree (key)
(unless (equal key *visitor-key*)
(setq *visitor-idx* 0
*visitor-key* key))
(let* ((recently-finished
(loop with i = 0
for trace in *unfinished-traces*
while (< i *traces-per-report*)
when (completed-p trace)
collect trace
and do
(incf i)
(setq *unfinished-traces*
(remove trace *unfinished-traces*))))
(new (loop for i
from (length recently-finished)
below *traces-per-report*
while (< *visitor-idx* (length *traces*))
for trace = (aref *traces* *visitor-idx*)
collect trace
unless (completed-p trace)
do (push trace *unfinished-traces*)
do (incf *visitor-idx*))))
(list
(mapcar #'describe-trace-for-emacs
(append recently-finished new))
(- (length *traces*) *visitor-idx*)
key)))
(defslyfun report-specs ()
(mapcar (lambda (spec)
(cons (string-downcase (present-for-emacs spec))
spec))
(sort (copy-list *traced-specs*)
#'string<
:key #'princ-to-string)))
(defslyfun report-total ()
(length *traces*))
(defslyfun clear-trace-tree ()
(setf *current-trace-by-thread* (clrhash *current-trace-by-thread*)
*visitor-key* nil
*unfinished-traces* nil)
(slynk-backend:call-with-lock-held
*trace-lock*
#'(lambda () (setf (fill-pointer *traces*) 0)))
nil)
(defslyfun trace-part-or-lose (id part-id type)
(let* ((trace (trace-or-lose id))
(l (ecase type
(:arg (args-of trace))
(:retval (slynk::ensure-list (retlist-of trace))))))
(or (nth part-id l)
(error "Cannot find a trace part with id ~a and part-id ~a"
id part-id))))
(defslyfun trace-arguments-or-lose (trace-id)
(values-list (args-of (trace-or-lose trace-id))))
(defslyfun inspect-trace-part (trace-id part-id type)
(slynk::inspect-object
(trace-part-or-lose trace-id part-id type)))
(defslyfun pprint-trace-part (trace-id part-id type)
(slynk::slynk-pprint (list (trace-part-or-lose trace-id part-id type))))
(defslyfun describe-trace-part (trace-id part-id type)
(slynk::describe-to-string (trace-part-or-lose trace-id part-id type)))
(defslyfun inspect-trace (trace-id)
(slynk::inspect-object (trace-or-lose trace-id)))
(defslyfun trace-location (trace-id)
(slynk-backend:find-source-location (function-of (trace-or-lose trace-id))))
(defslyfun dialog-trace (spec)
(let ((function nil))
(flet ((before-hook (args)
(setf (current-trace) (make-instance 'trace-entry
:spec spec
:function (or function
spec)
:args args
:parent (current-trace))))
(after-hook (returned-values)
(let ((trace (current-trace)))
(when trace
(with-slots (retlist parent printed-retlist) trace
;; the current trace might have been wiped away if the
;; user cleared the tree in the meantime. no biggie,
;; don't do anything.
;;
(setf retlist returned-values
printed-retlist
(mapcar (lambda (obj)
(present-for-emacs obj #'slynk-pprint-to-line))
(slynk::ensure-list retlist))
(current-trace) parent))))))
(when (dialog-traced-p spec)
(warn "~a is apparently already traced! Untracing and retracing." spec)
(dialog-untrace spec))
(setq function
(slynk-backend:wrap spec 'trace-dialog
:before #'before-hook
:after #'after-hook))
(pushnew spec *traced-specs*)
(format nil "~a is now traced for trace dialog" spec))))
(defslyfun dialog-untrace (spec)
(with-simple-restart
(continue "Never mind, i really want this trace to go away")
(slynk-backend:unwrap spec 'trace-dialog))
(setq *traced-specs* (remove spec *traced-specs* :test #'equal))
(format nil "~a is now untraced for trace dialog" spec))
(defslyfun dialog-toggle-trace (spec)
(if (dialog-traced-p spec)
(dialog-untrace spec)
(dialog-trace spec)))
(defslyfun dialog-traced-p (spec)
(find spec *traced-specs* :test #'equal))
(defslyfun dialog-untrace-all ()
(let ((regular (length (trace)))
(dialog (length *traced-specs*)))
(untrace)
(mapcar #'dialog-untrace *traced-specs*)
(cons regular dialog)))
;;;; Hook onto emacs
;;;;
(setq slynk:*after-toggle-trace-hook*
#'(lambda (spec traced-p)
(when *dialog-trace-follows-trace*
(cond (traced-p
(dialog-trace spec)
"traced for trace dialog as well")
(t
(dialog-untrace spec)
"untraced for the trace dialog as well")))))
;;;; Instrumentation
;;;;
(defmacro instrument (x &optional (id (gensym "EXPLICIT-INSTRUMENT-")) )
(let ((values-sym (gensym)))
`(let ((,values-sym (multiple-value-list ,x)))
(trace-format (format nil "~a: ~a" ',id "~a => ~{~a~^, ~}") ',x
,values-sym)
(values-list ,values-sym))))
(provide :slynk/trace-dialog)
(defpackage :slynk-stickers
(:use :cl :slynk-api)
(:import-from :slynk-backend :slynk-compile-string)
(:import-from :slynk :defslyfun :compile-string-for-emacs)
(:export #:record
#:compile-for-stickers
#:kill-stickers
#:inspect-sticker
#:inspect-sticker-recording
#:fetch
#:forget
#:total-recordings
#:find-recording-or-lose
#:search-for-recording
#:toggle-break-on-stickers
#:*break-on-stickers*))
(in-package :slynk-stickers)
(defvar *next-recording-id* 0)
(defclass recording ()
((id :initform (incf *next-recording-id*) :accessor id-of)
(ctime :initform (common-lisp:get-universal-time) :accessor ctime-of)
(sticker :initform (error "required") :initarg :sticker :accessor sticker-of)
(values :initform (error "required") :initarg :values :accessor values-of)
(condition :initarg :condition :accessor condition-of)))
(defmethod initialize-instance :after ((x recording) &key sticker)
(push x (recordings-of sticker))
(vector-push-extend x *recordings*))
(defun recording-description-string (recording
&optional stream print-first-value)
(let ((values (values-of recording))
(condition (condition-of recording)))
(cond (condition
(format stream "exited non-locally with: ~a"
(present-for-emacs condition)))
((eq values 'exited-non-locally)
(format stream "exited non-locally"))
((listp values)
(if (and print-first-value
values)
(format stream "~a" (present-for-emacs (car values)))
(format stream "~a values" (length values))))
(t
(format stream "corrupt recording")))))
(defmethod print-object ((r recording) s)
(print-unreadable-object (r s :type t)
(recording-description-string r s)))
(defclass sticker ()
((id :initform (error "required") :initarg :id :accessor id-of)
(hit-count :initform 0 :accessor hit-count-of)
(recordings :initform nil :accessor recordings-of)
(ignore-spec :initform nil :accessor ignore-spec-of)))
(defmethod print-object ((sticker sticker) s)
(print-unreadable-object (sticker s :type t)
(format s "id=~a hit-count=~a" (id-of sticker) (hit-count-of sticker))))
(defun exited-non-locally-p (recording)
(when (or (condition-of recording)
(eq (values-of recording) 'exited-non-locally))
t))
;; FIXME: This won't work for multiple connected SLY clients. A
;; channel, or some connection specific structure, is needed for that.
;;
(defvar *stickers* (make-hash-table))
(defvar *recordings* (make-array 0 :fill-pointer 0 :adjustable t))
(defvar *visitor* nil)
(defslyfun compile-for-stickers (new-stickers
dead-stickers
instrumented-string
original-string
buffer
position
filename
policy)
"Considering NEW-STICKERS, compile INSTRUMENTED-STRING.
INSTRUMENTED-STRING is exerpted from BUFFER at POSITION. BUFFER may be
associated with FILENAME. DEAD-STICKERS if any, are killed. If
compilation succeeds, return a list (NOTES T).
If ORIGINAL-STRING, if non-nil, is compiled as a fallback if the
previous compilation. In this case a list (NOTES NIL) is returned or
an error is signalled.
If ORIGINAL-STRING is not supplied and compilation of
INSTRUMENTED-STRING fails, return NIL.
New stickers for NEW-STICKERS are registered in *STICKERS* and
stickers in DEAD-STICKERS are killed. NEW-STICKERS are not necessarily
\"new\" in the sense that the ids are not assigned by Slynk, but
their ignore-spec is reset nonetheless."
;; Dead stickers are unconditionally removed from *stickers*
;;
(kill-stickers dead-stickers)
(let ((probe
(handler-case
(compile-string-for-emacs instrumented-string
buffer
position
filename
policy)
(error () nil))))
(cond (;; a non-nil and successful compilation result
(and probe
(third probe))
;; new objects for NEW-STICKERS are created
(loop for id in new-stickers
do (setf (gethash id *stickers*)
(make-instance 'sticker :id id)))
(list probe t))
(original-string
(list (compile-string-for-emacs
original-string buffer position filename policy)
nil)))))
(defslyfun kill-stickers (ids)
(loop for id in ids
do (remhash id *stickers*)))
(define-condition sticker-related-condition (condition)
((sticker :initarg :sticker :initform (error "~S is required" 'sticker)
:accessor sticker-of)
(debugger-extra-options :initarg :debugger-extra-options
:accessor debugger-extra-options-of)))
(define-condition just-before-sticker (sticker-related-condition)
()
(:report (lambda (c stream)
(with-slots (sticker) c
(print-unreadable-object (c stream)
(format stream "JUST BEFORE ~a" sticker))))))
(define-condition right-after-sticker (sticker-related-condition)
((recording :initarg :recording :accessor recording-of))
(:report (lambda (c stream)
(with-slots (sticker recording) c
(print-unreadable-object (c stream)
(format stream "RIGHT-AFTER ~a (recorded ~a)"
sticker
recording))))))
(defparameter *break-on-stickers* nil
"If non-nil, invoke to debugger when evaluating stickered forms.
If a list containing :BEFORE, break before evaluating. If a list
containing :AFTER, break after evaluating. If t, break before and
after.")
(defslyfun toggle-break-on-stickers ()
"Toggle the value of *BREAK-ON-STICKERS*"
(setq *break-on-stickers* (not *break-on-stickers*)))
(defun invoke-debugger-for-sticker (sticker condition)
(restart-case
(let ((*debugger-extra-options*
(append (debugger-extra-options-of condition)
*debugger-extra-options*)))
(invoke-debugger condition))
(continue () :report "OK, continue")
(ignore-this-sticker ()
:report "Stop bothering me about this sticker"
:test (lambda (c)
(cond ((null c)
;; test functions will often be called without
;; conditions.
t)
((typep c 'sticker-related-condition)
(and (eq (sticker-of c) sticker)
*break-on-stickers*))
(t
nil)))
(setf (ignore-spec-of sticker)
(list :before :after)))))
(defun break-on-sticker-p (sticker when)
(and (or (eq t *break-on-stickers*)
(and (listp *break-on-stickers*)
(member when *break-on-stickers*)))
(not (member when (ignore-spec-of sticker)))))
(defun call-with-sticker-recording (id fn)
(let* ((sticker (gethash id *stickers*))
(mark (gensym))
(retval mark)
(last-condition)
(recording))
(handler-bind ((condition (lambda (condition)
(setq last-condition condition))))
;; Maybe break before
;;
(when sticker
(incf (hit-count-of sticker))
(when (break-on-sticker-p sticker :before)
(invoke-debugger-for-sticker
sticker (make-condition 'just-before-sticker
:sticker sticker
:debugger-extra-options
`((:slynk-before-sticker ,id))))))
;; Run actual code under the sticker
;;
(unwind-protect
(values-list (setq retval (multiple-value-list (funcall fn))))
(when sticker
;; Always make a recording...
;;
(setq recording
(make-instance 'recording
:sticker sticker
:values (if (eq mark retval)
'exited-non-locally
retval)
:condition (and (eq mark retval)
last-condition)))
;; ...and then maybe break after.
(when (break-on-sticker-p sticker :after)
(invoke-debugger-for-sticker
sticker
(make-condition 'right-after-sticker
:sticker sticker
:recording recording
:debugger-extra-options
`((:slynk-after-sticker
,(describe-sticker-for-emacs
sticker recording)))))))))))
(defmacro record (id &rest body)
`(call-with-sticker-recording ,id (lambda () ,@body)))
(define-setf-expander record (x &environment env)
(declare (ignore x env))
(error "Sorry, not allowing ~S for ~S" 'setf 'record))
(defun search-for-recording-1 (from &key
ignore-p
increment)
"Return two values: a RECORDING and its position in *RECORDINGS*.
Start searching from position FROM, an index in *RECORDINGS* which is
successibely increased by INCREMENT before using that to index
*RECORDINGS*."
(loop for starting-position in `(,from ,(if (plusp increment)
-1
(length *recordings*)))
;; this funky scheme has something to do with rollover
;; semantics probably
;;
for inc in `(,increment ,(if (plusp increment) 1 -1))
for (rec idx) = (loop for cand-idx = (incf starting-position
inc)
while (< -1 cand-idx (length *recordings*))
for recording = (aref *recordings* cand-idx)
for sid = (id-of (sticker-of recording))
unless (funcall ignore-p sid)
return (list recording cand-idx))
when rec
return (values rec idx)))
(defun describe-recording-for-emacs (recording)
"Describe RECORDING as (ID CTIME VALUE-DESCRIPTIONS EXITED-NON-LOCALLY-P).
ID is a number. CTIME is the creation time, given by
CL:GET-UNIVERSAL-TIME VALUE-DESCRIPTIONS is a list of
strings. EXITED-NON-LOCALLY-P is an integer."
(list
(id-of recording)
(ctime-of recording)
(and (listp (values-of recording))
(loop for value in (values-of recording)
collect (slynk-api:present-for-emacs value)))
(exited-non-locally-p recording)))
(defun describe-sticker-for-emacs (sticker &optional recording)
"Describe STICKER and either its latest recording or RECORDING.
Returns a list (ID NRECORDINGS . RECORDING-DESCRIPTION).
RECORDING-DESCRIPTION is as given by DESCRIBE-RECORDING-FOR-EMACS."
(let* ((recordings (recordings-of sticker))
(recording (or recording
(first recordings))))
(list* (id-of sticker)
(length recordings)
(and recording
(describe-recording-for-emacs recording)))))
(defslyfun total-recordings ()
"Tell how many recordings in *RECORDINGS*" (length *recordings*))
(defslyfun search-for-recording (key ignored-ids ignore-zombies-p dead-stickers index
&optional command)
"Visit the next recording for the visitor KEY.
IGNORED-IDS is a list of sticker IDs to ignore. IGNORE-ZOMBIES-P is
non-nil if recordings for dead stickers should also be ignored.
Kill any stickers in DEAD-STICKERS.
INDEX is an integer designating a recording to move the playhead
to. If COMMAND is nil, INDEX is taken relative to the current
playhead and the search jumps over recordings of stickers in
IGNORE-SPEC. If it is a number, search for the INDEXth recording
of sticker with that ID. Otherwise, jump directly to the INDEXth
recording.
If a recording can be found return a list (LAST-RECORDING-ID
ABSOLUTE-INDEX . STICKER-DESCRIPTION). ABSOLUTE-INDEX is the position
of recording in the global *RECORDINGS* array. STICKER-DESCRIPTION is
as given by DESCRIBE-STICKER-FOR-EMACS.
Otherwise returns a list (NIL ERROR-DESCRIPTION)"
(kill-stickers dead-stickers)
(unless (and *visitor*
(eq key (car *visitor*)))
(setf *visitor* (cons key -1)))
(multiple-value-bind (recording absolute-index)
(cond
((zerop (length *recordings*))
nil)
((and command
(not (numberp command)))
(let ((absolute-index (mod index
(length *recordings*))))
(values (aref *recordings* absolute-index)
absolute-index)))
(t
(search-for-recording-1
(cdr *visitor*)
:increment index
:ignore-p
(if (numberp command)
(lambda (sid)
(not (= sid command)))
(lambda (sid)
(or (member sid ignored-ids)
(and
ignore-zombies-p
(not (gethash sid *stickers*)))))))))
(cond (recording
(setf (cdr *visitor*) absolute-index)
(list* (length *recordings*)
absolute-index
(describe-sticker-for-emacs (sticker-of recording) recording)))
(t
(list nil "No recording matches that criteria")))))
(defslyfun fetch (dead-stickers)
"Describe each known sticker to Emacs.
As always, take the opportunity to kill DEAD-STICKERS"
(kill-stickers dead-stickers)
(loop for sticker being the hash-values of *stickers*
collect (describe-sticker-for-emacs sticker)))
(defslyfun forget (dead-stickers &optional howmany)
"Forget HOWMANY sticker recordings.
Return number of remaining recordings"
(kill-stickers dead-stickers)
(maphash (lambda (id sticker)
(declare (ignore id))
(setf (recordings-of sticker) nil))
*stickers*)
(cond ((null howmany)
(setf *recordings* (make-array 0 :fill-pointer 0 :adjustable t)))
(t
(check-type howmany number)
(let ((remaining (- (length *recordings*)
howmany)))
(assert (not (minusp remaining)))
(setf *recordings*
(make-array remaining
:adjustable t
:fill-pointer t
:initial-contents (subseq *recordings*
howmany))))))
(length *recordings*))
(defslyfun find-recording-or-lose (recording-id vindex)
(let ((recording (find recording-id *recordings* :key #'id-of)))
(if vindex
(elt (values-of recording) vindex)
(values-list (values-of recording)))))
(defun find-sticker-or-lose (id)
(let ((probe (gethash id *stickers* :unknown)))
(if (eq probe :unknown)
(error "Cannot find sticker ~a" id)
probe)))
(defslyfun inspect-sticker (sticker-id)
(let ((sticker (find-sticker-or-lose sticker-id)))
(slynk::inspect-object sticker)))
(defslyfun inspect-sticker-recording (recording-id vindex)
(let ((recording (find-recording-or-lose recording-id vindex)))
(slynk::inspect-object recording)))
(provide 'slynk/stickers)
(defpackage :slynk-retro
(:use :cl :slynk :slynk-api))
(in-package :slynk-retro)
(defun ensure-slynk-package-nicknames (&rest ignored)
"Nickname all SLYNK-* package to SWANK-*"
(declare (ignore ignored))
(loop for package in (list-all-packages)
for package-name = (package-name package)
when (search "SLYNK" package-name :test #'char-equal)
do (rename-package package
package-name
(remove-duplicates
(cons
(format nil "SWANK~a"
(subseq package-name 5))
(package-nicknames package))
:test #'string-equal))))
(defun load-swankrcs-maybe ()
(find-if (lambda (homedir-file)
(load (merge-pathnames (user-homedir-pathname)
homedir-file)
:if-does-not-exist nil))
(list (make-pathname :name ".swank" :type "lisp")
(make-pathname :name ".swankrc"))))
(setq slynk-rpc:*translating-swank-to-slynk* nil)
(push #'ensure-slynk-package-nicknames
slynk-api:*slynk-require-hook*)
(ensure-slynk-package-nicknames)
;;; Take this chance to load ~/.swank.lisp and ~/.swankrc if no
;;; ~/.slynk.lisp or ~/.slynkrc have already been loaded.
;;;
(unless slynk-api:*loaded-user-init-file*
(setq slynk-api:*loaded-user-init-file*
(load-swankrcs-maybe)))
(provide :slynk/retro)
(defpackage :slynk-profiler
(:use :cl)
(:import-from :slynk :defslyfun :from-string :to-string)
(:export #:toggle-timing
#:untime-spec
#:clear-timing-tree
#:untime-all
#:timed-spec-p
#:time-spec))
(in-package :slynk-profiler)
(defvar *timing-lock* (slynk-backend:make-lock :name "slynk-timings lock"))
(defvar *current-timing* nil)
(defvar *timed-spec-lists* (make-array 10
:fill-pointer 0
:adjustable t))
(defun started-timing ())
(defmethod timed-specs ()
(aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*))))
(defmethod (setf timed-specs) (value)
(setf (aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*))) value))
(defclass timing ()
((parent :reader parent-of :initform *current-timing* )
(origin :initarg :origin :reader origin-of
:initform (error "must provide an ORIGIN for this TIMING"))
(start :reader start-of :initform (get-internal-real-time))
(end :accessor end-of :initform nil)))
(defclass timed-spec ()
((spec :initarg :spec :accessor spec-of
:initform (error "must provide a spec"))
(stats :accessor stats-of)
(total :accessor total-of)
(subtimings :accessor subtimings-of)
(owntimings :accessor owntimings-of)))
(defun get-singleton-create (spec)
(let ((existing (find spec (timed-specs) :test #'equal :key #'spec-of)))
(if existing
(reinitialize-instance existing)
(let ((new (make-instance 'timed-spec :spec spec)))
(push new (timed-specs))
new))))
(defmethod shared-initialize :after ((ts timed-spec) slot-names &rest initargs)
(declare (ignore slot-names))
(setf (stats-of ts) (make-hash-table)
(total-of ts) 0
(subtimings-of ts) nil
(owntimings-of ts) nil)
(loop for otherts in (remove ts (timed-specs))
do (setf (gethash ts (stats-of otherts)) 0)
(setf (gethash otherts (stats-of ts)) 0)))
(defmethod initialize-instance :after ((tm timing) &rest initargs)
(declare (ignore initargs))
(push tm (owntimings-of (origin-of tm)))
(let ((parent (parent-of tm)))
(when parent
(push tm (subtimings-of (origin-of parent))))))
(defmethod (setf end-of) :after (value (tm timing))
(let* ((parent (parent-of tm))
(parent-origin (and parent (origin-of parent)))
(origin (origin-of tm))
(tm1 (pop (owntimings-of origin)))
(tm2 (and parent
(pop (subtimings-of parent-origin))))
(delta (- value (start-of tm))))
(assert (eq tm tm1) nil "Hmm something's gone wrong in the owns")
(assert (or (null tm2)
(eq tm tm2)) nil "Something's gone wrong in the subs")
(when (null (owntimings-of origin))
(incf (total-of origin) delta))
(when (and parent-origin
(null (subtimings-of parent-origin)))
(incf (gethash origin (stats-of parent-origin))
delta))))
(defmethod duration ((tm timing))
(/ (- (or (end-of tm)
(get-internal-real-time))
(start-of tm))
internal-time-units-per-second))
(defmethod print-object ((tm timing) stream)
(print-unreadable-object (tm stream :type t :identity t)
(format stream "~a: ~f~a"
(spec-of (origin-of tm))
(duration tm)
(if (not (end-of tm)) "(unfinished)" ""))))
(defmethod print-object ((e timed-spec) stream)
(print-unreadable-object (e stream :type t)
(format stream "~a ~fs" (spec-of e)
(/ (total-of e)
internal-time-units-per-second))))
(defslyfun time-spec (spec)
(when (timed-spec-p spec)
(warn "~a is apparently already timed! Untiming and retiming." spec)
(untime-spec spec))
(let ((timed-spec (get-singleton-create spec)))
(flet ((before-hook (args)
(declare (ignore args))
(setf *current-timing*
(make-instance 'timing :origin timed-spec)))
(after-hook (retlist)
(declare (ignore retlist))
(let* ((timing *current-timing*))
(when timing
(setf (end-of timing) (get-internal-real-time))
(setf *current-timing* (parent-of timing))))))
(slynk-backend:wrap spec 'timings
:before #'before-hook
:after #'after-hook)
(format nil "~a is now timed for timing dialog" spec))))
(defslyfun untime-spec (spec)
(slynk-backend:unwrap spec 'timings)
(let ((moribund (find spec (timed-specs) :test #'equal :key #'spec-of)))
(setf (timed-specs) (remove moribund (timed-specs)))
(loop for otherts in (timed-specs)
do (remhash moribund (stats-of otherts))))
(format nil "~a is now untimed for timing dialog" spec))
(defslyfun toggle-timing (spec)
(if (timed-spec-p spec)
(untime-spec spec)
(time-spec spec)))
(defslyfun timed-spec-p (spec)
(find spec (timed-specs) :test #'equal :key #'spec-of))
(defslyfun untime-all ()
(mapcar #'untime-spec (timed-specs)))
;;;; Reporting to emacs
;;;
(defun describe-timing-for-emacs (timed-spec)
(declare (ignore timed-spec))
`not-implemented)
(defslyfun report-latest-timings ()
(loop for spec in (timed-specs)
append (loop for partial being the hash-values of (stats-of spec)
for path being the hash-keys of (stats-of spec)
collect (list (slynk-api:slynk-pprint-to-line spec) partial
(slynk-api:slynk-pprint-to-line path)))))
(defun print-tree ()
(loop for ts in (timed-specs)
for total = (total-of ts)
do (format t "~%~a~%~%" ts)
(when (plusp total)
(loop for partial being the hash-values of (stats-of ts)
for path being the hash-keys of (stats-of ts)
when (plusp partial)
sum partial into total-partials
and
do (format t " ~8fs ~4f% ~a ~%"
(/ partial
internal-time-units-per-second)
(* 100 (/ partial
total))
(spec-of path))
finally
(format t " ~8fs ~4f% ~a ~%"
(/ (- total total-partials)
internal-time-units-per-second)
(* 100 (/ (- total total-partials)
total))
'other)))))
(defslyfun clear-timing-tree ()
(setq *current-timing* nil)
(loop for ts in (timed-specs)
do (reinitialize-instance ts)))
(provide :slynk/profiler)
(in-package :slynk)
(defslyfun package= (string1 string2)
(let* ((pkg1 (guess-package string1))
(pkg2 (guess-package string2)))
(and pkg1 pkg2 (eq pkg1 pkg2))))
(defslyfun export-symbol-for-emacs (symbol-str package-str)
(let ((package (guess-package package-str)))
(when package
(let ((*buffer-package* package))
(export `(,(from-string symbol-str)) package)))))
(defslyfun import-symbol-for-emacs (symbol-str
destination-package-str
origin-package-str)
(let ((destination (guess-package destination-package-str))
(origin (guess-package origin-package-str)))
(when (and destination origin)
(let* ((*buffer-package* origin)
(symbol (from-string symbol-str)))
(when symbol
(import symbol destination))))))
(defslyfun unexport-symbol-for-emacs (symbol-str package-str)
(let ((package (guess-package package-str)))
(when package
(let ((*buffer-package* package))
(unexport `(,(from-string symbol-str)) package)))))
#+sbcl
(defun list-structure-symbols (name)
(let ((dd (sb-kernel:find-defstruct-description name )))
(list* name
(sb-kernel:dd-default-constructor dd)
(sb-kernel:dd-predicate-name dd)
(sb-kernel::dd-copier-name dd)
(mapcar #'sb-kernel:dsd-accessor-name
(sb-kernel:dd-slots dd)))))
#+ccl
(defun list-structure-symbols (name)
(let ((definition (gethash name ccl::%defstructs%)))
(list* name
(ccl::sd-constructor definition)
(ccl::sd-refnames definition))))
(defun list-class-symbols (name)
(let* ((class (find-class name))
(slots (slynk-mop:class-direct-slots class)))
(labels ((extract-symbol (name)
(if (and (consp name) (eql (car name) 'setf))
(cadr name)
name))
(slot-accessors (slot)
(nintersection (copy-list (slynk-mop:slot-definition-readers slot))
(copy-list (slynk-mop:slot-definition-readers slot))
:key #'extract-symbol)))
(list* (class-name class)
(mapcan #'slot-accessors slots)))))
(defslyfun export-structure (name package)
(let ((*package* (guess-package package)))
(when *package*
(let* ((name (from-string name))
(symbols (cond #+(or sbcl ccl)
((or (not (find-class name nil))
(subtypep name 'structure-object))
(list-structure-symbols name))
(t
(list-class-symbols name)))))
(export symbols)
symbols))))
(provide :slynk/package-fu)
;;; slynk-mrepl.lisp
;;
;; Licence: public domain
(defpackage :slynk-mrepl
(:use :cl :slynk-api)
(:import-from :slynk
#:*globally-redirect-io*
#:*use-dedicated-output-stream*
#:*dedicated-output-stream-port*
#:*dedicated-output-stream-buffering*)
(:export #:create-mrepl
#:globally-save-object
#:eval-for-mrepl
#:sync-package-and-default-directory
#:pprint-entry
#:inspect-entry
#:guess-and-set-package
#:copy-to-repl
#:describe-entry
#:send-prompt
#:copy-to-repl-in-emacs))
(in-package :slynk-mrepl)
;;; MREPL models
(defclass mrepl (channel listener)
((remote-id :initarg :remote-id :accessor mrepl-remote-id)
(mode :initform :eval :accessor mrepl-mode)
(pending-errors :initform nil :accessor mrepl-pending-errors))
(:documentation "A listener implemented in terms of a channel.")
(:default-initargs
:initial-env (copy-tree ; github#626
`((cl:*package* . ,cl:*package*)
(cl:*default-pathname-defaults*
. ,cl:*default-pathname-defaults*)
(*) (**) (***)
(/) (//) (///)
(+) (++) (+++)
(*history* . ,(make-array 40 :fill-pointer 0
:adjustable t))))))
(defmethod print-object ((r mrepl) stream)
(print-unreadable-object (r stream :type t)
(format stream "mrepl-~a-~a" (channel-id r) (mrepl-remote-id r))))
(defmethod initialize-instance :before ((r mrepl) &key)
(setf (slot-value r 'slynk::in) (make-mrepl-input-stream r)))
;;; Helpers
;;;
(defvar *history* nil)
(defvar *saved-objects* nil)
(defmethod slynk::drop-unprocessed-events ((r mrepl))
"Empty REPL of events, then send prompt to Emacs."
;; FIXME: Dropping events should be moved to the library, and this
;; :DROP nonsense dropped, hence the deliberate SLYNK::.
(with-slots (mode) r
(let ((old-mode mode))
(setf mode :drop)
(unwind-protect
(process-requests t)
(setf mode old-mode)))))
(defun mrepl-get-history-entry (entry-idx)
(let ((len (length *history*)))
(assert (and entry-idx
(integerp entry-idx)
(< -1 entry-idx len))
nil
"Illegal history entry ~a for ~a-long history"
entry-idx
len)
(aref *history* entry-idx)))
(defun mrepl-get-object-from-history (entry-idx &optional value-idx)
(let* ((entry (mrepl-get-history-entry entry-idx))
(len (length entry)))
(assert (or (not value-idx)
(and (integerp value-idx)
(< -1 value-idx len)))
nil
"History entry ~a is only ~a elements long."
entry-idx
len
value-idx)
(if (numberp value-idx)
(nth value-idx entry)
(values-list entry))))
(defparameter *backreference-character* #\v
"Character used for #v<entry>:<value> backreferences in the REPL.
Set this to some other value if it conflicts with some other reader
macro that you wish to use in the REPL.
Set this to NIL to turn this feature off.")
(defun backreference-reader (stream subchar arg)
"Reads #rfoo:bar into (MREPL-GET-OBJECT-FROM-HISTORY foo bar)."
(declare (ignore subchar arg))
(let* ((*readtable*
(let ((table (copy-readtable nil)))
(set-macro-character #\: (lambda (&rest args) nil) nil table)
table))
(entry-idx
(progn
(when (eq #\: (peek-char nil stream nil nil))
(error 'reader-error
:stream stream
:format-control "~a found in unexpected place in ~a"
:format-arguments `(#\: backreference-reader)))
(read-preserving-whitespace stream)))
(value-idx (progn
(and (eq #\: (peek-char nil stream nil nil))
(read-char stream)
(read stream)))))
`(mrepl-get-object-from-history
,entry-idx ,value-idx)))
#+nil
(defun backreference-reader-tests ()
(let ((expectations
'(("#v:something" error)
("#vnotanumber:something" (notanumber something))
("#vnotanumber" (notanumber nil))
("#v2 :something" (2 nil) :something)
("#v2:99 :something-else" (2 99) :something-else)))
(*readtable* (let ((table (copy-readtable)))
(if *backreference-character*
(set-dispatch-macro-character
#\#
*backreference-character*
#'backreference-reader table))
table)))
(loop for (input expected-spec following) in expectations
collect
(handler-case
(progn
(with-input-from-string (s input)
(let* ((observed (read s))
(expected
(progn
(if (eq 'error expected-spec )
(error "oops, ~a was supposed to have errored, but returned ~a"
input observed))
`(mrepl-get-object-from-history ,@expected-spec)))
(observed-second (and following
(read s))))
(unless (equal observed expected)
(error "oops, ~a was supposed to have returned ~a, but returned ~a"
input expected observed))
(unless (equal observed-second following)
(error "oops, ~a was have read ~a after, but read ~a"
input following observed-second))
(list observed observed-second))))
(reader-error (e)
(unless (eq 'error expected-spec)
(error "oops, ~a wasn't supposed to error with ~a" input e)))))))
(defun make-results (objects)
(loop for value in objects
collect (list (present-for-emacs value #'slynk-pprint)
(1- (length *history*))
(cond ((symbolp value)
(with-output-to-string (s)
(unless (keywordp value) (princ "'" s))
(write value :stream s :case :downcase)))
((numberp value)
(princ-to-string value))))))
(defun mrepl-eval (repl string)
(let ((aborted t)
(results)
(error-prompt-sent))
(setf (mrepl-mode repl) :busy)
(unwind-protect
(let* ((previous-hook *debugger-hook*)
(*debugger-hook*
;; Here's how this debugger hook handles "debugger
;; levels".
;;
;; (1) This very lambda may be called multiple
;; times, but *not recursively, for the same
;; MREPL-EVAL call. That is becasue because SLY's
;; top-level debugger hook enters a blocking
;; SLY-DB-LOOP, and letting users invoke all manners
;; of restarts established in the code they wants us
;; to evaluate. It's important that we mark the
;; condition that led to the debugger only once, in
;; the ERRORRED var. On that occasion, we also send
;; a prompt to the REPL and increase the debugger
;; level. If the user selects a restart that
;; re-runs (but *not* recursively) this very lambda,
;; we do *not* want to send a prompt again.
;;
;; (2) This lambda may also run multiple times, but
;; recursively, in the very special case of nested
;; MREPL-EVAL may be nested (if the program calls
;; PROCESS-REQUESTS explicitly e.g.). We
;; (hackishly) detect this case by checking by
;; checking the car of MREPL-PENDING-ERRORS. In
;; that case, we are sure that calling previous hook
;; (which is a different copy of this very lambda
;; but running in a different stack frame) will take
;; care of the prompt sending and error management
;; for us, so we just do that.
(lambda (condition hook)
(setq aborted condition)
(cond ((eq condition (car (mrepl-pending-errors repl)))
(funcall previous-hook condition hook))
(t
(push condition (mrepl-pending-errors repl))
(unless error-prompt-sent
(setq error-prompt-sent t)
(with-listener-bindings repl
(send-prompt repl condition)))
(unwind-protect
(funcall previous-hook condition hook)
(pop (mrepl-pending-errors repl))))))))
(setq results (mrepl-eval-1 repl string)
;; If somehow the form above MREPL-EVAL-1 exited
;; normally, set ABORTED to nil
aborted nil))
(unless (eq (mrepl-mode repl) :teardown)
(flush-listener-streams repl)
(saving-listener-bindings repl
(cond (aborted
(send-to-remote-channel (mrepl-remote-id repl)
`(:evaluation-aborted
,(slynk::without-printing-errors
(:object aborted :stream nil)
(prin1-to-string aborted)))))
(t
(when results
(setq /// // // / / results
*** ** ** * * (car results))
(vector-push-extend results *history*))
(send-to-remote-channel
(mrepl-remote-id repl)
`(:write-values ,(make-results results)))))
(send-prompt repl))))))
(defun prompt-arguments (repl condition)
"Return (PACKAGE NICKNAME ELEVEL ENTRY-IDX &optional CONDITION)"
`(,(package-name *package*)
,(package-string-for-prompt *package*)
,(length (mrepl-pending-errors repl))
,(length *history*)
,@(when condition
(list (write-to-string condition
:escape t
:readably nil)))))
(defun send-prompt (&optional (repl *channel*) condition)
(send-to-remote-channel (mrepl-remote-id repl)
`(:prompt ,@(prompt-arguments repl condition)))
(setf (mrepl-mode repl) :eval))
(defun mrepl-eval-1 (repl string)
"In REPL's environment, READ and EVAL forms in STRING."
(with-sly-interrupts
;; Use WITH-LISTENER-BINDINGS (not SAVING-LISTENER-BINDINGS)
;; instead, otherwise, if EVAL pops up an error in STRING's form,
;; and in the meantime we had some debugging prompts (which make
;; recursive calls to this function), the variables *, **, *** and
;; *HISTORY* will get incorrectly clobbered to their pre-debugger
;; values, whereas we want to serialize this history.
;;
;; However, as an exception, we /do/ want /some/ special symbols
;; to be clobbered if the evaluation of STRING eventually
;; completes. Currently, those are *PACKAGE* and
;; *DEFAULT-PATHNAME-DEFAULTS*.
;;
;; Another way to see this is: the forms that the user inputs can
;; only change binding of those special symbols in the listener's
;; environment. Everything else in there is handled automatically.
;;
(with-listener-bindings repl
(prog1
(with-retry-restart (:msg "Retry SLY mREPL evaluation request.")
(with-input-from-string (in string)
(loop with values
for form =
(let ((*readtable* (let ((table (copy-readtable)))
(if *backreference-character*
(set-dispatch-macro-character
#\#
*backreference-character*
#'backreference-reader table))
table)))
(read in nil in))
until (eq form in)
do (let ((- form))
(setq values (multiple-value-list
(eval
(saving-listener-bindings repl
(setq +++ ++ ++ + + form))))))
finally
(return values))))
(dolist (special-sym '(*package* *default-pathname-defaults*))
(setf (cdr (assoc special-sym (slot-value repl 'slynk::env)))
(symbol-value special-sym)))))))
(defun set-external-mode (repl new-mode)
(with-slots (mode remote-id) repl
(unless (eq mode new-mode)
(send-to-remote-channel remote-id `(:set-read-mode ,new-mode)))
(setf mode new-mode)))
(defun read-input (repl)
(with-slots (mode remote-id) repl
;; shouldn't happen with slynk-gray.lisp, they use locks
(assert (not (eq mode :read)) nil "Cannot pipeline READs")
(let ((tid (slynk-backend:thread-id (slynk-backend:current-thread)))
(old-mode mode))
(unwind-protect
(cond ((and (eq (channel-thread-id repl) tid)
(eq mode :busy))
(flush-listener-streams repl)
(set-external-mode repl :read)
(unwind-protect
(catch 'mrepl-read (process-requests nil))
(set-external-mode repl :finished-reading)))
(t
(setf mode :read)
(with-output-to-string (s)
(format s
(or (slynk::read-from-minibuffer-in-emacs
(format nil "Input for thread ~a? " tid))
(error "READ for thread ~a interrupted" tid)))
(terpri s))))
(setf mode old-mode)))))
;;; Channel methods
;;;
(define-channel-method :inspect-object ((r mrepl) entry-idx value-idx)
(with-listener-bindings r
(send-to-remote-channel
(mrepl-remote-id r)
`(:inspect-object
,(slynk::inspect-object
(mrepl-get-object-from-history entry-idx value-idx))))))
(define-channel-method :process ((c mrepl) string)
(with-slots (mode) c
(case mode
(:eval (mrepl-eval c string))
(:read (throw 'mrepl-read string))
(:drop))))
(define-channel-method :teardown ((r mrepl))
;; FIXME: this should be a `:before' spec and closing the channel in
;; slynk.lisp's :teardown method should suffice.
;;
(setf (mrepl-mode r) :teardown)
(call-next-method))
(define-channel-method :clear-repl-history ((r mrepl))
(saving-listener-bindings r
;; FIXME: duplication... use reinitialize-instance
(setf *history* (make-array 40 :fill-pointer 0
:adjustable t)
* nil ** nil *** nil
+ nil ++ nil +++ nil
/ nil // nil /// nil)
(send-to-remote-channel (mrepl-remote-id r) `(:clear-repl-history))
(send-prompt r)))
;;; slyfuns
;;;
(defslyfun create-mrepl (remote-id)
(let* ((mrepl (make-instance
'mrepl
:remote-id remote-id
:name (format nil "mrepl-remote-~a" remote-id)
:out (make-mrepl-output-stream remote-id))))
(let ((target (maybe-redirect-global-io *emacs-connection*)))
(saving-listener-bindings mrepl
(format *standard-output* "~&; SLY ~a (~a)~%"
*slynk-wire-protocol-version*
mrepl)
(cond
((and target
(not (eq mrepl target)))
(format *standard-output* "~&; Global redirection setup elsewhere~%"))
((not target)
(format *standard-output* "~&; Global redirection not setup~%"))))
(flush-listener-streams mrepl)
(send-prompt mrepl)
(list (channel-id mrepl) (channel-thread-id mrepl)))))
(defslyfun globally-save-object (slave-slyfun &rest args)
"Apply SLYFUN to ARGS and save the value.
The saved value should be visible to all threads and retrieved via
the COPY-TO-REPL slyfun."
(setq *saved-objects* (multiple-value-list (apply slave-slyfun args)))
t)
(defun copy-to-repl-in-emacs (values &key
(blurb "Here are some values")
(pop-to-buffer t))
"Copy any user object to SLY's REPL. Requires
`sly-enable-evaluate-in-emacs' to be true."
(with-connection ((default-connection))
(apply #'slynk-mrepl:globally-save-object #'cl:values values)
(slynk:eval-in-emacs `(sly-mrepl--copy-globally-saved-to-repl
:before ,blurb :pop-to-buffer ,pop-to-buffer))
t))
(defmacro with-eval-for-repl ((remote-id &optional mrepl-sym
update-mrepl) &body body)
(let ((mrepl-sym (or mrepl-sym
(gensym))))
`(let ((,mrepl-sym (find-channel ,remote-id)))
(assert ,mrepl-sym)
(assert
(eq (slynk-backend:thread-id
(slynk-backend:current-thread))
(channel-thread-id ,mrepl-sym))
nil
"This SLYFUN can only be called from threads belonging to MREPL")
,(if update-mrepl
`(saving-listener-bindings ,mrepl-sym
,@body)
`(with-listener-bindings ,mrepl-sym
,@body)))))
(defslyfun eval-for-mrepl (remote-id slave-slyfun &rest args)
"A synchronous form for evaluation in the mREPL context.
Calls SLAVE-SLYFUN with ARGS in the MREPL of REMOTE-ID. Both the
target MREPL's thread and environment are considered.
SLAVE-SLYFUN is typically destructive to the REPL listener's
environment.
This function returns a list of two elements. The first is a list
of arguments as sent in the :PROMPT channel method reply. The second
is the values list returned by SLAVE-SLYFUN transformed into a normal
list."
(with-eval-for-repl (remote-id mrepl 'allow-destructive)
(let ((objects (multiple-value-list (apply slave-slyfun args))))
(list
(prompt-arguments mrepl nil)
objects))))
(defslyfun inspect-entry (remote-id entry-idx value-idx)
(with-eval-for-repl (remote-id)
(slynk::inspect-object
(mrepl-get-object-from-history entry-idx value-idx))))
(defslyfun describe-entry (remote-id entry-idx value-idx)
(with-eval-for-repl (remote-id)
(slynk::describe-to-string
(mrepl-get-object-from-history entry-idx value-idx))))
(defslyfun pprint-entry (remote-id entry-idx value-idx)
(with-eval-for-repl (remote-id)
(slynk::slynk-pprint
(list (mrepl-get-object-from-history entry-idx value-idx)))))
;;; "Slave" slyfuns.
;;;
;;; These are slyfuns intented to be called as the SLAVE-SLYFUN
;;; argument of EVAL-FOR-MREPL.
;;;
(defslyfun guess-and-set-package (package-name)
(let ((package (slynk::guess-package package-name)))
(if package
(setq *package* package)
(error "Can't find a package for designator ~a" package-name))
t))
(defslyfun copy-to-repl (&optional entry-idx value-idx)
"Recall objects in *HISTORY* or *SAVED-OBJECTS* as the last entry."
(let ((objects
(cond ((and entry-idx value-idx)
(list (mrepl-get-object-from-history entry-idx value-idx)))
(entry-idx
(mrepl-get-history-entry entry-idx))
(value-idx
(error "Doesn't make sense"))
(t
*saved-objects*))))
(setq /// // // / / objects
*** ** ** * * (car objects))
(vector-push-extend objects *history*)
(values-list (make-results objects))))
(defslyfun sync-package-and-default-directory (&key package-name directory)
(when directory
(slynk:set-default-directory directory))
(when package-name
(guess-and-set-package package-name))
(values (package-name *package*) (slynk-backend:default-directory)))
;;;; Dedicated stream
;;;;
(defvar *use-dedicated-output-stream* :started-from-emacs
"When T, dedicate a second stream for sending output to Emacs.")
(defvar *dedicated-output-stream-port* 0
"Which port we should use for the dedicated output stream.")
(defvar *dedicated-output-stream-buffering*
(if (eq slynk:*communication-style* :spawn) :line nil)
"The buffering scheme that should be used for the output stream.
Be advised that some Lisp backends don't support this.
Valid values are nil, t, :line.")
(defun use-dedicated-output-stream-p ()
(case *use-dedicated-output-stream*
(:started-from-emacs slynk-api:*m-x-sly-from-emacs*)
(t *use-dedicated-output-stream*)))
(defun make-mrepl-output-stream (remote-id)
(or (and (use-dedicated-output-stream-p)
(open-dedicated-output-stream remote-id))
(slynk-backend:make-output-stream
(make-thread-bindings-aware-lambda
(lambda (string)
(send-to-remote-channel remote-id `(:write-string ,string)))))))
(defun make-mrepl-input-stream (repl)
(slynk-backend:make-input-stream
(lambda () (read-input repl))))
(defun open-dedicated-output-stream (remote-id)
"Establish a dedicated output connection to Emacs.
Emacs's channel at REMOTE-ID is notified of a socket listening at an
ephemeral port. Upon connection, the listening socket is closed, and
the resulting connecion socket is used as optimized way for Lisp to
deliver output to Emacs."
(let ((socket (slynk-backend:create-socket slynk::*loopback-interface*
*dedicated-output-stream-port*))
(ef (or (some #'slynk::find-external-format '("utf-8-unix" "utf-8"))
(error "no suitable coding system for dedicated stream"))))
(unwind-protect
(let ((port (slynk-backend:local-port socket)))
(send-to-remote-channel remote-id
`(:open-dedicated-output-stream ,port nil))
(let ((dedicated (slynk-backend:accept-connection
socket
:external-format ef
:buffering *dedicated-output-stream-buffering*
:timeout 30)))
(slynk:authenticate-client dedicated)
(slynk-backend:close-socket socket)
(setf socket nil)
(let ((result
;; See github issue #21: Only sbcl and cmucl apparently
;; respect :LINE as a buffering type, hence this reader
;; conditional. This could/should be a definterface, but
;; looks harmless enough...
;;
#+(or sbcl cmucl)
dedicated
;; ...on other implementations we make a relaying gray
;; stream that is guaranteed to use line buffering for
;; WRITE-SEQUENCE. That stream writes to the dedicated
;; socket whenever it sees fit.
;;
#-(or sbcl cmucl)
(slynk-backend:make-output-stream
(lambda (string)
(write-sequence string dedicated)
(force-output dedicated)))))
(prog1 result
(format result
"~&; Dedicated output stream setup (port ~a)~%"
port)
(force-output result)))))
(when socket
(slynk-backend:close-socket socket)))))
;;;; Globally redirect IO to Emacs
;;;
;;; This code handles redirection of the standard I/O streams
;;; (`*standard-output*', etc) into Emacs. If any LISTENER objects
;;; exist in the CONNECTION structure, they will contain the
;;; appropriate streams, so all we have to do is make the right
;;; bindings.
;;;
;;; When the first ever MREPL is created we redirect the streams into
;;; it, and they keep going into that MREPL even if more are
;;; established, in the current connection or even other
;;; connections. If the MREPL is closed (interactively or by closing
;;; the connection), we choose some other MREPL (in some other default
;;; connection possibly), or, or if there are no MREPL's left, we
;;; revert to the original (real) streams.
;;;
;;; It is slightly tricky to assign the global values of standard
;;; streams because they are often shadowed by dynamic bindings. We
;;; solve this problem by introducing an extra indirection via synonym
;;; streams, so that *STANDARD-INPUT* is a synonym stream to
;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
;;; variables, so they can always be assigned to affect a global
;;; change.
(defvar *globally-redirect-io* :started-from-emacs
"If non-nil, attempt to globally redirect standard streams to Emacs.
If the value is :STARTED-FROM-EMACS, do it only if the Slynk server
was started from SLYNK:START-SERVER, which is called from Emacs by M-x
sly.")
(defvar *saved-global-streams* '()
"A plist to save and restore redirected stream objects.
E.g. the value for '*standard-output* holds the stream object
for *standard-output* before we install our redirection.")
(defvar *standard-output-streams*
'(*standard-output* *error-output* *trace-output*)
"The symbols naming standard output streams.")
(defvar *standard-input-streams*
'(*standard-input*)
"The symbols naming standard input streams.")
(defvar *standard-io-streams*
'(*debug-io* *query-io* *terminal-io*)
"The symbols naming standard io streams.")
(defvar *target-listener-for-redirection* nil
"The listener to which standard I/O streams are globally redirected.
NIL if streams are not globally redirected.")
(defun setup-stream-indirection (stream-var &optional stream)
"Setup redirection scaffolding for a global stream variable.
Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
*STANDARD-INPUT*.
3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
*CURRENT-STANDARD-INPUT*.
This has the effect of making *CURRENT-STANDARD-INPUT* contain the
effective global value for *STANDARD-INPUT*. This way we can assign
the effective global value even when *STANDARD-INPUT* is shadowed by a
dynamic binding."
(let ((current-stream-var (prefixed-var '#:current stream-var))
(stream (or stream (symbol-value stream-var))))
;; Save the real stream value for the future.
(setf (getf *saved-global-streams* stream-var) stream)
;; Define a new variable for the effective stream.
;; This can be reassigned.
(proclaim `(special ,current-stream-var))
(set current-stream-var stream)
;; Assign the real binding as a synonym for the current one.
(let ((stream (make-synonym-stream current-stream-var)))
(set stream-var stream)
(slynk::set-default-initial-binding stream-var `(quote ,stream)))))
(defun prefixed-var (prefix variable-symbol)
"(PREFIXED-VAR \"FOO\" '*BAR*) => SLYNK::*FOO-BAR*"
(let ((basename (subseq (symbol-name variable-symbol) 1)))
(intern (format nil "*~A-~A" (string prefix) basename) :slynk)))
(defun init-global-stream-redirection ()
(cond (*saved-global-streams*
(warn "Streams already redirected."))
(t
(mapc #'setup-stream-indirection
(append *standard-output-streams*
*standard-input-streams*
*standard-io-streams*)))))
(defun globally-redirect-to-listener (listener)
"Set the standard I/O streams to redirect to LISTENER.
Assigns *CURRENT-<STREAM>* for all standard streams."
(saving-listener-bindings listener
(dolist (o *standard-output-streams*)
(set (prefixed-var '#:current o)
*standard-output*))
;; FIXME: If we redirect standard input to Emacs then we get the
;; regular Lisp top-level trying to read from our REPL.
;;
;; Perhaps the ideal would be for the real top-level to run in a
;; thread with local bindings for all the standard streams. Failing
;; that we probably would like to inhibit it from reading while
;; Emacs is connected.
;;
;; Meanwhile we just leave *standard-input* alone.
#+NIL
(dolist (i *standard-input-streams*)
(set (prefixed-var '#:current i)
(connection.user-input connection)))
(dolist (io *standard-io-streams*)
(set (prefixed-var '#:current io)
*terminal-io*))))
(defun revert-global-io-redirection ()
"Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
;; Log to SLYNK:*LOG-OUTPUT* since the standard streams whose
;; redirection are about to be reverted might be in an unconsistent
;; state after, for instance, restarting an image.
;;
(format slynk:*log-output* "~&; About to revert global IO direction~%")
(when *target-listener-for-redirection*
(flush-listener-streams *target-listener-for-redirection*))
(dolist (stream-var (append *standard-output-streams*
*standard-input-streams*
*standard-io-streams*))
(set (prefixed-var '#:current stream-var)
(getf *saved-global-streams* stream-var))))
(defun globally-redirect-io-p ()
(case *globally-redirect-io*
(:started-from-emacs slynk-api:*m-x-sly-from-emacs*)
(t *globally-redirect-io*)))
(defun maybe-redirect-global-io (connection)
"Consider globally redirecting output to CONNECTION's listener.
Return the current redirection target, or nil"
(let ((l (default-listener connection)))
(when (and (globally-redirect-io-p)
(null *target-listener-for-redirection*)
l)
(unless *saved-global-streams*
(init-global-stream-redirection))
(setq *target-listener-for-redirection* l)
(globally-redirect-to-listener l)
(with-listener-bindings l
(format *standard-output* "~&; Redirecting all output to this MREPL~%")
(flush-listener-streams l)))
*target-listener-for-redirection*))
(defmethod close-channel :before ((r mrepl) &key force)
(with-slots (mode remote-id) r
(unless (or force (eq mode :teardown))
(send-to-remote-channel remote-id `(:server-side-repl-close)))
;; If this channel was the redirection target.
(close-listener r)
(when (eq r *target-listener-for-redirection*)
(setq *target-listener-for-redirection* nil)
(maybe-redirect-global-io (default-connection))
(unless *target-listener-for-redirection*
(revert-global-io-redirection)
(format slynk:*log-output* "~&; Reverted global IO direction~%")))))
(provide :slynk/mrepl)
(in-package :slynk)
(defvar *application-hints-tables* '()
"A list of hash tables mapping symbols to indentation hints (lists
of symbols and numbers as per cl-indent.el). Applications can add hash
tables to the list to change the auto indentation sly sends to
emacs.")
(defun has-application-indentation-hint-p (symbol)
(let ((default (load-time-value (gensym))))
(dolist (table *application-hints-tables*)
(let ((indentation (gethash symbol table default)))
(unless (eq default indentation)
(return-from has-application-indentation-hint-p
(values indentation t))))))
(values nil nil))
(defun application-indentation-hint (symbol)
(let ((indentation (has-application-indentation-hint-p symbol)))
(labels ((walk (indentation-spec)
(etypecase indentation-spec
(null nil)
(number indentation-spec)
(symbol (string-downcase indentation-spec))
(cons (cons (walk (car indentation-spec))
(walk (cdr indentation-spec)))))))
(walk indentation))))
;;; override slynk version of this function
(defun symbol-indentation (symbol)
"Return a form describing the indentation of SYMBOL.
The form is to be used as the `sly-common-lisp-indent-function' property
in Emacs."
(cond
((has-application-indentation-hint-p symbol)
(application-indentation-hint symbol))
((and (macro-function symbol)
(not (known-to-emacs-p symbol)))
(let ((arglist (arglist symbol)))
(etypecase arglist
((member :not-available)
nil)
(list
(macro-indentation arglist)))))
(t nil)))
;;; More complex version.
(defun macro-indentation (arglist)
(labels ((frob (list &optional base)
(if (every (lambda (x)
(member x '(nil "&rest") :test #'equal))
list)
;; If there was nothing interesting, don't return anything.
nil
;; Otherwise substitute leading NIL's with 4 or 1.
(let ((ok t))
(substitute-if (if base
4
1)
(lambda (x)
(if (and ok (not x))
t
(setf ok nil)))
list))))
(walk (list level &optional firstp)
(when (consp list)
(let ((head (car list)))
(if (consp head)
(let ((indent (frob (walk head (+ level 1) t))))
(cons (list* "&whole" (if (zerop level)
4
1)
indent) (walk (cdr list) level)))
(case head
;; &BODY is &BODY, this is clear.
(&body
'("&body"))
;; &KEY is tricksy. If it's at the base level, we want
;; to indent them normally:
;;
;; (foo bar quux
;; :quux t
;; :zot nil)
;;
;; If it's at a destructuring level, we want indent of 1:
;;
;; (with-foo (var arg
;; :foo t
;; :quux nil)
;; ...)
(&key
(if (zerop level)
'("&rest" nil)
'("&rest" 1)))
;; &REST is tricksy. If it's at the front of
;; destructuring, we want to indent by 1, otherwise
;; normally:
;;
;; (foo (bar quux
;; zot)
;; ...)
;;
;; but
;;
;; (foo bar quux
;; zot)
(&rest
(if (and (plusp level) firstp)
'("&rest" 1)
'("&rest" nil)))
;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there
;; at all.
((&whole &environment)
(walk (cddr list) level firstp))
;; &OPTIONAL is indented normally -- and the &OPTIONAL marker
;; itself is not counted.
(&optional
(walk (cdr list) level))
;; Indent normally, walk the tail -- but
;; unknown lambda-list keywords terminate the walk.
(otherwise
(unless (member head lambda-list-keywords)
(cons nil (walk (cdr list) level))))))))))
(frob (walk arglist 0 t) t)))
#+nil
(progn
(assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body")
(macro-indentation '(bar quux (&rest slots) &body body))))
(assert (equal nil
(macro-indentation '(a b c &rest more))))
(assert (equal '(4 4 4 "&body")
(macro-indentation '(a b c &body more))))
(assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body")
(macro-indentation '((name zot &key foo bar) &body body))))
(assert (equal nil
(macro-indentation '(x y &key z)))))
(provide :slynk/indentation)
;;; slynk-fancy-inspector.lisp --- Fancy inspector for CLOS objects
;;
;; Author: Marco Baringer <mb@bese.it> and others
;; License: Public Domain
;;
(in-package :slynk)
(defmethod emacs-inspect ((symbol symbol))
(let ((package (symbol-package symbol)))
(multiple-value-bind (_symbol status)
(and package (find-symbol (string symbol) package))
(declare (ignore _symbol))
(append
(label-value-line "Its name is" (symbol-name symbol))
;;
;; Value
(cond ((boundp symbol)
(append
(label-value-line (if (constantp symbol)
"It is a constant of value"
"It is a global variable bound to")
(symbol-value symbol) :newline nil)
;; unbinding constants might be not a good idea, but
;; implementations usually provide a restart.
`(" " (:action "[unbind]"
,(lambda () (makunbound symbol))))
'((:newline))))
(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 "[unbind]"
,(lambda () (fmakunbound symbol))))
`((:newline)))
`("It has no function value." (:newline)))
(docstring-ispec "Function documentation" symbol 'function)
(when (compiler-macro-function symbol)
(append
(label-value-line "It also names the compiler macro"
(compiler-macro-function symbol) :newline nil)
`(" " (:action "[remove]"
,(lambda ()
(setf (compiler-macro-function symbol) nil)))
(:newline))))
(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]"
,(lambda () (export symbol package)))))
" "
(:action "[unintern]"
,(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)))
(inspect-type-specifier symbol)))))
#-sbcl
(defun inspect-type-specifier (symbol)
(declare (ignore symbol)))
#+sbcl
(defun inspect-type-specifier (symbol)
(let* ((kind (sb-int:info :type :kind symbol))
(fun (case kind
(:defined
(or (sb-int:info :type :expander symbol) t))
(:primitive
(or #.(if (slynk-sbcl::sbcl-version>= 1 3 1)
'(let ((x (sb-int:info :type :expander symbol)))
(if (consp x)
(car x)
x))
'(sb-int:info :type :translator symbol))
t)))))
(when fun
(append
(list
(format nil "It names a ~@[primitive~* ~]type-specifier."
(eq kind :primitive))
'(:newline))
(docstring-ispec "Type-specifier documentation" symbol 'type)
(unless (eq t fun)
(let ((arglist (arglist fun)))
(append
`("Type-specifier lambda-list: "
;; Could use ~:s, but inspector-princ does a bit more,
;; and not all NILs in the arglist should be printed that way.
,(if arglist
(inspector-princ arglist)
"()")
(:newline))
(multiple-value-bind (expansion ok)
(handler-case (sb-ext:typexpand-1 symbol)
(error () (values nil nil)))
(when ok
(list "Type-specifier expansion: "
(princ-to-string expansion)))))))))))
(defun docstring-ispec (label object kind)
"Return a inspector spec if OBJECT has a docstring 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))))))
(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil)
(defmethod emacs-inspect ((f function))
(inspect-function f)))
(defun inspect-function (f)
(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
(slynk-mop:eql-specializer
`(eql ,(slynk-mop:eql-specializer-object spec)))
#-sbcl
(t
(slynk-mop:class-name spec))
#+sbcl
(t
;; SBCL has extended specializers
(let ((gf (sb-mop:method-generic-function method)))
(cond (gf
(sb-pcl:unparse-specializer-using-class gf spec))
((typep spec 'class)
(class-name spec))
(t
spec))))))
(slynk-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 (slynk-mop:generic-function-name
(slynk-mop:method-generic-function method)))
(slynk-mop:method-qualifiers method)
(method-specializers-for-inspect method)))
(defmethod emacs-inspect ((object standard-object))
(let ((class (class-of object)))
`("Class: " (:value ,class) (:newline)
,@(all-slots-for-inspector object))))
(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 'slynk-mop:eql-specializer)
(not (typep s2 'slynk-mop:eql-specializer)))
((typep s1 'class)
(flet ((cpl (class)
(and (slynk-mop:class-finalized-p class)
(slynk-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 (slynk-mop:method-specializers meth1)
for s2 in (slynk-mop:method-specializers meth2)
do (cond ((specializer< s2 s1) (return nil))
((specializer< s1 s2) (return t))))))
(stable-sort (copy-seq (slynk-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))))
(defstruct (inspector-checklist (:conc-name checklist.)
(:constructor %make-checklist (buttons)))
(buttons nil :type (or null simple-vector))
(count 0))
(defun make-checklist (n)
(%make-checklist (make-array n :initial-element nil)))
(defun reinitialize-checklist (checklist)
;; Along this counter the buttons are created, so we have to
;; initialize it to 0 everytime the inspector page is redisplayed.
(setf (checklist.count checklist) 0)
checklist)
(defun make-checklist-button (checklist)
(let ((buttons (checklist.buttons checklist))
(i (checklist.count checklist)))
(incf (checklist.count checklist))
`(:action ,(if (svref buttons i)
"[X]"
"[ ]")
,#'(lambda ()
(setf (svref buttons i) (not (svref buttons i))))
:refreshp t)))
(defmacro do-checklist ((idx checklist) &body body)
"Iterate over all set buttons in CHECKLIST."
(let ((buttons (gensym "buttons")))
`(let ((,buttons (checklist.buttons ,checklist)))
(dotimes (,idx (length ,buttons))
(when (svref ,buttons ,idx)
,@body)))))
(defun box (thing) (cons :box thing))
(defun ref (box)
(assert (eq (car box) :box))
(cdr box))
(defun (setf ref) (value box)
(assert (eq (car box) :box))
(setf (cdr box) value))
(defvar *inspector-slots-default-order* :alphabetically
"Accepted values: :alphabetically and :unsorted")
(defvar *inspector-slots-default-grouping* :all
"Accepted values: :inheritance and :all")
(defgeneric all-slots-for-inspector (object))
(defmethod all-slots-for-inspector ((object standard-object))
(let* ((class (class-of object))
(direct-slots (slynk-mop:class-direct-slots class))
(effective-slots (slynk-mop:class-slots class))
(longest-slot-name-length
(loop for slot :in effective-slots
maximize (length (symbol-name
(slynk-mop:slot-definition-name slot)))))
(checklist
(reinitialize-checklist
(ensure-istate-metadata object :checklist
(make-checklist (length effective-slots)))))
(grouping-kind
;; We box the value so we can re-set it.
(ensure-istate-metadata object :grouping-kind
(box *inspector-slots-default-grouping*)))
(sort-order
(ensure-istate-metadata object :sort-order
(box *inspector-slots-default-order*)))
(sort-predicate (ecase (ref sort-order)
(:alphabetically #'string<)
(:unsorted (constantly nil))))
(sorted-slots (sort (copy-seq effective-slots)
sort-predicate
:key #'slynk-mop:slot-definition-name))
(effective-slots
(ecase (ref grouping-kind)
(:all sorted-slots)
(:inheritance (stable-sort-by-inheritance sorted-slots
class sort-predicate)))))
`("--------------------"
(:newline)
" Group slots by inheritance "
(:action ,(ecase (ref grouping-kind)
(:all "[ ]")
(:inheritance "[X]"))
,(lambda ()
;; We have to do this as the order of slots will
;; be sorted differently.
(fill (checklist.buttons checklist) nil)
(setf (ref grouping-kind)
(ecase (ref grouping-kind)
(:all :inheritance)
(:inheritance :all))))
:refreshp t)
(:newline)
" Sort slots alphabetically "
(:action ,(ecase (ref sort-order)
(:unsorted "[ ]")
(:alphabetically "[X]"))
,(lambda ()
(fill (checklist.buttons checklist) nil)
(setf (ref sort-order)
(ecase (ref sort-order)
(:unsorted :alphabetically)
(:alphabetically :unsorted))))
:refreshp t)
(:newline)
,@ (case (ref grouping-kind)
(:all
`((:newline)
"All Slots:"
(:newline)
,@(make-slot-listing checklist object class
effective-slots direct-slots
longest-slot-name-length)))
(:inheritance
(list-all-slots-by-inheritance checklist object class
effective-slots direct-slots
longest-slot-name-length)))
(:newline)
(:action "[set value]"
,(lambda ()
(do-checklist (idx checklist)
(query-and-set-slot class object
(nth idx effective-slots))))
:refreshp t)
" "
(:action "[make unbound]"
,(lambda ()
(do-checklist (idx checklist)
(slynk-mop:slot-makunbound-using-class
class object (nth idx effective-slots))))
:refreshp t)
(:newline))))
(defun list-all-slots-by-inheritance (checklist object class effective-slots
direct-slots longest-slot-name-length)
(flet ((slot-home-class (slot)
(slot-home-class-using-class slot class)))
(let ((current-slots '()))
(append
(loop for slot in effective-slots
for previous-home-class = (slot-home-class slot) then home-class
for home-class = previous-home-class then (slot-home-class slot)
if (eq home-class previous-home-class)
do (push slot current-slots)
else
collect '(:newline)
and collect (format nil "~A:" (class-name previous-home-class))
and collect '(:newline)
and append (make-slot-listing checklist object class
(nreverse current-slots)
direct-slots
longest-slot-name-length)
and do (setf current-slots (list slot)))
(and current-slots
`((:newline)
,(format nil "~A:"
(class-name (slot-home-class-using-class
(car current-slots) class)))
(:newline)
,@(make-slot-listing checklist object class
(nreverse current-slots) direct-slots
longest-slot-name-length)))))))
(defun make-slot-listing (checklist object class effective-slots direct-slots
longest-slot-name-length)
(flet ((padding-for (slot-name)
(make-string (- longest-slot-name-length (length slot-name))
:initial-element #\Space)))
(loop
for effective-slot :in effective-slots
for direct-slot = (find (slynk-mop:slot-definition-name effective-slot)
direct-slots
:key #'slynk-mop:slot-definition-name)
for slot-name = (inspector-princ
(slynk-mop:slot-definition-name effective-slot))
collect (make-checklist-button checklist)
collect " "
collect `(:value ,(if direct-slot
(list direct-slot effective-slot)
effective-slot)
,slot-name)
collect (padding-for slot-name)
collect " = "
collect (slot-value-for-inspector class object effective-slot)
collect '(:newline))))
(defgeneric slot-value-for-inspector (class object slot)
(:method (class object slot)
(let ((boundp (slynk-mop:slot-boundp-using-class class object slot)))
(if boundp
`(:value ,(slynk-mop:slot-value-using-class class object slot))
"#<unbound>"))))
(defun slot-home-class-using-class (slot class)
(let ((slot-name (slynk-mop:slot-definition-name slot)))
(loop for class in (reverse (slynk-mop:class-precedence-list class))
thereis (and (member slot-name (slynk-mop:class-direct-slots class)
:key #'slynk-mop:slot-definition-name
:test #'eq)
class))))
(defun stable-sort-by-inheritance (slots class predicate)
(stable-sort slots predicate
:key #'(lambda (s)
(class-name (slot-home-class-using-class s class)))))
(defun query-and-set-slot (class object slot)
(let* ((slot-name (slynk-mop:slot-definition-name slot))
(value-string (read-from-minibuffer-in-emacs
(format nil "Set slot ~S to (evaluated) : "
slot-name))))
(when (and value-string (not (string= value-string "")))
(with-simple-restart (abort "Abort setting slot ~S" slot-name)
(setf (slynk-mop:slot-value-using-class class object slot)
(eval (read-from-string value-string)))))))
(defmethod emacs-inspect ((gf standard-generic-function))
(flet ((lv (label value) (label-value-line label value)))
(append
(lv "Name" (slynk-mop:generic-function-name gf))
(lv "Arguments" (slynk-mop:generic-function-lambda-list gf))
(docstring-ispec "Documentation" gf t)
(lv "Method class" (slynk-mop:generic-function-method-class gf))
(lv "Method combination"
(slynk-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))))
(defmethod emacs-inspect ((method standard-method))
`(,@(if (slynk-mop:method-generic-function method)
`("Method defined on the generic function "
(:value ,(slynk-mop:method-generic-function method)
,(inspector-princ
(slynk-mop:generic-function-name
(slynk-mop:method-generic-function method)))))
'("Method without a generic function"))
(:newline)
,@(docstring-ispec "Documentation" method t)
"Lambda List: " (:value ,(slynk-mop:method-lambda-list method))
(:newline)
"Specializers: " (:value ,(slynk-mop:method-specializers method)
,(inspector-princ
(method-specializers-for-inspect method)))
(:newline)
"Qualifiers: " (:value ,(slynk-mop:method-qualifiers method))
(:newline)
"Method function: " (:value ,(slynk-mop:method-function method))
(:newline)
,@(all-slots-for-inspector method)))
(defun specializer-direct-methods (class)
(sort (copy-seq (slynk-mop:specializer-direct-methods class))
#'string<
:key
(lambda (x)
(symbol-name
(let ((name (slynk-mop::generic-function-name
(slynk-mop::method-generic-function x))))
(if (symbolp name)
name
(second name)))))))
(defmethod emacs-inspect ((class standard-class))
`("Name: "
(:value ,(class-name class))
(:newline)
"Super classes: "
,@(common-seperated-spec (slynk-mop:class-direct-superclasses class))
(:newline)
"Direct Slots: "
,@(common-seperated-spec
(slynk-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot ,(inspector-princ
(slynk-mop:slot-definition-name slot)))))
(:newline)
"Effective Slots: "
,@(if (slynk-mop:class-finalized-p class)
(common-seperated-spec
(slynk-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(inspector-princ
(slynk-mop:slot-definition-name slot)))))
`("#<N/A (class not finalized)> "
(:action "[finalize]"
,(lambda () (slynk-mop:finalize-inheritance class)))))
(:newline)
,@(let ((doc (documentation class t)))
(when doc
`("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
"Sub classes: "
,@(common-seperated-spec (slynk-mop:class-direct-subclasses class)
(lambda (sub)
`(:value ,sub
,(inspector-princ (class-name sub)))))
(:newline)
"Precedence List: "
,@(if (slynk-mop:class-finalized-p class)
(common-seperated-spec
(slynk-mop:class-precedence-list class)
(lambda (class)
`(:value ,class ,(inspector-princ (class-name class)))))
'("#<N/A (class not finalized)>"))
(:newline)
,@(when (slynk-mop:specializer-direct-methods class)
`("It is used as a direct specializer in the following methods:"
(:newline)
,@(loop
for method in (specializer-direct-methods class)
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 (slynk-mop:class-finalized-p class)
`(:value ,(slynk-mop:class-prototype class))
'"#<N/A (class not finalized)>")
(:newline)
,@(all-slots-for-inspector class)))
(defmethod emacs-inspect ((slot slynk-mop:standard-slot-definition))
`("Name: "
(:value ,(slynk-mop:slot-definition-name slot))
(:newline)
,@(when (slynk-mop:slot-definition-documentation slot)
`("Documentation:" (:newline)
(:value ,(slynk-mop:slot-definition-documentation
slot))
(:newline)))
"Init args: "
(:value ,(slynk-mop:slot-definition-initargs slot))
(:newline)
"Init form: "
,(if (slynk-mop:slot-definition-initfunction slot)
`(:value ,(slynk-mop:slot-definition-initform slot))
"#<unspecified>")
(:newline)
"Init function: "
(:value ,(slynk-mop:slot-definition-initfunction slot))
(:newline)
,@(all-slots-for-inspector slot)))
;; 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 EMACS-INSPECT.
;; 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))
(defun symbol-classification-string (symbol)
"Return a string in the form -f-c---- where each letter stands for
boundp fboundp generic-function class macro special-operator package"
(let ((letters "bfgctmsp")
(result (copy-seq "--------")))
(flet ((flip (letter)
(setf (char result (position letter letters))
letter)))
(when (boundp symbol) (flip #\b))
(when (fboundp symbol)
(flip #\f)
(when (typep (ignore-errors (fdefinition symbol))
'generic-function)
(flip #\g)))
(when (type-specifier-p symbol) (flip #\t))
(when (find-class symbol nil) (flip #\c) )
(when (macro-function symbol) (flip #\m))
(when (special-operator-p symbol) (flip #\s))
(when (find-package symbol) (flip #\p))
result)))
(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 (see SYMBOL-CLASSIFICATION-STRING)"
(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)))
(values
(concatenate 'string
name
(make-string (+ padding distance)
:initial-element #\Space))
(symbol-classification-string symbol)))))
`("" ; 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 #\-)
" "
(symbol-classification-string '#:foo))
(:newline)
,@(loop for symbol in symbols appending
(multiple-value-bind (symbol-string classification-string)
(string-representations symbol)
`((:value ,symbol ,symbol-string) ,classification-string
(:newline)
)))))))
(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols)
"For each possible classification (cf. CLASSIFY-SYMBOL), group
all the symbols in SYMBOLS to all of their respective
classifications. (If a symbol is, for instance, boundp and a
generic-function, it'll appear both below the BOUNDP group and
the GENERIC-FUNCTION group.) As macros and special-operators are
specified to be FBOUNDP, there is no general FBOUNDP group,
instead there are the three explicit FUNCTION, MACRO and
SPECIAL-OPERATOR groups."
(let ((table (make-hash-table :test #'eq))
(+default-classification+ :misc))
(flet ((normalize-classifications (classifications)
(cond ((null classifications) `(,+default-classification+))
;; Convert an :FBOUNDP in CLASSIFICATIONS to
;; :FUNCTION if possible.
((and (member :fboundp classifications)
(not (member :macro classifications))
(not (member :special-operator classifications)))
(substitute :function :fboundp classifications))
(t (remove :fboundp classifications)))))
(loop for symbol in symbols do
(loop for classification in
(normalize-classifications (classify-symbol symbol))
;; SYMBOLS are supposed to be sorted alphabetically;
;; this property is preserved here except for reversing.
do (push symbol (gethash classification table)))))
(let* ((classifications (loop for k being each hash-key in table
collect k))
(classifications (sort classifications
;; Sort alphabetically, except
;; +DEFAULT-CLASSIFICATION+ which
;; sort to the end.
(lambda (a b)
(cond ((eql a +default-classification+)
nil)
((eql b +default-classification+)
t)
(t (string< a b)))))))
(loop for classification in classifications
for symbols = (gethash classification table)
appending`(,(symbol-name classification)
(:newline)
,(make-string 64 :initial-element #\-)
(:newline)
,@(mapcan (lambda (symbol)
`((:value ,symbol ,(symbol-name symbol))
(:newline)))
;; restore alphabetic order.
(nreverse symbols))
(:newline))))))
(defmethod emacs-inspect ((%container %package-symbols-container))
(with-struct (%container. title description symbols grouping-kind) %container
`(,title (:newline) (:newline)
,@description
(:newline)
" " ,(ecase grouping-kind
(:symbol
`(:action "[Group by classification]"
,(lambda ()
(setf grouping-kind :classification))
:refreshp t))
(:classification
`(:action "[Group by symbol]"
,(lambda () (setf grouping-kind :symbol))
:refreshp t)))
(:newline) (:newline)
,@(make-symbols-listing grouping-kind symbols))))
(defun display-link (type symbols length &key title description)
(if (null symbols)
(format nil "0 ~A symbols." type)
`(:value ,(%make-package-symbols-container :title title
:description description
:symbols symbols)
,(format nil "~D ~A symbol~P." length type length))))
(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)
(tagbody ,@body))))))
(defmethod emacs-inspect ((package package))
(let ((package-name (package-name package))
(package-nicknames (package-nicknames package))
(package-use-list (package-use-list package))
(package-used-by-list (package-used-by-list package))
(shadowed-symbols (package-shadowing-symbols package))
(present-symbols '()) (present-symbols-length 0)
(internal-symbols '()) (internal-symbols-length 0)
(inherited-symbols '()) (inherited-symbols-length 0)
(external-symbols '()) (external-symbols-length 0))
(do-symbols* (sym package)
(let ((status (symbol-status sym package)))
(when (eq status :inherited)
(push sym inherited-symbols) (incf inherited-symbols-length)
(go :continue))
(push sym present-symbols) (incf present-symbols-length)
(cond ((eq status :internal)
(push sym internal-symbols) (incf internal-symbols-length))
(t
(push sym external-symbols) (incf external-symbols-length))))
:continue)
(setf package-nicknames (sort (copy-list package-nicknames)
#'string<)
package-use-list (sort (copy-list package-use-list)
#'string< :key #'package-name)
package-used-by-list (sort (copy-list package-used-by-list)
#'string< :key #'package-name)
shadowed-symbols (sort (copy-list shadowed-symbols)
#'string<))
;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18.
(setf present-symbols (sort present-symbols #'string<)
internal-symbols (sort internal-symbols #'string<)
external-symbols (sort external-symbols #'string<)
inherited-symbols (sort inherited-symbols #'string<))
`("" ;; dummy to preserve indentation.
"Name: " (:value ,package-name) (:newline)
"Nick names: " ,@(common-seperated-spec package-nicknames) (:newline)
,@(when (documentation package t)
`("Documentation:" (:newline)
,(documentation package t) (:newline)))
"Use list: " ,@(common-seperated-spec
package-use-list
(lambda (package)
`(:value ,package ,(package-name package))))
(:newline)
"Used by list: " ,@(common-seperated-spec
package-used-by-list
(lambda (package)
`(:value ,package ,(package-name package))))
(:newline)
,(display-link "present" present-symbols present-symbols-length
:title
(format nil "All present symbols of package \"~A\""
package-name)
:description
'("A symbol is considered present in a package if it's"
(:newline)
"\"accessible in that package directly, rather than"
(:newline)
"being inherited from another package.\""
(:newline)
"(CLHS glossary entry for `present')"
(:newline)))
(:newline)
,(display-link "external" external-symbols external-symbols-length
:title
(format nil "All external symbols of package \"~A\""
package-name)
:description
'("A symbol is considered external of a package if it's"
(:newline)
"\"part of the `external interface' to the package and"
(:newline)
"[is] inherited by any other package that uses the"
(:newline)
"package.\" (CLHS glossary entry of `external')"
(:newline)))
(:newline)
,(display-link "internal" internal-symbols internal-symbols-length
:title
(format nil "All internal symbols of package \"~A\""
package-name)
:description
'("A symbol is considered internal of a package if it's"
(:newline)
"present and not external---that is if the package is"
(:newline)
"the home package of the symbol, or if the symbol has"
(:newline)
"been explicitly imported into the package."
(:newline)
(:newline)
"Notice that inherited symbols will thus not be listed,"
(:newline)
"which deliberately deviates from the CLHS glossary"
(:newline)
"entry of `internal' because it's assumed to be more"
(:newline)
"useful this way."
(:newline)))
(:newline)
,(display-link "inherited" inherited-symbols inherited-symbols-length
:title
(format nil "All inherited symbols of package \"~A\""
package-name)
:description
'("A symbol is considered inherited in a package if it"
(:newline)
"was made accessible via USE-PACKAGE."
(:newline)))
(:newline)
,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
:title
(format nil "All shadowed symbols of package \"~A\""
package-name)
:description nil))))
(defmethod emacs-inspect ((pathname pathname))
`(,(if (wild-pathname-p pathname)
"A wild pathname."
"A pathname.")
(:newline)
,@(label-value-line*
("Namestring" (namestring pathname))
("Host" (pathname-host pathname))
("Device" (pathname-device pathname))
("Directory" (pathname-directory pathname))
("Name" (pathname-name pathname))
("Type" (pathname-type pathname))
("Version" (pathname-version pathname)))
,@ (unless (or (wild-pathname-p pathname)
(not (probe-file pathname)))
(label-value-line "Truename" (truename pathname)))))
(defmethod emacs-inspect ((pathname logical-pathname))
(append
(label-value-line*
("Namestring" (namestring pathname))
("Physical pathname: " (translate-logical-pathname pathname)))
`("Host: "
(:value ,(pathname-host pathname))
" ("
(:value ,(logical-pathname-translations
(pathname-host pathname)))
" other translations)"
(:newline))
(label-value-line*
("Directory" (pathname-directory pathname))
("Name" (pathname-name pathname))
("Type" (pathname-type pathname))
("Version" (pathname-version pathname))
("Truename" (if (not (wild-pathname-p pathname))
(probe-file pathname))))))
(defmethod emacs-inspect ((n number))
`("Value: " ,(princ-to-string n)))
(defun format-iso8601-time (time-value &optional include-timezone-p)
"Formats a universal time TIME-VALUE in ISO 8601 format, with
the time zone included if INCLUDE-TIMEZONE-P is non-NIL"
;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html
;; Thanks, Nikolai Sandved and Thomas Russ!
(flet ((format-iso8601-timezone (zone)
(if (zerop zone)
"Z"
(multiple-value-bind (h m) (truncate (abs zone) 1.0)
;; Tricky. Sign of time zone is reversed in ISO 8601
;; relative to Common Lisp convention!
(format nil "~:[+~;-~]~2,'0D:~2,'0D"
(> zone 0) h (round (* 60 m)))))))
(multiple-value-bind (second minute hour day month year dow dst zone)
(decode-universal-time time-value)
(declare (ignore dow))
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
year month day hour minute second
include-timezone-p (format-iso8601-timezone (if dst
(+ zone 1)
zone))))))
(defmethod emacs-inspect ((i integer))
(append
`(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
i i i i (ignore-errors (coerce i 'float)))
(:newline))
(when (< -1 i char-code-limit)
(label-value-line "Code-char" (code-char i)))
(label-value-line "Integer-length" (integer-length i))
(ignore-errors
(label-value-line "Universal-time" (format-iso8601-time i t)))))
(defmethod emacs-inspect ((c complex))
(label-value-line*
("Real part" (realpart c))
("Imaginary part" (imagpart c))))
(defmethod emacs-inspect ((r ratio))
(label-value-line*
("Numerator" (numerator r))
("Denominator" (denominator r))
("As float" (float r))))
(defmethod emacs-inspect ((f float))
(cond
((float-nan-p f)
;; try NaN first because the next tests may perform operations
;; that are undefined for NaNs.
(list "Not a Number."))
((not (float-infinity-p f))
(multiple-value-bind (significand exponent sign) (decode-float f)
(append
`("Scientific: " ,(format nil "~E" f) (:newline)
"Decoded: "
(:value ,sign) " * "
(:value ,significand) " * "
(:value ,(float-radix f)) "^"
(:value ,exponent) (:newline))
(label-value-line "Digits" (float-digits f))
(label-value-line "Precision" (float-precision f)))))
((> f 0)
(list "Positive infinity."))
((< f 0)
(list "Negative infinity."))))
(defun make-pathname-ispec (pathname position)
`("Pathname: "
(:value ,pathname)
(:newline) " "
,@(when position
`((:action "[visit file and show current position]"
,(lambda ()
(ed-in-emacs `(,pathname :position ,position :bytep t)))
:refreshp nil)
(:newline)))))
(defun make-file-stream-ispec (stream)
;; SBCL's socket stream are file-stream but are not associated to
;; any pathname.
(let ((pathname (ignore-errors (pathname stream))))
(when pathname
(make-pathname-ispec pathname (and (open-stream-p stream)
(file-position stream))))))
(defmethod emacs-inspect ((stream file-stream))
(multiple-value-bind (content)
(call-next-method)
(append (make-file-stream-ispec stream) content)))
(defmethod emacs-inspect ((condition stream-error))
(multiple-value-bind (content)
(call-next-method)
(let ((stream (stream-error-stream condition)))
(append (when (typep stream 'file-stream)
(make-file-stream-ispec stream))
content))))
(defun common-seperated-spec (list &optional (callback (lambda (v)
`(:value ,v))))
(butlast
(loop
for i in list
collect (funcall callback i)
collect ", ")))
(defun inspector-princ (list)
"Like princ-to-string, but don't rewrite (function foo) as #'foo.
Do NOT pass circular lists to this function."
(let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
(set-pprint-dispatch '(cons (member function)) nil)
(princ-to-string list)))
(provide :slynk/fancy-inspector)
;;; slynk-arglists.lisp --- arglist related code ??
;;
;; Authors: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;; Tobias C. Rittweiler <tcr@freebits.de>
;; and others
;;
;; License: Public Domain
;;
(in-package :slynk)
;;;; Utilities
(defun compose (&rest functions)
"Compose FUNCTIONS right-associatively, returning a function"
#'(lambda (x)
(reduce #'funcall functions :initial-value x :from-end t)))
(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))))
(declaim (inline memq))
(defun memq (item list)
(member item list :test #'eq))
(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))
(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)
(member symbol '(declare declaim))))
(defun function-exists-p (form)
(and (valid-function-name-p form)
(fboundp form)
t))
(defmacro multiple-value-or (&rest forms)
(if (null forms)
nil
(let ((first (first forms))
(rest (rest forms)))
`(let* ((values (multiple-value-list ,first))
(primary-value (first values)))
(if primary-value
(values-list values)
(multiple-value-or ,@rest))))))
(defun arglist-available-p (arglist)
(not (eql arglist :not-available)))
(defmacro with-available-arglist ((var &rest more-vars) form &body body)
`(multiple-value-bind (,var ,@more-vars) ,form
(if (eql ,var :not-available)
:not-available
(progn ,@body))))
;;;; Arglist Definition
(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) ...))
;;;
;; This is a wrapper object around anything that came from Slime and
;; could not reliably be read.
(defstruct (arglist-dummy
(:conc-name #:arglist-dummy.)
(:constructor make-arglist-dummy (string-representation)))
string-representation)
(defun empty-arg-p (dummy)
(and (arglist-dummy-p dummy)
(zerop (length (arglist-dummy.string-representation dummy)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter +lambda-list-keywords+
'(&provided &required &optional &rest &key &any)))
(defmacro do-decoded-arglist (decoded-arglist &body clauses)
(assert (loop for clause in clauses
thereis (member (car clause) +lambda-list-keywords+)))
(flet ((parse-clauses (clauses)
(let* ((size (length +lambda-list-keywords+))
(initial (make-hash-table :test #'eq :size size))
(main (make-hash-table :test #'eq :size size))
(final (make-hash-table :test #'eq :size size)))
(loop for clause in clauses
for lambda-list-keyword = (first clause)
for clause-parameter = (second clause)
do
(case clause-parameter
(:initially
(setf (gethash lambda-list-keyword initial) clause))
(:finally
(setf (gethash lambda-list-keyword final) clause))
(t
(setf (gethash lambda-list-keyword main) clause)))
finally
(return (values initial main final)))))
(generate-main-clause (clause arglist)
(destructure-case clause
((&provided (&optional arg) . body)
(let ((gensym (gensym "PROVIDED-ARG+")))
`(dolist (,gensym (arglist.provided-args ,arglist))
(declare (ignorable ,gensym))
(let (,@(when arg `((,arg ,gensym))))
,@body))))
((&required (&optional arg) . body)
(let ((gensym (gensym "REQUIRED-ARG+")))
`(dolist (,gensym (arglist.required-args ,arglist))
(declare (ignorable ,gensym))
(let (,@(when arg `((,arg ,gensym))))
,@body))))
((&optional (&optional arg init) . body)
(let ((optarg (gensym "OPTIONAL-ARG+")))
`(dolist (,optarg (arglist.optional-args ,arglist))
(declare (ignorable ,optarg))
(let (,@(when arg
`((,arg (optional-arg.arg-name ,optarg))))
,@(when init
`((,init (optional-arg.default-arg ,optarg)))))
,@body))))
((&key (&optional keyword arg init) . body)
(let ((keyarg (gensym "KEY-ARG+")))
`(dolist (,keyarg (arglist.keyword-args ,arglist))
(declare (ignorable ,keyarg))
(let (,@(when keyword
`((,keyword (keyword-arg.keyword ,keyarg))))
,@(when arg
`((,arg (keyword-arg.arg-name ,keyarg))))
,@(when init
`((,init (keyword-arg.default-arg ,keyarg)))))
,@body))))
((&rest (&optional arg body-p) . body)
`(when (arglist.rest ,arglist)
(let (,@(when arg `((,arg (arglist.rest ,arglist))))
,@(when body-p `((,body-p (arglist.body-p ,arglist)))))
,@body)))
((&any (&optional arg) . body)
(let ((gensym (gensym "REQUIRED-ARG+")))
`(dolist (,gensym (arglist.any-args ,arglist))
(declare (ignorable ,gensym))
(let (,@(when arg `((,arg ,gensym))))
,@body)))))))
(let ((arglist (gensym "DECODED-ARGLIST+")))
(multiple-value-bind (initially-clauses main-clauses finally-clauses)
(parse-clauses clauses)
`(let ((,arglist ,decoded-arglist))
(block do-decoded-arglist
,@(loop for keyword in '(&provided &required
&optional &rest &key &any)
append (cddr (gethash keyword initially-clauses))
collect (let ((clause (gethash keyword main-clauses)))
(when clause
(generate-main-clause clause arglist)))
append (cddr (gethash keyword finally-clauses)))))))))
;;;; Arglist Printing
(defun undummy (x)
(if (typep x 'arglist-dummy)
(arglist-dummy.string-representation x)
(prin1-to-string x)))
(defun print-decoded-arglist (arglist &key operator provided-args highlight)
(let ((first-space-after-operator (and operator t)))
(macrolet ((space ()
;; Kludge: When OPERATOR is not given, we don't want to
;; print a space for the first argument.
`(if (not operator)
(setq operator t)
(progn (write-char #\space)
(if first-space-after-operator
(setq first-space-after-operator nil)
(pprint-newline :fill)))))
(with-highlighting ((&key index) &body body)
`(if (eql ,index (car highlight))
(progn (princ "===> ") ,@body (princ " <==="))
(progn ,@body)))
(print-arglist-recursively (argl &key index)
`(if (eql ,index (car highlight))
(print-decoded-arglist ,argl :highlight (cdr highlight))
(print-decoded-arglist ,argl))))
(let ((index 0))
(pprint-logical-block (nil nil :prefix "(" :suffix ")")
(when operator
(print-arg operator)
(pprint-indent :current 1)) ; 1 due to possibly added space
(do-decoded-arglist (remove-given-args arglist provided-args)
(&provided (arg)
(space)
(print-arg arg :literal-strings t)
(incf index))
(&required (arg)
(space)
(if (arglist-p arg)
(print-arglist-recursively arg :index index)
(with-highlighting (:index index)
(print-arg arg)))
(incf index))
(&optional :initially
(when (arglist.optional-args arglist)
(space)
(princ '&optional)))
(&optional (arg init-value)
(space)
(if (arglist-p arg)
(print-arglist-recursively arg :index index)
(with-highlighting (:index index)
(if (null init-value)
(print-arg arg)
(format t "~:@<~A ~A~@:>"
(undummy arg) (undummy init-value)))))
(incf index))
(&key :initially
(when (arglist.key-p arglist)
(space)
(princ '&key)))
(&key (keyword arg init)
(space)
(if (arglist-p arg)
(pprint-logical-block (nil nil :prefix "(" :suffix ")")
(prin1 keyword) (space)
(print-arglist-recursively arg :index keyword))
(with-highlighting (:index keyword)
(cond ((and init (keywordp keyword))
(format t "~:@<~A ~A~@:>" keyword (undummy init)))
(init
(format t "~:@<(~A ..) ~A~@:>"
(undummy keyword) (undummy init)))
((not (keywordp keyword))
(format t "~:@<(~S ..)~@:>" keyword))
(t
(princ keyword))))))
(&key :finally
(when (arglist.allow-other-keys-p arglist)
(space)
(princ '&allow-other-keys)))
(&any :initially
(when (arglist.any-p arglist)
(space)
(princ '&any)))
(&any (arg)
(space)
(print-arg arg))
(&rest (args bodyp)
(space)
(princ (if bodyp '&body '&rest))
(space)
(if (arglist-p args)
(print-arglist-recursively args :index index)
(with-highlighting (:index index)
(print-arg args))))
;; FIXME: add &UNKNOWN-JUNK?
))))))
(defun print-arg (arg &key literal-strings)
(let ((arg (if (arglist-dummy-p arg)
(arglist-dummy.string-representation arg)
arg)))
(if (or
(and literal-strings
(stringp arg))
(keywordp arg))
(prin1 arg)
(princ arg))))
(defun print-decoded-arglist-as-template (decoded-arglist &key
(prefix "(") (suffix ")"))
(let ((first-p t))
(flet ((space ()
(unless first-p
(write-char #\space))
(setq first-p nil))
(print-arg-or-pattern (arg)
(etypecase arg
(symbol (if (keywordp arg) (prin1 arg) (princ arg)))
(string (princ arg))
(list (princ arg))
(arglist-dummy (princ
(arglist-dummy.string-representation arg)))
(arglist (print-decoded-arglist-as-template arg)))
(pprint-newline :fill)))
(pprint-logical-block (nil nil :prefix prefix :suffix suffix)
(do-decoded-arglist decoded-arglist
(&provided ()) ; do nothing; provided args are in the buffer already.
(&required (arg)
(space) (print-arg-or-pattern arg))
(&optional (arg)
(space) (princ "[") (print-arg-or-pattern arg) (princ "]"))
(&key (keyword arg)
(space)
(prin1 (if (keywordp keyword) keyword `',keyword))
(space)
(print-arg-or-pattern arg)
(pprint-newline :linear))
(&any (arg)
(space) (print-arg-or-pattern arg))
(&rest (args)
(when (or (not (arglist.keyword-args decoded-arglist))
(arglist.allow-other-keys-p decoded-arglist))
(space)
(format t "~A..." args))))))))
(defvar *arglist-pprint-bindings*
'((*print-case* . :downcase)
(*print-pretty* . t)
(*print-circle* . nil)
(*print-readably* . nil)
(*print-level* . 10)
(*print-length* . 20)
(*print-escape* . nil)))
(defvar *arglist-show-packages* t)
(defmacro with-arglist-io-syntax (&body body)
(let ((package (gensym)))
`(let ((,package *package*))
(with-standard-io-syntax
(let ((*package* (if *arglist-show-packages*
*package*
,package)))
(with-bindings *arglist-pprint-bindings*
,@body))))))
(defun decoded-arglist-to-string (decoded-arglist
&key operator highlight
print-right-margin)
(with-output-to-string (*standard-output*)
(with-arglist-io-syntax
(let ((*print-right-margin* print-right-margin))
(print-decoded-arglist decoded-arglist
:operator operator
:highlight highlight)))))
(defun decoded-arglist-to-template-string (decoded-arglist
&key (prefix "(") (suffix ")"))
(with-output-to-string (*standard-output*)
(with-arglist-io-syntax
(print-decoded-arglist-as-template decoded-arglist
:prefix prefix
:suffix suffix))))
;;;; Arglist Decoding / Encoding
(defun decode-required-arg (arg)
"ARG can be a symbol or a destructuring pattern."
(etypecase arg
(symbol arg)
(arglist-dummy arg)
(list (decode-arglist arg))
(number 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)
(defun canonicalize-default-arg (form)
(if (equalp ''nil form)
nil
form))
(defun make-keyword-arg (keyword arg-name default-arg)
(%make-keyword-arg :keyword keyword
:arg-name arg-name
:default-arg (canonicalize-default-arg default-arg)))
(defun decode-keyword-arg (arg)
"Decode a keyword item of formal argument list.
Return three values: keyword, argument name, default arg."
(flet ((intern-as-keyword (arg)
(intern (etypecase arg
(symbol (symbol-name arg))
(arglist-dummy (arglist-dummy.string-representation arg)))
+keyword-package+)))
(cond ((or (symbolp arg) (arglist-dummy-p arg))
(make-keyword-arg (intern-as-keyword arg) arg nil))
((and (consp arg)
(consp (car arg)))
(make-keyword-arg (caar arg)
(decode-required-arg (cadar arg))
(cadr arg)))
((consp arg)
(make-keyword-arg (intern-as-keyword (car arg))
(car arg) (cadr arg)))
(t
(error "Bad keyword item of formal argument list")))))
(defun encode-keyword-arg (arg)
(cond
((arglist-p (keyword-arg.arg-name arg))
;; Destructuring pattern
(let ((keyword/name (list (keyword-arg.keyword arg)
(encode-required-arg
(keyword-arg.arg-name arg)))))
(if (keyword-arg.default-arg arg)
(list keyword/name
(keyword-arg.default-arg arg))
(list keyword/name))))
((eql (intern (symbol-name (keyword-arg.arg-name arg))
+keyword-package+)
(keyword-arg.keyword arg))
(if (keyword-arg.default-arg arg)
(list (keyword-arg.arg-name arg)
(keyword-arg.default-arg arg))
(keyword-arg.arg-name arg)))
(t
(let ((keyword/name (list (keyword-arg.keyword arg)
(keyword-arg.arg-name arg))))
(if (keyword-arg.default-arg arg)
(list keyword/name
(keyword-arg.default-arg arg))
(list keyword/name))))))
(progn
(assert (equalp (decode-keyword-arg 'x)
(make-keyword-arg :x 'x nil)))
(assert (equalp (decode-keyword-arg '(x t))
(make-keyword-arg :x 'x t)))
(assert (equalp (decode-keyword-arg '((:x y)))
(make-keyword-arg :x 'y nil)))
(assert (equalp (decode-keyword-arg '((:x y) t))
(make-keyword-arg :x 'y t))))
;;; FIXME suppliedp?
(defstruct (optional-arg
(:conc-name optional-arg.)
(:constructor %make-optional-arg))
arg-name
default-arg)
(defun make-optional-arg (arg-name default-arg)
(%make-optional-arg :arg-name arg-name
:default-arg (canonicalize-default-arg default-arg)))
(defun decode-optional-arg (arg)
"Decode an optional item of a formal argument list.
Return an OPTIONAL-ARG structure."
(etypecase arg
(symbol (make-optional-arg arg nil))
(arglist-dummy (make-optional-arg arg nil))
(list (make-optional-arg (decode-required-arg (car arg))
(cadr arg)))))
(defun encode-optional-arg (optional-arg)
(if (or (optional-arg.default-arg optional-arg)
(arglist-p (optional-arg.arg-name optional-arg)))
(list (encode-required-arg
(optional-arg.arg-name optional-arg))
(optional-arg.default-arg optional-arg))
(optional-arg.arg-name optional-arg)))
(progn
(assert (equalp (decode-optional-arg 'x)
(make-optional-arg 'x nil)))
(assert (equalp (decode-optional-arg '(x t))
(make-optional-arg 'x t))))
(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
(defun decode-arglist (arglist)
"Parse the list ARGLIST and return an ARGLIST structure."
(if (eq arglist :not-available) (return-from decode-arglist arglist))
(loop
with mode = nil
with result = (make-arglist)
for arg = (if (consp arglist)
(pop arglist)
(progn
(prog1 arglist
(setf mode '&rest
arglist nil))))
do (cond
((eql mode '&unknown-junk)
;; don't leave this mode -- we don't know how the arglist
;; after unknown lambda-list keywords is interpreted
(push arg (arglist.unknown-junk result)))
((eql arg '&allow-other-keys)
(setf (arglist.allow-other-keys-p result) t))
((eql arg '&key)
(setf (arglist.key-p result) t
mode arg))
((memq arg '(&optional &rest &body &aux))
(setq mode arg))
((memq 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))
((memq arg lambda-list-keywords)
(setq mode '&unknown-junk)
(push arg (arglist.unknown-junk result)))
(t
(ecase mode
(&key
(push (decode-keyword-arg arg)
(arglist.keyword-args result)))
(&optional
(push (decode-optional-arg arg)
(arglist.optional-args result)))
(&body
(setf (arglist.body-p result) t
(arglist.rest result) arg))
(&rest
(setf (arglist.rest result) arg))
(&aux
(push (decode-optional-arg arg)
(arglist.aux-args result)))
((nil)
(push (decode-required-arg arg)
(arglist.required-args result)))
((&whole &environment)
(setf mode nil)
(push arg (arglist.known-junk result)))
(&any
(push arg (arglist.any-args result))))))
until (null arglist)
finally (nreversef (arglist.required-args result))
finally (nreversef (arglist.optional-args result))
finally (nreversef (arglist.keyword-args result))
finally (nreversef (arglist.aux-args result))
finally (nreversef (arglist.any-args result))
finally (nreversef (arglist.known-junk result))
finally (nreversef (arglist.unknown-junk result))
finally (assert (or (and (not (arglist.key-p result))
(not (arglist.any-p result)))
(exactly-one-p (arglist.key-p result)
(arglist.any-p result))))
finally (return result)))
(defun encode-arglist (decoded-arglist)
(append (mapcar #'encode-required-arg
(arglist.required-args decoded-arglist))
(when (arglist.optional-args decoded-arglist)
'(&optional))
(mapcar #'encode-optional-arg
(arglist.optional-args decoded-arglist))
(when (arglist.key-p decoded-arglist)
'(&key))
(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)
`(&body ,(arglist.rest decoded-arglist)))
(t
`(&rest ,(arglist.rest decoded-arglist))))
(when (arglist.aux-args decoded-arglist)
`(&aux ,(arglist.aux-args decoded-arglist)))
(arglist.known-junk decoded-arglist)
(arglist.unknown-junk decoded-arglist)))
;;;; Arglist Enrichment
(defun arglist-keywords (lambda-list)
"Return the list of keywords in ARGLIST.
As a secondary value, return whether &allow-other-keys appears."
(let ((decoded-arglist (decode-arglist lambda-list)))
(values (arglist.keyword-args decoded-arglist)
(arglist.allow-other-keys-p decoded-arglist))))
(defun methods-keywords (methods)
"Collect all keywords in the arglists of METHODS.
As a secondary value, return whether &allow-other-keys appears somewhere."
(let ((keywords '())
(allow-other-keys nil))
(dolist (method methods)
(multiple-value-bind (kw aok)
(arglist-keywords
(slynk-mop:method-lambda-list method))
(setq keywords (remove-duplicates (append keywords kw)
:key #'keyword-arg.keyword)
allow-other-keys (or allow-other-keys aok))))
(values keywords allow-other-keys)))
(defun generic-function-keywords (generic-function)
"Collect all keywords in the methods of GENERIC-FUNCTION.
As a secondary value, return whether &allow-other-keys appears somewhere."
(methods-keywords
(slynk-mop:generic-function-methods generic-function)))
(defun applicable-methods-keywords (generic-function arguments)
"Collect all keywords in the methods of GENERIC-FUNCTION that are
applicable for argument of CLASSES. As a secondary value, return
whether &allow-other-keys appears somewhere."
(methods-keywords
(multiple-value-bind (amuc okp)
(slynk-mop:compute-applicable-methods-using-classes
generic-function (mapcar #'class-of arguments))
(if okp
amuc
(compute-applicable-methods generic-function arguments)))))
(defgeneric extra-keywords (operator args)
(:documentation "Return a list of extra keywords of OPERATOR (a
symbol) when applied to the (unevaluated) ARGS.
As a secondary value, return whether other keys are allowed.
As a tertiary value, return the initial sublist of ARGS that was needed
to determine the extra keywords."))
;;; We make sure that symbol-from-KEYWORD-using keywords come before
;;; symbol-from-arbitrary-package-using keywords. And we sort the
;;; latter according to how their home-packages relate to *PACKAGE*.
;;;
;;; Rationale is to show those key parameters first which make most
;;; sense in the current context. And in particular: to put
;;; implementation-internal stuff last.
;;;
;;; This matters tremendeously on Allegro in combination with
;;; AllegroCache as that does some evil tinkering with initargs,
;;; obfuscating the arglist of MAKE-INSTANCE.
;;;
(defmethod extra-keywords :around (op args)
(declare (ignorable op args))
(multiple-value-bind (keywords aok enrichments) (call-next-method)
(values (sort-extra-keywords keywords) aok enrichments)))
(defun make-package-comparator (reference-packages)
"Returns a two-argument test function which compares packages
according to their used-by relation with REFERENCE-PACKAGES. Packages
will be sorted first which appear first in the PACKAGE-USE-LIST of the
reference packages."
(let ((package-use-table (make-hash-table :test 'eq)))
;; Walk the package dependency graph breadth-fist, and fill
;; PACKAGE-USE-TABLE accordingly.
(loop with queue = (copy-list reference-packages)
with bfn = 0 ; Breadth-First Number
for p = (pop queue)
unless (gethash p package-use-table)
do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn)))
and do (setf queue (nconc queue (copy-list (package-use-list p))))
while queue)
#'(lambda (p1 p2)
(let ((bfn1 (gethash p1 package-use-table))
(bfn2 (gethash p2 package-use-table)))
(cond ((and bfn1 bfn2) (<= bfn1 bfn2))
(bfn1 bfn1)
(bfn2 nil) ; p2 is used, p1 not
(t (string<= (package-name p1) (package-name p2))))))))
(defun sort-extra-keywords (kwds)
(stable-sort kwds (make-package-comparator (list +keyword-package+ *package*))
:key (compose #'symbol-package #'keyword-arg.keyword)))
(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."
(with-available-arglist (arglist) (arglist-from-form (ensure-list operator))
(values (arglist.keyword-args arglist)
(arglist.allow-other-keys-p arglist))))
(defmethod extra-keywords (operator args)
;; default method
(declare (ignore args))
(let ((symbol-function (symbol-function operator)))
(if (typep symbol-function 'generic-function)
(generic-function-keywords symbol-function)
nil)))
(defun class-from-class-name-form (class-name-form)
(when (and (listp class-name-form)
(= (length class-name-form) 2)
(eq (car class-name-form) 'quote))
(let* ((class-name (cadr class-name-form))
(class (find-class class-name nil)))
(when (and class
(not (slynk-mop:class-finalized-p class)))
;; Try to finalize the class, which can fail if
;; superclasses are not defined yet
(ignore-errors (slynk-mop:finalize-inheritance class)))
class)))
(defun extra-keywords/slots (class)
(multiple-value-bind (slots allow-other-keys-p)
(if (slynk-mop:class-finalized-p class)
(values (slynk-mop:class-slots class) nil)
(values (slynk-mop:class-direct-slots class) t))
(let ((slot-init-keywords
(loop for slot in slots append
(mapcar (lambda (initarg)
(make-keyword-arg
initarg
(slynk-mop:slot-definition-name slot)
(and (slynk-mop:slot-definition-initfunction slot)
(slynk-mop:slot-definition-initform slot))))
(slynk-mop:slot-definition-initargs slot)))))
(values slot-init-keywords allow-other-keys-p))))
(defun extra-keywords/make-instance (operator args)
(declare (ignore operator))
(unless (null args)
(let* ((class-name-form (car args))
(class (class-from-class-name-form class-name-form)))
(when class
(multiple-value-bind (slot-init-keywords class-aokp)
(extra-keywords/slots class)
(multiple-value-bind (allocate-instance-keywords ai-aokp)
(applicable-methods-keywords
#'allocate-instance (list class))
(multiple-value-bind (initialize-instance-keywords ii-aokp)
(ignore-errors
(applicable-methods-keywords
#'initialize-instance
(list (slynk-mop:class-prototype class))))
(multiple-value-bind (shared-initialize-keywords si-aokp)
(ignore-errors
(applicable-methods-keywords
#'shared-initialize
(list (slynk-mop:class-prototype class) t)))
(values (append slot-init-keywords
allocate-instance-keywords
initialize-instance-keywords
shared-initialize-keywords)
(or class-aokp ai-aokp ii-aokp si-aokp)
(list class-name-form))))))))))
(defun extra-keywords/change-class (operator args)
(declare (ignore operator))
(unless (null args)
(let* ((class-name-form (car args))
(class (class-from-class-name-form class-name-form)))
(when class
(multiple-value-bind (slot-init-keywords class-aokp)
(extra-keywords/slots class)
(declare (ignore class-aokp))
(multiple-value-bind (shared-initialize-keywords si-aokp)
(ignore-errors
(applicable-methods-keywords
#'shared-initialize
(list (slynk-mop:class-prototype class) t)))
;; FIXME: much as it would be nice to include the
;; applicable keywords from
;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
;; how to do it: so we punt, always declaring
;; &ALLOW-OTHER-KEYS.
(declare (ignore si-aokp))
(values (append slot-init-keywords shared-initialize-keywords)
t
(list class-name-form))))))))
(defmethod extra-keywords ((operator (eql 'make-instance))
args)
(multiple-value-or (extra-keywords/make-instance operator args)
(call-next-method)))
(defmethod extra-keywords ((operator (eql 'make-condition))
args)
(multiple-value-or (extra-keywords/make-instance operator args)
(call-next-method)))
(defmethod extra-keywords ((operator (eql 'error))
args)
(multiple-value-or (extra-keywords/make-instance operator args)
(call-next-method)))
(defmethod extra-keywords ((operator (eql 'signal))
args)
(multiple-value-or (extra-keywords/make-instance operator args)
(call-next-method)))
(defmethod extra-keywords ((operator (eql 'warn))
args)
(multiple-value-or (extra-keywords/make-instance operator args)
(call-next-method)))
(defmethod extra-keywords ((operator (eql 'cerror))
args)
(multiple-value-bind (keywords aok determiners)
(extra-keywords/make-instance operator (cdr args))
(if keywords
(values keywords aok
(cons (car args) determiners))
(call-next-method))))
(defmethod extra-keywords ((operator (eql 'change-class))
args)
(multiple-value-bind (keywords aok determiners)
(extra-keywords/change-class operator (cdr args))
(if keywords
(values keywords aok
(cons (car args) determiners))
(call-next-method))))
(defmethod extra-keywords ((operator symbol) args)
(declare (ignore args))
(multiple-value-or
(let ((extra-keyword-arglist (get operator :slynk-extra-keywords)))
(when extra-keyword-arglist
(values (loop for (sym default) in extra-keyword-arglist
for keyword = (intern (symbol-name sym) :keyword)
collect (make-keyword-arg keyword
keyword
default))
(get operator :slynk-allow-other-keywords)
nil)))
(call-next-method)))
(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords
allow-other-keys-p)
"Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
(when keywords
(setf (arglist.key-p decoded-arglist) t)
(setf (arglist.keyword-args decoded-arglist)
(remove-duplicates
(append (arglist.keyword-args decoded-arglist)
keywords)
:key #'keyword-arg.keyword)))
(setf (arglist.allow-other-keys-p decoded-arglist)
(or (arglist.allow-other-keys-p decoded-arglist)
allow-other-keys-p)))
(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
"Determine extra keywords from the function call FORM, and modify
DECODED-ARGLIST to include them. As a secondary return value, return
the initial sublist of ARGS that was needed to determine the extra
keywords. As a tertiary return value, return whether any enrichment
was done."
(multiple-value-bind (extra-keywords extra-aok determining-args)
(extra-keywords (car form) (cdr form))
;; enrich the list of keywords with the extra keywords
(enrich-decoded-arglist-with-keywords decoded-arglist
extra-keywords extra-aok)
(values decoded-arglist
determining-args
(or extra-keywords extra-aok))))
(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
(:documentation
"Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
If the arglist is not available, return :NOT-AVAILABLE."))
(defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
(with-available-arglist (decoded-arglist)
(decode-arglist (arglist operator-form))
(enrich-decoded-arglist-with-extra-keywords decoded-arglist
(cons operator-form
argument-forms))))
(defmethod compute-enriched-decoded-arglist
((operator-form (eql 'with-open-file)) argument-forms)
(declare (ignore argument-forms))
(multiple-value-bind (decoded-arglist determining-args)
(call-next-method)
(let ((first-arg (first (arglist.required-args decoded-arglist)))
(open-arglist (compute-enriched-decoded-arglist 'open nil)))
(when (and (arglist-p first-arg) (arglist-p open-arglist))
(enrich-decoded-arglist-with-keywords
first-arg
(arglist.keyword-args open-arglist)
nil)))
(values decoded-arglist determining-args t)))
(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
argument-forms)
(let ((function-name-form (car argument-forms)))
(when (and (listp function-name-form)
(length= function-name-form 2)
(memq (car function-name-form) '(quote function)))
(let ((function-name (cadr function-name-form)))
(when (valid-operator-symbol-p function-name)
(let ((function-arglist
(compute-enriched-decoded-arglist function-name
(cdr argument-forms))))
(return-from compute-enriched-decoded-arglist
(values
(make-arglist :required-args
(list 'function)
:optional-args
(append
(mapcar #'(lambda (arg)
(make-optional-arg arg nil))
(arglist.required-args function-arglist))
(arglist.optional-args function-arglist))
:key-p
(arglist.key-p function-arglist)
:keyword-args
(arglist.keyword-args function-arglist)
:rest
'args
:allow-other-keys-p
(arglist.allow-other-keys-p function-arglist))
(list function-name-form)
t)))))))
(call-next-method))
(defmethod compute-enriched-decoded-arglist
((operator-form (eql 'multiple-value-call)) argument-forms)
(compute-enriched-decoded-arglist 'apply argument-forms))
(defun delete-given-args (decoded-arglist args)
"Delete given ARGS from DECODED-ARGLIST."
(macrolet ((pop-or-return (list)
`(if (null ,list)
(return-from do-decoded-arglist)
(pop ,list))))
(do-decoded-arglist decoded-arglist
(&provided ()
(assert (eq (pop-or-return args)
(pop (arglist.provided-args decoded-arglist)))))
(&required ()
(pop-or-return args)
(pop (arglist.required-args decoded-arglist)))
(&optional ()
(pop-or-return args)
(pop (arglist.optional-args decoded-arglist)))
(&key (keyword)
;; N.b. we consider a keyword to be given only when the keyword
;; _and_ a value has been given for it.
(loop for (key value) on args by #'cddr
when (and (eq keyword key) value)
do (setf (arglist.keyword-args decoded-arglist)
(remove keyword (arglist.keyword-args decoded-arglist)
:key #'keyword-arg.keyword))))))
decoded-arglist)
(defun remove-given-args (decoded-arglist args)
;; FIXME: We actually needa deep copy here.
(delete-given-args (copy-arglist decoded-arglist) args))
;;;; Arglist Retrieval
(defun arglist-from-form (form)
(if (null form)
:not-available
(arglist-dispatch (car form) (cdr form))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export 'arglist-dispatch))
(defgeneric arglist-dispatch (operator arguments)
;; Default method
(:method (operator arguments)
(unless (and (symbolp operator) (valid-operator-symbol-p operator))
(return-from arglist-dispatch :not-available))
(when (equalp (package-name (symbol-package operator)) "closer-mop")
(let ((standard-symbol (or (find-symbol (symbol-name operator) :cl)
(find-symbol (symbol-name operator) :slynk-mop))))
(when standard-symbol
(return-from arglist-dispatch
(arglist-dispatch standard-symbol arguments)))))
(multiple-value-bind (decoded-arglist determining-args)
(compute-enriched-decoded-arglist operator arguments)
(with-available-arglist (arglist) decoded-arglist
;; replace some formal args by determining actual args
(setf arglist (delete-given-args arglist determining-args))
(setf (arglist.provided-args arglist) determining-args)
arglist))))
(defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments)
(match (cons operator arguments)
(('defmethod (#'function-exists-p gf-name) . rest)
(let ((gf (fdefinition gf-name)))
(when (typep gf 'generic-function)
(let ((lambda-list (slynk-mop:generic-function-lambda-list gf)))
(with-available-arglist (arglist) (decode-arglist lambda-list)
(let ((qualifiers (loop for x in rest
until (or (listp x) (empty-arg-p x))
collect x)))
(return-from arglist-dispatch
(make-arglist :provided-args (cons gf-name qualifiers)
:required-args (list arglist)
:rest "body" :body-p t))))))))
(_)) ; Fall through
(call-next-method))
(defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments)
(match (cons operator arguments)
(('define-compiler-macro (#'function-exists-p gf-name) . _)
(let ((gf (fdefinition gf-name)))
(with-available-arglist (arglist) (decode-arglist (arglist gf))
(return-from arglist-dispatch
(make-arglist :provided-args (list gf-name)
:required-args (list arglist)
:rest "body" :body-p t)))))
(_)) ; Fall through
(call-next-method))
(defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments)
(declare (ignore arguments))
(let ((eval-when-args '(:compile-toplevel :load-toplevel :execute)))
(make-arglist
:required-args (list (make-arglist :any-p t :any-args eval-when-args))
:rest '#:body :body-p t)))
(defmethod arglist-dispatch ((operator (eql 'declare)) arguments)
(let* ((declaration (cons operator (last arguments)))
(typedecl-arglist (arglist-for-type-declaration declaration)))
(if (arglist-available-p typedecl-arglist)
typedecl-arglist
(match declaration
(('declare ((#'consp typespec) . decl-args))
(with-available-arglist (typespec-arglist)
(decoded-arglist-for-type-specifier typespec)
(make-arglist
:required-args (list (make-arglist
:required-args (list typespec-arglist)
:rest '#:variables)))))
(('declare (decl-identifier . decl-args))
(decoded-arglist-for-declaration decl-identifier decl-args))
(_ (make-arglist :rest '#:declaration-specifiers))))))
(defmethod arglist-dispatch ((operator (eql 'declaim)) arguments)
(arglist-dispatch 'declare arguments))
(defun arglist-for-type-declaration (declaration)
(flet ((%arglist-for-type-declaration (identifier typespec rest-var-name)
(with-available-arglist (typespec-arglist)
(decoded-arglist-for-type-specifier typespec)
(make-arglist
:required-args (list (make-arglist
:provided-args (list identifier)
:required-args (list typespec-arglist)
:rest rest-var-name))))))
(match declaration
(('declare ('type (#'consp typespec) . decl-args))
(%arglist-for-type-declaration 'type typespec '#:variables))
(('declare ('ftype (#'consp typespec) . decl-args))
(%arglist-for-type-declaration 'ftype typespec '#:function-names))
(('declare ((#'consp typespec) . decl-args))
(with-available-arglist (typespec-arglist)
(decoded-arglist-for-type-specifier typespec)
(make-arglist
:required-args (list (make-arglist
:required-args (list typespec-arglist)
:rest '#:variables)))))
(_ :not-available))))
(defun decoded-arglist-for-declaration (decl-identifier decl-args)
(declare (ignore decl-args))
(with-available-arglist (arglist)
(decode-arglist (declaration-arglist decl-identifier))
(setf (arglist.provided-args arglist) (list decl-identifier))
(make-arglist :required-args (list arglist))))
(defun decoded-arglist-for-type-specifier (type-specifier)
(etypecase type-specifier
(arglist-dummy :not-available)
(cons (decoded-arglist-for-type-specifier (car type-specifier)))
(symbol
(with-available-arglist (arglist)
(decode-arglist (type-specifier-arglist type-specifier))
(setf (arglist.provided-args arglist) (list type-specifier))
arglist))))
;;; Slimefuns
;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at
;;; user's point in Emacs. A RAW-FORM looks like
;;;
;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SLYNK::%CURSOR-MARKER%))
;;;
;;; The expression before the cursor marker is the expression where
;;; user's cursor points at. An explicit marker is necessary to
;;; disambiguate between
;;;
;;; ("IF" ("PRED")
;;; ("F" "X" "Y" %CURSOR-MARKER%))
;;;
;;; and
;;; ("IF" ("PRED")
;;; ("F" "X" "Y") %CURSOR-MARKER%)
;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes
;;; user's point, the following should be sent ("FOO" ("BAR" ""
;;; %CURSOR-MARKER%)). Only the forms up to point should be
;;; considered.
(defslyfun autodoc (raw-form &key print-right-margin)
"Return a list of two elements.
First, a string representing the arglist for the deepest subform in
RAW-FORM that does have an arglist. The highlighted parameter is
wrapped in ===> X <===.
Second, a boolean value telling whether the returned string can be cached."
(handler-bind ((serious-condition
#'(lambda (c)
(unless (debug-on-slynk-error)
(let ((*print-right-margin* print-right-margin))
(return-from autodoc
(list :error
(format nil "Arglist Error: \"~A\"" c))))))))
(with-buffer-syntax ()
(multiple-value-bind (form arglist obj-at-cursor form-path)
(find-subform-with-arglist (parse-raw-form raw-form))
(cond ((boundp-and-interesting obj-at-cursor)
(list (print-variable-to-string obj-at-cursor) nil))
(t
(list
(with-available-arglist (arglist) arglist
(decoded-arglist-to-string
arglist
:print-right-margin print-right-margin
:operator (car form)
:highlight (form-path-to-arglist-path form-path
form
arglist)))
t)))))))
(defun boundp-and-interesting (symbol)
(and symbol
(symbolp symbol)
(boundp symbol)
(not (memq symbol '(cl:t cl:nil)))
(not (keywordp symbol))))
(defun print-variable-to-string (symbol)
"Return a short description of VARIABLE-NAME, or NIL."
(let ((*print-pretty* t) (*print-level* 4)
(*print-length* 10) (*print-lines* 1)
(*print-readably* nil)
(value (symbol-value symbol)))
(call/truncated-output-to-string
75 (lambda (s)
(without-printing-errors (:object value :stream s)
(format s "~A ~A~S" symbol "=> " value))))))
(defslyfun complete-form (raw-form)
"Read FORM-STRING in the current buffer package, then complete it
by adding a template for the missing arguments."
;; We do not catch errors here because COMPLETE-FORM is an
;; interactive command, not automatically run in the background like
;; ARGLIST-FOR-ECHO-AREA.
(with-buffer-syntax ()
(multiple-value-bind (arglist provided-args)
(find-immediately-containing-arglist (parse-raw-form raw-form))
(with-available-arglist (arglist) arglist
(decoded-arglist-to-template-string
(delete-given-args arglist
(remove-if #'empty-arg-p provided-args
:from-end t :count 1))
:prefix "" :suffix "")))))
(defparameter +cursor-marker+ '%cursor-marker%)
(defun find-subform-with-arglist (form)
"Returns four values:
The appropriate subform of `form' which is closest to the
+CURSOR-MARKER+ and whose operator is valid and has an
arglist. The +CURSOR-MARKER+ is removed from that subform.
Second value is the arglist. Local function and macro definitions
appearing in `form' into account.
Third value is the object in front of +CURSOR-MARKER+.
Fourth value is a form path to that object."
(labels
((yield-success (form local-ops)
(multiple-value-bind (form obj-at-cursor form-path)
(extract-cursor-marker form)
(values form
(let ((entry (assoc (car form) local-ops :test #'op=)))
(if entry
(decode-arglist (cdr entry))
(arglist-from-form form)))
obj-at-cursor
form-path)))
(yield-failure ()
(values nil :not-available))
(operator-p (operator local-ops)
(or (and (symbolp operator) (valid-operator-symbol-p operator))
(assoc operator local-ops :test #'op=)))
(op= (op1 op2)
(cond ((and (symbolp op1) (symbolp op2))
(eq op1 op2))
((and (arglist-dummy-p op1) (arglist-dummy-p op2))
(string= (arglist-dummy.string-representation op1)
(arglist-dummy.string-representation op2)))))
(grovel-form (form local-ops)
"Descend FORM top-down, always taking the rightest branch,
until +CURSOR-MARKER+."
(assert (listp form))
(destructuring-bind (operator . args) form
;; N.b. the user's cursor is at the rightmost, deepest
;; subform right before +CURSOR-MARKER+.
(let ((last-subform (car (last form)))
(new-ops))
(cond
((eq last-subform +cursor-marker+)
(if (operator-p operator local-ops)
(yield-success form local-ops)
(yield-failure)))
((not (operator-p operator local-ops))
(grovel-form last-subform local-ops))
;; Make sure to pick up the arglists of local
;; function/macro definitions.
((setq new-ops (extract-local-op-arglists operator args))
(multiple-value-or (grovel-form last-subform
(nconc new-ops local-ops))
(yield-success form local-ops)))
;; Some typespecs clash with function names, so we make
;; sure to bail out early.
((member operator '(cl:declare cl:declaim))
(yield-success form local-ops))
;; Mostly uninteresting, hence skip.
((memq operator '(cl:quote cl:function))
(yield-failure))
(t
(multiple-value-or (grovel-form last-subform local-ops)
(yield-success form local-ops))))))))
(if (null form)
(yield-failure)
(grovel-form form '()))))
(defun extract-cursor-marker (form)
"Returns three values: normalized `form' without +CURSOR-MARKER+,
the object in front of +CURSOR-MARKER+, and a form path to that
object."
(labels ((grovel (form last path)
(let ((result-form))
(loop for (car . cdr) on form do
(cond ((eql car +cursor-marker+)
(decf (first path))
(return-from grovel
(values (nreconc result-form cdr)
last
(nreverse path))))
((consp car)
(multiple-value-bind (new-car new-last new-path)
(grovel car last (cons 0 path))
(when new-path ; CAR contained cursor-marker?
(return-from grovel
(values (nreconc
(cons new-car result-form) cdr)
new-last
new-path))))))
(push car result-form)
(setq last car)
(incf (first path))
finally
(return-from grovel
(values (nreverse result-form) nil nil))))))
(grovel form nil (list 0))))
(defgeneric extract-local-op-arglists (operator args)
(:documentation
"If the form `(OPERATOR ,@ARGS) is a local operator binding form,
return a list of pairs (OP . ARGLIST) for each locally bound op.")
(:method (operator args)
(declare (ignore operator args))
nil)
;; FLET
(:method ((operator (eql 'cl:flet)) args)
(let ((defs (first args))
(body (rest args)))
(cond ((null body) nil) ; `(flet ((foo (x) |'
((atom defs) nil) ; `(flet ,foo (|'
(t (%collect-op/argl-alist defs)))))
;; LABELS
(:method ((operator (eql 'cl:labels)) args)
;; Notice that we only have information to "look backward" and
;; show arglists of previously occuring local functions.
(destructuring-bind (defs . body) args
(unless (or (atom defs) (null body)) ; `(labels ,foo (|'
(let ((current-def (car (last defs))))
(cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|'
((not (null body))
(extract-local-op-arglists 'cl:flet args))
(t
(let ((def.body (cddr current-def)))
(when def.body
(%collect-op/argl-alist defs)))))))))
;; MACROLET
(:method ((operator (eql 'cl:macrolet)) args)
(extract-local-op-arglists 'cl:labels args)))
(defun %collect-op/argl-alist (defs)
(setq defs (remove-if-not #'(lambda (x)
;; Well-formed FLET/LABELS def?
(and (consp x) (second x)))
defs))
(loop for (name arglist . nil) in defs
collect (cons name arglist)))
(defun find-immediately-containing-arglist (form)
"Returns the arglist of the subform _immediately_ containing
+CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may
be in a nested arglist \(e.g. `(WITH-OPEN-FILE (<here>'\), and the
arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be
returned in that case."
(flet ((try (form-path form arglist)
(let* ((arglist-path (form-path-to-arglist-path form-path
form
arglist))
(argl (apply #'arglist-ref
arglist
arglist-path))
(args (apply #'provided-arguments-ref
(cdr form)
arglist
arglist-path)))
(when (and (arglist-p argl) (listp args))
(values argl args)))))
(multiple-value-bind (form arglist obj form-path)
(find-subform-with-arglist form)
(declare (ignore obj))
(with-available-arglist (arglist) arglist
;; First try the form the cursor is in (in case of a normal
;; form), then try the surrounding form (in case of a nested
;; macro form).
(multiple-value-or (try form-path form arglist)
(try (butlast form-path) form arglist)
:not-available)))))
(defun form-path-to-arglist-path (form-path form arglist)
"Convert a form path to an arglist path consisting of arglist
indices."
(labels ((convert (path args arglist)
(if (null path)
nil
(let* ((idx (car path))
(idx* (arglist-index idx args arglist))
(arglist* (and idx* (arglist-ref arglist idx*)))
(args* (and idx* (provided-arguments-ref args
arglist
idx*))))
;; The FORM-PATH may be more detailed than ARGLIST;
;; consider (defun foo (x y) ...), a form path may
;; point into the function's lambda-list, but the
;; arglist of DEFUN won't contain as much information.
;; So we only recurse if possible.
(cond ((null idx*)
nil)
((arglist-p arglist*)
(cons idx* (convert (cdr path) args* arglist*)))
(t
(list idx*)))))))
(convert
;; FORM contains irrelevant operator. Adjust FORM-PATH.
(cond ((null form-path) nil)
((equal form-path '(0)) nil)
(t
(destructuring-bind (car . cdr) form-path
(cons (1- car) cdr))))
(cdr form)
arglist)))
(defun arglist-index (provided-argument-index provided-arguments arglist)
"Return the arglist index into `arglist' for the parameter belonging
to the argument (NTH `provided-argument-index' `provided-arguments')."
(let ((positional-args# (positional-args-number arglist))
(arg-index provided-argument-index))
(with-struct (arglist. key-p rest) arglist
(cond
((< arg-index positional-args#) ; required + optional
arg-index)
((and (not key-p) (not rest)) ; more provided than allowed
nil)
((not key-p) ; rest + body
(assert (arglist.rest arglist))
positional-args#)
(t ; key
;; Find last provided &key parameter
(let* ((argument (nth arg-index provided-arguments))
(provided-keys (subseq provided-arguments positional-args#)))
(loop for (key value) on provided-keys by #'cddr
when (eq value argument)
return (match key
(('quote symbol) symbol)
(_ key)))))))))
(defun arglist-ref (arglist &rest indices)
"Returns the parameter in ARGLIST along the INDICIES path. Numbers
represent positional parameters (required, optional), keywords
represent key parameters."
(flet ((ref-positional-arg (arglist index)
(check-type index (integer 0 *))
(with-struct (arglist. provided-args required-args
optional-args rest)
arglist
(loop for args in (list provided-args required-args
(mapcar #'optional-arg.arg-name
optional-args))
for args# = (length args)
if (< index args#)
return (nth index args)
else
do (decf index args#)
finally (return (or rest nil)))))
(ref-keyword-arg (arglist keyword)
;; keyword argument may be any symbol,
;; not only from the KEYWORD package.
(let ((keyword (match keyword
(('quote symbol) symbol)
(_ keyword))))
(do-decoded-arglist arglist
(&key (kw arg) (when (eq kw keyword)
(return-from ref-keyword-arg arg)))))
nil))
(dolist (index indices)
(assert (arglist-p arglist))
(setq arglist (if (numberp index)
(ref-positional-arg arglist index)
(ref-keyword-arg arglist index))))
arglist))
(defun provided-arguments-ref (provided-args arglist &rest indices)
"Returns the argument in PROVIDED-ARGUMENT along the INDICES path
relative to ARGLIST."
(check-type arglist arglist)
(flet ((ref (provided-args arglist index)
(if (numberp index)
(nth index provided-args)
(let ((provided-keys (subseq provided-args
(positional-args-number arglist))))
(loop for (key value) on provided-keys
when (eq key index)
return value)))))
(dolist (idx indices)
(setq provided-args (ref provided-args arglist idx))
(setq arglist (arglist-ref arglist idx)))
provided-args))
(defun positional-args-number (arglist)
(+ (length (arglist.provided-args arglist))
(length (arglist.required-args arglist))
(length (arglist.optional-args arglist))))
(defun parse-raw-form (raw-form)
"Parse a RAW-FORM into a Lisp form. I.e. substitute strings by
symbols if already interned. For strings not already interned, use
ARGLIST-DUMMY."
(unless (null raw-form)
(loop for element in raw-form
collect (etypecase element
(string (read-conversatively element))
(list (parse-raw-form element))
(symbol (prog1 element
;; Comes after list, so ELEMENT can't be NIL.
(assert (eq element +cursor-marker+))))))))
(defun read-conversatively (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), an object of type
ARGLIST-DUMMY is returned instead, which works as a placeholder
datum for subsequent logics to rely on."
(let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string))
(length (length string))
(type (cond ((zerop length) nil)
((eql (aref string 0) #\')
:quoted-symbol)
((search "#'" string :end2 (min length 2))
:sharpquoted-symbol)
((char= (char string 0) (char string (1- length))
#\")
:string)
(t
:symbol))))
(multiple-value-bind (symbol found?)
(case type
(:symbol (parse-symbol string))
(:quoted-symbol (parse-symbol (subseq string 1)))
(:sharpquoted-symbol (parse-symbol (subseq string 2)))
(:string (values string t))
(t (values string nil)))
(if found?
(ecase type
(:symbol symbol)
(:quoted-symbol `(quote ,symbol))
(:sharpquoted-symbol `(function ,symbol))
(:string (if (> length 1)
(subseq string 1 (1- length))
string)))
(make-arglist-dummy string)))))
(defun test-print-arglist ()
(flet ((test (arglist &rest strings)
(let* ((*package* (find-package :slynk))
(actual (decoded-arglist-to-string
(decode-arglist arglist)
:print-right-margin 1000)))
(unless (loop for string in strings
thereis (string= actual string))
(warn "Test failed: ~S => ~S~% Expected: ~A"
arglist actual
(if (cdr strings)
(format nil "One of: ~{~S~^, ~}" strings)
(format nil "~S" (first strings))))))))
(test '(function cons) "(function cons)")
(test '(quote cons) "(quote cons)")
(test '(&key (function #'+))
"(&key (function #'+))" "(&key (function (function +)))")
(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 ..)))")
(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)))")))
(defun test-arglist-ref ()
(macrolet ((soft-assert (form)
`(unless ,form
(warn "Assertion failed: ~S~%" ',form))))
(let ((sample (decode-arglist '(x &key ((:k (y z)))))))
(soft-assert (eq (arglist-ref sample 0) 'x))
(soft-assert (eq (arglist-ref sample :k 0) 'y))
(soft-assert (eq (arglist-ref sample :k 1) 'z))
(soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0)
'a))
(soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0)
'b))
(soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1)
'c)))))
(test-print-arglist)
(test-arglist-ref)
(provide :slynk/arglists)
;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'tramp)
(require 'cl-lib)
(define-sly-contrib sly-tramp
"Filename translations for tramp"
(:authors "Marco Baringer <mb@bese.it>")
(:license "GPL")
(:on-load
(setq sly-to-lisp-filename-function #'sly-tramp-to-lisp-filename)
(setq sly-from-lisp-filename-function #'sly-tramp-from-lisp-filename)))
(defcustom sly-filename-translations nil
"Assoc list of hostnames and filename translation functions.
Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP).
HOSTNAME-REGEXP is a regexp which is applied to the connection's
sly-machine-instance. If HOSTNAME-REGEXP maches then the
corresponding TO-LISP and FROM-LISP functions will be used to
translate emacs filenames and lisp filenames.
TO-LISP will be passed the filename of an emacs buffer and must
return a string which the underlying lisp understandas as a
pathname. FROM-LISP will be passed a pathname as returned by the
underlying lisp and must return something that emacs will
understand as a filename (this string will be passed to
find-file).
This list will be traversed in order, so multiple matching
regexps are possible.
Example:
Assuming you run emacs locally and connect to sly running on
the machine 'soren' and you can connect with the username
'animaliter':
(push (list \"^soren$\"
(lambda (emacs-filename)
(subseq emacs-filename (length \"/ssh:animaliter@soren:\")))
(lambda (lisp-filename)
(concat \"/ssh:animaliter@soren:\" lisp-filename)))
sly-filename-translations)
See also `sly-create-filename-translator'."
:type '(repeat (list :tag "Host description"
(regexp :tag "Hostname regexp")
(function :tag "To lisp function")
(function :tag "From lisp function")))
:group 'sly-lisp)
(defun sly-find-filename-translators (hostname)
(cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname))
sly-filename-translations)))
(t (list #'identity #'identity))))
(defun sly-make-tramp-file-name (username remote-host lisp-filename)
"Tramp compatability function.
Handles the signature of `tramp-make-tramp-file-name' changing
over time."
(cond
((>= emacs-major-version 26)
;; Emacs 26 requires the method to be provided and the signature of
;; `tramp-make-tramp-file-name' has changed.
(tramp-make-tramp-file-name (tramp-find-method nil username remote-host)
username
nil
remote-host
nil
lisp-filename))
((boundp 'tramp-multi-methods)
(tramp-make-tramp-file-name nil nil
username
remote-host
lisp-filename))
(t
(tramp-make-tramp-file-name nil
username
remote-host
lisp-filename))))
(cl-defun sly-create-filename-translator (&key machine-instance
remote-host
username)
"Creates a three element list suitable for push'ing onto
sly-filename-translations which uses Tramp to load files on
hostname using username. MACHINE-INSTANCE is a required
parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME
defaults to (user-login-name).
MACHINE-INSTANCE is the value returned by sly-machine-instance,
which is just the value returned by cl:machine-instance on the
remote lisp. REMOTE-HOST is the fully qualified domain name (or
just the IP) of the remote machine. USERNAME is the username we
should login with.
The functions created here expect your tramp-default-method or
tramp-default-method-alist to be setup correctly."
(let ((remote-host (or remote-host machine-instance))
(username (or username (user-login-name))))
(list (concat "^" machine-instance "$")
(lambda (emacs-filename)
(tramp-file-name-localname
(tramp-dissect-file-name emacs-filename)))
`(lambda (lisp-filename)
(sly-make-tramp-file-name
,username
,remote-host
lisp-filename)))))
(defun sly-tramp-to-lisp-filename (filename)
(funcall (if (let ((conn (sly-current-connection)))
(and conn (process-live-p conn)))
(cl-first (sly-find-filename-translators (sly-machine-instance)))
'identity)
(expand-file-name filename)))
(defun sly-tramp-from-lisp-filename (filename)
(funcall (cl-second (sly-find-filename-translators (sly-machine-instance)))
filename))
(provide 'sly-tramp)
;;; -*- coding: utf-8; lexical-binding: t -*-
;;;
;;; sly-trace-dialog.el -- a navigable dialog of inspectable trace entries
;;;
;;; TODO: implement better wrap interface for sbcl method, labels and such
;;; TODO: backtrace printing is very slow
;;;
(require 'sly)
(require 'sly-parse "lib/sly-parse")
(require 'cl-lib)
(define-sly-contrib sly-trace-dialog
"Provide an interactive trace dialog buffer for managing and
inspecting details of traced functions. Invoke this dialog with C-c T."
(:authors "João Távora <joaotavora@gmail.com>")
(:license "GPL")
(:slynk-dependencies slynk/trace-dialog)
(:on-load (add-hook 'sly-mode-hook 'sly-trace-dialog-shortcut-mode)
(define-key sly-selector-map (kbd "T") 'sly-trace-dialog))
(:on-unload (remove-hook 'sly-mode-hook 'sly-trace-dialogn-shortcut-mode)))
;;;; Variables
;;;
(defvar sly-trace-dialog-flash t
"Non-nil means flash the updated region of the SLY Trace Dialog. ")
(defvar sly-trace-dialog--specs-overlay nil)
(defvar sly-trace-dialog--progress-overlay nil)
(defvar sly-trace-dialog--tree-overlay nil)
(defvar sly-trace-dialog--collapse-chars (cons "-" "+"))
;;;; Local trace entry model
(defvar sly-trace-dialog--traces nil)
(cl-defstruct (sly-trace-dialog--trace
(:constructor sly-trace-dialog--make-trace))
id
parent
spec
args
retlist
depth
beg
end
collapse-button-marker
summary-beg
children-end
collapsed-p)
(defun sly-trace-dialog--find-trace (id)
(gethash id sly-trace-dialog--traces))
;;;; Modes and mode maps
;;;
(defvar sly-trace-dialog-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "G") 'sly-trace-dialog-fetch-traces)
(define-key map (kbd "C-k") 'sly-trace-dialog-clear-fetched-traces)
(define-key map (kbd "g") 'sly-trace-dialog-fetch-status)
(define-key map (kbd "q") 'quit-window)
(set-keymap-parent map button-buffer-map)
map))
(define-derived-mode sly-trace-dialog-mode fundamental-mode
"SLY Trace Dialog" "Mode for controlling SLY's Trace Dialog"
(set-syntax-table lisp-mode-syntax-table)
(read-only-mode 1)
(sly-mode 1)
(add-to-list (make-local-variable 'sly-trace-dialog-after-toggle-hook)
'sly-trace-dialog-fetch-status))
(defvar sly-trace-dialog-shortcut-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c T") 'sly-trace-dialog)
(define-key map (kbd "C-c C-t") 'sly-trace-dialog-toggle-trace)
(define-key map (kbd "C-c M-t")
(if (featurep 'sly-fancy-trace)
'sly-toggle-fancy-trace
'sly-toggle-trace-fdefinition))
map))
(define-minor-mode sly-trace-dialog-shortcut-mode
"Add keybindings for accessing SLY's Trace Dialog.")
(easy-menu-define sly-trace-dialog--shortcut-menu nil
"Menu setting traces from anywhere in SLY."
(let* ((in-dialog '(eq major-mode 'sly-trace-dialog-mode))
(_dialog-live `(and ,in-dialog
(memq sly-buffer-connection sly-net-processes)))
(connected '(sly-connected-p)))
`("Trace"
["Toggle trace.." sly-trace-dialog-toggle-trace ,connected]
["Untrace all" sly-trace-dialog-untrace-all ,connected]
["Trace complex spec" sly-trace-dialog-toggle-complex-trace ,connected]
["Open Trace dialog" sly-trace-dialog (and ,connected (not ,in-dialog))]
"--"
[ "Regular lisp trace..." sly-toggle-fancy-trace ,connected])))
(easy-menu-add-item sly-menu nil sly-trace-dialog--shortcut-menu "Documentation")
(easy-menu-define sly-trace-dialog--menu sly-trace-dialog-mode-map
"Menu for SLY's Trace Dialog"
(let* ((in-dialog '(eq major-mode 'sly-trace-dialog-mode))
(dialog-live `(and ,in-dialog
(memq sly-buffer-connection sly-net-processes))))
`("SLY-Trace"
[ "Refresh traces and progress" sly-trace-dialog-fetch-status
,dialog-live]
[ "Fetch next batch" sly-trace-dialog-fetch-traces ,dialog-live]
[ "Clear all fetched traces" sly-trace-dialog-clear-fetched-traces
,dialog-live]
[ "Toggle details" sly-trace-dialog-hide-details-mode ,in-dialog]
[ "Toggle autofollow" sly-trace-dialog-autofollow-mode ,in-dialog])))
(define-minor-mode sly-trace-dialog-hide-details-mode
"Hide details in `sly-trace-dialog-mode'"
nil " Brief"
:group 'sly-trace-dialog
(unless (derived-mode-p 'sly-trace-dialog-mode)
(error "Not a SLY Trace Dialog buffer"))
(sly-trace-dialog--set-hide-details-mode))
(define-minor-mode sly-trace-dialog-autofollow-mode
"Automatically inspect trace entries from `sly-trace-dialog-mode'"
nil " Autofollow"
:group 'sly-trace-dialog
(unless (derived-mode-p 'sly-trace-dialog-mode)
(error "Not a SLY Trace Dialog buffer")))
;;;; Helper functions
;;;
(defmacro sly-trace-dialog--insert-and-overlay (string overlay)
`(save-restriction
(let ((inhibit-read-only t))
(narrow-to-region (point) (point))
(insert ,string "\n")
(set (make-local-variable ',overlay)
(let ((overlay (make-overlay (point-min)
(point-max)
(current-buffer)
nil
t)))
(move-overlay overlay (overlay-start overlay)
(1- (overlay-end overlay)))
overlay)))))
(defun sly-trace-dialog--buffer-name ()
(sly-buffer-name :traces :connection (sly-current-connection)))
(defun sly-trace-dialog--live-dialog (&optional buffer-or-name)
(let ((buffer-or-name (or buffer-or-name
(sly-trace-dialog--buffer-name))))
(and (buffer-live-p (get-buffer buffer-or-name))
(with-current-buffer buffer-or-name
(memq sly-buffer-connection sly-net-processes))
buffer-or-name)))
(defun sly-trace-dialog--ensure-buffer ()
(let ((name (sly-trace-dialog--buffer-name)))
(or (sly-trace-dialog--live-dialog name)
(let ((connection (sly-current-connection)))
(with-current-buffer (get-buffer-create name)
(let ((inhibit-read-only t))
(erase-buffer))
(sly-trace-dialog-mode)
(save-excursion
(buffer-disable-undo)
(sly-trace-dialog--insert-and-overlay
"[waiting for the traced specs to be available]"
sly-trace-dialog--specs-overlay)
(sly-trace-dialog--insert-and-overlay
"[waiting for some info on trace download progress ]"
sly-trace-dialog--progress-overlay)
(sly-trace-dialog--insert-and-overlay
"[waiting for the actual traces to be available]"
sly-trace-dialog--tree-overlay)
(current-buffer))
(setq sly-buffer-connection connection)
(current-buffer))))))
(defun sly-trace-dialog--set-collapsed (collapsed-p trace button)
(save-excursion
(setf (sly-trace-dialog--trace-collapsed-p trace) collapsed-p)
(sly-trace-dialog--go-replace-char-at
button
(if collapsed-p
(cdr sly-trace-dialog--collapse-chars)
(car sly-trace-dialog--collapse-chars)))
(sly-trace-dialog--hide-unhide
(sly-trace-dialog--trace-summary-beg trace)
(sly-trace-dialog--trace-end trace)
(if collapsed-p 1 -1))
(sly-trace-dialog--hide-unhide
(sly-trace-dialog--trace-end trace)
(sly-trace-dialog--trace-children-end trace)
(if collapsed-p 1 -1))))
(defun sly-trace-dialog--hide-unhide (start-pos end-pos delta)
(cl-loop with inhibit-read-only = t
for pos = start-pos then next
for next = (next-single-property-change
pos
'sly-trace-dialog--hidden-level
nil
end-pos)
for hidden-level = (+ (or (get-text-property
pos
'sly-trace-dialog--hidden-level)
0)
delta)
do (add-text-properties pos next
(list 'sly-trace-dialog--hidden-level
hidden-level
'invisible
(cl-plusp hidden-level)))
while (< next end-pos)))
(defun sly-trace-dialog--set-hide-details-mode ()
(cl-loop for trace being the hash-values of sly-trace-dialog--traces
do (sly-trace-dialog--hide-unhide
(sly-trace-dialog--trace-summary-beg trace)
(sly-trace-dialog--trace-end trace)
(if sly-trace-dialog-hide-details-mode 1 -1))))
(defun sly-trace-dialog--format (fmt-string &rest args)
(let* ((string (apply #'format fmt-string args))
(indent (make-string (max 2
(- 50 (length string))) ? )))
(format "%s%s" string indent)))
(defun sly-trace-dialog--call-maintaining-properties (pos fn)
(save-excursion
(goto-char pos)
(let* ((saved-props (text-properties-at pos))
(saved-point (point))
(inhibit-read-only t)
(inhibit-point-motion-hooks t))
(funcall fn)
(add-text-properties saved-point (point) saved-props)
(if (markerp pos) (set-marker pos saved-point)))))
(cl-defmacro sly-trace-dialog--maintaining-properties (pos
&body body)
(declare (indent 1))
`(sly-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body)))
(defun sly-trace-dialog--go-replace-char-at (pos char)
(sly-trace-dialog--maintaining-properties pos
(delete-char 1)
(insert char)))
;;;; Handlers for the *trace-dialog* buffer
;;;
(defun sly-trace-dialog--open-specs (traced-specs)
(let ((make-report-spec-fn-fn
(lambda (&optional form)
(lambda (_button)
(sly-eval-async
`(cl:progn
,form
(slynk-trace-dialog:report-specs))
#'(lambda (results)
(sly-trace-dialog--open-specs results)))))))
(sly-refreshing
(:overlay sly-trace-dialog--specs-overlay
:recover-point-p t)
(insert
(sly-trace-dialog--format "Traced specs (%s)" (length traced-specs))
(sly-make-action-button "[refresh]"
(funcall make-report-spec-fn-fn))
"\n" (make-string 50 ? )
(sly-make-action-button
"[untrace all]"
(funcall make-report-spec-fn-fn `(slynk-trace-dialog:dialog-untrace-all)))
"\n\n")
(cl-loop for (spec-pretty . spec) in traced-specs
do (insert
" "
(sly-make-action-button
"[untrace]"
(funcall make-report-spec-fn-fn
`(slynk-trace-dialog:dialog-untrace ',spec)))
(format " %s" spec-pretty)
"\n")))))
(defvar sly-trace-dialog--fetch-key nil)
(defvar sly-trace-dialog--stop-fetching nil)
(defun sly-trace-dialog--update-progress (total &optional show-stop-p remaining-p)
;; `remaining-p' indicates `total' is the number of remaining traces.
(sly-refreshing
(:overlay sly-trace-dialog--progress-overlay
:recover-point-p t)
(let* ((done (hash-table-count sly-trace-dialog--traces))
(total (if remaining-p (+ done total) total)))
(insert
(sly-trace-dialog--format "Trace collection status (%d/%s)"
done
(or total "0"))
(sly-make-action-button "[refresh]"
#'(lambda (_button)
(sly-trace-dialog-fetch-progress))))
(when (and total (cl-plusp (- total done)))
(insert "\n" (make-string 50 ? )
(sly-make-action-button
"[fetch next batch]"
#'(lambda (_button)
(sly-trace-dialog-fetch-traces nil)))
"\n" (make-string 50 ? )
(sly-make-action-button
"[fetch all]"
#'(lambda (_button)
(sly-trace-dialog-fetch-traces t)))))
(when total
(insert "\n" (make-string 50 ? )
(sly-make-action-button
"[clear]"
#'(lambda (_button)
(sly-trace-dialog-clear-fetched-traces)))))
(when show-stop-p
(insert "\n" (make-string 50 ? )
(sly-make-action-button
"[stop]"
#'(lambda (_button)
(setq sly-trace-dialog--stop-fetching t)))))
(insert "\n\n"))))
;;;; Rendering traces
;;;
(define-button-type 'sly-trace-dialog-part :supertype 'sly-part
'sly-button-inspect
#'(lambda (trace-id part-id type)
(sly-eval-for-inspector
`(slynk-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type)
:inspector-name (sly-maybe-read-inspector-name)))
'sly-button-pretty-print
#'(lambda (trace-id part-id type)
(sly-eval-describe
`(slynk-trace-dialog:pprint-trace-part ,trace-id ,part-id ,type)))
'sly-button-describe
#'(lambda (trace-id part-id type)
(sly-eval-describe
`(slynk-trace-dialog:describe-trace-part ,trace-id ,part-id ,type))))
(defun sly-trace-dialog-part-button (part-id part-text trace-id type)
(sly--make-text-button part-text nil
:type 'sly-trace-dialog-part
'part-args (list trace-id part-id type)
'part-label (format "%s %s"
(capitalize
(substring (symbol-name type) 1))
part-id)))
(define-button-type 'sly-trace-dialog-spec :supertype 'sly-part
'action 'sly-button-show-source
'sly-button-inspect
#'(lambda (trace-id _spec)
(sly-eval-for-inspector `(slynk-trace-dialog:inspect-trace ,trace-id)
:inspector-name "trace-entries"))
'sly-button-show-source
#'(lambda (trace-id _spec)
(sly-eval-async
`(slynk-trace-dialog:trace-location ,trace-id)
#'(lambda (location)
(sly--display-source-location location 'noerror))))
'point-entered
#'(lambda (before after)
(let ((button (sly-button-at after nil 'no-error)))
(when (and (not (sly-button-at before nil 'no-error))
button
sly-trace-dialog-autofollow-mode)
;; we can't quite `push-button' here, because
;; of the need for `save-selected-window'
;;
(let ((id (button-get button 'trace-id)))
(sly-eval-for-inspector
`(slynk-trace-dialog:inspect-trace ,id)
:inspector-name "trace-entries"
:save-selected-window t))))))
(defun sly-trace-dialog-spec-button (label trace &rest props)
(let ((id (sly-trace-dialog--trace-id trace)))
(apply #'sly--make-text-button label nil
:type 'sly-trace-dialog-spec
'trace-id id
'part-args (list id
(cdr (sly-trace-dialog--trace-spec trace)))
'part-label (format "Trace entry: %s" id)
props)))
(defun sly-trace-dialog--draw-tree-lines (start offset direction)
(save-excursion
(let ((inhibit-point-motion-hooks t))
(goto-char start)
(cl-loop with replace-set = (if (eq direction 'down)
'(? )
'(? ?`))
for line-beginning = (line-beginning-position
(if (eq direction 'down)
2 0))
for pos = (+ line-beginning offset)
while (and (< (point-min) line-beginning)
(< line-beginning (point-max))
(memq (char-after pos) replace-set))
do
(sly-trace-dialog--go-replace-char-at pos "|")
(goto-char pos)))))
(defun sly-trace-dialog--make-indent (depth suffix)
(concat (make-string (* 3 (max 0 (1- depth))) ? )
(if (cl-plusp depth) suffix)))
(defun sly-trace-dialog--make-collapse-button (trace)
(sly-make-action-button (if (sly-trace-dialog--trace-collapsed-p trace)
(cdr sly-trace-dialog--collapse-chars)
(car sly-trace-dialog--collapse-chars))
#'(lambda (button)
(sly-trace-dialog--set-collapsed
(not (sly-trace-dialog--trace-collapsed-p
trace))
trace
button))))
(defun sly-trace-dialog--insert-trace (trace)
(let* ((id (sly-trace-dialog--trace-id trace))
(parent (sly-trace-dialog--trace-parent trace))
(has-children-p (sly-trace-dialog--trace-children-end trace))
(indent-spec (sly-trace-dialog--make-indent
(sly-trace-dialog--trace-depth trace)
"`--"))
(indent-summary (sly-trace-dialog--make-indent
(sly-trace-dialog--trace-depth trace)
" "))
(id-string
(sly-trace-dialog-spec-button
(format "%4s" id) trace 'skip t 'action 'sly-button-inspect))
(spec-button (sly-trace-dialog-spec-button
(format "%s" (car (sly-trace-dialog--trace-spec trace)))
trace))
(summary (cl-loop for (type objects marker) in
`((:arg ,(sly-trace-dialog--trace-args trace)
" > ")
(:retval ,(sly-trace-dialog--trace-retlist trace)
" < "))
concat (cl-loop for object in objects
concat " "
concat indent-summary
concat marker
concat (sly-trace-dialog-part-button
(cl-first object)
(cl-second object)
id
type)
concat "\n"))))
(puthash id trace sly-trace-dialog--traces)
;; insert and propertize the text
;;
(setf (sly-trace-dialog--trace-beg trace) (point-marker))
(insert id-string " ")
(insert indent-spec)
(if has-children-p
(insert (sly-trace-dialog--make-collapse-button trace))
(setf (sly-trace-dialog--trace-collapse-button-marker trace)
(point-marker))
(insert "-"))
(insert " " spec-button "\n")
(setf (sly-trace-dialog--trace-summary-beg trace) (point-marker))
(insert summary)
(setf (sly-trace-dialog--trace-end trace) (point-marker))
(set-marker-insertion-type (sly-trace-dialog--trace-beg trace) t)
;; respect brief mode and collapsed state
;;
(cl-loop for condition in (list sly-trace-dialog-hide-details-mode
(sly-trace-dialog--trace-collapsed-p trace))
when condition
do (sly-trace-dialog--hide-unhide
(sly-trace-dialog--trace-summary-beg
trace)
(sly-trace-dialog--trace-end trace)
1))
(cl-loop for tr = trace then parent
for parent = (sly-trace-dialog--trace-parent tr)
while parent
when (sly-trace-dialog--trace-collapsed-p parent)
do (sly-trace-dialog--hide-unhide
(sly-trace-dialog--trace-beg trace)
(sly-trace-dialog--trace-end trace)
(+ 1
(or (get-text-property (sly-trace-dialog--trace-beg parent)
'sly-trace-dialog--hidden-level)
0)))
(cl-return))
;; maybe add the collapse-button to the parent in case it didn't
;; have one already
;;
(when (and parent
(sly-trace-dialog--trace-collapse-button-marker parent))
(sly-trace-dialog--maintaining-properties
(sly-trace-dialog--trace-collapse-button-marker parent)
(delete-char 1)
(insert (sly-trace-dialog--make-collapse-button parent))
(setf (sly-trace-dialog--trace-collapse-button-marker parent)
nil)))
;; draw the tree lines
;;
(when parent
(sly-trace-dialog--draw-tree-lines (sly-trace-dialog--trace-beg trace)
(+ 2 (length indent-spec))
'up))
(when has-children-p
(sly-trace-dialog--draw-tree-lines (sly-trace-dialog--trace-beg trace)
(+ 5 (length indent-spec))
'down))
;; set the "children-end" slot
;;
(unless (sly-trace-dialog--trace-children-end trace)
(cl-loop for parent = trace
then (sly-trace-dialog--trace-parent parent)
while parent
do
(setf (sly-trace-dialog--trace-children-end parent)
(sly-trace-dialog--trace-end trace))))))
(defun sly-trace-dialog--render-trace (trace)
;; Render the trace entry in the appropriate place.
;;
;; A trace becomes a few lines of slightly propertized text in the
;; buffer, inserted by `sly-trace-dialog--insert-trace', bound by
;; point markers that we use here.
;;
;; The new trace might be replacing an existing one, or otherwise
;; must be placed under its existing parent which might or might not
;; be the last entry inserted.
;;
(let ((existing (sly-trace-dialog--find-trace
(sly-trace-dialog--trace-id trace)))
(parent (sly-trace-dialog--trace-parent trace)))
(cond (existing
;; Other traces might already reference `existing' and with
;; need to maintain that eqness. Best way to do that is
;; destructively modify `existing' with the new retlist...
;;
(setf (sly-trace-dialog--trace-retlist existing)
(sly-trace-dialog--trace-retlist trace))
;; Now, before deleting and re-inserting `existing' at an
;; arbitrary point in the tree, note that it's
;; "children-end" marker is already non-nil, and informs us
;; about its parenthood status. We want to 1. leave it
;; alone if it's already a parent, or 2. set it to nil if
;; it's a leaf, thus forcing the needed update of the
;; parents' "children-end" marker.
;;
(when (= (sly-trace-dialog--trace-children-end existing)
(sly-trace-dialog--trace-end existing))
(setf (sly-trace-dialog--trace-children-end existing) nil))
(delete-region (sly-trace-dialog--trace-beg existing)
(sly-trace-dialog--trace-end existing))
(goto-char (sly-trace-dialog--trace-end existing))
;; Remember to set `trace' to be `existing'
;;
(setq trace existing))
(parent
(goto-char (1+ (sly-trace-dialog--trace-children-end parent))))
(;; top level trace
t
(goto-char (point-max))))
(goto-char (line-beginning-position))
(sly-trace-dialog--insert-trace trace)))
(defun sly-trace-dialog--update-tree (tuples)
(save-excursion
(sly-refreshing
(:overlay sly-trace-dialog--tree-overlay
:dont-erase t)
(cl-loop for tuple in tuples
for parent = (sly-trace-dialog--find-trace (cl-second tuple))
for trace = (sly-trace-dialog--make-trace
:id (cl-first tuple)
:parent parent
:spec (cl-third tuple)
:args (cl-fourth tuple)
:retlist (cl-fifth tuple)
:depth (if parent
(1+ (sly-trace-dialog--trace-depth
parent))
0))
do (sly-trace-dialog--render-trace trace)))))
(defun sly-trace-dialog--clear-local-tree ()
(set (make-local-variable 'sly-trace-dialog--fetch-key)
(cl-gensym "sly-trace-dialog-fetch-key-"))
(set (make-local-variable 'sly-trace-dialog--traces)
(make-hash-table))
(sly-refreshing
(:overlay sly-trace-dialog--tree-overlay))
(sly-trace-dialog--update-progress nil))
(defun sly-trace-dialog--on-new-results (results &optional recurse)
(cl-destructuring-bind (tuples remaining reply-key)
results
(cond ((and sly-trace-dialog--fetch-key
(string= (symbol-name sly-trace-dialog--fetch-key)
(symbol-name reply-key)))
(sly-trace-dialog--update-tree tuples)
(sly-trace-dialog--update-progress
remaining
(and recurse
(cl-plusp remaining))
t)
(when (and recurse
(not (prog1 sly-trace-dialog--stop-fetching
(setq sly-trace-dialog--stop-fetching nil)))
(cl-plusp remaining))
(sly-eval-async `(slynk-trace-dialog:report-partial-tree
',reply-key)
#'(lambda (results) (sly-trace-dialog--on-new-results
results
recurse))))))))
;;;; Interactive functions
;;;
(defun sly-trace-dialog-fetch-specs ()
"Refresh just list of traced specs."
(interactive)
(sly-eval-async `(slynk-trace-dialog:report-specs)
#'sly-trace-dialog--open-specs))
(defun sly-trace-dialog-fetch-progress ()
(interactive)
(sly-eval-async
'(slynk-trace-dialog:report-total)
#'(lambda (total)
(sly-trace-dialog--update-progress
total))))
(defun sly-trace-dialog-fetch-status ()
"Refresh just the status part of the SLY Trace Dialog"
(interactive)
(sly-trace-dialog-fetch-specs)
(sly-trace-dialog-fetch-progress))
(defun sly-trace-dialog-clear-fetched-traces (&optional interactive)
"Clear local and remote traces collected so far"
(interactive "p")
(when (or (not interactive)
(y-or-n-p "Clear all collected and fetched traces?"))
(sly-eval-async
'(slynk-trace-dialog:clear-trace-tree)
#'(lambda (_ignored)
(sly-trace-dialog--clear-local-tree)))))
(defun sly-trace-dialog-fetch-traces (&optional recurse)
(interactive "P")
(setq sly-trace-dialog--stop-fetching nil)
(sly-eval-async `(slynk-trace-dialog:report-partial-tree
',sly-trace-dialog--fetch-key)
#'(lambda (results) (sly-trace-dialog--on-new-results results
recurse))))
(defvar sly-trace-dialog-after-toggle-hook nil
"Hooks run after toggling a dialog-trace")
(defun sly-trace-dialog-toggle-trace (&optional using-context-p)
"Toggle the dialog-trace of the spec at point.
When USING-CONTEXT-P, attempt to decipher lambdas. methods and
other complicated function specs."
(interactive "P")
;; Notice the use of "spec strings" here as opposed to the
;; proper cons specs we use on the slynk side.
;;
;; Notice the conditional use of `sly-trace-query' found in
;; slynk-fancy-trace.el
;;
(let* ((spec-string (if using-context-p
(sly-extract-context)
(sly-symbol-at-point)))
(spec-string (if (fboundp 'sly-trace-query)
(sly-trace-query spec-string)
spec-string)))
(sly-message "%s" (sly-eval `(slynk-trace-dialog:dialog-toggle-trace
(slynk::from-string ,spec-string))))
(run-hooks 'sly-trace-dialog-after-toggle-hook)))
(defun sly-trace-dialog-untrace-all ()
"Untrace all specs traced for the Trace Dialog."
(interactive)
(sly-eval-async `(slynk-trace-dialog:dialog-untrace-all)
#'(lambda (results)
(sly-message "%s dialog specs and %s regular specs untraced"
(cdr results) (car results) )))
(run-hooks 'sly-trace-dialog-after-toggle-hook))
(defun sly-trace-dialog--update-existing-dialog ()
(let ((existing (sly-trace-dialog--live-dialog)))
(when existing
(with-current-buffer existing
(sly-trace-dialog-fetch-status)))))
(add-hook 'sly-trace-dialog-after-toggle-hook
'sly-trace-dialog--update-existing-dialog)
(defun sly-trace-dialog-toggle-complex-trace ()
"Toggle the dialog-trace of the complex spec at point.
See `sly-trace-dialog-toggle-trace'."
(interactive)
(sly-trace-dialog-toggle-trace t))
(defun sly-trace-dialog (&optional clear-and-fetch)
"Show trace dialog and refresh trace collection status.
With optional CLEAR-AND-FETCH prefix arg, clear the current tree
and fetch a first batch of traces."
(interactive "P")
(with-current-buffer
;; FIXME: refactor with `sly-with-popup-buffer'
(pop-to-buffer
(sly-trace-dialog--ensure-buffer)
`(display-buffer-reuse-window . ((inhibit-same-window . t))))
(sly-trace-dialog-fetch-status)
(when (or clear-and-fetch
(null sly-trace-dialog--fetch-key))
(sly-trace-dialog--clear-local-tree))
(when clear-and-fetch
(sly-trace-dialog-fetch-traces nil))))
(provide 'sly-trace-dialog)
;;; sly-stickers.el --- Live-code annotations for SLY -*- lexical-binding: t; -*-
;; Copyright (C) 2014 João Távora
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords: convenience, languages, lisp, tools
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
;;; There is much in this library that would merit comment. Just some points:
;;;
;;; * Stickers are just overlays that exist on the Emacs side. A lot
;;; of the code is managing overlay nesting levels so that faces
;;; are chosen suitably for making sticker inside stickers
;;; visually recognizable.
;;;
;;; The main entry-point here is the interactive command
;;; `sly-sticker-dwim', which places and removes stickers.
;;;
;;; Stickers are also indexed by an integer and placed in a
;;; connection-global hash-table, `sly-stickers--stickers'. It can
;;; be connection-global because the same sticker with the same id
;;; might eventually be sent, multiple times, to many
;;; connections. It's the Slynk side that has to be able to tell
;;; whence the stickers comes from (this is not done currently).
;;;
;;; * The gist of stickers is instrumenting top-level forms. This is
;;; done by hooking onto `sly-compile-region-function'. Two separate
;;; compilations are performed: one for the uninstrumented form and
;;; another for the intrumented form. This is so that warnings and
;;; compilations errors that are due to stickers exclusively can be
;;; sorted out. If the second compilation fails, the stickers dont
;;; "stick", i.e. they are not armed.
;;;
;;; * File compilation is also hooked onto via
;;; `sly-compilation-finished-hook'. The idea here is to first
;;; compile the whole file, then traverse any top-level forms that
;;; contain stickers and instrument those.
;;;
;;; * On the emacs-side, the sticker overlays are very ephemeral
;;; objects. They are not persistently saved in any way. Deleting or
;;; modifying text inside them automatically deletes them.
;;;
;;; The slynk side eventually must be told to let go of deleted
;;; stickers. Before this happens these stickers are known as
;;; zombies. Reaping happens on almost every SLY -> Slynk call.
;;; Killing the buffer they live in doesn't automatically delete
;;; them, but reaping eventually happens anyway via
;;; `sly-stickers--sticker-by-id'.
;;;
;;; Before a zombie sticker is reaped, some code may still be
;;; running that adds recordings to these stickers, and some of
;;; these recordings make it to the Emacs side. The user can ignore
;;; them in `sly-stickers-replay', being notified that a deleted
;;; sticker is being referenced.
;;;
;;; This need to communicate dead stickers to Slynk is only here
;;; because using weak-hash-tables is impractical for stickers
;;; indexed by integers. Perhaps this could be fixed if the
;;; instrumented forms could reference sticker objects directly.
;;;
;;; * To see the results of sticker-instrumented code, there are the
;;; interactive commands `sly-stickers-replay' and
;;; `sly-stickers-fetch'. If "breaking stickers" is enabled, the
;;; debugger is also invoked before a sticker is reached and after a
;;; sticker returns (if it returns). Auxiliary data-structures like
;;; `sly-stickers--recording' are used here.
;;;
;;; * `sly-stickers--replay-state' and `sly-stickers--replay-map' are
;;; great big hacks just for handling the `sly-stickers-replay'
;;; interactive loop. Should look into recursive minibuffers or
;;; something more akin to `ediff', for example.
;;;
;;; Code:
(require 'sly)
(require 'sly-parse "lib/sly-parse")
(require 'sly-buttons "lib/sly-buttons")
(eval-when-compile
(when (version< emacs-version "26")
;; Using `cl-defstruct' needs `cl' on older Emacsen. See issue
;; https://github.com/joaotavora/sly/issues/54
(require 'cl)))
(require 'cl-lib)
(require 'hi-lock) ; for the faces
(require 'color)
(require 'pulse) ; pulse-momentary-highlight-overlay
(define-sly-contrib sly-stickers
"Mark expressions in source buffers and annotate return values."
(:authors "João Távora <joaotavora@gmail.com>")
(:license "GPL")
(:slynk-dependencies slynk/stickers)
(:on-load (add-hook 'sly-editing-mode-hook 'sly-stickers-mode)
(add-hook 'sly-mode-hook 'sly-stickers-shortcut-mode)
(setq sly-compile-region-function
'sly-stickers-compile-region-aware-of-stickers)
(add-hook 'sly-compilation-finished-hook
'sly-stickers-after-buffer-compilation t)
(add-hook 'sly-db-extras-hooks 'sly-stickers--handle-break))
(:on-unload (remove-hook 'sly-editing-mode-hook 'sly-stickers-mode)
(remove-hook 'sly-mode-hook 'sly-stickers-shortcut-mode)
(setq sly-compile-region-function 'sly-compile-region-as-string)
(remove-hook 'sly-compilation-finished-hook
'sly-stickers-after-buffer-compilation)
(remove-hook 'sly-db-extras-hooks 'sly-stickers--handle-break)))
;;;; Bookeeping for local stickers
;;;;
(defvar sly-stickers--counter 0)
(defvar sly-stickers--stickers (make-hash-table))
(defvar sly-stickers--zombie-sticker-ids nil
"Sticker ids that might exist in Slynk but no longer in Emacs.")
(defun sly-stickers--zombies () sly-stickers--zombie-sticker-ids)
(defun sly-stickers--reset-zombies () (setq sly-stickers--zombie-sticker-ids nil))
;;;; Sticker display and UI logic
;;;;
(defgroup sly-stickers nil
"Mark expressions in source buffers and annotate return values."
:prefix "sly-stickers-"
:group 'sly)
(when nil
(cl-loop for sym in '(sly-stickers-placed-face
sly-stickers-armed-face
sly-stickers-empty-face
sly-stickers-recordings-face
sly-stickers-exited-non-locally-face)
do
(put sym 'face-defface-spec nil)))
(defface sly-stickers-placed-face
'((((background dark)) (:background "light grey" :foreground "black"))
(t (:background "light grey")))
"Face for sticker just set")
(defface sly-stickers-armed-face
'((t (:strike-through nil :inherit hi-blue)))
"Face for stickers that have been armed")
(defface sly-stickers-recordings-face
'((t (:strike-through nil :inherit hi-green)))
"Face for stickers that have new recordings")
(defface sly-stickers-empty-face
'((t (:strike-through nil :inherit hi-pink)))
"Face for stickers that have no recordings.")
(defface sly-stickers-exited-non-locally-face
'((t (:strike-through t :inherit sly-stickers-empty-face)))
"Face for stickers that have exited non-locally.")
(defvar sly-stickers-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c C-s C-s") 'sly-stickers-dwim)
(define-key map (kbd "C-c C-s C-d") 'sly-stickers-clear-defun-stickers)
(define-key map (kbd "C-c C-s C-k") 'sly-stickers-clear-buffer-stickers)
map))
(defvar sly-stickers-shortcut-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c C-s S") 'sly-stickers-fetch)
(define-key map (kbd "C-c C-s F") 'sly-stickers-forget)
(define-key map (kbd "C-c C-s C-r") 'sly-stickers-replay)
map))
(define-minor-mode sly-stickers-mode
"Mark expression in source buffers and annotate return values.")
(define-minor-mode sly-stickers-shortcut-mode
"Shortcuts for navigating sticker recordings.")
(defvar sly-stickers--sticker-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "M-RET") 'sly-mrepl-copy-part-to-repl)
(define-key map [down-mouse-3] 'sly-button-popup-part-menu)
(define-key map [mouse-3] 'sly-button-popup-part-menu)
map))
(define-button-type 'sly-stickers-sticker :supertype 'sly-part
'sly-button-inspect 'sly-stickers--inspect-recording
'sly-button-echo 'sly-stickers--echo-sticker
'keymap sly-stickers--sticker-map)
(defun sly-stickers--set-tooltip (sticker &optional info)
(let* ((help-base (button-get sticker 'sly-stickers--base-help-echo))
(text (if info
(concat "[sly] Sticker:" info "\n" help-base)
help-base)))
(button-put sticker 'help-echo text)
(button-put sticker 'sly-stickers--info info)))
(defun sly-stickers--echo-sticker (sticker &rest more)
(cl-assert (null more) "Apparently two stickers at exact same location")
(sly-message (button-get sticker 'sly-stickers--info))
(sly-button-flash sticker))
(defcustom sly-stickers-max-nested-stickers 4
"The maximum expected level expected of sticker nesting.
If you nest more than this number of stickers inside other
stickers, the overlay face will be very dark, and probably
render the underlying text unreadable."
:type :integer)
(defvar sly-stickers-color-face-attribute :background
"Color-capable attribute of sticker faces that represents nesting.")
(gv-define-setter sly-stickers--level (level sticker)
`(prog1
(setf (sly-button--level ,sticker) ,level)
(when (button-get ,sticker 'sly-stickers--base-face)
(sly-stickers--set-face ,sticker))))
(defun sly-stickers--level (sticker) (sly-button--level sticker))
(defun sly-stickers--guess-face-color (face)
(face-attribute-specified-or
(face-attribute face sly-stickers-color-face-attribute nil t)
nil))
(defun sly-stickers--set-face (sticker &optional face)
(let* ((face (or face
(button-get sticker 'sly-stickers--base-face)))
(guessed-color (sly-stickers--guess-face-color face)))
(button-put sticker 'sly-stickers--base-face face)
(unless guessed-color
(sly-error "sorry, can't guess color for face %s for sticker %s"))
(button-put sticker 'face
`(:inherit ,face
,sly-stickers-color-face-attribute
,(color-darken-name
guessed-color
(* 25
(/ (sly-stickers--level sticker)
sly-stickers-max-nested-stickers
1.0)))))))
(defun sly-stickers--stickers-in (beg end)
(sly-button--overlays-in beg end 'sly-stickers--sticker-id))
(defun sly-stickers--stickers-at (pos)
(sly-button--overlays-at pos 'sly-stickers--sticker-id))
(defun sly-stickers--stickers-between (beg end)
(sly-button--overlays-between beg end 'sly-stickers--sticker-id))
(defun sly-stickers--stickers-exactly-at (beg end)
(sly-button--overlays-exactly-at beg end 'sly-stickers--sticker-id))
(defun sly-stickers--sticker (from to)
"Place a new sticker from FROM to TO"
(let* ((intersecting (sly-stickers--stickers-in from to))
(contained (sly-stickers--stickers-between from to))
(not-contained (cl-set-difference intersecting contained))
(containers nil))
(unless (cl-every #'(lambda (e)
(and (< (button-start e) from)
(> (button-end e) to)))
not-contained)
(sly-error "Cannot place a sticker that partially overlaps other stickers"))
(when (sly-stickers--stickers-exactly-at from to)
(sly-error "There is already a sticker at those very coordinates"))
;; by now we know that other intersecting, non-contained stickers
;; are our containers.
;;
(setq containers not-contained)
(let* ((label "Brand new sticker")
(sticker
;;; FIXME: We aren't using sly--make-text-button here
;;; because it doesn't allow overlay button s
(make-button from to :type 'sly-stickers-sticker
'sly-connection (sly-current-connection)
'part-args (list -1 nil)
'part-label label
'sly-button-search-id (sly-button-next-search-id)
'modification-hooks '(sly-stickers--sticker-modified)
'sly-stickers-id (cl-incf sly-stickers--counter)
'sly-stickers--base-help-echo
"mouse-3: Context menu")))
;; choose a suitable level for ourselves and increase the
;; level of those contained by us
;;
(setf (sly-stickers--level sticker)
(1+ (cl-reduce #'max containers
:key #'sly-stickers--level
:initial-value -1)))
(mapc (lambda (s) (cl-incf (sly-stickers--level s))) contained)
;; finally, set face
;;
(sly-stickers--set-tooltip sticker label)
(sly-stickers--set-face sticker 'sly-stickers-placed-face)
sticker)))
(defun sly-stickers--sticker-id (sticker)
(button-get sticker 'sly-stickers-id))
(defun sly-stickers--arm-sticker (sticker)
(let* ((id (sly-stickers--sticker-id sticker))
(label (format "Sticker %d is armed" id)))
(button-put sticker 'part-args (list id nil))
(button-put sticker 'part-label label)
(button-put sticker 'sly-stickers--last-known-recording nil)
(sly-stickers--set-tooltip sticker label)
(sly-stickers--set-face sticker 'sly-stickers-armed-face)
(puthash id sticker sly-stickers--stickers)))
(defun sly-stickers--disarm-sticker (sticker)
(let* ((id (sly-stickers--sticker-id sticker))
(label (format "Sticker %d failed to stick" id)))
(button-put sticker 'part-args (list -1 nil))
(button-put sticker 'part-label label)
(sly-stickers--set-tooltip sticker label)
(sly-stickers--set-face sticker 'sly-stickers-placed-face)))
(define-button-type 'sly-stickers--recording-part :supertype 'sly-part
'sly-button-inspect
'sly-stickers--inspect-recording
;; 'sly-button-pretty-print
;; #'(lambda (id) ...)
;; 'sly-button-describe
;; #'(lambda (id) ...)
;; 'sly-button-show-source
;; #'(lambda (id) ...)
)
(defun sly-stickers--recording-part (label sticker-id recording vindex
&rest props)
(apply #'sly--make-text-button
label nil
:type 'sly-stickers--recording-part
'part-args (list sticker-id recording vindex)
'part-label "Recorded value"
props))
(cl-defun sly-stickers--describe-recording-values (recording &key
(indent 0)
(prefix "=> "))
(cl-flet ((indent (str)
(concat (make-string indent ? )str))
(prefix (str)
(concat prefix str)))
(let ((descs (sly-stickers--recording-value-descriptions recording)))
(cond ((sly-stickers--recording-exited-non-locally-p recording)
(indent (propertize "exited non locally" 'face 'sly-action-face)))
((null descs)
(indent (propertize "no values" 'face 'sly-action-face)))
(t
(cl-loop for (value-desc . rest) on descs
for vindex from 0
concat
(indent (prefix
(sly-stickers--recording-part
value-desc
(sly-stickers--recording-sticker-id recording)
recording
vindex)))
when rest
concat "\n"))))))
(defconst sly-stickers--newline "\n"
"Work around bug #63, actually Emacs bug #21839.
\"25.0.50; can't use newlines in defaults in cl functions\"")
(cl-defun sly-stickers--pretty-describe-recording
(recording &key (separator sly-stickers--newline))
(let* ((recording-sticker-id (sly-stickers--recording-sticker-id recording))
(sticker (gethash recording-sticker-id
sly-stickers--stickers))
(nvalues (length (sly-stickers--recording-value-descriptions recording))))
(format "%s%s:%s%s"
(if sticker
(format "Sticker %s on line %s of %s"
(sly-stickers--sticker-id sticker)
(with-current-buffer (overlay-buffer sticker)
(line-number-at-pos (overlay-start sticker)))
(overlay-buffer sticker))
(format "Deleted or unknown sticker %s"
recording-sticker-id))
(if (cl-plusp nvalues)
(format " returned %s values" nvalues) "")
separator
(sly-stickers--describe-recording-values recording
:indent 2))))
(defun sly-stickers--populate-sticker (sticker recording)
(let* ((id (sly-stickers--sticker-id sticker))
(total (sly-stickers--recording-sticker-total recording)))
(cond ((cl-plusp total)
(button-put sticker 'part-label
(format "Sticker %d has %d recordings" id total))
(unless (sly-stickers--recording-void-p recording)
(button-put sticker 'sly-stickers--last-known-recording recording)
(button-put sticker 'part-args (list id recording))
(sly-stickers--set-tooltip
sticker
(format "Newest of %s sticker recordings:\n%s"
total
(sly-stickers--describe-recording-values recording :prefix "")))
(sly-stickers--set-face
sticker
(if (sly-stickers--recording-exited-non-locally-p recording)
'sly-stickers-exited-non-locally-face
'sly-stickers-recordings-face))))
(t
(let ((last-known-recording
(button-get sticker 'sly-stickers--last-known-recording)))
(button-put sticker 'part-label
(format "Sticker %d has no recordings" id))
(when last-known-recording
(sly-stickers--set-tooltip
sticker
(format "No new recordings. Last known:\n%s"
(sly-stickers--describe-recording-values
last-known-recording))))
(sly-stickers--set-tooltip sticker "No new recordings")
(sly-stickers--set-face sticker 'sly-stickers-empty-face))))))
(defun sly-stickers--sticker-substickers (sticker)
(let* ((retval
(remove sticker
(sly-stickers--stickers-between (button-start sticker)
(button-end sticker))))
;; To verify an important invariant, and warn (don't crash)
;;
(exactly-at
(sly-stickers--stickers-exactly-at (button-start sticker)
(button-end sticker))))
(cond
((remove sticker exactly-at)
(sly-warning "Something's fishy. More than one sticker at same position")
(cl-set-difference retval exactly-at))
(t
retval))))
(defun sly-stickers--briefly-describe-sticker (sticker)
(let ((beg (button-start sticker))
(end (button-end sticker)))
(if (< (- end beg) 20)
(format "sticker around %s" (buffer-substring-no-properties beg end))
(cl-labels ((word (point direction)
(apply #'buffer-substring-no-properties
(sort (list
point
(save-excursion (goto-char point)
(forward-word direction)
(point)))
#'<))))
(format "sticker from \"%s...\" to \"...%s\""
(word beg 1)
(word end -1))))))
(defun sly-stickers--delete (sticker)
"Ensure that sticker is deleted."
;; Delete the overlay and take care of levels for contained and
;; containers, but note that a sticker might have no buffer anymore
;; if that buffer was killed, for example...
;;
(when (and (overlay-buffer sticker)
(buffer-live-p (overlay-buffer sticker)))
(mapc (lambda (s) (cl-decf (sly-stickers--level s)))
(sly-stickers--sticker-substickers sticker))
(delete-overlay sticker))
;; We also want to deregister it from the hashtable in case it's
;; there (it's not there if it has never been armed)
;;
(let ((id (sly-stickers--sticker-id sticker)))
(when (gethash (sly-stickers--sticker-id sticker)
sly-stickers--stickers)
(remhash id sly-stickers--stickers)
(add-to-list 'sly-stickers--zombie-sticker-ids id))))
(defun sly-stickers--sticker-modified (sticker _after? beg end
&optional _pre-change-len)
(unless (save-excursion
(goto-char beg)
(skip-chars-forward "\t\n\s")
(>= (point) end))
(let ((inhibit-modification-hooks t))
(sly-message "Deleting %s"
(sly-stickers--briefly-describe-sticker sticker))
(sly-stickers--delete sticker))))
(defun sly-stickers-next-sticker (&optional n)
(interactive "p")
(sly-button-search n 'sly-stickers--sticker-id))
(defun sly-stickers-prev-sticker (&optional n)
(interactive "p")
(sly-button-search (- n) 'sly-stickers--sticker-id))
(put 'sly-stickers-next-sticker 'sly-button-navigation-command t)
(put 'sly-stickers-prev-sticker 'sly-button-navigation-command t)
(defun sly-stickers-clear-defun-stickers ()
"Clear all stickers in the current top-level form."
(interactive)
(let* ((region (sly-region-for-defun-at-point)))
(sly-stickers-clear-region-stickers (car region) (cadr region))))
(defun sly-stickers-clear-buffer-stickers ()
"Clear all the stickers in the current buffer."
(interactive)
(sly-stickers-clear-region-stickers (point-min) (point-max)))
(defun sly-stickers-clear-region-stickers (&optional from to)
"Clear all the stickers between FROM and TO."
(interactive "r")
(let* ((from (or from (region-beginning)))
(to (or to (region-end)))
(stickers (sly-stickers--stickers-in from to)))
(cond (stickers
(mapc #'sly-stickers--delete stickers)
(sly-message "%s stickers cleared" (length stickers)))
(t
(sly-message "no stickers to clear")))))
(defun sly-stickers-delete-sticker-at-point (&optional point)
"Delete the topmost sticker at point."
(interactive "d")
(let ((stickers (sly-stickers--stickers-at (or point (point)))))
(cond
(stickers
(sly-stickers--delete (car stickers))
(if (cdr stickers)
(sly-message "Deleted topmost sticker (%d remain at point)"
(length (cdr stickers)))
(sly-message "Deleted sticker %s"
(sly-stickers--briefly-describe-sticker (car stickers)))))
(t
(sly-user-error "No stickers at point")))))
(defun sly-stickers-maybe-add-sticker (&optional point)
"Add of remove a sticker at POINT.
If point is currently at a sticker boundary, delete that sticker,
otherwise, add a sticker to the sexp at point."
(interactive "d")
(save-excursion
(goto-char (or point (point)))
(let* ((bounds (sly-bounds-of-sexp-at-point))
(beg (car bounds))
(end (cdr bounds))
(matching (and bounds
(sly-stickers--stickers-exactly-at beg end))))
(cond
((not bounds)
(sly-message "Nothing here to place sticker on, apparently"))
(matching
(sly-stickers--delete (car matching))
(sly-message "Deleted sticker"))
(t
(let ((sticker (sly-stickers--sticker beg end)))
(sly-message "Added %s"
(sly-stickers--briefly-describe-sticker sticker))))))))
(defun sly-stickers-dwim (prefix)
"Set or remove stickers at point.
Set a sticker for the current sexp at point, or delete it if it
already exists.
If the region is active set a sticker in the current region.
With interactive prefix arg PREFIX always delete stickers.
- One C-u means delete the current top-level form's stickers.
- Two C-u's means delete the current buffer's stickers"
(interactive "p")
(cond
((= prefix 4)
(if (region-active-p)
(sly-stickers-clear-region-stickers)
(sly-stickers-clear-defun-stickers)))
((>= prefix 16)
(sly-stickers-clear-buffer-stickers))
((region-active-p)
(sly-stickers--sticker (region-beginning) (region-end))
(deactivate-mark t))
((not (sly-inside-string-or-comment-p))
(sly-stickers-maybe-add-sticker))
(t
(sly-message "No point placing stickers in string literals or comments"))))
(defun sly-stickers--sticker-by-id (sticker-id)
"Return the sticker for STICKER-ID, or return NIL.
Perform some housecleaning tasks for stickers that have been
properly deleted or brutally killed with the buffer they were in."
(let* ((sticker (gethash sticker-id sly-stickers--stickers)))
(cond ((and sticker (overlay-buffer sticker)
(buffer-live-p (overlay-buffer sticker)))
sticker)
(sticker
;; `sticker-id' references a sticker that hasn't been
;; deleted but whose overlay can't be found. One reason for
;; this is that the buffer it existed in was killed. So
;; delete it now and mark it a zombie.
(sly-stickers--delete sticker)
nil)
(t
;; The sticker isn't in the `sly-stickers--stickers' hash
;; table, so it has probably already been marked zombie,
;; and possibly already deleted. We're probably just seeing
;; it because recording playback and breaking stickers may
;; not filtering these out by user option.
;;
;; To be on the safe side, add the id to the table anyway,
;; so it'll get killed on the Slynk side on the next
;; request.
;;
(add-to-list 'sly-stickers--zombie-sticker-ids sticker-id)
nil))))
(defvar sly-stickers--flashing-sticker nil
"The sticker currently being flashed.")
(cl-defun sly-stickers--find-and-flash (sticker-id &key (otherwise nil))
"Find and flash the sticker referenced by STICKER-ID.
otherwise call OTHERWISE with a single argument, a string stating
the reason why the sticker couldn't be found"
(let ((sticker (sly-stickers--sticker-by-id sticker-id)))
(cond (sticker
(let ((buffer (overlay-buffer sticker)))
(when buffer
(with-current-buffer buffer
(let* ((window (display-buffer buffer t)))
(when window
(with-selected-window window
(push-mark nil t)
(goto-char (overlay-start sticker))
(sly-recenter (point))
(setq sly-stickers--flashing-sticker sticker)
(pulse-momentary-highlight-overlay sticker 'highlight)
(run-with-timer
2 nil
(lambda ()
(when (eq sly-stickers--flashing-sticker sticker)
(pulse-momentary-highlight-overlay
sticker 'highlight)))))))))))
(otherwise
(funcall otherwise "Can't find sticker (probably deleted!)")))))
;; Work around an Emacs bug, probably won't be needed in Emacs 27.1
(advice-add 'pulse-momentary-unhighlight
:before (lambda (&rest _args)
(let ((o pulse-momentary-overlay))
(when (and o (overlay-get o 'sly-stickers-id))
(overlay-put o 'priority nil))))
'((name . fix-pulse-momentary-unhighlight-bug)))
;;;; Recordings
;;;;
(cl-defstruct (sly-stickers--recording
(:constructor sly-stickers--make-recording-1)
(:conc-name sly-stickers--recording-)
(:copier sly-stickers--copy-recording))
(sticker-id nil)
(sticker-total nil)
(id nil)
(value-descriptions nil)
(exited-non-locally-p nil)
(sly-connection nil))
(defun sly-stickers--recording-void-p (recording)
(not (sly-stickers--recording-id recording)))
(defun sly-stickers--make-recording (description)
"Make a `sly-stickers--recording' from DESCRIPTION.
A DESCRIPTION is how the Lisp side describes a sticker and
usually its most recent recording. If it doesn't, a recording
veryfying `sly-stickers--recording-void-p' is created."
(cl-destructuring-bind (sticker-id sticker-total . recording-description)
description
(let ((recording (sly-stickers--make-recording-1
:sticker-id sticker-id
:sticker-total sticker-total
:sly-connection (sly-current-connection))))
(when recording-description
(cl-destructuring-bind (recording-id _recording-ctime
value-descriptions
exited-non-locally-p)
recording-description
(setf
(sly-stickers--recording-id recording)
recording-id
(sly-stickers--recording-value-descriptions recording)
value-descriptions
(sly-stickers--recording-exited-non-locally-p recording)
exited-non-locally-p)))
recording)))
;;;; Replaying sticker recordings
;;;;
(defvar sly-stickers--replay-help nil)
(defvar sly-stickers--replay-mode-map
(let ((map (make-sparse-keymap)))
(cl-flet
((def
(key binding &optional desc)
(define-key map (kbd key) binding)
(setf
(cl-getf sly-stickers--replay-help binding)
(cons (cons key (car (cl-getf sly-stickers--replay-help binding)))
(or desc
(cdr (cl-getf sly-stickers--replay-help binding)))))))
(def "n" 'sly-stickers-replay-next
"Scan recordings forward")
(def "SPC" 'sly-stickers-replay-next)
(def "N" 'sly-stickers-replay-next-for-sticker
"Scan recordings forward for this sticker")
(def "DEL" 'sly-stickers-replay-prev
"Scan recordings backward")
(def "p" 'sly-stickers-replay-prev)
(def "P" 'sly-stickers-replay-prev-for-sticker
"Scan recordings backward for this sticker")
(def "j" 'sly-stickers-replay-jump
"Jump to a recording")
(def ">" 'sly-stickers-replay-jump-to-end
"Go to last recording")
(def "<" 'sly-stickers-replay-jump-to-beginning
"Go to first recording")
(def "h" 'sly-stickers-replay-toggle-help
"Toggle help")
(def "v" 'sly-stickers-replay-pop-to-current-sticker
"Pop to current sticker")
(def "V" 'sly-stickers-replay-toggle-pop-to-stickers
"Toggle popping to stickers")
(def "q" 'quit-window
"Quit")
(def "x" 'sly-stickers-replay-toggle-ignore-sticker
"Toggle ignoring a sticker")
(def "z" 'sly-stickers-replay-toggle-ignore-zombies
"Toggle ignoring deleted stickers")
(def "R" 'sly-stickers-replay-reset-ignore-list
"Reset ignore list")
(def "F" 'sly-stickers-forget
"Forget about sticker recordings")
(def "g" 'sly-stickers-replay-refresh
"Refresh current recording")
map)))
(define-derived-mode sly-stickers--replay-mode fundamental-mode
"SLY Stickers Replay" "Mode for controlling sticker replay sessions Dialog"
(set-syntax-table lisp-mode-syntax-table)
(read-only-mode 1)
(sly-mode 1)
(add-hook 'post-command-hook
'sly-stickers--replay-postch t t))
(defun sly-stickers--replay-postch ()
(let ((win (get-buffer-window (current-buffer))))
(when (and win
(window-live-p win))
(ignore-errors
(set-window-text-height win (line-number-at-pos (point-max)))))))
(defvar sly-stickers--replay-expanded-help nil)
(defun sly-stickers-replay-toggle-help ()
(interactive)
(set (make-local-variable 'sly-stickers--replay-expanded-help)
(not sly-stickers--replay-expanded-help))
(sly-stickers--replay-refresh-1))
(sly-def-connection-var sly-stickers--replay-data nil
"Data structure for information related to recordings")
(defvar sly-stickers--replay-key nil
"A symbol identifying a particular replaying session in the
Slynk server.")
(defvar sly-stickers--replay-pop-to-stickers t)
(defun sly-stickers--replay-refresh-1 ()
"Insert a description of the current recording into the current
buffer"
(cl-assert (eq major-mode 'sly-stickers--replay-mode)
nil
"%s must be run in a stickers replay buffer"
this-command)
(cl-labels
((paragraph () (if sly-stickers--replay-expanded-help "\n\n" "\n"))
(describe-ignored-stickers
()
(let ((ignored-ids (cl-getf (sly-stickers--replay-data)
:ignored-ids))
(ignore-zombies-p (cl-getf (sly-stickers--replay-data)
:ignore-zombies-p)))
(if (or ignored-ids ignore-zombies-p)
(format "%s%s%s"
(paragraph)
(if ignore-zombies-p
"Skipping recordings of deleted stickers. " "")
(if ignored-ids
(format "Skipping recordings of sticker%s %s."
(if (cl-rest ignored-ids) "s" "")
(concat (mapconcat #'pp-to-string
(butlast ignored-ids)
", ")
(and (cl-rest ignored-ids) " and ")
(pp-to-string
(car (last ignored-ids)))))
""))
"")))
(describe-help
()
(format "%s%s"
(paragraph)
(if sly-stickers--replay-expanded-help
(substitute-command-keys "\\{sly-stickers--replay-mode-map}")
"n => next, p => previous, x => ignore, h => help, q => quit")))
(describe-number-of-recordings
(new-total)
(let* ((old-total (cl-getf (sly-stickers--replay-data) :old-total))
(diff (and old-total (- new-total old-total))))
(format "%s total recordings%s"
new-total
(cond ((and diff
(cl-plusp diff))
(propertize (format ", %s new in the meantime"
diff)
'face 'bold))
(t
"")))))
(describe-playhead
(recording)
(let ((new-total (cl-getf (sly-stickers--replay-data) :total))
(index (cl-getf (sly-stickers--replay-data) :index)))
(cond
((and new-total
recording)
(format "Playhead at recording %s of %s"
(ignore-errors (1+ index))
(describe-number-of-recordings new-total)))
(new-total
(format "Playhead detached (ignoring too many stickers?) on %s"
(describe-number-of-recordings new-total)))
(recording
(substitute-command-keys
"Playhead confused (perhaps hit \\[sly-stickers-replay-refresh])"))
(t
(format
"No recordings! Perhaps you need to run some sticker-aware code first"))))))
(sly-refreshing ()
(let ((rec (cl-getf (sly-stickers--replay-data) :recording)))
(insert (describe-playhead rec) (paragraph))
(when rec
(insert (sly-stickers--pretty-describe-recording
rec
:separator (paragraph)))))
(insert (describe-ignored-stickers))
(insert (describe-help)))))
(defun sly-stickers-replay ()
"Start interactive replaying of known sticker recordings."
(interactive)
(let* ((buffer-name (sly-buffer-name :stickers-replay
:connection (sly-current-connection)))
(existing-buffer (get-buffer buffer-name)))
(let ((split-width-threshold nil)
(split-height-threshold 0))
(sly-with-popup-buffer (buffer-name
:mode 'sly-stickers--replay-mode
:select t)
(setq existing-buffer standard-output)))
(with-current-buffer existing-buffer
(setf (cl-getf (sly-stickers--replay-data) :replay-key)
(cl-gensym "stickers-replay-"))
(let ((old-total (cl-getf (sly-stickers--replay-data) :total))
(new-total (sly-eval '(slynk-stickers:total-recordings))))
(setf (cl-getf (sly-stickers--replay-data) :old-total) old-total)
(when (and
old-total
(cl-plusp old-total)
(> new-total old-total)
(sly-y-or-n-p
"Looks like there are %s new recordings since last replay.\n
Forget about old ones before continuing?" (- new-total old-total)))
(sly-stickers-forget old-total)))
(sly-stickers-replay-refresh 0
(if existing-buffer nil t)
t)
(set-window-dedicated-p nil 'soft)
(with-current-buffer existing-buffer
(sly-stickers--replay-postch)))))
(defun sly-stickers-replay-refresh (n command &optional interactive)
"Refresh the current sticker replay session.
N and COMMAND are passed to the Slynk server and instruct what
recording to fetch:
If COMMAND is nil, navigate to Nth next sticker recording,
skipping ignored stickers.
If COMMAND is a number, navigate to the Nth next sticker
recording for the sticker with that numeric sticker id.
If COMMAND is any other value, jump directly to the recording
index N.
Interactively, N is 0 and and COMMAND is nil, meaning that the
playhead should stay put and the buffer should be refreshed.
Non-interactively signal an error if no recording was fetched and
INTERACTIVE is the symbol `sly-error'.
Non-interactively, set the `:recording' slot of
`sly-stickers--replay-data' to nil if no recording was fetched."
(interactive (list 0 nil t))
(let ((result (sly-eval
`(slynk-stickers:search-for-recording
',(cl-getf (sly-stickers--replay-data) :replay-key)
',(cl-getf (sly-stickers--replay-data) :ignored-ids)
',(cl-getf (sly-stickers--replay-data) :ignore-zombies-p)
',(sly-stickers--zombies)
,n
',command))))
;; presumably, Slynk cleaned up the zombies we passed it.
;;
(sly-stickers--reset-zombies)
(cond ((car result)
(cl-destructuring-bind (total index &rest sticker-description)
result
(let ((rec (sly-stickers--make-recording sticker-description))
(old-index (cl-getf (sly-stickers--replay-data) :index)))
(setf (cl-getf (sly-stickers--replay-data) :index) index
(cl-getf (sly-stickers--replay-data) :total) total
(cl-getf (sly-stickers--replay-data) :recording) rec)
(if old-index
(if (cl-plusp n)
(if (> old-index index) (sly-message "Rolled over to start"))
(if (< old-index index) (sly-message "Rolled over to end"))))
;; Assert that the recording isn't void
;;
(when (sly-stickers--recording-void-p rec)
(sly-error "Attempt to visit a void recording described by %s"
sticker-description))
(when sly-stickers--replay-pop-to-stickers
(sly-stickers--find-and-flash
(sly-stickers--recording-sticker-id rec))))))
(interactive
;; If we were called interactively and got an error, it's
;; probably because there aren't any recordings, so reset
;; data
;;
(setf (sly-stickers--replay-data) nil)
(when (eq interactive 'sly-error)
(sly-error "%s for %s reported an error: %s"
'slynk-stickers:search-for-recording
n
(cadr result)))
(setf (cl-getf (sly-stickers--replay-data) :recording) nil)))
(if interactive
(sly-stickers--replay-refresh-1)
(cl-getf (sly-stickers--replay-data) :recording ))))
(defun sly-stickers-replay-next (n)
"Navigate to Nth next sticker recording, skipping ignored stickers"
(interactive "p")
(sly-stickers-replay-refresh n nil 'sly-error))
(defun sly-stickers-replay-prev (n)
"Navigate to Nth prev sticker recording, skipping ignored stickers"
(interactive "p")
(sly-stickers-replay-refresh (- n) nil 'sly-error))
(defun sly-stickers-replay--current-sticker-interactive (prompt)
(if current-prefix-arg
(read-number (format "[sly] %s " prompt))
(sly-stickers--recording-sticker-id
(cl-getf (sly-stickers--replay-data) :recording))))
(defun sly-stickers-replay-next-for-sticker (n sticker-id)
"Navigate to Nth next sticker recording for STICKER-ID"
(interactive (list
(if (numberp current-prefix-arg)
current-prefix-arg
1)
(sly-stickers-replay--current-sticker-interactive
"Which sticker?")))
(sly-stickers-replay-refresh n sticker-id 'sly-error))
(defun sly-stickers-replay-prev-for-sticker (n sticker-id)
"Navigate to Nth prev sticker recording for STICKER-ID"
(interactive (list
(- (if (numberp current-prefix-arg)
current-prefix-arg
1))
(sly-stickers-replay--current-sticker-interactive
"Which sticker?")))
(sly-stickers-replay-refresh n sticker-id 'sly-error))
(defun sly-stickers-replay-jump (n)
"Fetch and jump to Nth sticker recording"
(interactive (read-number "[sly] jump to which recording? "))
(sly-stickers-replay-refresh n 'absolute-p 'sly-error))
(defun sly-stickers-replay-jump-to-beginning ()
"Fetch and jump to the first sticker recording"
(interactive)
(sly-stickers-replay-refresh 0 'absolute-p 'sly-error))
(defun sly-stickers-replay-jump-to-end ()
"Fetch and jump to the last sticker recording"
(interactive)
(sly-stickers-replay-refresh -1 'absolute-p 'sly-error))
(defun sly-stickers-replay-toggle-ignore-sticker (sticker-id)
"Toggle ignoring recordings of sticker with STICKER-ID"
(interactive (list
(sly-stickers-replay--current-sticker-interactive
"Toggle ignoring which sticker id?")))
(let* ((ignored (cl-getf (sly-stickers--replay-data) :ignored-ids))
(ignored-p (memq sticker-id ignored)))
(cond (ignored-p
(setf (cl-getf (sly-stickers--replay-data) :ignored-ids)
(delq sticker-id (cdr ignored)))
(sly-message "No longer ignoring sticker %s" sticker-id))
(t
(setf (cl-getf (sly-stickers--replay-data) :ignored-ids)
(delete-dups ; stupid but safe
(cons sticker-id ignored)))
(sly-message "Now ignoring sticker %s" sticker-id)))
(sly-stickers-replay-refresh (if ignored-p ; was ignored, now isn't
0
1)
nil
t)))
(defun sly-stickers-replay-toggle-ignore-zombies ()
"Toggle ignoring recordings of zombie stickers."
(interactive)
(let ((switch
(setf
(cl-getf (sly-stickers--replay-data) :ignore-zombies-p)
(not (cl-getf (sly-stickers--replay-data) :ignore-zombies-p)))))
(if switch
(sly-message "Now ignoring zombie stickers")
(sly-message "No longer ignoring zombie stickers")))
(sly-stickers-replay-refresh 0 nil t))
(defun sly-stickers-replay-pop-to-current-sticker (sticker-id)
"Pop to sticker with STICKER-ID"
(interactive (list
(sly-stickers-replay--current-sticker-interactive
"Pop to which sticker id?")))
(sly-stickers--find-and-flash sticker-id
:otherwise #'sly-error))
(defun sly-stickers-replay-toggle-pop-to-stickers ()
"Toggle popping to stickers when replaying sticker recordings."
(interactive)
(set (make-local-variable 'sly-stickers--replay-pop-to-stickers)
(not sly-stickers--replay-pop-to-stickers))
(if sly-stickers--replay-pop-to-stickers
(sly-message "Auto-popping to stickers ON")
(sly-message "Auto-popping to stickers OFF")))
(defun sly-stickers-replay-reset-ignore-list ()
"Reset the sticker ignore specs"
(interactive)
(setf (cl-getf (sly-stickers--replay-data) :ignored-ids) nil)
(sly-stickers-replay-refresh 0 nil t))
(defun sly-stickers-fetch ()
"Fetch recordings from Slynk and update stickers accordingly.
See also `sly-stickers-replay'."
(interactive)
(sly-eval-async `(slynk-stickers:fetch ',(sly-stickers--zombies))
#'(lambda (result)
(sly-stickers--reset-zombies)
(let ((message
(format "Fetched recordings for %s armed stickers"
(length result))))
(cl-loop for sticker-description in result
;; Although we are analysing sticker descriptions
;; here, recordings are made to pass to
;; `sly-stickers--sticker-by-id', even if they are
;; are `sly-stickers--recording-void-p', which is
;; the case if the sticker has never been
;; traversed.
;;
for recording =
(sly-stickers--make-recording sticker-description)
for sticker =
(sly-stickers--sticker-by-id
(sly-stickers--recording-sticker-id recording))
when sticker
do (sly-stickers--populate-sticker sticker recording))
(sly-message message)))
"CL_USER"))
(defun sly-stickers-forget (&optional howmany interactive)
"Forget about sticker recordings in the Slynk side.
If HOWMANY is non-nil it must be a number stating how many
recordings to forget about. In this cases Because 0 is an index,
in the `nth' sense, the HOWMANYth recording survives."
(interactive (list (and (numberp current-prefix-arg)
current-prefix-arg)
t))
(when (or (not interactive)
(sly-y-or-n-p "Really forget about sticker recordings?"))
(sly-eval `(slynk-stickers:forget ',(sly-stickers--zombies) ,howmany))
(sly-stickers--reset-zombies)
(setf (cl-getf (sly-stickers--replay-data) :rec) nil
(cl-getf (sly-stickers--replay-data) :old-total) nil)
(when interactive
(sly-message "Forgot all about sticker recordings."))
(when (eq major-mode 'sly-stickers--replay-mode)
(sly-stickers-replay-refresh 0 t t))))
;;;; Breaking stickers
(defun sly-stickers--handle-break (extra)
(sly-dcase extra
((:slynk-after-sticker description)
(let ((sticker-id (cl-first description))
(recording (sly-stickers--make-recording description)))
(sly-stickers--find-and-flash sticker-id
:otherwise 'sly-message)
(insert
"\n\n"
(sly-stickers--pretty-describe-recording recording
))))
((:slynk-before-sticker sticker-id)
(sly-stickers--find-and-flash sticker-id
:otherwise 'sly-message))
(;; don't do anything if we don't know this "extra" info
t
nil)))
(defun sly-stickers-toggle-break-on-stickers ()
(interactive)
(let ((break-p (sly-eval '(slynk-stickers:toggle-break-on-stickers))))
(sly-message "Breaking on stickers is %s" (if break-p "ON" "OFF"))))
;;;; Functions for examining recordings
;;;;
(eval-after-load "sly-mrepl"
`(progn
(button-type-put 'sly-stickers-sticker
'sly-mrepl-copy-part-to-repl
'sly-stickers--copy-recording-to-repl)
(button-type-put 'sly-stickers--recording-part
'sly-mrepl-copy-part-to-repl
'sly-stickers--copy-recording-to-repl)))
;;; shoosh byte-compiler
(declare-function sly-mrepl--save-and-copy-for-repl nil)
(cl-defun sly-stickers--copy-recording-to-repl
(_sticker-id recording &optional (vindex 0))
(check-recording recording)
(sly-mrepl--save-and-copy-for-repl
`(slynk-stickers:find-recording-or-lose
,(sly-stickers--recording-id recording)
,vindex)
:before (format "Returning values of recording %s of sticker %s"
(sly-stickers--recording-id recording)
(sly-stickers--recording-sticker-id recording))))
(defun check-recording (recording)
(cond ((null recording)
(sly-error "This sticker doesn't seem to have any recordings"))
((not (eq (sly-stickers--recording-sly-connection recording)
(sly-current-connection)))
(sly-error "Recording is for a different connection (%s)"
(sly-connection-name
(sly-stickers--recording-sly-connection recording))))))
(cl-defun sly-stickers--inspect-recording
(_sticker-id recording &optional (vindex 0))
(check-recording recording)
(sly-eval-for-inspector
`(slynk-stickers:inspect-sticker-recording
,(sly-stickers--recording-id recording)
,vindex)))
;;;; Sticker-aware compilation
;;;;
(cl-defun sly-stickers--compile-region-aware-of-stickers-1
(start end callback &key sync fallback flash)
"Compile from START to END considering stickers.
After compilation call CALLBACK with the stickers and the
compilation result. If SYNC, use `sly-eval' other wise use
`sly-eval-async'. If FALLBACK, send the uninstrumneted region as
a fallback. If FLASH, flash the compiled region."
(let* ((uninstrumented (buffer-substring-no-properties start end))
(stickers (sly-stickers--stickers-between start end))
(original-buffer (current-buffer)))
(cond (stickers
(when flash
(sly-flash-region start end :face 'sly-stickers-armed-face))
(sly-with-popup-buffer ((sly-buffer-name :stickers :hidden t)
:select :hidden)
(mapc #'delete-overlay (overlays-in (point-min) (point-max)))
(insert uninstrumented)
;; Use a second set of overlays placed just in the
;; pre-compilation buffer. We need this to correctly keep
;; track of the markers because in this buffer we are going
;; to change actual text
;;
(cl-loop for sticker in stickers
for overlay =
(make-overlay (- (button-start sticker) (1- start))
(- (button-end sticker) (1- start)))
do (overlay-put overlay 'sly-stickers--sticker sticker))
(cl-loop for overlay in (overlays-in (point-min) (point-max))
for sticker = (overlay-get overlay 'sly-stickers--sticker)
do
(sly-stickers--arm-sticker sticker)
(goto-char (overlay-start overlay))
(insert (format "(slynk-stickers:record %d "
(sly-stickers--sticker-id sticker)))
(goto-char (overlay-end overlay))
(insert ")"))
;; Now send both the instrumented and uninstrumented
;; string to the Lisp
;;
(let ((instrumented (buffer-substring-no-properties (point-min)
(point-max)))
(new-ids (mapcar #'sly-stickers--sticker-id stickers)))
(with-current-buffer original-buffer
(let ((form `(slynk-stickers:compile-for-stickers
',new-ids
',(sly-stickers--zombies)
,instrumented
,(when fallback uninstrumented)
,(buffer-name)
',(sly-compilation-position start)
,(if (buffer-file-name)
(sly-to-lisp-filename (buffer-file-name)))
',sly-compilation-policy)))
(cond (sync
(funcall callback
stickers
(sly-eval form))
(sly-stickers--reset-zombies))
(t (sly-eval-async form
(lambda (result)
(sly-stickers--reset-zombies)
(funcall callback stickers result))))))))))
(t
(sly-compile-region-as-string start end)))))
(defun sly-stickers-compile-region-aware-of-stickers (start end)
"Compile region from START to END aware of stickers.
Intended to be placed in `sly-compile-region-function'"
(sly-stickers--compile-region-aware-of-stickers-1
start end
(lambda (stickers result-and-stuck-p)
(cl-destructuring-bind (result &optional stuck-p)
result-and-stuck-p
(unless stuck-p
(mapc #'sly-stickers--disarm-sticker stickers))
(sly-compilation-finished
result
nil
(if stuck-p
(format " (%d stickers armed)" (length stickers))
" (stickers failed to stick)"))))
:fallback t
:flash t))
(defun sly-stickers-after-buffer-compilation (success _notes buffer loadp)
"After compilation, compile regions with stickers.
Intented to be placed in `sly-compilation-finished-hook'"
(when (and buffer loadp success)
(save-restriction
(widen)
(let* ((all-stickers (sly-stickers--stickers-between
(point-min) (point-max)))
(regions (cl-loop for sticker in all-stickers
for region = (sly-region-for-defun-at-point
(overlay-start sticker))
unless (member region regions)
collect region into regions
finally (cl-return regions))))
(when regions
(cl-loop
with successful
with unsuccessful
for region in regions
do
(sly-stickers--compile-region-aware-of-stickers-1
(car region) (cadr region)
(lambda (stickers result)
(cond (result
(push (cons region stickers) successful))
(t
(mapc #'sly-stickers--disarm-sticker stickers)
(push (cons region stickers) unsuccessful))))
:sync t)
finally
(sly-temp-message
3 3
"%s stickers stuck in %s regions, %s disarmed in %s regions"
(cl-reduce #'+ successful :key (lambda (x) (length (cdr x))))
(length successful)
(cl-reduce #'+ unsuccessful :key (lambda (x) (length (cdr x))))
(length unsuccessful))))))))
;;;; Menu
;;;;
(easy-menu-define sly-stickers--shortcut-menu nil
"Placing stickers in `lisp-mode' buffers."
(let* ((in-source-file 'sly-stickers-mode)
(connected '(sly-connected-p)))
`("Stickers"
["Add or remove sticker at point"
sly-stickers-dwim ,in-source-file]
["Delete stickers from top-level form"
sly-stickers-clear-defun-stickers ,in-source-file]
["Delete stickers from buffer"
sly-stickers-clear-buffer-stickers ,in-source-file]
"--"
["Start sticker recording replay"
sly-stickers-replay ,connected]
["Fetch most recent recordings"
sly-stickers-fetch ,connected]
["Toggle breaking on stickers"
sly-stickers-toggle-break-on-stickers ,connected])))
(easy-menu-add-item sly-menu nil sly-stickers--shortcut-menu "Documentation")
(provide 'sly-stickers)
;;; sly-stickers.el ends here
;;; sly-scratch.el -*- lexical-binding: t; -*-
(require 'sly)
(require 'cl-lib)
(define-sly-contrib sly-scratch
"Imitate Emacs' *scratch* buffer"
(:authors "Helmut Eller <heller@common-lisp.net>")
(:on-load
(define-key sly-selector-map (kbd "s") 'sly-scratch))
(:license "GPL"))
;;; Code
(defvar sly-scratch-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-map)
(define-key map "\C-j" 'sly-eval-print-last-expression)
map))
(defun sly-scratch ()
(interactive)
(sly-switch-to-scratch-buffer))
(defun sly-switch-to-scratch-buffer ()
(set-buffer (sly-scratch-buffer))
(unless (eq (current-buffer) (window-buffer))
(pop-to-buffer (current-buffer) t)))
(defvar sly-scratch-file nil)
(defun sly-scratch-buffer ()
"Return the scratch buffer, create it if necessary."
(or (get-buffer (sly-buffer-name :scratch))
(with-current-buffer (if sly-scratch-file
(find-file sly-scratch-file)
(get-buffer-create (sly-buffer-name :scratch)))
(rename-buffer (sly-buffer-name :scratch))
(lisp-mode)
(use-local-map sly-scratch-mode-map)
(sly-mode t)
(current-buffer))))
(provide 'sly-scratch)
;; -*- lexical-binding: t; -*-
(require 'sly)
(define-sly-contrib sly-retro
"Enable SLIME to connect to a SLY-started SLYNK"
(:slynk-dependencies slynk/retro)
(:on-load (setq sly-net-send-translator #'sly-retro-slynk-to-swank))
(:on-unload (setq sly-net-send-translator nil)))
(defun sly-retro-slynk-to-swank (sexp)
(cond ((and sexp
(symbolp sexp)
(string-match "^slynk\\(.*\\)$" (symbol-name sexp)))
(intern (format "swank%s" (match-string 1 (symbol-name sexp)))))
((and sexp (listp sexp))
(cl-loop for (x . rest) on sexp
append (list (sly-retro-slynk-to-swank x)) into foo
finally (return (append foo (sly-retro-slynk-to-swank rest)))))
(t
sexp)))
(provide 'sly-retro)
;;; -*- coding: utf-8; lexical-binding: t -*-
;;;
;;; sly-profiler.el -- a navigable dialog of inspectable timing entries
;;;
(eval-and-compile
(require 'sly)
(require 'sly-parse "lib/sly-parse"))
(define-sly-contrib sly-profiler
"Provide an interfactive timing dialog buffer for managing and
inspecting details of timing functions. Invoke this dialog with C-c Y."
(:authors "João Távora <joaotavora@gmail.com>")
(:license "GPL")
(:slynk-dependencies slynk/profiler)
(:on-load (add-hook 'sly-mode-hook 'sly-profiler-enable))
(:on-unload (remove-hook 'sly-mode-hook 'sly-profiler-enable)))
;;;; Modes and mode maps
;;;
(defvar sly-profiler-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "G") 'sly-profiler-fetch-timings)
(define-key map (kbd "C-k") 'sly-profiler-clear-fetched-timings)
(define-key map (kbd "g") 'sly-profiler-fetch-status)
(define-key map (kbd "q") 'quit-window)
map))
(define-derived-mode sly-profiler-mode fundamental-mode
"SLY Timing Dialog" "Mode for controlling SLY's Timing Dialog"
(set-syntax-table lisp-mode-syntax-table)
(read-only-mode 1))
(defvar sly-profiler-shortcut-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c Y") 'sly-profiler)
(define-key map (kbd "C-c C-y") 'sly-profiler-toggle-timing)
map))
(define-minor-mode sly-profiler-shortcut-mode
"Add keybindings for accessing SLY's Profiler.")
(defun sly-profiler-enable () (sly-profiler-shortcut-mode 1))
;;;; Helpers
;;;
(defun sly-profiler--get-buffer ()
(let* ((name (format "*profiler for %s*"
(sly-connection-name sly-default-connection)))
(existing (get-buffer name)))
(cond ((and existing
(buffer-live-p existing)
(with-current-buffer existing
(memq sly-buffer-connection sly-net-processes)))
existing)
(t
(if existing (kill-buffer existing))
(with-current-buffer (get-buffer-create name)
(sly-profiler-mode)
(setq sly-buffer-connection sly-default-connection)
(pop-to-buffer (current-buffer)))))))
(defun sly-profiler--clear-local-tree ()
(erase-buffer)
(insert "Cleared timings!"))
(defun sly-profiler--render-timings (timing-specs)
(let ((inhibit-read-only t))
(erase-buffer)
(let ((standard-output (current-buffer)))
(cl-loop for spec in timing-specs
do (princ spec) (terpri)))))
;;;; Interactive functions
;;;
;; (defun sly-profiler-fetch-specs ()
;; "Refresh just list of timing specs."
;; (interactive)
;; (sly-eval-async `(slynk-profiler:report-specs)
;; #'sly-profiler--open-specs))
(defun sly-profiler-clear-fetched-timings (&optional interactive)
"Clear local and remote timings collected so far"
(interactive "p")
(when (or (not interactive)
(y-or-n-p "Clear all collected and fetched timings?"))
(sly-eval-async
'(slynk-profiler:clear-timing-tree)
#'sly-profiler--clear-local-tree)))
(defun sly-profiler-fetch-timings ()
(interactive)
(sly-eval-async `(slynk-profiler:report-latest-timings)
#'sly-profiler--render-timings))
(defun sly-profiler-fetch-status ()
(interactive)
(sly-profiler-fetch-timings))
(defun sly-profiler-toggle-timing (&optional using-context-p)
"Toggle the dialog-timing of the spec at point.
When USING-CONTEXT-P, attempt to decipher lambdas. methods and
other complicated function specs."
(interactive "P")
;; Notice the use of "spec strings" here as opposed to the
;; proper cons specs we use on the slynk side.
;;
;; Notice the conditional use of `sly-trace-query' found in
;; slynk-fancy-trace.el
;;
(let* ((spec-string (if using-context-p
(sly-extract-context)
(sly-symbol-at-point)))
(spec-string (read-from-minibuffer "(Un)time: " (format "%s" spec-string))))
(message "%s" (sly-eval `(slynk-profiler:toggle-timing
(slynk::from-string ,spec-string))))))
(defun sly-profiler (&optional refresh)
"Show timing dialog and refresh timing collection status.
With optional CLEAR-AND-FETCH prefix arg, clear the current tree
and fetch a first batch of timings."
(interactive "P")
(sly-with-popup-buffer ((sly-buffer-name :profiler :connection sly-default-connection)
:mode 'sly-profiler-mode
:select t)
(when refresh (sly-profiler-fetch-timings))))
;;;; Menu
;;;
(easy-menu-define sly-profiler--shortcut-menu nil
"Menu setting traces from anywhere in SLY."
(let* ((in-dialog '(eq major-mode 'sly-profiler-mode))
(_dialog-live `(and ,in-dialog
(memq sly-buffer-connection sly-net-processes)))
(connected '(sly-connected-p)))
`("Profiling"
["(Un)Profile definition" sly-profiler-toggle-timing ,connected]
["Open Profiler Dialog" sly-profiler (and ,connected (not ,in-dialog))])))
(easy-menu-add-item sly-menu nil sly-profiler--shortcut-menu "Documentation")
(defvar sly-profiler--easy-menu
(let ((condition '(memq sly-buffer-connection sly-net-processes)))
`("Timing"
[ "Clear fetched timings" sly-profiler-clear-fetched-timings ,condition]
[ "Fetch timings" sly-profiler-fetch-timings ,condition])))
(easy-menu-define my-menu sly-profiler-mode-map "Timing"
sly-profiler--easy-menu)
(provide 'sly-profiler)
;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'sly-parse "lib/sly-parse")
(define-sly-contrib sly-package-fu
"Exporting/Unexporting symbols at point."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slynk-dependencies slynk/package-fu)
(:on-load
(define-key sly-mode-map "\C-cx" 'sly-export-symbol-at-point)
(define-key sly-mode-map "\C-ci" 'sly-import-symbol-at-point))
(:on-unload
;; FIXME: To properly support unloading, this contrib should be
;; made a minor mode with it's own keymap. The minor mode
;; activation function should be added to the proper sly-* hooks.
;;
))
(defvar sly-package-file-candidates
(mapcar #'file-name-nondirectory
'("package.lisp" "packages.lisp" "pkgdcl.lisp"
"defpackage.lisp")))
(defvar sly-export-symbol-representation-function
#'(lambda (n) (format "#:%s" n)))
(defvar sly-import-symbol-package-transform-function
'identity
"String transformation used by `sly-import-symbol-at-point'.
This function is applied to a package name before it is inserted
into the defpackage form. By default, it is `identity' but you
may wish redefine it to do some tranformations, for example, to
replace dots with slashes to conform to a package-inferred ASDF
system-definition style.")
(defvar sly-export-symbol-representation-auto t
"Determine automatically which style is used for symbols, #: or :
If it's mixed or no symbols are exported so far,
use `sly-export-symbol-representation-function'.")
(define-obsolete-variable-alias 'sly-export-save-file
'sly-package-fu-save-file "1.0.0-beta-3")
(defvar sly-package-fu-save-file nil
"Save the package file after each automatic modification")
(defvar sly-defpackage-regexp
"^(\\(cl:\\|common-lisp:\\|uiop:\\|\\uiop/package:\\)?\\(defpackage\\|define-package\\)\\>[ \t']*")
(put 'uiop:define-package 'sly-common-lisp-indent-function '(as defpackage))
(defun sly-find-package-definition-rpc (package)
(sly-eval `(slynk:find-definition-for-thing
(slynk::guess-package ,package))))
(defun sly-find-package-definition-regexp (package)
(save-excursion
(save-match-data
(goto-char (point-min))
(cl-block nil
(while (re-search-forward sly-defpackage-regexp nil t)
(when (sly-package-equal package (sly-sexp-at-point))
(backward-sexp)
(cl-return (make-sly-file-location (buffer-file-name)
(1- (point))))))))))
(defun sly-package-equal (designator1 designator2)
;; First try to be lucky and compare the strings themselves (for the
;; case when one of the designated packages isn't loaded in the
;; image.) Then try to do it properly using the inferior Lisp which
;; will also resolve nicknames for us &c.
(or (cl-equalp (sly-cl-symbol-name designator1)
(sly-cl-symbol-name designator2))
(sly-eval `(slynk:package= ,designator1 ,designator2))))
(defun sly-export-symbol (symbol package)
"Unexport `symbol' from `package' in the Lisp image."
(sly-eval `(slynk:export-symbol-for-emacs ,symbol ,package)))
(defun sly-unexport-symbol (symbol package)
"Export `symbol' from `package' in the Lisp image."
(sly-eval `(slynk:unexport-symbol-for-emacs ,symbol ,package)))
(defun sly-find-possible-package-file (buffer-file-name)
(cl-labels ((file-name-subdirectory (dirname)
(expand-file-name
(concat (file-name-as-directory (sly-to-lisp-filename dirname))
(file-name-as-directory ".."))))
(try (dirname)
(cl-dolist (package-file-name sly-package-file-candidates)
(let ((f (sly-to-lisp-filename
(concat dirname package-file-name))))
(when (file-readable-p f)
(cl-return f))))))
(when buffer-file-name
(let ((buffer-cwd (file-name-directory buffer-file-name)))
(or (try buffer-cwd)
(try (file-name-subdirectory buffer-cwd))
(try (file-name-subdirectory
(file-name-subdirectory buffer-cwd))))))))
(defun sly-goto-package-source-definition (package)
"Tries to find the DEFPACKAGE form of `package'. If found,
places the cursor at the start of the DEFPACKAGE form."
(cl-labels ((try (location)
(when (sly-location-p location)
(sly-move-to-source-location location)
t)))
(or (try (sly-find-package-definition-rpc package))
(try (sly-find-package-definition-regexp package))
(try (sly--when-let
(package-file (sly-find-possible-package-file
(buffer-file-name)))
(with-current-buffer (find-file-noselect package-file t)
(sly-find-package-definition-regexp package))))
(sly-error "Couldn't find source definition of package: %s" package))))
(defun sly-at-expression-p (pattern)
(when (ignore-errors
;; at a list?
(= (point) (progn (down-list 1)
(backward-up-list 1)
(point))))
(save-excursion
(down-list 1)
(sly-in-expression-p pattern))))
(defun sly-goto-next-export-clause ()
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(save-excursion
(cl-block nil
(while (ignore-errors (sly-forward-sexp) t)
(skip-chars-forward " \n\t")
(when (sly-at-expression-p '(:export *))
(setq point (point))
(cl-return)))))
(if point
(goto-char point)
(error "No next (:export ...) clause found"))))
(defun sly-search-exports-in-defpackage (symbol-name)
"Look if `symbol-name' is mentioned in one of the :EXPORT clauses."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(cl-labels ((target-symbol-p (symbol)
(string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$"
(regexp-quote symbol-name))
symbol)))
(save-excursion
(cl-block nil
(while (ignore-errors (sly-goto-next-export-clause) t)
(let ((clause-end (save-excursion (forward-sexp) (point))))
(save-excursion
(while (search-forward symbol-name clause-end t)
(when (target-symbol-p (sly-symbol-at-point))
(cl-return (if (sly-inside-string-p)
;; Include the following "
(1+ (point))
(point))))))))))))
(defun sly-package-fu--read-symbols ()
"Reads sexps as strings from the point to end of sexp.
For example, in this situation.
(for<point> bar minor (again 123))
this will return (\"bar\" \"minor\" \"(again 123)\")"
(cl-labels ((read-sexp ()
(ignore-errors
(forward-comment (point-max))
(buffer-substring-no-properties
(point) (progn (forward-sexp) (point))))))
(save-excursion
(cl-loop for sexp = (read-sexp) while sexp collect sexp))))
(defun sly-package-fu--normalize-name (name)
(if (string-prefix-p "\"" name)
(read name)
(replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)"
"" name)))
(defun sly-defpackage-exports ()
"Return a list of symbols inside :export clause of a defpackage."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(save-excursion
(mapcar #'sly-package-fu--normalize-name
(cl-loop while (ignore-errors (sly-goto-next-export-clause) t)
do (down-list) (forward-sexp)
append (sly-package-fu--read-symbols)
do (up-list) (backward-sexp)))))
(defun sly-symbol-exported-p (name symbols)
(cl-member name symbols :test 'cl-equalp))
(defun sly-frob-defpackage-form (current-package do-what symbols)
"Adds/removes `symbol' from the DEFPACKAGE form of `current-package'
depending on the value of `do-what' which can either be `:export',
or `:unexport'.
Returns t if the symbol was added/removed. Nil if the symbol was
already exported/unexported."
(save-excursion
(sly-goto-package-source-definition current-package)
(down-list 1) ; enter DEFPACKAGE form
(forward-sexp) ; skip DEFPACKAGE symbol
;; Don't or will fail if (:export ...) is immediately following
;; (forward-sexp) ; skip package name
(let ((exported-symbols (sly-defpackage-exports))
(symbols (if (consp symbols)
symbols
(list symbols)))
(number-of-actions 0))
(cl-ecase do-what
(:export
(sly-add-export)
(dolist (symbol symbols)
(let ((symbol-name (sly-cl-symbol-name symbol)))
(unless (sly-symbol-exported-p symbol-name exported-symbols)
(cl-incf number-of-actions)
(sly-package-fu--insert-symbol symbol-name)))))
(:unexport
(dolist (symbol symbols)
(let ((symbol-name (sly-cl-symbol-name symbol)))
(when (sly-symbol-exported-p symbol-name exported-symbols)
(sly-remove-export symbol-name)
(cl-incf number-of-actions))))))
(when sly-package-fu-save-file
(save-buffer))
(cons number-of-actions
(current-buffer)))))
(defun sly-add-export ()
(let (point)
(save-excursion
(while (ignore-errors (sly-goto-next-export-clause) t)
(setq point (point))))
(cond (point
(goto-char point)
(down-list)
(sly-end-of-list))
(t
(sly-end-of-list)
(unless (looking-back "^\\s-*" (line-beginning-position) nil)
(newline-and-indent))
(insert "(:export ")
(save-excursion (insert ")"))))))
(defun sly-determine-symbol-style ()
;; Assumes we're inside :export
(save-excursion
(sly-beginning-of-list)
(sly-forward-sexp)
(let ((symbols (sly-package-fu--read-symbols)))
(cond ((null symbols)
sly-export-symbol-representation-function)
((cl-every (lambda (x)
(string-match "^:" x))
symbols)
(lambda (n) (format ":%s" n)))
((cl-every (lambda (x)
(string-match "^#:" x))
symbols)
(lambda (n) (format "#:%s" n)))
((cl-every (lambda (x)
(string-prefix-p "\"" x))
symbols)
(lambda (n) (prin1-to-string (upcase (substring-no-properties n)))))
(t
sly-export-symbol-representation-function)))))
(defun sly-format-symbol-for-defpackage (symbol-name)
(funcall (if sly-export-symbol-representation-auto
(sly-determine-symbol-style)
sly-export-symbol-representation-function)
symbol-name))
(defun sly-package-fu--insert-symbol (symbol-name)
;; Assumes we're at the inside :export or :import-from form
;; after the last symbol
(let ((symbol-name (sly-format-symbol-for-defpackage symbol-name)))
(unless (looking-back "^\\s-*" (line-beginning-position) nil)
(newline-and-indent))
(insert symbol-name)
(when (looking-at "\\s_") (insert " "))))
(defun sly-remove-export (symbol-name)
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(while (setq point (sly-search-exports-in-defpackage symbol-name))
(save-excursion
(goto-char point)
(backward-sexp)
(delete-region (point) point)
(beginning-of-line)
(when (looking-at "^\\s-*$")
(join-line)
(delete-trailing-whitespace (point) (line-end-position)))))))
(defun sly-export-symbol-at-point ()
"Add the symbol at point to the defpackage source definition
belonging to the current buffer-package. With prefix-arg, remove
the symbol again. Additionally performs an EXPORT/UNEXPORT of the
symbol in the Lisp image if possible."
(interactive)
(let* ((symbol (sly-symbol-at-point))
(package (or (and (string-match "^\\([^:]+\\):.*" symbol)
(match-string 1 symbol))
(sly-current-package))))
(unless symbol (error "No symbol at point."))
(cond (current-prefix-arg
(let* ((attempt (sly-frob-defpackage-form package :unexport symbol))
(howmany (car attempt))
(where (buffer-file-name (cdr attempt))))
(if (cl-plusp howmany)
(sly-message "Symbol `%s' no longer exported from `%s' in %s"
symbol package where)
(sly-message "Symbol `%s' is not exported from `%s' in %s"
symbol package where)))
(sly-unexport-symbol symbol package))
(t
(let* ((attempt (sly-frob-defpackage-form package :export symbol))
(howmany (car attempt))
(where (buffer-file-name (cdr attempt))))
(if (cl-plusp howmany)
(sly-message "Symbol `%s' now exported from `%s' in %s"
symbol package where)
(sly-message "Symbol `%s' already exported from `%s' in %s"
symbol package where)))
(sly-export-symbol symbol package)))))
(defun sly-export-class (name)
"Export acessors, constructors, etc. associated with a structure or a class"
(interactive (list (sly-read-from-minibuffer "Export structure named: "
(sly-symbol-at-point))))
(let* ((package (sly-current-package))
(symbols (sly-eval `(slynk:export-structure ,name ,package))))
(sly-message "%s symbols exported from `%s'"
(car (sly-frob-defpackage-form package :export symbols))
package)))
(defalias 'sly-export-structure 'sly-export-class)
;;
;; Dealing with import-from
;;
(defun sly-package-fu--search-import-from (package)
(let* ((normalized-package (sly-package-fu--normalize-name package))
(regexp (format "(:import-from[ \t']*\\(:\\|#:\\)?%s"
(regexp-quote normalized-package))))
(re-search-forward regexp nil t)))
(defun sly-package-fu--create-new-import-from (package symbol)
"Add new :IMPORT-FROM subform for PACKAGE. Add SYMBOL.
Assumes point just before start of DEFPACKAGE form"
(forward-sexp)
;; Now, search last :import-from or :use form
(cond
((or (re-search-backward "(:\\(use\\|import-from\\)" nil t)
(and (re-search-backward "def[[:alnum:]]*package" nil t)
(progn (forward-sexp) t)))
;; Skip found expression
(forward-sexp)
;; and insert a new (:import-from <package> <symbol>) form.
(newline-and-indent)
(let ((symbol-name (sly-format-symbol-for-defpackage symbol))
(package-name (sly-format-symbol-for-defpackage package)))
(insert "(:import-from )")
(backward-char)
(insert package-name)
(newline-and-indent)
(insert symbol-name)))
(t (error "Can't find suitable place for :import-from defpackage form."))))
(defun sly-package-fu--add-or-update-import-from-form (symbol)
"Do the heavy-lifting for `sly-import-symbol-at-point'.
Accept a string or a symbol like \"alexandria:with-gensyms\",
and add it to existing (import-from #:alexandria ...) form, or
create a new one. Return name of the given symbol inside of its
package. For example above, return \"with-gensyms\"."
(let* ((package (or (funcall sly-import-symbol-package-transform-function
(sly-cl-symbol-package symbol))
;; We only process symbols in fully qualified form like
;; weblocks/request:get-parameter
(user-error "`%s' is not a package-qualified symbol."
symbol)))
(simple-symbol (sly-cl-symbol-name symbol)))
(save-excursion
;; First go to just before relevant DEFPACKAGE form
;;
(sly-goto-package-source-definition (sly-current-package))
;; Ask CL to actually import the symbol (a synchronized eval
;; makes sure an error aborts the rest of the command)
;;
(sly-eval `(slynk:import-symbol-for-emacs ,symbol
,(sly-current-package)
,package))
(if (sly-package-fu--search-import-from package)
;; If specific (:IMPORT-FROM PACKAGE... ) subform exists,
;; attempt to insert package-less SYMBOL there.
(let ((imported-symbols (mapcar #'sly-package-fu--normalize-name
(sly-package-fu--read-symbols))))
(unless (cl-member simple-symbol
imported-symbols
:test 'cl-equalp)
(sly-package-fu--insert-symbol simple-symbol)
(when sly-package-fu-save-file (save-buffer))))
;; Else, point is unmoved. Add a new (:IMPORT-FROM PACKAGE)
;; subform after any other existing :IMPORT-FROM or :USE
;; subforms.
(sly-package-fu--create-new-import-from package
simple-symbol)
(when sly-package-fu-save-file (save-buffer)))
;; Always return symbol-without-package, because it is useful
;; to replace symbol at point and change it from fully qualified
;; form to a simple-form
simple-symbol)))
(defun sly-import-symbol-at-point ()
"Add a qualified symbol to package's :import-from subclause.
Takes a package-qualified symbol at point, adds it to the current
package's defpackage form (under its :import-form subclause) and
replaces with a symbol name without the package designator."
(interactive)
(let* ((bounds (sly-bounds-of-symbol-at-point))
(beg (set-marker (make-marker) (car bounds)))
(end (set-marker (make-marker) (cdr bounds))))
(when bounds
(let ((non-qualified-name
(sly-package-fu--add-or-update-import-from-form
(buffer-substring-no-properties beg end))))
(when non-qualified-name
(delete-region beg end)
(insert non-qualified-name))))))
(provide 'sly-package-fu)
;; -*- lexical-binding: t -*- An experimental implementation of
;; multiple REPLs multiplexed over a single Slime socket. M-x
;; sly-mrepl or M-x sly-mrepl-new create new REPL buffers.
;;
(require 'sly)
(require 'sly-autodoc)
(require 'cl-lib)
(require 'comint)
(define-sly-contrib sly-mrepl
"Multiple REPLs."
(:license "GPL")
(:sly-dependencies sly-autodoc)
(:slynk-dependencies slynk/mrepl)
(:on-load
;; Define a new "part action" for the `sly-part' buttons and change
;; the `sly-inspector-part', `sly-db-local-variable' and
;; `sly-trace-dialog-part' to include it.
;;
(sly-button-define-part-action sly-mrepl-copy-part-to-repl
"Copy to REPL" (kbd "M-RET"))
(sly-button-define-part-action sly-mrepl-copy-call-to-repl
"Copy call to REPL" (kbd "M-S-<return>"))
(button-type-put 'sly-inspector-part
'sly-mrepl-copy-part-to-repl
'sly-inspector-copy-part-to-repl)
(button-type-put 'sly-db-local-variable
'sly-mrepl-copy-part-to-repl
'sly-db-copy-part-to-repl)
(button-type-put 'sly-apropos-symbol
'sly-mrepl-copy-part-to-repl
'sly-apropos-copy-symbol-to-repl)
(button-type-put 'sly-db-frame
'sly-mrepl-copy-call-to-repl
'sly-db-copy-call-to-repl)
(eval-after-load "sly-trace-dialog"
`(progn
(button-type-put 'sly-trace-dialog-part
'sly-mrepl-copy-part-to-repl
'sly-trace-dialog-copy-part-to-repl)
(button-type-put 'sly-trace-dialog-spec
'sly-mrepl-copy-call-to-repl
'sly-trace-dialog-copy-call-to-repl)))
;; Make C-c ~ bring popup REPL
;;
(define-key sly-mode-map (kbd "C-c ~") 'sly-mrepl-sync)
(define-key sly-mode-map (kbd "C-c C-z") 'sly-mrepl)
(define-key sly-selector-map (kbd "~") 'sly-mrepl-sync)
(define-key sly-selector-map (kbd "r") 'sly-mrepl)
;; Insinuate ourselves in hooks
;;
(add-hook 'sly-connected-hook 'sly-mrepl-on-connection)
(add-hook 'sly-net-process-close-hooks 'sly-mrepl--teardown-repls)
;; The connection list is also tweaked
;;
(setq sly-connection-list-button-action
#'(lambda (process)
(let ((sly-default-connection process))
(sly-mrepl 'pop-to-buffer)))))
(:on-unload
;; FIXME: This `:on-unload' is grossly incomplete
;;
(remove-hook 'sly-connected-hook 'sly-mrepl-on-connection)
(remove-hook 'sly-net-process-close-hooks 'sly-mrepl--teardown-repls)))
;; User-visible variables
;;
(defvar sly-mrepl-mode-hook nil
"Functions run after `sly-mrepl-mode' is set up")
(defvar sly-mrepl-hook nil
"Functions run after `sly-mrepl-new' sets up a REPL.")
(defvar sly-mrepl-runonce-hook nil
"Functions run once after `sly-mrepl-new' sets up a REPL.
After running the contents of this hook its default value is
emptied. See also `sly-mrepl-hook'")
(defvar sly-mrepl-output-filter-functions comint-preoutput-filter-functions
"List of functions filtering Slynk's REPL output.
This variables behaves like `comint-preoutput-filter-functions',
for output printed to the REPL (not for evaluation results)")
(defvar sly-mrepl-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'sly-mrepl-return)
(define-key map (kbd "TAB") 'sly-mrepl-indent-and-complete-symbol)
(define-key map (kbd "C-c C-b") 'sly-interrupt)
(define-key map (kbd "C-c C-c") 'sly-interrupt)
(define-key map (kbd "C-c C-o") 'sly-mrepl-clear-recent-output)
(define-key map (kbd "C-c M-o") 'sly-mrepl-clear-repl)
(define-key map (kbd "M-p") 'sly-mrepl-previous-input-or-button)
(define-key map (kbd "M-n") 'sly-mrepl-next-input-or-button)
(define-key map (kbd "C-M-p") 'sly-button-backward)
(define-key map (kbd "C-M-n") 'sly-button-forward)
map))
(defvar sly-mrepl-pop-sylvester 'on-connection)
(defface sly-mrepl-prompt-face
`((t (:inherit font-lock-builtin-face)))
"Face for the regular MREPL prompt."
:group 'sly-mode-faces)
(defface sly-mrepl-note-face
`((t (:inherit font-lock-keyword-face)))
"Face for the MREPL notes."
:group 'sly-mode-faces)
(defface sly-mrepl-output-face
'((((class color)
(background dark))
(:foreground "VioletRed1"))
(((class color)
(background light))
(:foreground "steel blue"))
(t
(:bold t :italic t)))
"Face for the regular MREPL prompt."
:group 'sly-mode-faces)
;; Internal variables
;;
(defvar sly-mrepl--remote-channel nil)
(defvar sly-mrepl--local-channel nil)
(defvar sly-mrepl--read-mark nil)
(defvar sly-mrepl--output-mark nil)
(defvar sly-mrepl--dedicated-stream nil)
(defvar sly-mrepl--last-prompt-overlay nil)
(defvar sly-mrepl--pending-output nil
"Output that can't be inserted right now.")
(defvar sly-mrepl--dedicated-stream-hooks)
(defvar sly-mrepl--history-separator "####\n")
(defvar sly-mrepl--dirty-history nil)
;; Major mode
;;
(define-derived-mode sly-mrepl-mode comint-mode "mrepl"
(sly-mode 1)
(cl-loop for (var value)
in `((comint-use-prompt-regexp nil)
(comint-inhibit-carriage-motion t)
(comint-input-sender sly-mrepl--input-sender)
(comint-output-filter-functions nil)
(comint-input-filter-functions nil)
(comint-history-isearch dwim)
(comint-input-ignoredups t)
(comint-input-history-ignore "^;")
(comint-prompt-read-only t)
(comint-process-echoes nil)
(comint-completion-addsuffix "")
(indent-line-function lisp-indent-line)
(sly-mrepl--read-mark nil)
(sly-mrepl--pending-output nil)
(sly-mrepl--output-mark ,(point-marker))
(sly-mrepl--last-prompt-overlay ,(make-overlay 0 0 nil nil))
(sly-find-buffer-package-function sly-mrepl-guess-package)
(sly-autodoc-inhibit-autodoc
sly-mrepl-inside-string-or-comment-p)
(mode-line-process nil)
(parse-sexp-ignore-comments t)
(syntax-propertize-function sly-mrepl--syntax-propertize)
(forward-sexp-function sly-mrepl--forward-sexp)
(comint-scroll-show-maximum-output nil)
(comint-scroll-to-bottom-on-input nil)
(comint-scroll-to-bottom-on-output nil)
(inhibit-field-text-motion nil)
(lisp-indent-function sly-common-lisp-indent-function)
(open-paren-in-column-0-is-defun-start nil)
(buffer-file-coding-system utf-8-unix)
;; Paredit workaround (see
;; https://github.com/joaotavora/sly/issues/110)
(paredit-override-check-parens-function (lambda (_c) t))
(comment-start ";"))
do (set (make-local-variable var) value))
(set-marker-insertion-type sly-mrepl--output-mark nil)
(add-hook 'kill-emacs-hook 'sly-mrepl--save-all-histories)
;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input)
(set-syntax-table lisp-mode-syntax-table)
(set-keymap-parent sly-mrepl-mode-map nil)
;; The REPL buffer has interactive text buttons
(sly-interactive-buttons-mode 1)
;; Add hooks to isearch-mode placed strategically after the ones
;; set by comint.el itself.
;;
(add-hook 'isearch-mode-hook 'sly-mrepl--setup-comint-isearch t t)
(add-hook 'isearch-mode-end-hook 'sly-mrepl--teardown-comint-isearch t t)
;; Add a post-command-handler
;;
(add-hook 'post-command-hook 'sly-mrepl--highlight-backreferences-maybe t t))
;;; Channel methods
(sly-define-channel-type listener)
(sly-define-channel-method listener :write-values (results)
(with-current-buffer (sly-channel-get self 'buffer)
(sly-mrepl--insert-results results)))
(sly-define-channel-method listener :evaluation-aborted (&optional condition)
(with-current-buffer (sly-channel-get self 'buffer)
(sly-mrepl--catch-up)
(sly-mrepl--insert-note (format "Evaluation aborted on %s" condition))))
(sly-define-channel-method listener :write-string (string)
(with-current-buffer (sly-channel-get self 'buffer)
(sly-mrepl--insert-output string)))
(sly-define-channel-method listener :set-read-mode (mode)
(with-current-buffer (sly-channel-get self 'buffer)
(cl-macrolet ((assert-soft
(what) `(unless ,what
(sly-warning
,(format "Expectation failed: %s" what)))))
(let ((inhibit-read-only t))
(cl-ecase mode
(:read
(assert-soft (null sly-mrepl--read-mark))
;; Give a chance for output to come in before we block it
;; during the read.
(sly-mrepl--accept-process-output)
(setq sly-mrepl--read-mark (point))
(add-text-properties (1- (point)) (point)
`(rear-nonsticky t))
(sly-message "REPL now waiting for input to read"))
(:finished-reading
(assert-soft (integer-or-marker-p sly-mrepl--read-mark))
(when sly-mrepl--read-mark
(add-text-properties (1- sly-mrepl--read-mark) (point)
`(face bold read-only t)))
(setq sly-mrepl--read-mark nil)
;; github#456 need to flush any output that has overtaken
;; the set-read-mode rpc.
(when sly-mrepl--pending-output
(sly-mrepl--insert-output "\n"))
(sly-message "REPL back to normal evaluation mode")))))))
(sly-define-channel-method listener :prompt (&rest prompt-args)
(with-current-buffer (sly-channel-get self 'buffer)
(apply #'sly-mrepl--insert-prompt prompt-args)))
(sly-define-channel-method listener :open-dedicated-output-stream
(port _coding-system)
(with-current-buffer (sly-channel-get self 'buffer)
;; HACK: no coding system
(set (make-local-variable 'sly-mrepl--dedicated-stream)
(sly-mrepl--open-dedicated-stream self port nil))))
(sly-define-channel-method listener :clear-repl-history ()
(with-current-buffer (sly-channel-get self 'buffer)
(let ((inhibit-read-only t))
(erase-buffer)
(sly-mrepl--insert-note "Cleared REPL history"))))
(sly-define-channel-method listener :server-side-repl-close ()
(with-current-buffer (sly-channel-get self 'buffer)
(sly-mrepl--teardown "Server side close" 'dont-signal-server)))
;;; Button type
;;;
(define-button-type 'sly-mrepl-part :supertype 'sly-part
'sly-button-inspect
#'(lambda (entry-idx value-idx)
(sly-eval-for-inspector `(slynk-mrepl:inspect-entry
,sly-mrepl--remote-channel
,entry-idx
,value-idx)
:inspector-name (sly-maybe-read-inspector-name)))
'sly-button-describe
#'(lambda (entry-idx value-idx)
(sly-eval-describe `(slynk-mrepl:describe-entry ,sly-mrepl--remote-channel
,entry-idx
,value-idx)))
'sly-button-pretty-print
#'(lambda (entry-idx value-idx)
(sly-eval-describe `(slynk-mrepl:pprint-entry ,sly-mrepl--remote-channel
,entry-idx
,value-idx)))
'sly-mrepl-copy-part-to-repl 'sly-mrepl--copy-part-to-repl)
;;; Internal functions
;;;
(defun sly-mrepl--buffer-name (connection &optional handle)
(sly-buffer-name :mrepl :connection connection
:suffix handle))
(defun sly-mrepl--teardown-repls (process)
(cl-loop for buffer in (buffer-list)
when (buffer-live-p buffer)
do (with-current-buffer buffer
(when (and (eq major-mode 'sly-mrepl-mode)
(eq sly-buffer-connection process))
(sly-mrepl--teardown (process-get process
'sly-net-close-reason))))))
(defun sly-mrepl--process () (get-buffer-process (current-buffer))) ;stupid
(defun sly-mrepl--mark ()
"Returns a marker to the end of the last prompt."
(let ((proc (sly-mrepl--process)))
(unless proc (sly-user-error "Not in a connected REPL"))
(process-mark proc)))
(defun sly-mrepl--safe-mark ()
"Like `sly-mrepl--mark', but safe if there's no process."
(if (sly-mrepl--process) (sly-mrepl--mark) (point-max)))
(defmacro sly-mrepl--commiting-text (props &rest body)
(declare (debug (sexp &rest form))
(indent 1))
(let ((start-sym (cl-gensym)))
`(let ((,start-sym (marker-position (sly-mrepl--mark)))
(inhibit-read-only t))
,@body
(add-text-properties ,start-sym (sly-mrepl--mark)
(append '(read-only t front-sticky (read-only))
,props)))))
(defun sly-mrepl--forward-sexp (n)
"Just like `forward-sexp' unless point it at prompt start.
In that case, moving a sexp backward does nothing."
(if (or (cl-plusp n)
(/= (point) (sly-mrepl--safe-mark)))
(let ((forward-sexp-function nil))
(forward-sexp n))))
(defun sly-mrepl--syntax-propertize (beg end)
"Make everything up to current prompt comment syntax."
(remove-text-properties beg end '(syntax-table nil))
(let ((end (min end (sly-mrepl--safe-mark)))
(beg beg))
(when (> end beg)
(unless (nth 8 (syntax-ppss beg))
(add-text-properties beg (1+ beg)
`(syntax-table ,(string-to-syntax "!"))))
(add-text-properties (1- end) end
`(syntax-table ,(string-to-syntax "!"))))))
(defun sly-mrepl--call-with-repl (repl-buffer fn)
(with-current-buffer repl-buffer
(cl-loop
while (not (buffer-local-value 'sly-mrepl--remote-channel
(current-buffer)))
do
(sly-warning "Waiting for a REPL to be setup for %s"
(sly-connection-name (sly-current-connection)))
(sit-for 0.5))
(funcall fn)))
(defmacro sly-mrepl--with-repl (repl-buffer &rest body)
(declare (indent 1) (debug (sexp &rest form)))
`(sly-mrepl--call-with-repl ,repl-buffer #'(lambda () ,@body)))
(defun sly-mrepl--insert (string &optional face)
(sly-mrepl--commiting-text (when face
`(face ,face font-lock-face ,face))
(comint-output-filter (sly-mrepl--process)
(propertize string 'sly-mrepl-break-output t))))
(defun sly-mrepl--break-output-p (pos)
(and (not (eq ?\n (char-after pos)))
(get-char-property pos 'sly-mrepl-break-output)))
(defun sly-mrepl--insert-output (string &optional face nofilters)
(cond ((and (not sly-mrepl--read-mark) string)
(let ((inhibit-read-only t)
(start (marker-position sly-mrepl--output-mark))
(face (or face
'sly-mrepl-output-face)))
(save-excursion
(goto-char sly-mrepl--output-mark)
(cond ((and (not (bobp))
(sly-mrepl--break-output-p (1- start))
(not (zerop (current-column))))
(insert-before-markers "\n")))
(setq string
(propertize (concat sly-mrepl--pending-output string)
'face face
'font-lock-face face))
(setq sly-mrepl--pending-output nil)
(unless nofilters
(run-hook-wrapped
'sly-mrepl-output-filter-functions
(lambda (fn)
(setq string (funcall fn string))
nil)))
(insert-before-markers string)
(cond ((and (not (zerop (current-column)))
(sly-mrepl--break-output-p (point)))
(save-excursion (insert "\n"))))
(add-text-properties start sly-mrepl--output-mark
`(read-only t front-sticky (read-only)
field sly-mrepl--output)))))
(t
(setq sly-mrepl--pending-output
(concat sly-mrepl--pending-output string))
(sly-message "Some output saved for later insertion"))))
(defun sly-mrepl--insert-note (string &optional face)
(let* ((face (or face 'sly-mrepl-note-face))
(string (replace-regexp-in-string "^" "; " string)))
(cond ((sly-mrepl--process)
;; notes are inserted "synchronously" with the process mark process
(sly-mrepl--ensure-newline)
(sly-mrepl--insert string face))
(t
;; If no process yet, fall back to the simpler strategy.
(sly-mrepl--insert-output string face)))))
(defun sly-mrepl--send-input-sexp ()
(goto-char (point-max))
(save-excursion
(skip-chars-backward "\n\t\s")
(delete-region (max (point)
(sly-mrepl--mark))
(point-max)))
(buffer-disable-undo)
(overlay-put sly-mrepl--last-prompt-overlay 'face 'highlight)
(set (make-local-variable 'sly-mrepl--dirty-history) t)
(sly-mrepl--commiting-text
`(field sly-mrepl-input
keymap ,(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'sly-mrepl-insert-input)
(define-key map [return] 'sly-mrepl-insert-input)
(define-key map [mouse-2] 'sly-mrepl-insert-input)
map))
(comint-send-input))
(sly-mrepl--ensure-prompt-face))
(defun sly-mrepl--ensure-newline ()
(unless (save-excursion
(goto-char (sly-mrepl--mark))
(zerop (current-column)))
(sly-mrepl--insert "\n")))
(defun sly-mrepl--accept-process-output ()
(when (and sly-mrepl--dedicated-stream
(process-live-p sly-mrepl--dedicated-stream))
;; This non-blocking call should be enough to allow asynch calls
;; to `sly-mrepl--insert-output' to still see the correct value
;; for `sly-mrepl--output-mark' just before we call
;; `sly-mrepl--catch-up'.
(while (accept-process-output sly-mrepl--dedicated-stream
0
(and (eq (window-system) 'w32) 1)))))
(defun sly-mrepl--ensure-prompt-face ()
"Override `comint.el''s use of `comint-highlight-prompt'."
(let ((inhibit-read-only t))
(add-text-properties (overlay-start sly-mrepl--last-prompt-overlay)
(overlay-end sly-mrepl--last-prompt-overlay)
'(font-lock-face sly-mrepl-prompt-face))))
(defun sly-mrepl-default-prompt (_package
nickname
error-level
_entry-idx
_condition)
"Compute default SLY prompt string.
Suitable for `sly-mrepl-prompt-formatter'."
(concat
(when (cl-plusp error-level)
(concat (sly-make-action-button
(format "[%d]" error-level)
#'sly-db-pop-to-debugger-maybe)
" "))
(propertize
(concat nickname "> ")
'face 'sly-mrepl-prompt-face
'font-lock-face 'sly-mrepl-prompt-face)))
(defcustom sly-mrepl-prompt-formatter #'sly-mrepl-default-prompt
"Compute propertized string to use as REPL prompt.
Value is a function passed at least 5 arguments with the
following signature:
(PACKAGE NICKNAME ERROR-LEVEL NEXT-ENTRY-IDX CONDITION &REST)
PACKAGE is a string denoring the full name of the current
package. NICKNAME is the shortest or preferred nickname of
PACKAGE, according to the Lisp variables
SLYNK:*CANONICAL-PACKAGE-NICKNAMES* and
SLYNK:*AUTO-ABBREVIATE-DOTTED-PACKAGES*. ERROR-LEVEL is a
integer counting the number of outstanding errors.
NEXT-ENTRY-IDX is a number identifying future evaluation results
for backreferencing purposes. Depending on ERROR-LEVEL,
CONDITION is either nil or a string containing the printed
representation of the outstanding condition that caused the
current ERROR-LEVEL."
:type 'function
:group 'sly)
(defun sly-mrepl--insert-prompt (package nickname error-level
&optional next-entry-idx condition)
(sly-mrepl--accept-process-output)
(overlay-put sly-mrepl--last-prompt-overlay 'face 'bold)
(when condition
(sly-mrepl--insert-note (format "Debugger entered on %s" condition)))
(sly-mrepl--ensure-newline)
(sly-mrepl--catch-up)
(let ((beg (marker-position (sly-mrepl--mark))))
(sly-mrepl--insert
(propertize
(funcall sly-mrepl-prompt-formatter
package
nickname
error-level
next-entry-idx
condition)
'sly-mrepl--prompt (downcase package)))
(move-overlay sly-mrepl--last-prompt-overlay beg (sly-mrepl--mark)))
(sly-mrepl--ensure-prompt-face)
(buffer-disable-undo)
(buffer-enable-undo))
(defun sly-mrepl--copy-part-to-repl (entry-idx value-idx)
(sly-mrepl--copy-objects-to-repl
`(,entry-idx ,value-idx)
:before (format "Returning value %s of history entry %s"
value-idx entry-idx)))
(cl-defun sly-mrepl--eval-for-repl
(slyfun-and-args
&key insert-p before-prompt after-prompt (pop-to-buffer t))
"Evaluate SLYFUN-AND-ARGS in Slynk, then call callbacks.
SLYFUN-AND-ARGS is (SLYFUN . ARGS) and is called in
Slynk. SLYFUN's multiple return values are captured in a list and
passed to the optional unary callbacks BEFORE-PROMPT and
AFTER-PROMPT, called before or after prompt insertion,
respectively.
If INSERT-P is non-nil, SLYFUN's results are printable
representations of Slynk objects and should be inserted into the
REPL. POP-TO-BUFFER says whether to pop the REPL buffer."
(sly-eval-async `(slynk-mrepl:eval-for-mrepl
,sly-mrepl--remote-channel
',(car slyfun-and-args)
,@(cdr slyfun-and-args))
(lambda (prompt-args-and-results)
(cl-destructuring-bind (prompt-args results)
prompt-args-and-results
(goto-char (sly-mrepl--mark))
(let ((saved-text (buffer-substring (point) (point-max))))
(delete-region (point) (point-max))
(sly-mrepl--catch-up)
(when before-prompt
(funcall before-prompt results))
(when insert-p
(sly-mrepl--insert-results results))
(apply #'sly-mrepl--insert-prompt prompt-args)
(when pop-to-buffer
(pop-to-buffer (current-buffer)))
(goto-char (sly-mrepl--mark))
(insert saved-text)
(when after-prompt
(funcall after-prompt results)))))))
(cl-defun sly-mrepl--copy-objects-to-repl
(method-args &key before after (pop-to-buffer t))
"Recall objects in the REPL history as a new entry.
METHOD-ARGS are SLYNK-MREPL:COPY-TO-REPL's optional args. If nil
, consider the globally saved objects that
SLYNK-MREPL:GLOBALLY-SAVE-OBJECT stored. Otherwise, it is a
list (ENTRY-IDX VALUE-IDX). BEFORE and AFTER as in
`sly-mrepl--save-and-copy-for-repl' POP-TO-BUFFER as in
`sly-mrepl--eval-for-repl'."
(sly-mrepl--eval-for-repl
`(slynk-mrepl:copy-to-repl
,@method-args)
:before-prompt (if (stringp before)
(lambda (objects)
(sly-mrepl--insert-note before)
(sly-mrepl--insert-results objects))
before)
:after-prompt after
:pop-to-buffer pop-to-buffer))
(defun sly-mrepl--make-result-button (result idx)
(sly--make-text-button (car result) nil
:type 'sly-mrepl-part
'part-args (list (cadr result) idx)
'part-label (format "REPL Result")
'sly-mrepl--result result
'sly-button-search-id (sly-button-next-search-id)))
(defun sly-mrepl--insert-results (results)
(let* ((comint-preoutput-filter-functions nil))
(if (null results)
(sly-mrepl--insert-note "No values")
(cl-loop for result in results
for idx from 0
do
(sly-mrepl--ensure-newline)
(sly-mrepl--insert
(sly-mrepl--make-result-button result idx))))))
(defun sly-mrepl--catch-up ()
"Synchronize the output mark with the REPL process mark."
(set-marker sly-mrepl--output-mark (sly-mrepl--mark)))
(defun sly-mrepl--input-sender (_proc string)
(sly-mrepl--send-string (substring-no-properties string)))
(defun sly-mrepl--send-string (string &optional _command-string)
(sly-mrepl--send `(:process ,string)))
(defun sly-mrepl--send (msg)
"Send MSG to the remote channel."
(sly-send-to-remote-channel sly-mrepl--remote-channel msg))
(defun sly-mrepl--find-buffer (&optional connection thread)
"Find the shortest-named (default) `sly-mrepl' buffer for CONNECTION."
;; CONNECTION defaults to the `sly-default-connection' passing
;; through `sly-connection'. Seems to work OK...
;;
(let* ((connection (or connection
(let ((sly-buffer-connection nil)
(sly-dispatching-connection nil))
(sly-connection))))
(repls (cl-remove-if-not
(lambda (x)
(with-current-buffer x
(and (eq major-mode 'sly-mrepl-mode)
(eq sly-buffer-connection connection)
(or (not thread)
(eq thread sly-current-thread)))))
(buffer-list)))
(sorted (cl-sort repls #'< :key (sly-compose #'length #'buffer-name))))
(car sorted)))
(defun sly-mrepl--find-create (connection)
(or (sly-mrepl--find-buffer connection)
(sly-mrepl-new connection)))
(defun sly-mrepl--busy-p ()
(>= sly-mrepl--output-mark (sly-mrepl--mark)))
(defcustom sly-mrepl-history-file-name (expand-file-name "~/.sly-mrepl-history")
"File used to store SLY REPL's input history across sessions."
:type 'file
:group 'sly)
(defun sly-mrepl--read-input-ring ()
(let ((comint-input-ring-separator sly-mrepl--history-separator)
(comint-input-ring-file-name sly-mrepl-history-file-name))
(comint-read-input-ring)))
(defcustom sly-mrepl-prevent-duplicate-history 'move
"If non-nil, prevent duplicate entries in input history.
Otherwise (if nil), input entry are always added to the end of
the history, even if they already occur in the history.
If the non-nil value is `move', the previously occuring entry is
discarded, i.e. moved to a more recent spot. Any other non-nil
value laves the previous entry untouched and it is the more
recent entry that is discarded."
:type 'symbol
:group 'sly)
(defun sly-mrepl--merge-and-save-history ()
(let*
;; To merge the file's history with the current buffer's
;; history, sntart by deep-copying `comint-input-ring' to a
;; separate variable.
;;
((current-ring (copy-tree comint-input-ring 'vectors-too))
(index (ring-length current-ring))
(comint-input-ring-separator sly-mrepl--history-separator)
(comint-input-ring-file-name sly-mrepl-history-file-name))
;; this sets `comint-input-ring' from the file
;;
(sly-mrepl--read-input-ring)
;; loop `current-ring', which potentially contains new entries and
;; re-add entries to `comint-input-ring', which is now synched
;; with the file and will be written to disk. Respect
;; `sly-mrepl-prevent-duplicate-history'.
;;
(cl-loop for i from (1- index) downto 0
for item = (ring-ref current-ring i)
for existing-index = (ring-member comint-input-ring item)
do (cond ((and existing-index
(eq sly-mrepl-prevent-duplicate-history 'move))
(ring-remove comint-input-ring existing-index)
(ring-insert comint-input-ring item))
((and existing-index
(not sly-mrepl-prevent-duplicate-history))
(ring-insert comint-input-ring item))
(t
(ring-insert comint-input-ring item)))
unless (ring-member comint-input-ring item)
do (ring-insert comint-input-ring item))
;; Now save `comint-input-ring'
(let ((coding-system-for-write 'utf-8-unix))
(comint-write-input-ring))
(set (make-local-variable 'sly-mrepl--dirty-history) nil)))
(defun sly-mrepl--save-all-histories ()
(cl-loop for buffer in (buffer-list)
do
(with-current-buffer buffer
(when (and (eq major-mode 'sly-mrepl-mode)
sly-mrepl--dirty-history)
(sly-mrepl--merge-and-save-history)))))
(defun sly-mrepl--teardown (&optional reason dont-signal-server)
(remove-hook 'kill-buffer-hook 'sly-mrepl--teardown t)
(let ((inhibit-read-only t))
(goto-char (point-max))
(let ((start (point)))
(unless (zerop (current-column)) (insert "\n"))
(insert (format "; %s" (or reason "REPL teardown")))
(unless (zerop (current-column)) (insert "\n"))
(insert "; --------------------------------------------------------\n")
(add-text-properties start (point) '(read-only t))))
(sly-mrepl--merge-and-save-history)
(when sly-mrepl--dedicated-stream
(process-put sly-mrepl--dedicated-stream 'sly-mrepl--channel nil)
(kill-buffer (process-buffer sly-mrepl--dedicated-stream)))
(sly-close-channel sly-mrepl--local-channel)
;; signal lisp that we're closingq
(unless dont-signal-server
(ignore-errors
;; uses `sly-connection', which falls back to
;; `sly-buffer-connection'. If that is closed it's probably
;; because lisp died from (SLYNK:QUIT-LISP) already, and so
(sly-mrepl--send `(:teardown))))
(set (make-local-variable 'sly-mrepl--remote-channel) nil)
(when (sly-mrepl--process)
(delete-process (sly-mrepl--process))))
(defun sly-mrepl--dedicated-stream-output-filter (process string)
(let* ((channel (process-get process 'sly-mrepl--channel))
(buffer (and channel
(sly-channel-get channel 'buffer))))
(if (buffer-live-p buffer)
(with-current-buffer buffer
(when (and (cl-plusp (length string))
(eq (process-status sly-buffer-connection) 'open))
(sly-mrepl--insert-output string)))
(sly-warning "No channel in process %s, probably torn down" process))))
(defun sly-mrepl--open-dedicated-stream (channel port coding-system)
(let* ((name (format "sly-dds-%s-%s"
(process-get sly-buffer-connection
'sly--net-connect-counter)
(sly-channel.id channel)))
(stream (open-network-stream
name
(generate-new-buffer
(format " *%s*" name))
(car (process-contact sly-buffer-connection))
port))
(emacs-coding-system (car (cl-find coding-system
sly-net-valid-coding-systems
:key #'cl-third))))
(set-process-query-on-exit-flag stream nil)
(set-process-plist stream `(sly-mrepl--channel ,channel))
(set-process-filter stream 'sly-mrepl--dedicated-stream-output-filter)
(set-process-coding-system stream emacs-coding-system emacs-coding-system)
(sly--when-let (secret (sly-secret))
(sly-net-send secret stream))
(run-hook-with-args 'sly-mrepl--dedicated-stream-hooks stream)
stream))
(cl-defun sly-mrepl--save-and-copy-for-repl
(slyfun-and-args &key repl before after)
"Evaluate SLYFUN-AND-ARGS in Slynk and prepare to copy to REPL.
BEFORE is a string inserted as a note, or a nullary function
which is run just before the object is copied to the
REPL. Optional BEFORE and AFTER are unary functions called with a
list of the saved values' presentations strings and run before
and after the the the prompt are inserted, respectively. BEFORE
can also be a string in which case it is inserted via
`sly-insert-note' followed by the saved values' presentations.
REPL is the REPL buffer to return the objects to."
(sly-eval-async
`(slynk-mrepl:globally-save-object ',(car slyfun-and-args)
,@(cdr slyfun-and-args))
#'(lambda (_ignored)
(sly-mrepl--copy-globally-saved-to-repl :before before
:after after
:repl repl))))
(cl-defun sly-mrepl--copy-globally-saved-to-repl
(&key before after repl (pop-to-buffer t))
"Copy last globally saved values to REPL, or active REPL.
BEFORE and AFTER as described in
`sly-mrepl--save-and-copy-for-repl'."
(sly-mrepl--with-repl (or repl
(sly-mrepl--find-create (sly-connection)))
(sly-mrepl--copy-objects-to-repl nil
:before before
:after after
:pop-to-buffer pop-to-buffer)))
(defun sly-mrepl--insert-call (spec results)
(delete-region (sly-mrepl--mark) (point-max))
(insert (format
"%s"
`(,spec
,@(cl-loop for (_object j constant) in results
for i from 0
collect
(or constant
(make-symbol (format "#v%d:%d" j i))))))))
(defun sly-mrepl--assert-mrepl ()
(unless (eq major-mode 'sly-mrepl-mode)
(sly-error "Not in a mREPL buffer")))
;;; ELI-like history (and a bugfix)
;;;
;;;
(defcustom sly-mrepl-eli-like-history-navigation nil
"If non-NIL navigate history like ELI.
When this option is active, previous history entries navigated to
by M-p and M-n keep the current input and use it to surround the
history entry navigated to."
:type 'boolean
:group 'sly)
(defvar sly-mrepl--eli-input nil)
(defun sly-mrepl--set-eli-input ()
(setq sly-mrepl--eli-input
(and sly-mrepl-eli-like-history-navigation
(let* ((offset (- (point) (sly-mrepl--mark)))
(existing (and (> offset 0)
(buffer-substring (sly-mrepl--mark)
(point-max)))))
(when existing
(cons (substring existing 0 offset)
(substring existing offset)))))))
(defun sly-mrepl--keep-eli-input-maybe ()
(when sly-mrepl--eli-input
(save-excursion
(goto-char (sly-mrepl--mark))
(insert (car sly-mrepl--eli-input))
(goto-char (point-max))
(insert (cdr sly-mrepl--eli-input)))))
(defvar sly-mrepl--eli-input-overlay nil)
(defun sly-mrepl--surround-with-eli-input-overlay ()
(if sly-mrepl--eli-input-overlay
(move-overlay sly-mrepl--eli-input-overlay
(sly-mrepl--mark) (point-max))
(setq sly-mrepl--eli-input-overlay
(make-overlay (sly-mrepl--mark) (point-max))))
(overlay-put sly-mrepl--eli-input-overlay
'before-string (car sly-mrepl--eli-input))
(overlay-put sly-mrepl--eli-input-overlay
'after-string (cdr sly-mrepl--eli-input)))
(defun sly-mrepl--setup-comint-isearch ()
;; Defeat Emacs bug 19572 in Emacs whereby comint refuses to
;; i-search multi-line history entries. The doc of
;; `isearch-search-fun-function' should explain the need for this
;; lambda madness.
;;
(unless (eq isearch-search-fun-function
'isearch-search-fun-default)
(set (make-local-variable 'isearch-search-fun-function)
#'(lambda ()
#'(lambda (&rest args)
(cl-letf
(((symbol-function
'comint-line-beginning-position)
#'field-beginning))
(apply (comint-history-isearch-search)
args))))))
(sly-mrepl--set-eli-input)
(when sly-mrepl-eli-like-history-navigation
(set (make-local-variable 'isearch-push-state-function)
#'sly-mrepl--isearch-push-state)))
(defun sly-mrepl--isearch-push-state (&rest args)
(apply #'comint-history-isearch-push-state args)
(unless (memq this-command
'(isearch-backward isearch-forward))
(sly-mrepl--surround-with-eli-input-overlay)))
(defun sly-mrepl--teardown-comint-isearch ()
(set (make-local-variable 'isearch-search-fun-function)
'isearch-search-fun-default)
(when (overlayp sly-mrepl--eli-input-overlay)
(delete-overlay sly-mrepl--eli-input-overlay)
(setq sly-mrepl--eli-input-overlay nil))
(sly-mrepl--keep-eli-input-maybe))
;;; Interactive commands
;;;
(defun sly-mrepl-indent-and-complete-symbol (arg)
"Indent the current line, perform symbol completion or show arglist.
Completion performed by `completion-at-point' or
`company-complete'. If there's no symbol at the point, show the
arglist for the most recently enclosed macro or function."
(interactive "P")
(let ((pos (point))
(fn (if (bound-and-true-p company-mode)
'company-complete
'completion-at-point)))
(indent-for-tab-command arg)
(when (= pos (point))
(cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
(funcall fn))
((memq (char-before) '(?\t ?\ ))
(sly-show-arglist))))))
(defun sly-mrepl-return (&optional end-of-input)
"If the input is a whole expression, evaluate it and return the result."
(interactive "P")
(cl-assert (sly-connection))
(cl-assert (process-live-p (sly-mrepl--process)) nil
"No local live process, cannot use this REPL")
(accept-process-output)
(cond ((and
(not sly-mrepl--read-mark)
(sly-mrepl--busy-p))
(sly-message "REPL is busy"))
((and (not sly-mrepl--read-mark)
(or (sly-input-complete-p (sly-mrepl--mark) (point-max))
end-of-input))
(sly-mrepl--send-input-sexp)
(sly-mrepl--catch-up))
(sly-mrepl--read-mark
(unless end-of-input
(goto-char (point-max))
(newline))
(let ((comint-input-filter (lambda (_s) nil)))
(comint-send-input 'no-newline))
(sly-mrepl--catch-up))
(t
(newline-and-indent)
(sly-message "Input not complete"))))
(defun sly-mrepl-previous-input-or-button (n)
(interactive "p")
(if (>= (point) (sly-mrepl--mark))
(progn
(unless (memq last-command
'(sly-mrepl-previous-input-or-button
sly-mrepl-next-input-or-button))
(sly-mrepl--set-eli-input))
(comint-previous-input n)
(sly-mrepl--keep-eli-input-maybe))
(sly-button-backward n)))
(defun sly-mrepl-next-input-or-button (n)
(interactive "p")
(sly-mrepl-previous-input-or-button (- n)))
(put 'sly-mrepl-next-input-or-button 'sly-button-navigation-command t)
(put 'sly-mrepl-previous-input-or-button 'sly-button-navigation-command t)
;;;###autoload
(defun sly-mrepl (&optional display-action)
"Find or create the first useful REPL for the default connection.
If supplied, DISPLAY-ACTION is called on the
buffer. Interactively, DISPLAY-ACTION defaults to using
`switch-to-buffer' unless the intended buffer is already visible
in some window, in which case that window is selected."
(interactive (list (lambda (buf)
(let ((w (get-buffer-window buf)))
(if w (select-window w) (switch-to-buffer buf))))))
(let* ((buffer
(sly-mrepl--find-create (sly-current-connection))))
(when display-action
(funcall display-action buffer))
buffer))
(defun sly-mrepl-on-connection ()
(let* ((inferior-buffer
(and (sly-process) (process-buffer (sly-process))))
(inferior-window
(and inferior-buffer (get-buffer-window inferior-buffer t))))
(let ((sly-mrepl-pop-sylvester
(or (eq sly-mrepl-pop-sylvester 'on-connection)
sly-mrepl-pop-sylvester)))
(sly-mrepl 'pop-to-buffer))
(when inferior-window
(bury-buffer inferior-buffer)
(delete-window inferior-window))
(goto-char (point-max))))
(defun sly-mrepl-new (connection &optional handle)
"Create and setup a new REPL buffer for CONNECTION.
CONNECTION defaults to the current SLY connection. If such a
buffer already exists, or a prefix arg is given, prompt for a
handle to distinguish the new buffer from the existing."
(interactive
;; FIXME: Notice a subtle bug/feature than when calling
;; interactively in a buffer which has a connection, but not the
;; default connection, the new REPL will be for that connection.
(let ((connection (sly-connection)))
(list connection
(if (or (get-buffer (sly-mrepl--buffer-name connection))
current-prefix-arg)
(sly-read-from-minibuffer
"Nickname for this new REPL? ")))))
(let* ((name (sly-mrepl--buffer-name connection handle))
(existing (get-buffer name)))
(when (and handle existing)
(sly-user-error "A REPL with that handle already exists"))
;; Take this oportunity to save any other REPL histories so that
;; the new REPL will see them.
(sly-mrepl--save-all-histories)
(let* ((local (sly-make-channel sly-listener-channel-methods))
(buffer (pop-to-buffer name))
(default-directory (if (file-readable-p default-directory)
default-directory
(expand-file-name "~/"))))
(with-current-buffer buffer
(sly-mrepl-mode)
(when (and (not existing)
(eq sly-mrepl-pop-sylvester t))
(sly-mrepl--insert-note
(concat "\n" (sly-mrepl-random-sylvester) "\n\n")
'sly-mrepl-output-face))
(setq sly-buffer-connection connection)
(start-process (format "sly-pty-%s-%s"
(process-get connection
'sly--net-connect-counter)
(sly-channel.id local))
(current-buffer)
nil)
(set-process-query-on-exit-flag (sly-mrepl--process) nil)
(setq header-line-format
(format "Waiting for REPL creation ack for channel %d..."
(sly-channel.id local)))
(sly-channel-put local 'buffer (current-buffer))
(add-hook 'kill-buffer-hook 'sly-mrepl--teardown nil 'local)
(set (make-local-variable 'sly-mrepl--local-channel) local))
(sly-eval-async
`(slynk-mrepl:create-mrepl ,(sly-channel.id local))
(lambda (result)
(cl-destructuring-bind (remote thread-id) result
(with-current-buffer buffer
(sly-mrepl--read-input-ring)
(setq header-line-format nil)
(setq sly-current-thread thread-id)
(set (make-local-variable 'sly-mrepl--remote-channel) remote)
(unwind-protect
(run-hooks 'sly-mrepl-hook 'sly-mrepl-runonce-hook)
(set-default 'sly-mrepl-runonce-hook nil))))))
buffer)))
(defun sly-mrepl-insert-input (pos)
(interactive (list (if (mouse-event-p last-input-event)
(posn-point (event-end last-input-event))
(point))))
(sly-mrepl--assert-mrepl)
(let* ((pos (if (eq (field-at-pos pos) 'sly-mrepl-input)
pos
(1+ pos)))
(new-input (and
(eq (field-at-pos (1+ pos)) 'sly-mrepl-input)
(field-string-no-properties pos)))
(offset (and new-input
(- (point) (field-beginning pos)))))
(cond (new-input
(goto-char (sly-mrepl--mark))
(delete-region (point) (point-max))
(insert (sly-trim-whitespace new-input))
(goto-char (+ (sly-mrepl--mark) offset)))
(t
(sly-user-error "No input at point")))))
(defun sly-mrepl-guess-package (&optional point interactive)
(interactive (list (point) t))
(let* ((point (or point (point)))
(probe
(previous-single-property-change point
'sly-mrepl--prompt))
(package (and probe
(or (get-text-property probe 'sly-mrepl--prompt)
(let ((probe2
(previous-single-property-change
probe 'sly-mrepl--prompt)))
(and probe2
(get-text-property probe2
'sly-mrepl--prompt)))))))
(when interactive
(sly-message "Guessed package \"%s\"" package))
package))
(define-obsolete-function-alias
'sly-mrepl-sync-package-and-default-directory 'sly-mrepl-sync
"1.0.0-alpha-3")
(defun sly-mrepl-sync (&optional package directory expression)
"Go to the REPL, and set Slynk's PACKAGE and DIRECTORY.
Also yank EXPRESSION into the prompt. Interactively gather
PACKAGE and DIRECTORY these values from the current buffer, if
available. In this scenario EXPRESSION is only set if a C-u
prefix argument is given."
(interactive (list (sly-current-package)
(and buffer-file-name
default-directory)
(and current-prefix-arg
(sly-last-expression))))
(sly-mrepl--with-repl (sly-mrepl--find-create (sly-connection))
(when directory
(cd directory))
(sly-mrepl--eval-for-repl
`(slynk-mrepl:sync-package-and-default-directory
:package-name ,package
:directory ,(and directory
(sly-to-lisp-filename directory)))
:insert-p nil
:before-prompt
#'(lambda (results)
(cl-destructuring-bind (package-2 directory-2) results
(sly-mrepl--insert-note
(cond ((and package directory)
(format "Synched package to %s and directory to %s"
package-2 directory-2))
(directory
(format "Synched directory to %s" directory-2))
(package
(format "Synched package to %s" package-2))
(t
(format "Remaining in package %s and directory %s"
package-2 directory-2))))))
:after-prompt
#'(lambda (_results)
(when expression
(goto-char (point-max))
(let ((saved (point)))
(insert expression)
(when (string-match "\n" expression)
(indent-region saved (point-max)))))))))
(defun sly-mrepl-clear-repl ()
"Clear all this REPL's output history.
Doesn't clear input history."
(interactive)
(sly-mrepl--assert-mrepl)
(sly-mrepl--send `(:clear-repl-history)))
(defun sly-mrepl-clear-recent-output ()
"Clear this REPL's output between current and last prompt."
(interactive)
(sly-mrepl--assert-mrepl)
(cl-loop for search-start =
(set-marker (make-marker)
(1+ (overlay-start sly-mrepl--last-prompt-overlay)))
then pos
for pos = (set-marker
search-start
(previous-single-property-change search-start 'field))
while (and (marker-position pos)
;; FIXME: fragile (1- pos), use narrowing
(not (get-text-property (1- pos) 'sly-mrepl--prompt))
(> pos (point-min)))
when (eq (field-at-pos pos) 'sly-mrepl--output)
do (let ((inhibit-read-only t))
(delete-region (field-beginning pos)
(+
(if (eq ?\n (char-before (field-end pos))) 0 1)
(field-end pos)))
(sly-mrepl--insert-output "; Cleared last output"
'sly-mrepl-note-face))
and return nil)
(sly-message "Cleared last output"))
(defun sly-mrepl-next-prompt ()
"Go to the beginning of the next REPL prompt."
(interactive)
(let ((pos (next-single-char-property-change (line-beginning-position 2)
'sly-mrepl--prompt)))
(goto-char pos))
(end-of-line))
(defun sly-mrepl-previous-prompt ()
"Go to the beginning of the previous REPL prompt."
(interactive)
;; This has two wrinkles around the first prompt: (1) when going to
;; the first prompt it leaves point at column 0 (1) when called from
;; frist prompt goes to beginning of buffer. The correct fix is to
;; patch comint.el's comint-next-prompt and comint-previous-prompt
;; anyway...
(let* ((inhibit-field-text-motion t)
(pos (previous-single-char-property-change (1- (line-beginning-position))
'sly-mrepl--prompt)))
(goto-char pos)
(goto-char (line-beginning-position)))
(end-of-line))
;;; "External" non-interactive functions for plugging into
;;; other parts of SLY
;;;
(defun sly-inspector-copy-part-to-repl (number)
"Evaluate the inspector slot at point via the REPL (to set `*')."
(sly-mrepl--save-and-copy-for-repl
;; FIXME: Using SLYNK:EVAL-FOR-INSPECTOR here repeats logic from
;; sly.el's `sly-eval-for-inspector', but we can't use that here
;; because we're already using `sly-mrepl--save-and-copy-for-repl'.
;; Investigate if these functions could maybe be macros instead.
`(slynk:eval-for-inspector
,sly--this-inspector-name
nil
'slynk:inspector-nth-part-or-lose
,number)
:before (format "Returning inspector slot %s" number)))
(defun sly-db-copy-part-to-repl (frame-id var-id)
"Evaluate the frame var at point via the REPL (to set `*')."
(sly-mrepl--save-and-copy-for-repl
`(slynk-backend:frame-var-value ,frame-id ,var-id)
:repl (sly-mrepl--find-buffer (sly-current-connection) sly-current-thread)
:before (format "Returning var %s of frame %s" var-id frame-id)))
(defun sly-apropos-copy-symbol-to-repl (name _type)
(sly-mrepl--save-and-copy-for-repl
`(common-lisp:identity ',(car (read-from-string name)))
:before (format "Returning symbol %s" name)))
(defun sly-trace-dialog-copy-part-to-repl (id part-id type)
"Eval the Trace Dialog entry under point in the REPL (to set *)"
(sly-mrepl--save-and-copy-for-repl
`(slynk-trace-dialog:trace-part-or-lose ,id ,part-id ,type)
:before (format "Returning part %s (%s) of trace entry %s" part-id type id)))
(defun sly-db-copy-call-to-repl (frame-id spec)
(sly-mrepl--save-and-copy-for-repl
`(slynk-backend:frame-arguments ,frame-id)
:before (format "The actual arguments passed to frame %s" frame-id)
:after #'(lambda (objects)
(sly-mrepl--insert-call spec objects))))
(defun sly-trace-dialog-copy-call-to-repl (trace-id spec)
(sly-mrepl--save-and-copy-for-repl
`(slynk-trace-dialog:trace-arguments-or-lose ,trace-id)
:before (format "The actual arguments passed to trace %s" trace-id)
:after #'(lambda (objects)
(sly-mrepl--insert-call spec objects))))
(defun sly-mrepl-inside-string-or-comment-p ()
(let ((mark (and (process-live-p (sly-mrepl--process))
(sly-mrepl--mark))))
(when (and mark (> (point) mark))
(let ((ppss (parse-partial-sexp mark (point))))
(or (nth 3 ppss) (nth 4 ppss))))))
;;; The comma shortcut
;;;
(defvar sly-mrepl-shortcut-history nil "History for sly-mrepl-shortcut.")
(defun sly-mrepl-reset-shortcut (key-sequence)
"Set `sly-mrepl-shortcut' and reset REPL keymap accordingly."
(interactive "kNew shortcut key sequence? ")
(when (boundp 'sly-mrepl-shortcut)
(define-key sly-mrepl-mode-map sly-mrepl-shortcut nil))
(set-default 'sly-mrepl-shortcut key-sequence)
(define-key sly-mrepl-mode-map key-sequence
'(menu-item "" sly-mrepl-shortcut
:filter (lambda (cmd)
(if (and (eq major-mode 'sly-mrepl-mode)
(sly-mrepl--shortcut-location-p))
cmd)))))
(defcustom sly-mrepl-shortcut (kbd ",")
"Keybinding string used for the REPL shortcut commands.
When setting this variable outside of the Customize interface,
`sly-mrepl-reset-shortcut' must be used."
:group 'sly
:type 'key-sequence
:set (lambda (_sym value)
(sly-mrepl-reset-shortcut value)))
(defun sly-mrepl--shortcut-location-p ()
(or (< (point) (sly-mrepl--mark))
(and (not (let ((state (syntax-ppss)))
(or (nth 3 state) (nth 4 state))))
(or (not (equal sly-mrepl-shortcut ","))
(not (save-excursion
(search-backward "`" (sly-mrepl--mark) 'noerror)))))))
(defvar sly-mrepl-shortcut-alist
;; keep this alist ordered by the key value, in order to make it easier to see
;; the identifying prefixes and keep them short
'(("cd" . sly-mrepl-set-directory)
("clear repl" . sly-mrepl-clear-repl)
("disconnect" . sly-disconnect)
("disconnect all" . sly-disconnect-all)
("in-package" . sly-mrepl-set-package)
("restart lisp" . sly-restart-inferior-lisp)
("quit lisp" . sly-quit-lisp)
("sayoonara" . sly-quit-lisp)
("set directory" . sly-mrepl-set-directory)
("set package" . sly-mrepl-set-package)))
(defun sly-mrepl-set-package ()
(interactive)
(let ((package (sly-read-package-name "New package: ")))
(sly-mrepl--eval-for-repl `(slynk-mrepl:guess-and-set-package ,package))))
(defun sly-mrepl-set-directory ()
(interactive)
(let ((dir (read-directory-name "New directory: "
default-directory nil t)))
;; repeats logic in `sly-cd'.
(sly-mrepl--eval-for-repl
`(slynk:set-default-directory
(slynk-backend:filename-to-pathname
,(sly-to-lisp-filename dir))))
(sly-mrepl--insert-note (format "Setting directory to %s" dir))
(cd dir)))
(advice-add
'sly-cd :around
(lambda (oldfun r)
(interactive (lambda (oldspec)
(if (or (not (eq major-mode 'sly-mrepl-mode))
(sly-y-or-n-p
(substitute-command-keys
"This won't set the REPL's directory (use \
\\[sly-mrepl-set-directory] for that). Proceed?")))
(list (advice-eval-interactive-spec oldspec))
(keyboard-quit))))
(apply oldfun r))
'((name . sly-mrepl--be-aware-of-sly-cd)))
(defun sly-mrepl-shortcut ()
(interactive)
(let* ((string (completing-read "Command: "
(mapcar #'car sly-mrepl-shortcut-alist)
nil 'require-match nil
'sly-mrepl-shortcut-history
(car sly-mrepl-shortcut-history)))
(command (and string
(cdr (assoc string sly-mrepl-shortcut-alist)))))
(call-interactively command)))
;;; Backreference highlighting
;;;
(defvar sly-mrepl--backreference-overlays nil
"List of overlays on top of REPL result buttons.")
(make-variable-buffer-local 'sly-mrepl--backreference-overlays)
(defun sly-mrepl-highlight-results (&optional entry-idx value-idx)
"Highlight REPL results for ENTRY-IDX and VALUE-IDX.
If VALUE-IDX is nil or `all', highlight all results for entry
ENTRY-IDX. If ENTRY-IDX is nil, highlight all results. Returns
a list of result buttons thus highlighted"
(interactive)
(cl-loop
for button in (sly-button-buttons-in (point-min) (point-max))
for e-idx = (car (button-get button 'part-args))
for v-idx = (cadr (button-get button 'part-args))
when (and (button-type-subtype-p (button-type button) 'sly-mrepl-part)
(eq (button-get button 'sly-connection) (sly-current-connection))
(not (button-get button 'sly-mrepl--highlight-overlay))
(and (or (not entry-idx)
(= e-idx entry-idx))
(or (not value-idx)
(eq value-idx 'all)
(= v-idx value-idx))))
collect button and
do (let ((overlay (make-overlay (button-start button) (button-end button))))
(push overlay sly-mrepl--backreference-overlays)
(overlay-put overlay 'before-string
(concat
(propertize
(format "%s:%s"
(car (button-get button 'part-args))
(cadr (button-get button 'part-args)))
'face 'highlight)
" ")))))
(defun sly-mrepl-unhighlight-results ()
"Unhighlight all repl results"
(interactive)
(mapc #'delete-overlay sly-mrepl--backreference-overlays)
(setq sly-mrepl--backreference-overlays nil))
(defvar sly-mrepl--backreference-overlay nil)
(defvar sly-mrepl--backreference-prefix "#v")
(defun sly-mrepl--highlight-backreferences-maybe ()
"Intended to be placed in `post-command-hook'."
(sly-mrepl-unhighlight-results)
(when sly-mrepl--backreference-overlay
(delete-overlay sly-mrepl--backreference-overlay))
(let* ((match (save-excursion
(sly-beginning-of-symbol)
(looking-at
(format "%s\\([[:digit:]]+\\)?\\(:\\([[:digit:]]+\\)\\|:\\)?"
sly-mrepl--backreference-prefix))))
(m0 (and match (match-string 0)))
(m1 (and m0 (match-string 1)))
(m2 (and m1 (match-string 2)))
(m3 (and m2 (match-string 3)))
(entry-idx (and m1 (string-to-number m1)))
(value-idx (and match
(or (and m3 (string-to-number m3))
(and (not m2)
'all)))))
(if (null match)
(set (make-local-variable 'sly-autodoc-preamble) nil)
(let ((buttons (sly-mrepl-highlight-results entry-idx value-idx))
(overlay
(or sly-mrepl--backreference-overlay
(set (make-local-variable 'sly-mrepl--backreference-overlay)
(make-overlay 0 0))))
(message-log-max nil)
(message-text))
(move-overlay sly-mrepl--backreference-overlay
(match-beginning 0) (match-end 0))
(cond
((null buttons)
(overlay-put overlay 'face 'font-lock-warning-face)
(setq message-text (format "No history references for backreference `%s'" m0)))
((and buttons
entry-idx
value-idx)
(overlay-put overlay 'face 'sly-action-face)
(let* ((prefix (if (numberp value-idx)
(format "Matched history value %s of entry %s: "
value-idx
entry-idx)
(format "Matched history entry %s%s: "
entry-idx
(if (cl-rest buttons)
(format " (%s values)" (length buttons))
""))))
(hint (propertize
(truncate-string-to-width
(replace-regexp-in-string "\n" " "
(button-label
(cl-first buttons)))
(- (window-width (minibuffer-window))
(length prefix) 10)
nil
nil
"...")
'face
'sly-action-face)))
(setq message-text (format "%s" (format "%s%s" prefix hint)))))
(buttons
(setq message-text (format "Ambiguous backreference `%s', %s values possible"
m0 (length buttons)))
(overlay-put overlay 'face 'font-lock-warning-face))
(t
(overlay-put overlay 'face 'font-lock-warning-face)
(setq message-text (format "Invalid backreference `%s'" m0))))
(sly-message "%s" message-text)
(set (make-local-variable 'sly-autodoc-preamble) message-text)))))
;;;; Menu
;;;;
(easy-menu-define sly-mrepl--shortcut-menu nil
"Menu for accessing the mREPL anywhere in sly."
(let* ((C '(sly-connected-p)))
`("mREPL"
["Go to default REPL" sly-mrepl ,C]
["New REPL" sly-mrepl-new ,C]
["Sync Package & Directory" sly-mrepl-sync
(and sly-editing-mode ,C)])))
(easy-menu-add-item sly-menu nil sly-mrepl--shortcut-menu "Documentation")
(easy-menu-define sly-mrepl--menu sly-mrepl-mode-map
"Menu for SLY's MREPL"
(let* ((C '(sly-connected-p)))
`("SLY-mREPL"
[ " Complete symbol at point " sly-mrepl-indent-and-complete-symbol ,C ]
[ " Interrupt " sly-interrupt ,C ]
[ " Isearch history backward " isearch-backward ,C]
"----"
[ " Clear REPL" sly-mrepl-clear-repl ,C ]
[ " Clear last output" sly-mrepl-clear-recent-output ,C ])))
(defvar sly-mrepl--debug-overlays nil)
(defun sly-mrepl--debug (&rest ignored)
(interactive)
(mapc #'delete-overlay sly-mrepl--debug-overlays)
(let ((overlay (make-overlay sly-mrepl--output-mark
(sly-mrepl--mark)))
(color (if (< sly-mrepl--output-mark (sly-mrepl--mark))
"green"
"orange"))
(marker-color (if (= sly-mrepl--output-mark (sly-mrepl--mark))
"red"
"purple")))
(overlay-put overlay
'face `(:background ,color))
(overlay-put overlay
'after-string (propertize "F" 'face
`(:background ,marker-color)))
(push overlay sly-mrepl--debug-overlays)))
(defun sly-mrepl--turn-on-debug ()
(interactive)
(add-hook 'after-change-functions 'sly-mrepl--debug nil 'local)
(add-hook 'post-command-hook 'sly-mrepl--debug nil 'local))
(defun sly-mrepl--turn-off-debug ()
(interactive)
(remove-hook 'after-change-functions 'sly-mrepl--debug 'local)
(remove-hook 'post-command-hook 'sly-mrepl--debug 'local))
;;; A hack for Emacs Bug#32014 (Sly gh#165)
;;;
(when (version<= "26.1" emacs-version)
(advice-add
#'lisp-indent-line
:around
(lambda (&rest args)
(let ((beg (save-excursion (progn (beginning-of-line) (point)))))
(cl-letf (((symbol-function #'indent-line-to)
(lambda (indent)
(let ((shift-amt (- indent (current-column))))
(if (zerop shift-amt)
nil
(delete-region beg (point))
(indent-to indent))))))
;; call original
(apply args))))
'((name . sly-workaround-for-emacs-bug-32014))))
;;; Sylvesters
;;;
(defvar sly-mrepl--sylvesters
(with-temp-buffer
(insert-file-contents-literally
(expand-file-name "sylvesters.txt"
(file-name-directory load-file-name)))
(cl-loop while (< (point) (point-max))
for start = (point)
do (search-forward "\n\n" nil 'noerror)
collect (buffer-substring-no-properties start (- (point) 2)))))
(defun sly-mrepl-random-sylvester ()
(let* ((sylvester (nth (random (length sly-mrepl--sylvesters))
sly-mrepl--sylvesters))
(woe (sly-random-words-of-encouragement))
(uncommented
(replace-regexp-in-string "@@@@" woe sylvester)))
uncommented))
(provide 'sly-mrepl)
;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'cl-lib)
(require 'sly-cl-indent "lib/sly-cl-indent")
(define-sly-contrib sly-indentation
"Contrib interfacing `sly-cl-indent' and SLY."
(:slynk-dependencies slynk/indentation)
(:on-load
(setq sly--lisp-indent-current-package-function 'sly-current-package)))
(defun sly-update-system-indentation (symbol indent packages)
(let ((list (gethash symbol sly-common-lisp-system-indentation))
(ok nil))
(if (not list)
(puthash symbol (list (cons indent packages))
sly-common-lisp-system-indentation)
(dolist (spec list)
(cond ((equal (car spec) indent)
(dolist (p packages)
(unless (member p (cdr spec))
(push p (cdr spec))))
(setf ok t))
(t
(setf (cdr spec)
(cl-set-difference (cdr spec) packages :test 'equal)))))
(unless ok
(puthash symbol (cons (cons indent packages) list)
sly-common-lisp-system-indentation)))))
(provide 'sly-indentation)
;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'sly-parse "lib/sly-parse")
(require 'font-lock)
(require 'cl-lib)
;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros.
;;; Fontify CHECK-FOO like CHECK-TYPE.
(defvar sly-additional-font-lock-keywords
'(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)
("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)))
;;;; Specially fontify forms suppressed by a reader conditional.
(defcustom sly-highlight-suppressed-forms t
"Display forms disabled by reader conditionals as comments."
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'sly-mode)
(define-sly-contrib sly-fontifying-fu
"Additional fontification tweaks:
Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros.
Fontify CHECK-FOO like CHECK-TYPE."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:on-load
(font-lock-add-keywords
'lisp-mode sly-additional-font-lock-keywords)
(when sly-highlight-suppressed-forms
(sly-activate-font-lock-magic)))
(:on-unload
;; FIXME: remove `sly-search-suppressed-forms', and remove the
;; extend-region hook.
(font-lock-remove-keywords
'lisp-mode sly-additional-font-lock-keywords)))
(defface sly-reader-conditional-face
'((t (:inherit font-lock-comment-face)))
"Face for compiler notes while selected."
:group 'sly-mode-faces)
(defvar sly-search-suppressed-forms-match-data (list nil nil))
(defun sly-search-suppressed-forms-internal (limit)
(when (search-forward-regexp sly-reader-conditionals-regexp limit t)
(let ((start (match-beginning 0)) ; save match data
(state (sly-current-parser-state)))
(if (or (nth 3 state) (nth 4 state)) ; inside string or comment?
(sly-search-suppressed-forms-internal limit)
(let* ((char (char-before))
(expr (read (current-buffer)))
(val (sly-eval-feature-expression expr)))
(when (<= (point) limit)
(if (or (and (eq char ?+) (not val))
(and (eq char ?-) val))
;; If `sly-extend-region-for-font-lock' did not
;; fully extend the region, the assertion below may
;; fail. This should only happen on XEmacs and older
;; versions of GNU Emacs.
(ignore-errors
(forward-sexp) (backward-sexp)
;; Try to suppress as far as possible.
(sly-forward-sexp)
(cl-assert (<= (point) limit))
(let ((md (match-data nil sly-search-suppressed-forms-match-data)))
(setf (cl-first md) start)
(setf (cl-second md) (point))
(set-match-data md)
t))
(sly-search-suppressed-forms-internal limit))))))))
(defun sly-search-suppressed-forms (limit)
"Find reader conditionalized forms where the test is false."
(when (and sly-highlight-suppressed-forms
(sly-connected-p))
(let ((result 'retry))
(while (and (eq result 'retry) (<= (point) limit))
(condition-case condition
(setq result (sly-search-suppressed-forms-internal limit))
(end-of-file ; e.g. #+(
(setq result nil))
;; We found a reader conditional we couldn't process for
;; some reason; however, there may still be other reader
;; conditionals before `limit'.
(invalid-read-syntax ; e.g. #+#.foo
(setq result 'retry))
(scan-error ; e.g. #+nil (foo ...
(setq result 'retry))
(sly-incorrect-feature-expression ; e.g. #+(not foo bar)
(setq result 'retry))
(sly-unknown-feature-expression ; e.g. #+(foo)
(setq result 'retry))
(error
(setq result nil)
(sly-warning
(concat "Caught error during fontification while searching for forms\n"
"that are suppressed by reader-conditionals. The error was: %S.")
condition))))
result)))
(defun sly-search-directly-preceding-reader-conditional ()
"Search for a directly preceding reader conditional. Return its
position, or nil."
;;; We search for a preceding reader conditional. Then we check that
;;; between the reader conditional and the point where we started is
;;; no other intervening sexp, and we check that the reader
;;; conditional is at the same nesting level.
(condition-case nil
(let* ((orig-pt (point))
(reader-conditional-pt
(search-backward-regexp sly-reader-conditionals-regexp
;; We restrict the search to the
;; beginning of the /previous/ defun.
(save-excursion
(beginning-of-defun)
(point))
t)))
(when reader-conditional-pt
(let* ((parser-state
(parse-partial-sexp
(progn (goto-char (+ reader-conditional-pt 2))
(forward-sexp) ; skip feature expr.
(point))
orig-pt))
(paren-depth (car parser-state))
(last-sexp-pt (cl-caddr parser-state)))
(if (and paren-depth
(not (cl-plusp paren-depth)) ; no '(' in between?
(not last-sexp-pt)) ; no complete sexp in between?
reader-conditional-pt
nil))))
(scan-error nil))) ; improper feature expression
;;; We'll push this onto `font-lock-extend-region-functions'. In past,
;;; we didn't do so which made our reader-conditional font-lock magic
;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
;;; worked quite non-deterministic in general.)
;;;
;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
;;;
;;; We make sure that `font-lock-beg' and `font-lock-end' always point
;;; to the beginning or end of a toplevel form. So we never miss a
;;; reader-conditional, or point in mid of one.
(defvar font-lock-beg) ; shoosh compiler
(defvar font-lock-end)
(defun sly-extend-region-for-font-lock ()
(when sly-highlight-suppressed-forms
(condition-case c
(let (changedp)
(cl-multiple-value-setq (changedp font-lock-beg font-lock-end)
(sly-compute-region-for-font-lock font-lock-beg font-lock-end))
changedp)
(error
(sly-warning
(concat "Caught error when trying to extend the region for fontification.\n"
"The error was: %S\n"
"Further: font-lock-beg=%d, font-lock-end=%d.")
c font-lock-beg font-lock-end)))))
(defsubst sly-beginning-of-tlf ()
(let ((pos (syntax-ppss-toplevel-pos (sly-current-parser-state))))
(if pos (goto-char pos))))
(defun sly-compute-region-for-font-lock (orig-beg orig-end)
(let ((beg orig-beg)
(end orig-end))
(goto-char beg)
(sly-beginning-of-tlf)
(cl-assert (not (cl-plusp (nth 0 (sly-current-parser-state)))))
(setq beg (let ((pt (point)))
(cond ((> (- beg pt) 20000) beg)
((sly-search-directly-preceding-reader-conditional))
(t pt))))
(goto-char end)
(while (search-backward-regexp sly-reader-conditionals-regexp beg t)
(setq end (max end (save-excursion
(ignore-errors (sly-forward-reader-conditional))
(point)))))
(cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end)))
(defun sly-activate-font-lock-magic ()
(font-lock-add-keywords
'lisp-mode
`((sly-search-suppressed-forms 0 ,''sly-reader-conditional-face t)))
(add-hook 'lisp-mode-hook
#'(lambda ()
(add-hook 'font-lock-extend-region-functions
'sly-extend-region-for-font-lock t t))))
;;; Compile hotspots
;;;
(sly-byte-compile-hotspots
'(sly-extend-region-for-font-lock
sly-compute-region-for-font-lock
sly-search-directly-preceding-reader-conditional
sly-search-suppressed-forms
sly-beginning-of-tlf))
(provide 'sly-fontifying-fu)
;; -*- lexical-binding: t; -*-
(require 'sly)
(define-sly-contrib sly-fancy
"Make SLY fancy."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:sly-dependencies sly-mrepl
sly-autodoc
sly-fancy-inspector
sly-fancy-trace
sly-scratch
sly-package-fu
sly-fontifying-fu
sly-trace-dialog
;; sly-profiler ;; not ready for prime-time yet
sly-stickers
sly-indentation
sly-tramp))
(provide 'sly-fancy)
;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'sly-parse "lib/sly-parse")
(define-sly-contrib sly-fancy-trace
"Enhanced version of sly-trace capable of tracing local functions,
methods, setf functions, and other entities supported by specific
slynk:slynk-toggle-trace backends. Invoke via C-u C-t."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL"))
(defun sly-trace-query (spec)
"Ask the user which function to trace; SPEC is the default.
The result is a string."
(cond ((null spec)
(sly-read-from-minibuffer "(Un)trace: "))
((stringp spec)
(sly-read-from-minibuffer "(Un)trace: " spec))
((symbolp spec) ; `sly-extract-context' can return symbols.
(sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
(t
(sly-dcase spec
((setf n)
(sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:defun n)
(sly-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
((:defgeneric n)
(let* ((name (prin1-to-string n))
(answer (sly-read-from-minibuffer "(Un)trace: " name)))
(cond ((and (string= name answer)
(y-or-n-p (concat "(Un)trace also all "
"methods implementing "
name "? ")))
(prin1-to-string `(:defgeneric ,n)))
(t
answer))))
((:defmethod &rest _)
(sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:call caller callee)
(let* ((callerstr (prin1-to-string caller))
(calleestr (prin1-to-string callee))
(answer (sly-read-from-minibuffer "(Un)trace: "
calleestr)))
(cond ((and (string= calleestr answer)
(y-or-n-p (concat "(Un)trace only when " calleestr
" is called by " callerstr "? ")))
(prin1-to-string `(:call ,caller ,callee)))
(t
answer))))
(((:labels :flet) &rest _)
(sly-read-from-minibuffer "(Un)trace local function: "
(prin1-to-string spec)))
(t (error "Don't know how to trace the spec %S" spec))))))
(defun sly-toggle-fancy-trace (&optional using-context-p)
"Toggle trace."
(interactive "P")
(let* ((spec (if using-context-p
(sly-extract-context)
(sly-symbol-at-point)))
(spec (sly-trace-query spec)))
(sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec)))))
;; override sly-toggle-trace-fdefinition
(define-key sly-prefix-map "\C-t" 'sly-toggle-fancy-trace)
(provide 'sly-fancy-trace)
;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'sly-parse "lib/sly-parse")
(define-sly-contrib sly-fancy-inspector
"Fancy inspector for CLOS objects."
(:authors "Marco Baringer <mb@bese.it> and others")
(:license "GPL")
(:slynk-dependencies slynk/fancy-inspector))
(defun sly-inspect-definition ()
"Inspect definition at point"
(interactive)
(sly-inspect (sly-definition-at-point)))
(defun sly-disassemble-definition ()
"Disassemble definition at point"
(interactive)
(sly-eval-describe `(slynk:disassemble-form
,(sly-definition-at-point t))))
(provide 'sly-fancy-inspector)
;;; -*-lexical-binding:t-*-
;;; (require 'sly)
(require 'eldoc)
(require 'cl-lib)
(require 'sly-parse "lib/sly-parse")
(define-sly-contrib sly-autodoc
"Show fancy arglist in echo area."
(:license "GPL")
(:authors "Luke Gorrie <luke@bluetail.com>"
"Lawrence Mitchell <wence@gmx.li>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:slynk-dependencies slynk/arglists)
(:on-load (add-hook 'sly-editing-mode-hook 'sly-autodoc-mode)
(add-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode)
(add-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode))
(:on-unload (remove-hook 'sly-editing-mode-hook 'sly-autodoc-mode)
(remove-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode)
(remove-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode)))
(defcustom sly-autodoc-accuracy-depth 10
"Number of paren levels that autodoc takes into account for
context-sensitive arglist display (local functions. etc)"
:type 'integer
:group 'sly-ui)
(defun sly-arglist (name)
"Show the argument list for NAME."
(interactive (list (sly-read-symbol-name "Arglist of: " t)))
(let ((arglist (sly-autodoc--retrieve-arglist name)))
(if (eq arglist :not-available)
(error "Arglist not available")
(message "%s" (sly-autodoc--fontify arglist)))))
(defun sly-autodoc--retrieve-arglist (name)
(let ((name (cl-etypecase name
(string name)
(symbol (symbol-name name)))))
(car (sly-eval `(slynk:autodoc '(,name ,sly-cursor-marker))))))
(defun sly-autodoc-manually ()
"Like autodoc information forcing multiline display."
(interactive)
(let ((doc (sly-autodoc t)))
(cond (doc (eldoc-message (format "%s" doc)))
(t (eldoc-message nil)))))
;; Must call eldoc-add-command otherwise (eldoc-display-message-p)
;; returns nil and eldoc clears the echo area instead.
(eldoc-add-command 'sly-autodoc-manually)
(defun sly-autodoc-space (n)
"Like `sly-space' but nicer."
(interactive "p")
(self-insert-command n)
(let ((doc (sly-autodoc)))
(when doc
(eldoc-message (format "%s" doc)))))
(eldoc-add-command 'sly-autodoc-space)
;;;; Autodoc cache
(defvar sly-autodoc--cache-last-context nil)
(defvar sly-autodoc--cache-last-autodoc nil)
;;;; Formatting autodoc
(defsubst sly-autodoc--canonicalize-whitespace (string)
(replace-regexp-in-string "[ \n\t]+" " " string))
(defvar sly-autodoc-preamble nil)
(defun sly-autodoc--format (doc multilinep)
(let* ((strings (delete nil
(list sly-autodoc-preamble
(and doc
(sly-autodoc--fontify doc)))))
(message (and strings (mapconcat #'identity strings "\n"))))
(when message
(cond (multilinep message)
(t (sly-oneliner (sly-autodoc--canonicalize-whitespace message)))))))
(defun sly-autodoc--fontify (string)
"Fontify STRING as `font-lock-mode' does in Lisp mode."
(with-current-buffer (get-buffer-create (sly-buffer-name :fontify :hidden t))
(erase-buffer)
(unless (eq major-mode 'lisp-mode)
;; Just calling (lisp-mode) will turn sly-mode on in that buffer,
;; which may interfere with this function
(setq major-mode 'lisp-mode)
(lisp-mode-variables t))
(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))
(sly-insert-propertized '(face eldoc-highlight-function-argument)
highlight)))
(buffer-substring (point-min) (point-max))))
;;;; Autodocs (automatic context-sensitive help)
(defun sly-autodoc (&optional force-multiline)
"Returns the cached arglist information as string, or nil.
If it's not in the cache, the cache will be updated asynchronously."
(interactive "P")
(save-excursion
(save-match-data
;; See github#385 and
;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=45117
(let* ((inhibit-quit t)
(context
(cons
(sly-current-connection)
(sly-autodoc--parse-context))))
(when (car context)
(let* ((cached (and (equal context sly-autodoc--cache-last-context)
sly-autodoc--cache-last-autodoc))
(multilinep (or force-multiline
eldoc-echo-area-use-multiline-p)))
(cond (cached (sly-autodoc--format cached multilinep))
(t
(when (sly-background-activities-enabled-p)
(sly-autodoc--async context multilinep))
nil))))))))
;; Return the context around point that can be passed to
;; slynk:autodoc. nil is returned if nothing reasonable could be
;; found.
(defun sly-autodoc--parse-context ()
(and (not (sly-inside-string-or-comment-p))
(sly-parse-form-upto-point sly-autodoc-accuracy-depth)))
(defun sly-autodoc--async (context multilinep)
(sly-eval-async
`(slynk:autodoc ',(cdr context) ;; FIXME: misuse of quote
:print-right-margin ,(window-width (minibuffer-window)))
(sly-curry #'sly-autodoc--async% context multilinep)))
(defun sly-autodoc--async% (context multilinep doc)
(cl-destructuring-bind (doc &optional cache-p) doc
(unless (eq doc :not-available)
(when cache-p
(setq sly-autodoc--cache-last-context context)
(setq sly-autodoc--cache-last-autodoc doc))
;; Now that we've got our information,
;; get it to the user ASAP.
(when (eldoc-display-message-p)
(eldoc-message (format "%s" (sly-autodoc--format doc multilinep)))))))
;;; Minor mode definition
(defvar sly-autodoc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c C-d A") 'sly-autodoc)
map))
(define-minor-mode sly-autodoc-mode
"Toggle echo area display of Lisp objects at point."
nil nil nil
(cond (sly-autodoc-mode
(set (make-local-variable 'eldoc-documentation-function) 'sly-autodoc)
(set (make-local-variable 'eldoc-minor-mode-string) "")
(eldoc-mode sly-autodoc-mode))
(t
(eldoc-mode -1)
(set (make-local-variable 'eldoc-documentation-function) nil)
(set (make-local-variable 'eldoc-minor-mode-string) " ElDoc"))))
(provide 'sly-autodoc)
;;; org-mind-map.el --- Creates a directed graph from org-mode files
;; Author: Ted Wiles <theodore.wiles@gmail.com>
;; Keywords: orgmode, extensions, graphviz, dot
;; Version: 0.4
;; URL: https://github.com/theodorewiles/org-mind-map
;; Package-Requires: ((emacs "24") (dash "1.8.0") (org "8.2.10"))
;; This file is NOT part of GNU Emacs.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file LICENSE. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This package takes an org-mode tree and converts it into a
;; file that can be read into graphviz in order to visually show the
;; tree as a directed graph. Mail to <theodore.wiles@gmail.com> to discuss
;; features and additions. All suggestions are more than welcome.
;;; Commands:
;;
;; Below is a complete list of commands:
;;
;; `org-mind-map-write'
;; Create a digraph based on all org trees in the current buffer.
;; Keybinding: M-x org-mind-map-write
;; `org-mind-map-write-current-branch'
;; Create a directed graph output based on just the current org tree branch.
;; Keybinding: M-x org-mind-map-write-current-branch
;; `org-mind-map-write-current-tree'
;; Create a directed graph output based on the whole current org tree.
;; Keybinding: M-x org-mind-map-write-current-tree
;;
;;; Customizable Options:
;;
;; Below is a list of customizable options:
;;
;; `org-mind-map-wrap-line-length'
;; Line length within graphviz nodes.
;; default = 30
;; `org-mind-map-wrap-legend-line-length'
;; Line length of the graphviz legend.
;; default = 45
;; `org-mind-map-unflatten-command'
;; Shell executable command for running the UNFLATTEN command.
;; default = "unflatten -l3"
;; `org-mind-map-dot-command'
;; Shell executable command for running the DOT command.
;; default = "dot"
;; `org-mind-map-dot-output'
;; Format of the DOT output. Defaults to PDF.
;; default = "pdf"
;; `org-mind-map-engine'
;; Sets the layout engine used in your graphs.
;; default = "dot"
;; `org-mind-map-default-node-attribs'
;; Alist of default node attributes and values.
;; default = '(("shape" . "plaintext"))
;; `org-mind-map-default-edge-attribs'
;; Alist of default edge attributes and values.
;; default = nil
;; `org-mind-map-default-graph-attribs'
;; Alist of default graph attributes and values.
;; default = '(("autosize" . "false") ("size" . "9,12") ("resolution" . "100") ...))
;; `org-mind-map-node-formats'
;; Assoc list of (NAME . FN) pairs where NAME is a value for the :OMM-NODE-FMT property
;; See also `org-mind-map-make-node-fn'
;; default = nil
;; `org-mind-map-edge-formats'
;; Assoc list of (NAME . FN) pairs where NAME is a value for the :OMM-EDGE-FMT property
;; See also `org-mind-map-make-edge-fn'
;; default = nil
;; `org-mind-map-edge-format-default'
;; Default format string for graph edges, e.g. "[style=dotted]".
;; default = ""
;; `org-mind-map-reserved-colors'
;; List of colors that will not be used for coloring tags.
;; default = nil
;; `org-mind-map-tag-colors'
;; An alist of (TAG . COLOR) pairs for choosing colors for tags.
;; default = nil
;; `org-mind-map-include-text'
;; A boolean indicating whether our not to include paragraph text in body of nodes.
;; default = t
;; `org-mind-map-include-images'
;; A boolean indicating whether our not to include images in body of nodes.
;; default = t
;; The headings of the org-mode file are treated as node text in the resulting tree.
;; Org-mode heading tags are included in the resulting tree as additional cells
;; within the node.
;; The tags are color-coded to be consistent across the tree.
;; Tree interleaving is also possible by naming multiple org-mode headings
;; with the same heading.
;; NOTE: this requires the GRAPHVIZ software. This is installable on
;; windows using cygwin.
;; To install, add this code to your .emacs:
;; (load "org-mind-map.el")
;; If on linux, customize the values of `org-mind-map-unflatten-command'
;; and `org-mind-map-dot-command' to have the values corresponding to
;; the executables in your system.
;; Then, run "M-x org-mind-map-write" to create a graph of all trees in the current buffer,
;; You can customize the style of the graph by adding :OMM-NODE-FMT and :OMM-EDGE-FMT properties
;; to the headlines in the tree.
;; The latest version is available at:
;;
;; https://github.com/theodorewiles/org-mind-map
;;
;;; Code:
(require 'dash)
(require 'org)
(require 'subr-x)
(defconst org-mind-map-version "0.4")
(defgroup org-mind-map nil
"Convert org-mode tree into a graphviz directed graph"
:group 'org)
(defcustom org-mind-map-wrap-line-length 30
"Line length within graphviz nodes."
:type 'integer
:group 'org-mind-map)
(defcustom org-mind-map-wrap-text-length 60
"Line length within graphviz nodes that have longer text."
:type 'integer
:group 'org-mind-map)
(defcustom org-mind-map-wrap-legend-line-length 45
"Line length of the graphviz legend."
:type 'integer
:group 'org-mind-map)
(defcustom org-mind-map-unflatten-command "unflatten -l3"
"Shell executable command for running the UNFLATTEN command."
:type 'string
:group 'org-mind-map)
(defcustom org-mind-map-dot-command "dot"
"Shell executable command for running the DOT command."
:type 'string
:group 'org-mind-map)
(defcustom org-mind-map-dot-output '("pdf" "png" "jpeg" "svg" "eps" "gif" "tiff")
"List of formats for the DOT output file.
If more than one are specified then the user will be prompted to choose one.
To find a list of available formats, on the command line enter: dot -T?"
:type '(repeat (string :tag "File type"))
:group 'org-mind-map)
(defcustom org-mind-map-display nil
"How the results should be displayed:
nil = don't display results
current = display results in current window
window = display results in new window
frame = display results in new frame"
:type '(choice (const :tag "Don't display" nil)
(const :tag "Display in current window" current)
(const :tag "Display in new window" window)
(const :tag "Display in new frame" frame))
:group 'org-mind-map)
(defcustom org-mind-map-engine "dot"
"Sets the layout engine used in your graphs.
See the graphviz user manual for description of these options."
:type '(choice
(const :tag "Directed Graph" "dot")
(const :tag "Undirected Spring Graph" "neato")
(const :tag "Radial Layout" "twopi")
(const :tag "Circular Layout" "circo")
(const :tag "Undirected Spring Force-Directed" "fdp"))
:group 'org-mind-map)
(defcustom org-mind-map-default-node-attribs '(("shape" . "plaintext"))
"Alist of default node attributes and values.
Each item in the alist should be a cons cell of the form (ATTRIB . VALUE)
where ATTRIB and VALUE are strings.
For a list of value attributes, see here: https://graphviz.gitlab.io/_pages/doc/info/attrs.html"
:type '(alist :key-type (string :tag "Attribute") :value-type (string :tag " Value"))
:group 'org-mind-map)
(defcustom org-mind-map-default-edge-attribs nil
"Alist of default edge attributes and values.
Each item in the alist should be a cons cell of the form (ATTRIB . VALUE)
where ATTRIB and VALUE are strings.
For a list of value attributes, see here: https://graphviz.gitlab.io/_pages/doc/info/attrs.html"
:type '(alist :key-type (string :tag "Attribute") :value-type (string :tag " Value"))
:group 'org-mind-map)
(defcustom org-mind-map-default-graph-attribs '(("autosize" . "false")
("size" . "9,12")
("resolution" . "100")
("nodesep" . "0.75")
("overlap" . "false")
("spline" . "true")
("rankdir" . "LR"))
"Alist of default graph attributes and values.
Each item in the alist should be a cons cell of the form (ATTRIB . VALUE)
where ATTRIB and VALUE are strings.
For a list of value attributes, see here: https://graphviz.gitlab.io/_pages/doc/info/attrs.html"
:type '(alist :key-type (string :tag "Attribute") :value-type (string :tag " Value"))
:group 'org-mind-map)
(defcustom org-mind-map-node-formats nil
"Assoc list of (NAME . FN) pairs where NAME is a value for the :OMM-NODE-FMT property
of a node/headline, and FN is a function which outputs a format string to be placed after the
node name (e.g. \"[label='Node1',color='red']\").
The function FN should take the following 5 arguments which can be used to construct the format:
TITLE = the label string for the node
TAGS = a list of org tags for the current node
COLOR = the contents of the OMM-COLOR property for the current node
HM = a hash map of colors
EL = an org element obtained from `org-element-map'
Note: the :OMM-NODE-FMT property is inherited by children of the node/headline where it is defined."
:type '(alist :key-type (string :tag " Name")
:value-type (function :tag "Format function"))
:group 'org-mind-map)
(defcustom org-mind-map-edge-formats nil
"Assoc list of (NAME . FN) pairs where NAME is a value for the :OMM-EDGE-FMT property
of a node/headline, and FN is a function which outputs a format string to be placed after an
edge (e.g. \"[style=dotted]\").
The function FN should take the following 2 arguments which can be used to construct the format:
HM = a hash map of colors
EL = an org element obtained from `org-element-map'
Note: the :OMM-EDGE-FMT property affects edges leading to the node at which it is defined, and
is inherited by children of that node/headline."
:type '(alist :key-type (string :tag " Name")
:value-type (function :tag "Format function"))
:group 'org-mind-map)
(defcustom org-mind-map-edge-format-default ""
"Default format string for graph edges, e.g. \"[style=dotted]\"."
:type 'string
:group 'org-mind-map)
(defcustom org-mind-map-reserved-colors nil
"List of colors that will not be used for coloring tags.
These colors will be excluded when random tag colors are chosen by `org-mind-map-rgb'
so that you can use them for other things.
Each color should be in hexadecimal form, e.g: \"#e3cfbc\", where the consecutive pairs
of hexdigits indicate levels of red, green and blue respectively.
It is not necessary to include any colors with levels below 7d, as these are not used
for creating random tag colors."
:type '(repeat string)
:group 'org-mind-map)
(defcustom org-mind-map-tag-colors nil
"An alist of (TAG . COLOR) pairs for choosing colors for tags.
Any tags not listed here will be colored with randomly selected colors that dont
clash with those in `org-mind-map-reserved-colors'.
Each color should be in hexadecimal form, e.g: \"#e3cfbc\", where the consecutive pairs
of hexdigits indicate levels of red, green and blue respectively.
Note: you can also set tag colors by altering the hashmap passed as an argument to functions
defined in `org-mind-map-node-formats'."
:type '(alist :key-type (string :tag " Tag") :value-type (string :tag "Color"))
:group 'org-mind-map)
(defcustom org-mind-map-include-text t
"A boolean indicating whether our not to include paragraph text in body of nodes.
default = t"
:type 'boolean
:group 'org-mind-map
)
(defcustom org-mind-map-include-images t
"A boolean indicating whether our not to include paragraph text in body of nodes.
default = t"
:type 'boolean
:group 'org-mind-map
)
(defun org-mind-map-do-wrap (words width)
"Create lines of maximum width WIDTH (in characters) from word list WORDS."
(let (lines line)
(while words
(setq line (pop words))
(while (and words (< (+ (length line) (length (car words))) width))
(setq line (concat line " " (pop words))))
(setq lines (push line lines)))
(nreverse lines)))
(defun org-mind-map-wrap (s l)
(let* ((s2 (org-mind-map-do-wrap (split-string s " ") l)))
(mapconcat 'identity s2 "<br></br>")))
(defun org-mind-map-wrap-lines (s)
"Wraps a string S so that it can never be more than ORG-MIND-MAP-WRAP-LINE-LENGTH characters long."
(org-mind-map-wrap s org-mind-map-wrap-line-length))
(defun org-mind-map-wrap-text (s)
"Wraps a string S so that it can never be more than ORG-MIND-MAP-WRAP-TEXT-LENGTH characters long."
(org-mind-map-wrap s org-mind-map-wrap-text-length))
(defun org-mind-map-wrap-legend-lines (s)
"Wraps a string S so that it can never be more than ORG-MIND-MAP-WRAP-LEGEND-LINE-LENGTH characters long."
(let* ((s2 (org-mind-map-do-wrap (split-string s " ") org-mind-map-wrap-legend-line-length)))
(mapconcat 'identity s2 "<br></br>")))
(defun org-mind-map-dot-node-name (s)
"Make string S formatted to be usable within dot node names."
(concat "\""
(replace-regexp-in-string
"</?\\(table\\|tr\\|td\\)[^<>]*>" ""
(replace-regexp-in-string "label=\\(\"[^\"]+\"\\|[^,]+\\).*" "\\1" s))
"\""))
(defun org-mind-map-add-color (hm tag &optional colspan)
"Create data element containing TAG with associated color found in hashmap HM."
(let* ((color (gethash tag hm)))
(concat "<td"
(if colspan (concat " colspan=\"" (int-to-string colspan) "\""))
(if color (concat " bgcolor=\"" color "\"")) ">" tag "</td>")))
(defun org-mind-map-write-tags-default (title tags color hm el &optional content images)
"Default function for writing nodes.
Label node with TITLE and background COLOR, and write TAGS (a list of tag names)
into boxes underneath, using associated colors in hashmap HM.
The EL argument is not used, but is needed for compatibility."
(concat "[label=<<table>"
(if (> (length tags) 0)
(concat "<tr><td colspan=\"" (int-to-string (length tags)) "\" ")
"<tr><td")
(if color (concat " bgcolor=\"" color "\" "))
">" title "</td></tr>"
(if (> (length tags) 0)
(concat
"<tr>" (mapconcat (-partial 'org-mind-map-add-color hm) tags "") "</tr>"))
(if (> (length content) 0)
(concat
"<tr><td BALIGN=\"LEFT\" ALIGN=\"LEFT\">" content "</td></tr>")
)
(if (> (length images) 0)
images ""
)
"</table>>];"))
(defun org-mind-map-get-property (prop el &optional inheritp)
"Get property PROP from an org element EL, using inheritance if INHERITP is non-nil.
PROP can be either the property symbol (beginning with :), or the name of the property (with or without :).
If there is a column summary value for the property that has recently be calculated it will be used."
(let* ((node el)
(propstr (if (stringp prop)
(upcase (if (string-match "^:" prop)
(substring prop 1)
prop))
(substring (symbol-name prop) 1)))
(prop (if (stringp prop) (intern (concat ":" propstr)) prop))
(val (or (cdr (cl-find propstr (get-text-property
(org-element-property :begin el)
'org-summaries)
:test (lambda (x y) (equal (caar y) x))))
(org-element-property prop el))))
(while (and inheritp
(not val)
(not (eq (org-element-type node) 'org-data)))
(setq node (org-element-property :parent node)
val (org-element-property prop node)))
val))
(defun org-mind-map-narrow-to-heading-content (b)
"Narrow to the region until the next headline, if applicable"
(let* ((new-end
(org-element-map (org-element-parse-buffer 'object 'true)
'headline
(lambda (x)
(if (not
(= (org-element-property :begin x) b))
b nil))
nil 'true)))
(if new-end
(progn
(widen)
(narrow-to-region b new-end)))))
(defun org-mind-map-write-tags (hm el &optional edgep)
"Use HM as the hash-map of colors and takes an element EL and extracts the title and tags.
Then, formats the titles and tags so as to be usable within DOT's graphviz language."
(let* ((ts (org-element-property :title el))
(wrapped-title (org-mind-map-wrap-lines (if (listp ts) (first ts) ts)))
(title (replace-regexp-in-string "&" "&" wrapped-title nil t))
(color (org-element-property :OMM-COLOR el))
(tags (org-element-property :tags el))
(fmt (org-mind-map-get-property (if edgep :OMM-EDGE-FMT :OMM-NODE-FMT) el))
(b (org-element-property :begin el))
(e (org-element-property :end el))
(images
(if org-mind-map-include-images
(save-restriction
(narrow-to-region b e)
(org-mind-map-narrow-to-heading-content b)
(mapconcat 'identity
(org-element-map (org-element-parse-buffer 'object 'true)
'(link)
(lambda (x)
(message "Inline image: %s" (org-export-inline-image-p x))
(if (org-export-inline-image-p x)
(concat
"<tr><td fixedsize='TRUE' height='100' width='100'>" "<IMG src='"
(org-element-property :path x)
"'/>"
"</td></tr>")
"")))
""))))
(content
(if org-mind-map-include-text
(save-restriction
(narrow-to-region b e)
(org-mind-map-narrow-to-heading-content b)
(mapconcat 'identity
(org-element-map (org-element-parse-buffer 'object 'true)
'(paragraph)
(lambda (x)
(org-mind-map-wrap-text
(string-trim
(substring-no-properties
(car (org-element-contents x)))))))
"<br></br><br></br>"))
nil))
)
(if edgep (funcall (or (cdr (assoc fmt org-mind-map-edge-formats))
(lambda (a b) org-mind-map-edge-format-default))
hm el)
(funcall (or (cdr (assoc fmt org-mind-map-node-formats))
'org-mind-map-write-tags-default)
title tags color hm el content images))))
(defun org-mind-map-first-headline (e)
"Figure out the first headline within element E."
(let* ((parent (org-element-property :parent e)))
(if parent
(if (eq (org-element-type parent) 'headline)
parent
(org-mind-map-first-headline parent))
nil)))
(defun org-mind-map-valid-link? (e)
"Is E at a valid link?"
(condition-case ex
(let* ((org-link-search-inhibit-query t)
(type (org-element-property :type e))
(l (org-element-property :path e)))
(if (string= type "fuzzy")
(save-excursion
(org-link-search l) t)
nil))
('error nil)))
(defun org-mind-map-destination-headline (e)
"Figure out where the link in E is pointing to."
(let* ((l (org-element-property :path e))
(org-link-search-inhibit-query t))
(save-excursion
(org-open-link-from-string (concat "[[" l "]]"))
(org-element-at-point))))
(defun org-mind-map-get-links (hm)
"Make a list of links with the headline they are within and
their destination. Pass hashmap arg HM mapping tags to colors
in order to keep the tag colors consistent across calls."
(org-element-map (org-element-parse-buffer 'object)
'link
(lambda (l)
(if (org-mind-map-valid-link? l)
(let* ((origin
(org-mind-map-write-tags hm
(org-mind-map-first-headline l)))
(h (org-mind-map-destination-headline l))
(destination
(org-mind-map-write-tags hm h)))
(list origin destination))))))
(defun org-mind-map-make-legend (h)
"Make a legend using the hash-map HM."
(let ((res '()))
(maphash (lambda (k v) (push k res)) h)
(if (> (length res) 0)
(concat
"{
Legend [shape=none, margin=0, label=<
<TABLE BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\" CELLPADDING=\"4\">
<TR>
<TD COLSPAN=\"2\"><B>Legend</B></TD>
</TR>"
(mapconcat 'identity
(let* (result)
(maphash
(lambda (name color)
(push (concat "<tr><td>" (org-mind-map-wrap-legend-lines name)
"</td><td bgcolor=\"" color "\"> </td></tr>")
result))
h)
(reverse result))
"")
"</TABLE>>];}"))))
(defun org-mind-map-rgb (&optional exceptions)
"Make a random pastel-like RGB color.
Dont return any of the colors listed in the optional arg EXCEPTIONS."
(let* ((fn (lambda nil
(concat "#"
(format "%x" (+ 125 (random (- 255 125))))
(format "%x" (+ 125 (random (- 255 125))))
(format "%x" (+ 125 (random (- 255 125)))))))
(color (funcall fn)))
(while (member color exceptions)
(setq color (funcall fn)))
color))
(defun org-mind-map-tags (&optional exceptions)
"Return a hash map of tags in the org file mapped to random colors.
Dont return any of the colors listed in the optional arg EXCEPTIONS."
(let* ((hm (make-hash-table :test 'equal)))
(org-element-map (org-element-parse-buffer 'headline) 'headline
(lambda (hl)
(let ((tags (mapcar 'substring-no-properties (org-element-property :tags hl)))
(legend (org-element-property :OMM-LEGEND hl))
(color (org-element-property :OMM-COLOR hl)))
(if legend (puthash legend color hm))
(if tags (mapcar (lambda (x)
(puthash x (--if-let (assoc x org-mind-map-tag-colors)
(cdr it)
(org-mind-map-rgb
(append exceptions
(mapcar 'cdr org-mind-map-tag-colors))))
hm))
tags)))))
hm))
(defun org-mind-map-data (&optional linksp)
"Create graph & tag legend of all directed pairs of headlines for constructing the digraph.
If LINKSP is non-nil include graph edges for org links."
(let* ((hm (org-mind-map-tags org-mind-map-reserved-colors))
(output
(org-element-map (org-element-parse-buffer 'headline) 'headline
(lambda (hl)
(let ((parent (org-element-property :parent hl)))
(and (eq (org-element-type parent) 'headline)
(list (org-mind-map-write-tags hm parent)
(org-mind-map-write-tags hm hl)
(org-mind-map-write-tags hm hl t))))))))
(list (append output (if linksp (org-mind-map-get-links hm))) hm)))
(defun org-mind-map-make-dot (data)
"Create the dot file from DATA."
(let ((table (nth 0 data))
(legend (nth 1 data)))
(concat "digraph structs {\n // DEFAULT OPTIONS\n"
(if org-mind-map-default-graph-attribs
(concat " graph ["
(mapconcat #'(lambda (x) (concat (car x) "=\"" (cdr x) "\""))
org-mind-map-default-graph-attribs ", ")
"];\n"))
(if org-mind-map-default-node-attribs
(concat
" node [" (mapconcat #'(lambda (x) (concat (car x) "=\"" (cdr x) "\""))
org-mind-map-default-node-attribs ", ")
"];\n"))
(if org-mind-map-default-edge-attribs
(concat
" edge [" (mapconcat #'(lambda (x) (concat (car x) "=\"" (cdr x) "\""))
org-mind-map-default-edge-attribs ", ")
"];\n"))
" // NODES\n"
(mapconcat
#'(lambda (x) (concat " " (org-mind-map-dot-node-name x) " " x))
(-distinct (-flatten (mapcar (lambda (x) (list (nth 0 x) (nth 1 x))) table)))
"\n")
"\n // EDGES\n"
(mapconcat #'(lambda (x) (format " %s -> %s;"
(org-mind-map-dot-node-name (nth 0 x))
(org-mind-map-dot-node-name (nth 1 x))
(nth 2 x)))
table "\n")
(org-mind-map-make-legend legend)
"}")))
(defun org-mind-map-command (name outputtype)
"Return the shell script that will create the correct file NAME of type OUTPUTTYPE.
The output file will be in the same location as the org file."
(concat org-mind-map-unflatten-command " | "
org-mind-map-dot-command " -T"
(shell-quote-argument outputtype) " -K"
(shell-quote-argument org-mind-map-engine) " -o"
(shell-quote-argument (concat name "." outputtype ""))))
(defun org-mind-map-update-message (filename process event)
"Write an update message on the output of running org-mind-map based on PROCESS and EVENT.
Open FILENAME according to value of `org-mind-map-display'."
(let* ((e (with-current-buffer "*org-mind-map-errors*"
(buffer-string))))
(if (string= e "")
(princ (format "Org mind map %s" event))
(princ (format "Org mind map %sErrors: %s" event e)))
(if (string= event "finished\n")
(progn
(cl-case org-mind-map-display
(nil nil)
(current (find-file filename))
(window (find-file-other-window filename))
(frame (switch-to-buffer-other-frame (find-file-noselect filename))))
(cl-case major-mode
(pdf-view-mode (pdf-view-fit-page-to-window))
(doc-view-mode (doc-view-fit-page-to-window)))))))
(defun org-mind-map-write-named (name &optional debug linksp)
"Create a directed graph output based on the org tree in the current buffer, with name NAME.
To customize, see the org-mind-map group.
If DEBUG is non-nil, then print the dot command to the *Messages* buffer,
and print the dotfile to the *Messages* buffer or to a file if DEBUG is a filename.
If LINKSP is non-nil include graph edges for org links."
(let ((dot (org-mind-map-make-dot (org-mind-map-data linksp)))
a (outputtype (if (> (length org-mind-map-dot-output) 1)
(completing-read "Output file type: " org-mind-map-dot-output)
(car org-mind-map-dot-output))))
(if debug
(progn (message (org-mind-map-command name outputtype))
(if (stringp debug)
(with-temp-file debug (insert dot))
(message dot "%s"))))
(if (get-buffer "*org-mind-map-errors*")
(kill-buffer "*org-mind-map-errors*"))
(let* ((p (start-process-shell-command
"org-mind-map-s" "*org-mind-map-errors*"
(org-mind-map-command name outputtype)))
(filename (concat name "." outputtype "")))
(process-send-string p dot)
(process-send-string p "\n")
(process-send-eof p)
(set-process-sentinel p (-partial 'org-mind-map-update-message filename))
filename)))
;;;###autoload
(defun org-mind-map-write-with-prompt nil
"Prompt for an output FILENAME (without extension) to write your output and .dot files."
(let ((filename (read-file-name "What is the file name you would like to save to?")))
(org-mind-map-write-named filename (concat filename ".dot")
(y-or-n-p "Include org links? "))))
(defun org-mind-map-default-filename (treenamep)
"Return a default filename for saving the tree diagram.
If TREENAMEP is non-nil include in the filename the name of the top level header of the tree."
(concat (file-name-sans-extension (buffer-name))
"_diagram"
(if treenamep
(concat "-"
(replace-regexp-in-string " +" "_" (nth 4 (org-heading-components)))))))
;;;###autoload
(defun org-mind-map-write (&optional promptp)
"Create a digraph based on all org trees in the current buffer.
The digraph will be named the same name as the current buffer.
To customize, see the org-mind-map group.
If called with prefix arg (or PROMPTP is non-nil), then call `org-mind-map-write-with-prompt'."
(interactive "P")
(if promptp (org-mind-map-write-with-prompt)
(org-mind-map-write-named (org-mind-map-default-filename nil))))
;;;###autoload
(defun org-mind-map-write-current-branch (&optional promptp)
"Create a directed graph output based on just the current org tree branch.
To customize, see the org-mind-map group.
If called with prefix arg (or PROMPTP is non-nil), then call `org-mind-map-write-with-prompt'."
(interactive "P")
(org-narrow-to-subtree)
(let ((filename (if promptp (org-mind-map-write-with-prompt)
(org-mind-map-write-named (org-mind-map-default-filename t)))))
(widen)
filename))
;;;###autoload
(defun org-mind-map-write-current-tree (&optional promptp)
"Create a directed graph output based on the whole current org tree.
If called with prefix arg (or PROMPTP is non-nil), then call `org-mind-map-write-with-prompt'."
(interactive "P")
(save-restriction
(ignore-errors (outline-up-heading 100))
(org-mind-map-write-current-branch promptp)))
;;;###autoload
(defmacro org-mind-map-make-node-fn (name doc props &optional shape color other)
"Create a function org-mind-map-NAME-node for use with :OMM-NODE-FMT writing node properties.
The created function should be added to `org-mind-map-node-formats' and the associated string
can be used as the :OMM-NODE-FMT for a tree.
Document the function with the DOC arg.
PROPS is a list of either property & format string pairs, or individual property names,
which will be placed in each node, e.g: ((\"PROB\" \"probability=%s\") \"COST\").
For property names with no format string, \"%s=%s\" will be used with the property name and value.
The node shape and background color can be specified with the optional SHAPE and COLOR arguments,
and any other attributes (e.g. \"fontsize=30\") can be specified with the OTHER argument.
Each of these arguments can be either a string or a form which is evaluated for each node,
and returns a string.
Example: (org-mind-map-make-node-fn decisiontree \"Draw decision tree\" (\"COST\" (\"NOTES\" \"Notes: %s\")) nil
(cond ((equal (org-mind-map-get-property :todo-keyword el) \"ACTION\") \"red\")
((equal (org-mind-map-get-property :todo-keyword el) \"STATE\") \"yellow\")
((equal (org-mind-map-get-property :todo-keyword el) \"DECISION\") \"green\")))
You could put this code in your emacs startup file (e.g. ~/.emacs) and then add to `org-mind-map-node-formats'
the pair '(\"decisiontree\" . org-mind-map-decisiontree-node), and use \":OMM-NODE-FMT: decisiontree\" as a
tree property."
`(defun ,(intern (concat "org-mind-map-" (symbol-name name) "-node"))
(title tags color hm el)
,doc
(let* ((numtags (if tags (length tags)))
(colspan (if tags (int-to-string numtags)))
(propstxt
(cl-remove
nil (list ,@(mapcar
(lambda (p)
(cond ((stringp p)
`(--if-let (org-mind-map-get-property ,p el)
(concat ,(upcase p) "=" it)))
((consp p)
`(--if-let (org-mind-map-get-property ,(car p) el)
(format ,(nth 1 p) it)))
(t (error "Invalid props value"))))
props))))
(shape ,shape)
(color (or color ,color))
(other ,other))
(concat "[label=<<table" (if shape " border=\"0\"") ">"
(if numtags (concat "<tr><td colspan=\"" colspan "\" ") "<tr><td")
(if (and color (not shape)) (concat " bgcolor=\"" color "\" "))
">" title "</td></tr>"
(mapconcat (lambda (p)
(concat "<tr>" (org-mind-map-add-color hm p numtags) "</tr>"))
propstxt "")
(if numtags
(concat "<tr>"
(mapconcat (-partial 'org-mind-map-add-color hm) tags "")
"</tr>"))
"</table>>"
(if shape (concat ",shape=" shape (if color (concat ",style=filled,color=" color))))
(if other (concat "," other)) "];"))))
;;;###autoload
(defmacro org-mind-map-make-edge-fn (name doc props &optional style color other)
"Create a function org-mind-map-write-NAME for writing edge properties which can be used for :OMM-EDGE-FMT.
Document the function with the DOC arg.
PROPS is a list of either property & format string pairs, or individual property names,
which will concatenated and used to label the edges, e.g: ((\"PROB\" \"probability=%s\") \"COST\").
For property names with no format string \"%s=%s\" will be used with the property name and value.
The edge style and color can be specified with the optional STYLE and COLOR arguments,
and any other attributes (e.g. \"fontsize=30\") can be specified with the OTHER argument.
Each of these arguments can be either a string or a form which is evaluated for each node,
and returns a string.
Example: (org-mind-map-make-edge-fn decisiontree \"Draw decision tree\" (\"PROB\"))
You could put this code in your emacs startup file (e.g. ~/.emacs) and then add to `org-mind-map-edge-formats'
the pair '(\"decisiontree\" . org-mind-map-decisiontree-edge), and use \":OMM-EDGE-FMT: decisiontree\" as a
tree property."
`(defun ,(intern (concat "org-mind-map-" (symbol-name name) "-edge"))
(hm el)
,doc
(let* ((propstxt (cl-remove
nil (list ,@(mapcar (lambda (p)
(cond ((stringp p)
`(--if-let (org-mind-map-get-property ,p el)
(concat ,(upcase p) "=" it)))
((consp p)
`(--if-let (org-mind-map-get-property ,(car p) el)
(format ,(nth 1 p) it)))
(t (error "Invalid props value"))))
props))))
(style ,style)
(color ,color)
(other ,other))
(concat "[label=\"" (mapconcat 'identity propstxt ",") "\""
(if color (concat ",color=\"" color "\" "))
(if style (concat ",style=\"" style "\""))
(if other (concat "," other)) "]"))))
(defun ox-graphviz-export (&optional async subtreep visible-only body-only info)
"Export the current buffer to a graphviz diagram.
Optional argument ASYNC to asynchronously export.
Optional argument SUBTREEP to export current subtree.
Optional argument VISIBLE-ONLY to only export visible content.
Optional argument BODY-ONLY export only the body.
Optional argument INFO is a plist of options."
(let ((org-mind-map-display nil))
(if subtreep (org-mind-map-write-current-branch)
(org-mind-map-write))))
(defun ox-graphviz-export-and-open (&optional async subtreep visible-only body-only info)
"Export the current buffer to a graphviz diagram, and open the output file.
Optional argument ASYNC to asynchronously export.
Optional argument SUBTREEP to export current subtree.
Optional argument VISIBLE-ONLY to only export visible content.
Optional argument BODY-ONLY export only the body.
Optional argument INFO is a plist of options."
(let ((org-mind-map-display (or org-mind-map-display 'current)))
(if subtreep (org-mind-map-write-current-branch)
(org-mind-map-write))))
(defun ox-graphviz-export-dot (&optional async subtreep visible-only body-only info)
"Export the current buffer to a graphviz diagram, and create and open a dot file.
Optional argument ASYNC to asynchronously export.
Optional argument SUBTREEP to export current subtree.
Optional argument VISIBLE-ONLY to only export visible content.
Optional argument BODY-ONLY export only the body.
Optional argument INFO is a plist of options."
(let ((org-mind-map-display nil)
(filename (org-mind-map-default-filename subtreep))
(linksp (y-or-n-p "Include org links? ")))
(if subtreep (org-narrow-to-subtree))
(org-mind-map-write-named filename (concat filename ".dot") linksp)
(widen)))
(defun ox-graphviz-export-dot-and-open (&optional async subtreep visible-only body-only info)
"Export the current buffer to a graphviz diagram and a dot file, and open the output file.
Optional argument ASYNC to asynchronously export.
Optional argument SUBTREEP to export current subtree.
Optional argument VISIBLE-ONLY to only export visible content.
Optional argument BODY-ONLY export only the body.
Optional argument INFO is a plist of options."
(let ((org-mind-map-display (or org-mind-map-display 'current))
(filename (org-mind-map-default-filename subtreep))
(linksp (y-or-n-p "Include org links? ")))
(if subtreep (org-narrow-to-subtree))
(org-mind-map-write-named filename (concat filename ".dot") linksp)
(widen)))
(defun org-mind-map-export-message nil
"Message string for `org-export-dispatch' buffer."
(if (> (length org-mind-map-dot-output) 1)
"Select output file format"
(concat "As " (car org-mind-map-dot-output) " file")))
(org-export-define-derived-backend 'graphviz 'org
:menu-entry
'(?g "Export to graphviz diagram"
((?f "Create graph" ox-graphviz-export)
(?o "Create graph and open" ox-graphviz-export-and-open)
(?d "Create graph & dot file" ox-graphviz-export-dot)
(?O "Create graph & dot file, and open graph" ox-graphviz-export-dot-and-open))))
;; Add a tool bar icon
;; (define-key org-mode-map [tool-bar org-button]
;; '(menu-item "Write the org-mode file mind map to disk." org-mind-map-write-with-prompt
;; :image (image :type xpm :file "info.xpm")
;; ))
;; Add menu items
;; (define-key org-mode-map [menu-bar Org Diagram]
;; (cons "Graphviz diagram" (make-sparse-keymap "Graphviz diagram")))
;; (define-key org-mode-map [menu-bar Org Diagram all]
;; '("Diagram of whole buffer" . org-mind-map-write))
;; (define-key org-mode-map [menu-bar Org Diagram current]
;; '("Diagram of current tree" . org-mind-map-write-current-tree))
;; (define-key org-mode-map [menu-bar Org Diagram branch]
;; '("Diagram of current branch" . org-mind-map-write-current-branch))
;; (global-set-key (kbd "<f4>") 'org-mind-map-write)
(provide 'org-mind-map)
;;; org-mind-map.el ends here
(define-package "org-mind-map" "20180826.2340" "Creates a directed graph from org-mode files"
'((emacs "24")
(dash "1.8.0")
(org "8.2.10"))
:commit "41df4b2e30455494f1848b4e06cc9208aa9e902b" :authors
'(("Ted Wiles" . "theodore.wiles@gmail.com"))
:maintainers
'(("Ted Wiles" . "theodore.wiles@gmail.com"))
:maintainer
'("Ted Wiles" . "theodore.wiles@gmail.com")
:keywords
'("orgmode" "extensions" "graphviz" "dot")
:url "https://github.com/theodorewiles/org-mind-map")
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; org-mind-map-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from org-mind-map.el
(autoload 'org-mind-map-write-with-prompt "org-mind-map" "\
Prompt for an output FILENAME (without extension) to write your output and .dot files.")
(autoload 'org-mind-map-write "org-mind-map" "\
Create a digraph based on all org trees in the current buffer.
The digraph will be named the same name as the current buffer.
To customize, see the org-mind-map group.
If called with prefix arg (or PROMPTP is non-nil), then call `org-mind-map-write-with-prompt'.
(fn &optional PROMPTP)" t)
(autoload 'org-mind-map-write-current-branch "org-mind-map" "\
Create a directed graph output based on just the current org tree branch.
To customize, see the org-mind-map group.
If called with prefix arg (or PROMPTP is non-nil), then call `org-mind-map-write-with-prompt'.
(fn &optional PROMPTP)" t)
(autoload 'org-mind-map-write-current-tree "org-mind-map" "\
Create a directed graph output based on the whole current org tree.
If called with prefix arg (or PROMPTP is non-nil), then call `org-mind-map-write-with-prompt'.
(fn &optional PROMPTP)" t)
(autoload 'org-mind-map-make-node-fn "org-mind-map" "\
Create a function org-mind-map-NAME-node for use with :OMM-NODE-FMT writing node properties.
The created function should be added to `org-mind-map-node-formats' and the associated string
can be used as the :OMM-NODE-FMT for a tree.
Document the function with the DOC arg.
PROPS is a list of either property & format string pairs, or individual property names,
which will be placed in each node, e.g: ((\"PROB\" \"probability=%s\") \"COST\").
For property names with no format string, \"%s=%s\" will be used with the property name and value.
The node shape and background color can be specified with the optional SHAPE and COLOR arguments,
and any other attributes (e.g. \"fontsize=30\") can be specified with the OTHER argument.
Each of these arguments can be either a string or a form which is evaluated for each node,
and returns a string.
Example: (org-mind-map-make-node-fn decisiontree \"Draw decision tree\" (\"COST\" (\"NOTES\" \"Notes: %s\")) nil
(cond ((equal (org-mind-map-get-property :todo-keyword el) \"ACTION\") \"red\")
((equal (org-mind-map-get-property :todo-keyword el) \"STATE\") \"yellow\")
((equal (org-mind-map-get-property :todo-keyword el) \"DECISION\") \"green\")))
You could put this code in your emacs startup file (e.g. ~/.emacs) and then add to `org-mind-map-node-formats'
the pair '(\"decisiontree\" . org-mind-map-decisiontree-node), and use \":OMM-NODE-FMT: decisiontree\" as a
tree property.
(fn NAME DOC PROPS &optional SHAPE COLOR OTHER)" nil t)
(autoload 'org-mind-map-make-edge-fn "org-mind-map" "\
Create a function org-mind-map-write-NAME for writing edge properties which can be used for :OMM-EDGE-FMT.
Document the function with the DOC arg.
PROPS is a list of either property & format string pairs, or individual property names,
which will concatenated and used to label the edges, e.g: ((\"PROB\" \"probability=%s\") \"COST\").
For property names with no format string \"%s=%s\" will be used with the property name and value.
The edge style and color can be specified with the optional STYLE and COLOR arguments,
and any other attributes (e.g. \"fontsize=30\") can be specified with the OTHER argument.
Each of these arguments can be either a string or a form which is evaluated for each node,
and returns a string.
Example: (org-mind-map-make-edge-fn decisiontree \"Draw decision tree\" (\"PROB\"))
You could put this code in your emacs startup file (e.g. ~/.emacs) and then add to `org-mind-map-edge-formats'
the pair '(\"decisiontree\" . org-mind-map-decisiontree-edge), and use \":OMM-EDGE-FMT: decisiontree\" as a
tree property.
(fn NAME DOC PROPS &optional STYLE COLOR OTHER)" nil t)
(register-definition-prefixes "org-mind-map" '("org-mind-map-" "ox-graphviz-export"))
;;; End of scraped data
(provide 'org-mind-map-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; org-mind-map-autoloads.el ends here
;;; nov.el --- Featureful EPUB reader mode
;; Copyright (C) 2017 Vasilij Schneidermann <mail@vasilij.de>
;; Author: Vasilij Schneidermann <mail@vasilij.de>
;; URL: https://depp.brause.cc/nov.el
;; Version: 0.4.0
;; Package-Requires: ((esxml "0.3.6") (emacs "25.1"))
;; Keywords: hypermedia, multimedia, epub
;; This file is NOT part of GNU Emacs.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; nov.el provides a major mode for reading EPUB documents.
;;
;; Features:
;;
;; - Basic navigation (jump to TOC, previous/next chapter)
;; - Remembering and restoring the last read position
;; - Jump to next chapter when scrolling beyond end
;; - Storing and following Org links to EPUB files
;; - Renders EPUB2 (.ncx) and EPUB3 (<nav>) TOCs
;; - Hyperlinks to internal and external targets
;; - Supports textual and image documents
;; - Info-style history navigation
;; - View source of document files
;; - Metadata display
;; - Image rescaling
;;; Code:
(require 'cl-lib)
(require 'dom)
(require 'esxml-query)
(require 'image)
(require 'seq)
(require 'shr)
(require 'url-parse)
(require 'xml)
(require 'bookmark)
(require 'easymenu)
(require 'imenu)
(require 'org)
(require 'recentf)
(when (not (fboundp 'libxml-parse-xml-region))
(message "Your Emacs wasn't compiled with libxml support"))
;;; EPUB preparation
(defgroup nov nil
"EPUB reader mode"
:group 'multimedia)
(defcustom nov-unzip-program (executable-find "unzip")
"Path to decompression executable."
:type '(file :must-match t)
:group 'nov)
(defcustom nov-unzip-args '("-od" directory filename)
"Arguments to decompression executable.
This variable expects a list of strings, except for `directory'
and `filename' symbols, which will be replaced accordingly when
opening an EPUB file."
:type 'list
:group 'nov)
(defcustom nov-variable-pitch t
"Non-nil if a variable pitch face should be used.
Otherwise the default face is used."
:type 'boolean
:group 'nov)
(defcustom nov-text-width nil
"Width filled text shall occupy.
An integer is interpreted as the number of columns. If nil, use
the full window's width. If t, disable filling completely. Note
that this variable only has an effect in Emacs 25.1 or greater."
:type '(choice (integer :tag "Fixed width in characters")
(const :tag "Use the width of the window" nil)
(const :tag "Disable filling" t))
:group 'nov)
(defcustom nov-render-html-function 'nov-render-html
"Function used to render HTML.
It's called without arguments with a buffer containing HTML and
should change it to contain the rendered version of it."
:type 'function
:group 'nov)
(defcustom nov-pre-html-render-hook nil
"Hook run before `nov-render-html'."
:type 'hook
:group 'nov)
(defcustom nov-post-html-render-hook nil
"Hook run after `nov-render-html'."
:type 'hook
:group 'nov)
(defcustom nov-save-place-file (locate-user-emacs-file "nov-places")
"File name where last reading places are saved to and restored from.
If set to `nil', no saving and restoring is performed."
:type '(choice (file :tag "File name")
(const :tag "Don't save last reading places" nil))
:group 'nov)
(defcustom nov-header-line-format "%t: %c"
"Header line format.
- %t is replaced by the title.
- %c is replaced by the chapter title."
:type 'string
:group 'nov)
(defvar-local nov-file-name nil
"Path to the EPUB file backing this buffer.")
(defvar-local nov-temp-dir nil
"Temporary directory containing the buffer's EPUB files.")
(defvar-local nov-content-file nil
"Path to the EPUB buffer's .opf file.")
(defvar-local nov-epub-version nil
"Version string of the EPUB buffer.")
(defvar-local nov-metadata nil
"Metadata of the EPUB buffer.")
(defvar-local nov-documents nil
"Alist for the EPUB buffer's documents.
Each alist item consists of the identifier and full path.")
(defvar-local nov-documents-index 0
"Index of the currently rendered document in the EPUB buffer.")
(defvar-local nov-toc-id nil
"TOC identifier of the EPUB buffer.")
(defvar-local nov-history nil
"Stack of documents user has visited.
Each element of the stack is a list (NODEINDEX BUFFERPOS).")
(defvar-local nov-history-forward nil
"Stack of documents user has visited with `nov-history-back' command.
Each element of the stack is a list (NODEINDEX BUFFERPOS).")
(defun nov-make-path (directory file)
"Create a path from DIRECTORY and FILE."
(concat (file-name-as-directory directory) file))
(defun nov-directory-files (directory)
"Returns a list of files in DIRECTORY except for . and .."
(seq-remove (lambda (file) (string-match-p "/\\.\\(?:\\.\\)?\\'" file))
(directory-files directory t)))
(defun nov-contains-nested-directory-p (directory)
"Non-nil if DIRECTORY contains exactly one directory."
(let* ((files (nov-directory-files directory))
(file (car files)))
(and (= (length files) 1)
(file-directory-p file)
file)))
(defun nov-unnest-directory (directory child)
"Move contents of CHILD into DIRECTORY, then delete CHILD."
;; FIXME: this will most certainly fail for con/con
(dolist (item (nov-directory-files child))
(rename-file item directory))
(delete-directory child))
(defun nov--fix-permissions (file-or-directory mode)
(let* ((modes (file-modes file-or-directory))
(fixed-mode (file-modes-symbolic-to-number mode modes)))
(set-file-modes file-or-directory fixed-mode)))
(defun nov-fix-permissions (directory)
"Iterate recursively through DIRECTORY to fix its files."
(nov--fix-permissions directory "+rx")
(dolist (file (nov-directory-files directory))
(if (file-directory-p file)
(nov-fix-permissions file)
(nov--fix-permissions file "+r"))))
(defun nov-unzip-epub (directory filename)
"Extract FILENAME into DIRECTORY.
Unnecessary nesting is removed with `nov-unnest-directory'."
(let* ((status (apply #'call-process nov-unzip-program nil "*nov unzip*" t
(mapcar (lambda (arg)
(cond
((eq arg 'directory) directory)
((eq arg 'filename) filename)
(t arg)))
nov-unzip-args)))
child)
(while (setq child (nov-contains-nested-directory-p directory))
(nov-unnest-directory directory child))
;; HACK: unzip preserves file permissions, no matter how silly they
;; are, so ensure files and directories are readable
(nov-fix-permissions directory)
status))
(defun nov-warn (message &optional level)
"Like `display-warning', but for nov-specific warnings.
Displays MESSAGE in a warnings buffer, with LEVEL as severity."
(display-warning 'nov message level))
(defmacro nov-ignore-file-errors (&rest body)
"Like `ignore-errors', but for file errors."
`(condition-case nil (progn ,@body) (file-error nil)))
(defun nov-slurp (filename &optional parse-xml-p)
"Return the contents of FILENAME.
If PARSE-XML-P is t, return the contents as parsed by libxml."
(with-temp-buffer
(insert-file-contents filename)
(if parse-xml-p
(libxml-parse-xml-region (point-min) (point-max))
(buffer-string))))
(defun nov-mimetype-valid-p (directory)
"Return t if DIRECTORY contains a valid EPUB mimetype file."
(nov-ignore-file-errors
(let ((filename (nov-make-path directory "mimetype")))
(equal (nov-slurp filename) "application/epub+zip"))))
(defun nov-container-filename (directory)
"Return the container filename for DIRECTORY."
(let ((filename (nov-make-path directory "META-INF")))
(nov-make-path filename "container.xml")))
(defun nov-container-content-filename (content)
"Return the content filename for CONTENT."
(let* ((query "container>rootfiles>rootfile[media-type='application/oebps-package+xml']")
(node (esxml-query query content)))
(dom-attr node 'full-path)))
(defun nov-container-valid-p (directory)
"Return t if DIRECTORY holds a valid EPUB container."
(let ((filename (nov-container-filename directory)))
(when (and filename (file-exists-p filename))
(let* ((content (nov-slurp filename t))
(content-file (nov-container-content-filename content)))
(when (and content content-file)
(file-exists-p (nov-make-path directory content-file)))))))
(defun nov-epub-valid-p (directory)
"Return t if DIRECTORY makes up a valid EPUB document."
(when (not (nov-mimetype-valid-p directory))
(message "Invalid mimetype"))
(nov-container-valid-p directory))
(defun nov-urldecode (string)
"Return urldecoded version of STRING or nil."
(when string
(url-unhex-string string)))
(defun nov-content-version (content)
"Return the EPUB version for CONTENT."
(let* ((node (esxml-query "package" content))
(version (dom-attr node 'version)))
(when (not version)
(error "Version not specified"))
version))
(defun nov-content-unique-identifier-name (content)
"Return the unique identifier name referenced in CONTENT.
This is used in `nov-content-unique-identifier' to retrieve the
the specific type of unique identifier."
(let* ((node (esxml-query "package[unique-identifier]" content))
(name (dom-attr node 'unique-identifier)))
(when (not name)
(error "Unique identifier name not specified"))
name))
(defun nov-content-unique-identifier (content)
"Return the the unique identifier for CONTENT."
(let* ((name (nov-content-unique-identifier-name content))
(selector (format "package>metadata>identifier[id='%s']"
(esxml-query-css-escape name)))
(id (car (dom-children (esxml-query selector content)))))
(when (not id)
(error "Unique identifier not found by its name: %s" name))
(intern id)))
;; NOTE: unique identifier is queried separately as identifiers can
;; appear more than once and only one of them can be the unique one
(defvar nov-required-metadata-tags '(title language)
"Required metadata tags used for `nov-content-metadata'.")
(defvar nov-optional-metadata-tags
'(contributor coverage creator date description format
publisher relation rights source subject type)
"Optional metadata tags used for `nov-content-metadata'.")
(defun nov-content-metadata (content)
"Return a metadata alist for CONTENT.
Required keys are \\='identifier and everything in
`nov-required-metadata-tags', optional keys are in
`nov-optional-metadata-tags'."
(let* ((identifier (nov-content-unique-identifier content))
(candidates (mapcar (lambda (node)
(cons (dom-tag node) (car (dom-children node))))
(esxml-query-all "package>metadata>*" content)))
(required (mapcar (lambda (tag)
(let ((candidate (cdr (assq tag candidates))))
(when (not candidate)
;; NOTE: this should ideally be a
;; warning, but `warn' is too obtrusive
(message "Required metadatum %s not found" tag))
(cons tag candidate)))
nov-required-metadata-tags))
(optional (mapcar (lambda (tag) (cons tag (cdr (assq tag candidates))))
nov-optional-metadata-tags)))
(append `((identifier . ,identifier)) required optional)))
(defun nov-content-manifest (directory content)
"Extract an alist of manifest files for CONTENT in DIRECTORY.
Each alist item consists of the identifier and full path."
(mapcar (lambda (node)
(let ((id (dom-attr node 'id))
(href (dom-attr node 'href)))
(cons (intern id)
(nov-make-path directory (nov-urldecode href)))))
(esxml-query-all "package>manifest>item" content)))
(defun nov-content-spine (content)
"Extract a list of spine identifiers for CONTENT."
(mapcar (lambda (node) (intern (dom-attr node 'idref)))
(esxml-query-all "package>spine>itemref" content)))
(defun nov--content-epub2-files (content manifest files)
(let* ((node (esxml-query "package>spine[toc]" content))
(id (dom-attr node 'toc)))
(when (not id)
(error "EPUB 2 NCX ID not found"))
(setq nov-toc-id (intern id))
(let ((toc-file (assq nov-toc-id manifest)))
(when (not toc-file)
(error "EPUB 2 NCX file not found"))
(cons toc-file files))))
(defun nov--content-epub3-files (content manifest files)
(let* ((node (esxml-query "package>manifest>item[properties~=nav]" content))
(id (dom-attr node 'id)))
(when (not id)
(error "EPUB 3 <nav> ID not found"))
(setq nov-toc-id (intern id))
(let ((toc-file (assq nov-toc-id manifest)))
(when (not toc-file)
(error "EPUB 3 <nav> file not found"))
(setq files (seq-remove (lambda (item) (eq (car item) nov-toc-id)) files))
(cons toc-file files))))
(defun nov-content-files (directory content)
"Create correctly ordered file alist for CONTENT in DIRECTORY.
Each alist item consists of the identifier and full path."
(let* ((manifest (nov-content-manifest directory content))
(spine (nov-content-spine content))
(files (mapcar (lambda (item) (assq item manifest)) spine)))
(if (version< nov-epub-version "3.0")
(nov--content-epub2-files content manifest files)
(nov--content-epub3-files content manifest files))))
(defun nov--walk-ncx-node (node)
(let ((tag (dom-tag node))
(children (seq-filter (lambda (child) (eq (dom-tag child) 'navPoint))
(dom-children node))))
(cond
((eq tag 'navMap)
(insert "<ol>\n")
(mapc (lambda (node) (nov--walk-ncx-node node)) children)
(insert "</ol>\n"))
((eq tag 'navPoint)
(let* ((label-node (esxml-query "navLabel>text" node))
(content-node (esxml-query "content" node))
(href (nov-urldecode (dom-attr content-node 'src)))
(label (car (dom-children label-node))))
(when (not href)
(error "Navigation point is missing href attribute"))
(let ((link (format "<a href=\"%s\">%s</a>"
(xml-escape-string href)
(xml-escape-string (or label href)))))
(if children
(progn
(insert (format "<li>\n%s\n<ol>\n" link))
(mapc (lambda (node) (nov--walk-ncx-node node))
children)
(insert (format "</ol>\n</li>\n")))
(insert (format "<li>\n%s\n</li>\n" link)))))))))
(defun nov-ncx-to-html (path)
"Convert NCX document at PATH to HTML."
(let ((root (esxml-query "navMap" (nov-slurp path t))))
(with-temp-buffer
(nov--walk-ncx-node root)
(buffer-string))))
;;; UI
(defvar nov-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "g") 'nov-render-document)
(define-key map (kbd "v") 'nov-view-source)
(define-key map (kbd "V") 'nov-view-content-source)
(define-key map (kbd "a") 'nov-reopen-as-archive)
(define-key map (kbd "m") 'nov-display-metadata)
(define-key map (kbd "n") 'nov-next-document)
(define-key map (kbd "]") 'nov-next-document)
(define-key map (kbd "p") 'nov-previous-document)
(define-key map (kbd "[") 'nov-previous-document)
(define-key map (kbd "t") 'nov-goto-toc)
(define-key map (kbd "l") 'nov-history-back)
(define-key map (kbd "r") 'nov-history-forward)
(define-key map (kbd "TAB") 'shr-next-link)
(define-key map (kbd "M-TAB") 'shr-previous-link)
(define-key map (kbd "<backtab>") 'shr-previous-link)
(define-key map (kbd "SPC") 'nov-scroll-up)
(define-key map (kbd "S-SPC") 'nov-scroll-down)
(define-key map (kbd "DEL") 'nov-scroll-down)
(define-key map (kbd "<home>") 'beginning-of-buffer)
(define-key map (kbd "<end>") 'end-of-buffer)
map))
(defvar nov-button-map
(let ((map (copy-keymap nov-mode-map)))
(set-keymap-parent map shr-map)
(define-key map (kbd "RET") 'nov-browse-url)
(define-key map (kbd "<mouse-2>") 'nov-browse-url)
(define-key map (kbd "c") 'nov-copy-url)
map))
(easy-menu-define nov-mode-menu nov-mode-map "Menu for nov-mode"
'("EPUB"
["Next" nov-next-document
:help "Go to the next document"]
["Previous" nov-previous-document
:help "Go to the previous document"]
["Backward" nov-history-back
:help "Go back in the history to the last visited document"]
["Forward" nov-history-forward
:help "Go forward in the history of visited documents"]
["Next Link" shr-next-link
:help "Go to the next link"]
["Previous Link" shr-previous-link
:keys "M-TAB"
:help "Go to the previous link"]
["Table of Contents" nov-goto-toc
:help "Display the table of contents"]
["Redisplay" nov-render-document
:help "Redisplay the document"]
"---"
["View Metadata" nov-display-metadata
:help "View the metadata of the EPUB document"]
["View HTML Source" nov-view-source
:help "View the HTML source of the current document in a new buffer"]
["View OPF Source" nov-view-content-source
:help "View the OPF source of the EPUB document in a new buffer"]
["View as Archive" nov-reopen-as-archive
:help "Reopen the EPUB document as an archive"]))
(defun nov-clean-up ()
"Delete temporary files of the current EPUB buffer."
(when nov-temp-dir
(let ((identifier (cdr (assq 'identifier nov-metadata)))
(index (if (integerp nov-documents-index)
nov-documents-index
0)))
(nov-save-place identifier index (point)))
(nov-ignore-file-errors
(delete-directory nov-temp-dir t))))
(defun nov-clean-up-all ()
"Delete temporary files of all opened EPUB buffers."
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (eq major-mode 'nov-mode)
(nov-clean-up)))))
(defun nov-external-url-p (url)
"Return t if URL refers to an external document."
(and (url-type (url-generic-parse-url url)) t))
(defun nov-url-filename-and-target (url)
"Return a list of URL's filename and target."
(setq url (url-generic-parse-url url))
(mapcar 'nov-urldecode (list (url-filename url) (url-target url))))
;; adapted from `shr-rescale-image'
(defun nov-insert-image (path alt)
"Insert an image for PATH at point, falling back to ALT.
This function honors `shr-max-image-proportion' if possible."
(let ((type (if (or (and (fboundp 'image-transforms-p) (image-transforms-p))
(not (fboundp 'imagemagick-types)))
nil
'imagemagick)))
(if (not (display-graphic-p))
(insert alt)
(seq-let (x1 y1 x2 y2) (window-inside-pixel-edges
(get-buffer-window (current-buffer)))
(let ((image
;; `create-image' errors out for unsupported image types
(ignore-errors
(create-image path type nil
:ascent 100
:max-width (truncate (* shr-max-image-proportion
(- x2 x1)))
:max-height (truncate (* shr-max-image-proportion
(- y2 y1)))))))
(if image
(insert-image image)
(insert alt)))))))
(defvar nov-original-shr-tag-img-function
(symbol-function 'shr-tag-img))
(defun nov-render-img (dom &optional url)
"Custom <img> rendering function for DOM.
Uses `shr-tag-img' for external paths and `nov-insert-image' for
internal ones."
(let ((url (or url (cdr (assq 'src (cadr dom)))))
(alt (or (cdr (assq 'alt (cadr dom))) "")))
(if (nov-external-url-p url)
;; HACK: avoid hanging in an infinite loop when using
;; `cl-letf' to override `shr-tag-img' with a function that
;; might call `shr-tag-img' again
(funcall nov-original-shr-tag-img-function dom url)
(setq url (expand-file-name (nov-urldecode url)))
(nov-insert-image url alt))))
(defun nov-render-title (dom)
"Custom <title> rendering function for DOM.
Sets `header-line-format' according to `nov-header-line-format'."
(setq header-line-format
(and nov-header-line-format
(let ((title (cdr (assq 'title nov-metadata)))
(chapter-title (car (dom-children dom))))
(when (not chapter-title)
(setq chapter-title (propertize "No title" 'face 'italic)))
;; this shouldn't happen for properly authored EPUBs
(when (not title)
(setq title (propertize "No title" 'face 'italic)))
(replace-regexp-in-string
"%" "%%"
(format-spec
nov-header-line-format
`((?c . ,chapter-title)
(?t . ,title))))))))
(defvar nov-shr-rendering-functions
'(;; default function uses url-retrieve and fails on local images
(img . nov-render-img)
;; titles are rendered *inside* the document by default
(title . nov-render-title))
"Alist of rendering functions used with `shr-render-region'.")
(defun nov-render-html ()
"Render HTML in current buffer with shr."
(run-hooks 'nov-pre-html-render-hook)
(let (;; HACK: make buttons use our own commands
(shr-map nov-button-map)
(shr-external-rendering-functions nov-shr-rendering-functions)
(shr-use-fonts nov-variable-pitch))
;; HACK: `shr-external-rendering-functions' doesn't cover
;; every usage of `shr-tag-img'
(cl-letf (((symbol-function 'shr-tag-img) 'nov-render-img))
(if (eq nov-text-width t)
(cl-letf (((symbol-function 'shr-fill-line) 'ignore))
(shr-render-region (point-min) (point-max)))
(let ((shr-width nov-text-width))
(shr-render-region (point-min) (point-max))))))
(run-hooks 'nov-post-html-render-hook))
(defun nov-render-document ()
"Render the document referenced by `nov-documents-index'.
If the document path refers to an image (as determined by
`image-type-file-name-regexps'), an image is inserted, otherwise
the HTML is rendered with `nov-render-html-function'."
(interactive)
(seq-let (id &rest path) (aref nov-documents nov-documents-index)
(let (;; HACK: this should be looked up in the manifest
(imagep (seq-find (lambda (item) (string-match-p (car item) path))
image-type-file-name-regexps))
;; NOTE: allows resolving image references correctly
(default-directory (file-name-directory path))
buffer-read-only)
(erase-buffer)
(cond
(imagep
(nov-insert-image path ""))
((and (version< nov-epub-version "3.0")
(eq id nov-toc-id))
(insert (nov-ncx-to-html path)))
(t
(insert (nov-slurp path))))
(when (not imagep)
(funcall nov-render-html-function))
;; NOTE: this is how doc-view avoids overwriting the file
(set-buffer-modified-p nil)
(goto-char (point-min)))))
(defun nov-find-document (predicate)
"Return first item in `nov-documents' PREDICATE is true for."
(let ((i 0)
done)
(while (and (not done)
(< i (length nov-documents)))
(when (funcall predicate (aref nov-documents i))
(setq done t))
(setq i (1+ i)))
(when done
(1- i))))
(defun nov-goto-document (index)
"Go to the document denoted by INDEX."
(let ((history (cons (list nov-documents-index (point))
nov-history)))
(setq nov-documents-index index)
(nov-render-document)
(setq nov-history history)))
(defun nov-goto-toc ()
"Go to the TOC index and render the TOC document."
(interactive)
(let ((index (nov-find-document (lambda (doc) (eq (car doc) nov-toc-id)))))
(when (not index)
(error "Couldn't locate TOC"))
(nov-goto-document index)))
(defun nov-view-source ()
"View the source of the current document in a new buffer."
(interactive)
(find-file (cdr (aref nov-documents nov-documents-index))))
(defun nov-view-content-source ()
"View the source of the content file in a new buffer."
(interactive)
(find-file nov-content-file))
(defun nov-reopen-as-archive ()
"Reopen the EPUB document using `archive-mode'."
(interactive)
(with-current-buffer (find-file-literally nov-file-name)
(archive-mode)))
(defun nov-display-metadata ()
"View the metadata of the EPUB document in a new buffer."
(interactive)
(let ((buffer "*EPUB metadata*")
(metadata nov-metadata)
(version nov-epub-version))
(with-current-buffer (get-buffer-create buffer)
(special-mode)
(let (buffer-read-only)
(erase-buffer)
(insert (format "EPUB Version: %s\n" version))
(dolist (item metadata)
(seq-let (key &rest value) item
(insert (format "%s: " (capitalize (symbol-name key))))
(if value
(if (eq key 'description)
(let ((beg (point)))
(insert value)
(shr-render-region beg (point)))
(insert (format "%s" value)))
(insert (propertize "None" 'face 'italic)))
(insert "\n")))
(goto-char (point-min))))
(pop-to-buffer buffer)))
(defun nov-next-document ()
"Go to the next document and render it."
(interactive)
(when (< nov-documents-index (1- (length nov-documents)))
(nov-goto-document (1+ nov-documents-index))))
(defun nov-previous-document ()
"Go to the previous document and render it."
(interactive)
(when (> nov-documents-index 0)
(nov-goto-document (1- nov-documents-index))))
(defun nov-scroll-up (arg)
"Scroll with `scroll-up' or visit next chapter if at bottom."
(interactive "P")
(if (>= (window-end) (point-max))
(nov-next-document)
(scroll-up arg)))
(defun nov-scroll-down (arg)
"Scroll with `scroll-down' or visit previous chapter if at top."
(interactive "P")
(if (and (<= (window-start) (point-min))
(> nov-documents-index 0))
(progn
(nov-previous-document)
(goto-char (point-max)))
(scroll-down arg)))
(defun nov-visit-relative-file (filename target)
"Visit the document as specified by FILENAME and TARGET."
(let (index)
(when (not (zerop (length filename)))
(let* ((current-path (cdr (aref nov-documents nov-documents-index)))
(directory (file-name-directory current-path))
(path (file-truename (nov-make-path directory filename)))
(match (nov-find-document
(lambda (doc) (equal path (file-truename (cdr doc)))))))
(when (not match)
(error "Couldn't locate document"))
(setq index match)))
;; HACK: this binding is only need for Emacs 27.1 and older, as of
;; Emacs 28.1, shr.el always adds the shr-target-id property
(let ((shr-target-id target))
(nov-goto-document (or index nov-documents-index))))
(when target
(let ((pos (point-min))
done)
(while (and (not done)
(setq pos (next-single-property-change pos 'shr-target-id)))
(let ((property (get-text-property pos 'shr-target-id)))
(when (or (equal property target)
;; NOTE: as of Emacs 28.1 this may be a list of targets
(and (consp property) (member target property)))
(goto-char pos)
(recenter (1- (max 1 scroll-margin)))
(setq done t))))
(when (not done)
(error "Couldn't locate target")))))
;; adapted from `shr-browse-url'
(defun nov-browse-url (&optional mouse-event)
"Follow an external url with `browse-url'.
Internal URLs are visited with `nov-visit-relative-file'."
(interactive (list last-nonmenu-event))
(mouse-set-point mouse-event)
(let ((url (get-text-property (point) 'shr-url)))
(when (not url)
(user-error "No link under point"))
(if (nov-external-url-p url)
(browse-url url)
(apply 'nov-visit-relative-file (nov-url-filename-and-target url)))))
(defun nov-copy-url (&optional mouse-event)
(interactive (list last-nonmenu-event))
(mouse-set-point mouse-event)
(let ((url (get-text-property (point) 'shr-url)))
(when (not url)
(user-error "No link under point"))
(kill-new url)
(message "%s" url)))
(defun nov-saved-places ()
"Retrieve saved places in `nov-save-place-file'."
(when (and nov-save-place-file (file-exists-p nov-save-place-file))
(with-temp-buffer
(insert-file-contents-literally nov-save-place-file)
(goto-char (point-min))
(condition-case nil
(read (current-buffer))
(error
(nov-warn "Failed to retrieve saved places from `nov-save-place-file'")
nil)))))
(defun nov-saved-place (identifier)
"Retrieve saved place for IDENTIFIER in `nov-saved-place-file'."
(cdr (assq identifier (nov-saved-places))))
(defun nov-save-place (identifier index point)
"Save place as identified by IDENTIFIER, INDEX and POINT.
Saving is only done if `nov-save-place-file' is set."
(when nov-save-place-file
(let* ((place `(,identifier (index . ,index)
(point . ,point)))
(places (cons place (assq-delete-all identifier (nov-saved-places))))
print-level
print-length)
(with-temp-file nov-save-place-file
(insert (prin1-to-string places))))))
(defun nov--index-valid-p (documents index)
(and (integerp index)
(>= index 0)
(< index (length documents))))
(defun nov-history-back ()
"Go back in the history to the last visited document."
(interactive)
(or nov-history
(user-error "This is the first document you looked at"))
(let ((history-forward (cons (list nov-documents-index (point))
nov-history-forward)))
(seq-let (index opoint) (car nov-history)
(setq nov-history (cdr nov-history))
(nov-goto-document index)
(setq nov-history (cdr nov-history))
(setq nov-history-forward history-forward)
(goto-char opoint)
(recenter (1- (max 1 scroll-margin))))))
(defun nov-history-forward ()
"Go forward in the history of visited documents."
(interactive)
(or nov-history-forward
(user-error "This is the last document you looked at"))
(let ((history-forward (cdr nov-history-forward)))
(seq-let (index opoint) (car nov-history-forward)
(nov-goto-document index)
(setq nov-history-forward history-forward)
(goto-char opoint)
(recenter (1- (max 1 scroll-margin))))))
;;;###autoload
(define-derived-mode nov-mode special-mode "EPUB"
"Major mode for reading EPUB documents"
(add-hook 'kill-buffer-hook 'nov-clean-up nil t)
(add-hook 'kill-emacs-hook 'nov-clean-up-all)
(add-hook 'change-major-mode-hook 'nov-clean-up nil t)
(when (not buffer-file-name)
(error "EPUB must be associated with file"))
(when (not nov-unzip-program)
(error "unzip executable not found, customize `nov-unzip-program'"))
(setq nov-temp-dir (make-temp-file "nov-" t ".epub"))
(let ((exit-code (nov-unzip-epub nov-temp-dir buffer-file-name)))
(when (not (integerp exit-code))
(nov-clean-up)
(error "EPUB extraction aborted by signal %s" exit-code))
(when (> exit-code 1) ; exit code 1 is most likely a warning
(nov-clean-up)
(error "EPUB extraction failed with exit code %d (see *nov unzip* buffer)"
exit-code)))
(when (not (nov-epub-valid-p nov-temp-dir))
(nov-clean-up)
(error "Invalid EPUB file"))
(let* ((content (nov-slurp (nov-container-filename nov-temp-dir) t))
(content-file-name (nov-container-content-filename content))
(content-file (nov-make-path nov-temp-dir content-file-name))
(work-dir (file-name-directory content-file))
(content (nov-slurp content-file t)))
(setq nov-content-file content-file)
(setq nov-epub-version (nov-content-version content))
(setq nov-metadata (nov-content-metadata content))
(setq nov-documents (apply 'vector (nov-content-files work-dir content)))
(setq nov-documents-index 0))
(setq buffer-undo-list t)
(setq nov-file-name (buffer-file-name)) ; kept for compatibility reasons
(setq-local bookmark-make-record-function
'nov-bookmark-make-record)
(let ((place (nov-saved-place (cdr (assq 'identifier nov-metadata)))))
(if place
(let ((index (cdr (assq 'index place)))
(point (cdr (assq 'point place))))
(if (nov--index-valid-p nov-documents index)
(progn
(setq nov-documents-index index)
(nov-render-document)
(goto-char point))
(nov-warn "Couldn't restore last position")
(nov-render-document)))
(nov-render-document))))
;;; recentf interop
(defun nov-add-to-recentf ()
"Add real path to recentf list if possible."
(when nov-file-name
(recentf-add-file nov-file-name)))
(add-hook 'nov-mode-hook 'nov-add-to-recentf)
(add-hook 'nov-mode-hook 'hack-dir-local-variables-non-file-buffer)
(defun nov--find-file (file index point)
"Open FILE in nov-mode and go to the specified INDEX and POSITION.
If FILE is nil, the current buffer is used."
(when file
(find-file file))
(unless (eq major-mode 'nov-mode)
(nov-mode))
(when (not (nov--index-valid-p nov-documents index))
(error "Invalid documents index"))
(setq nov-documents-index index)
(nov-render-document)
(goto-char point))
;; Bookmark interop
(defun nov-bookmark-make-record ()
"Create a bookmark epub record."
(cons (buffer-name)
`((filename . ,nov-file-name)
(index . ,nov-documents-index)
(position . ,(point))
(handler . nov-bookmark-jump-handler))))
;;;###autoload
(defun nov-bookmark-jump-handler (bmk)
"The bookmark handler-function interface for bookmark BMK.
See also `nov-bookmark-make-record'."
(let ((file (bookmark-prop-get bmk 'filename))
(index (bookmark-prop-get bmk 'index))
(position (bookmark-prop-get bmk 'position)))
(nov--find-file file index position)))
;;; Org interop
(defun nov-org-link-follow (path)
"Follow nov: link designated by PATH."
(if (string-match "^\\(.*\\)::\\([0-9]+\\):\\([0-9]+\\)$" path)
(let ((file (match-string 1 path))
(index (string-to-number (match-string 2 path)))
(point (string-to-number (match-string 3 path))))
(nov--find-file file index point))
(error "Invalid nov.el link")))
(defun nov-org-link-store ()
"Store current EPUB location as nov: link."
(when (and (eq major-mode 'nov-mode) nov-file-name)
(when (not (integerp nov-documents-index))
(setq nov-documents-index 0))
(let ((org-store-props-function
(if (fboundp 'org-link-store-props)
'org-link-store-props
'org-store-link-props))
(link (format "nov:%s::%d:%d"
nov-file-name
nov-documents-index
(point)))
(description (format "EPUB file at %s" nov-file-name)))
(funcall org-store-props-function
:type "nov"
:link link
:description description))))
(cond
((fboundp 'org-link-set-parameters)
(org-link-set-parameters
"nov"
:follow 'nov-org-link-follow
:store 'nov-org-link-store))
((fboundp 'org-add-link-type)
(org-add-link-type "nov" 'nov-org-link-follow)
(add-hook 'org-store-link-functions 'nov-org-link-store)))
;;; Imenu interop
(defun nov-imenu-goto-function (_name filename target)
"Visit imenu item using FILENAME and TARGET."
;; Make sure file is visited relative to toc file.
(let ((nov-documents-index 0))
(nov-visit-relative-file filename target)))
(defun nov-imenu-create-index ()
"Generate Imenu index."
(let* ((toc-path (cdr (aref nov-documents 0)))
(ncxp (version< nov-epub-version "3.0"))
(toc (with-temp-buffer
(if ncxp
(insert (nov-ncx-to-html toc-path))
(insert-file-contents toc-path))
(libxml-parse-html-region (point-min) (point-max)))))
(mapcar
(lambda (node)
(let ((href (dom-attr node 'href))
(label (dom-text node)))
(seq-let (filename target) (nov-url-filename-and-target href)
(list label filename 'nov-imenu-goto-function target))))
(esxml-query-all "a" toc))))
(defun nov-imenu-setup ()
(setq imenu-create-index-function 'nov-imenu-create-index))
(add-hook 'nov-mode-hook 'nov-imenu-setup)
;;; multi-isearch interop
(defun nov-misearch-next-buffer (buffer wrap)
(if isearch-forward
(cond
((< nov-documents-index (1- (length nov-documents)))
(nov-goto-document (1+ nov-documents-index))
(current-buffer))
(wrap
(nov-goto-document 0)
nil))
(cond
((> nov-documents-index 0)
(nov-goto-document (1- nov-documents-index))
(current-buffer))
(wrap
(nov-goto-document (1- (length nov-documents)))
nil))))
(defun nov-misearch-setup ()
(setq-local multi-isearch-next-buffer-function #'nov-misearch-next-buffer))
(add-hook 'nov-mode-hook #'nov-misearch-setup)
(provide 'nov)
;;; nov.el ends here
(define-package "nov" "20230715.1434" "Featureful EPUB reader mode"
'((esxml "0.3.6")
(emacs "25.1"))
:commit "cc31ce0356226c3a2128119b08de6107e38fdd17" :authors
'(("Vasilij Schneidermann" . "mail@vasilij.de"))
:maintainers
'(("Vasilij Schneidermann" . "mail@vasilij.de"))
:maintainer
'("Vasilij Schneidermann" . "mail@vasilij.de")
:keywords
'("hypermedia" "multimedia" "epub")
:url "https://depp.brause.cc/nov.el")
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; nov-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from nov.el
(autoload 'nov-mode "nov" "\
Major mode for reading EPUB documents
(fn)" t)
(autoload 'nov-bookmark-jump-handler "nov" "\
The bookmark handler-function interface for bookmark BMK.
See also `nov-bookmark-make-record'.
(fn BMK)")
(register-definition-prefixes "nov" '("nov-"))
;;; End of scraped data
(provide 'nov-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; nov-autoloads.el ends here
;;; m-buffer.el --- List-Oriented, Functional Buffer Manipulation -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.rg.uk>
;; Version: 0.16
;; Package-Requires: ((seq "2.14"))
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2024 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides a set of list-oriented functions for operating over the
;; contents of buffers, mostly revolving around regexp searching, and regions.
;; They avoid the use of looping, manipulating global state with `match-data'.
;; Many high-level functions exist for matching sentences, lines and so on.
;; Functions are generally purish: i.e. that is those functions which do
;; change state, by for example replacing text or adding overlays, should only
;; change state in one way; they will not affect point, current buffer, match
;; data or so forth.
;; Likewise to protect against changes in state, markers are used rather than
;; integer positions. This means that it is possible, for example, to search
;; for regexp matches and then replace them all without the earlier
;; replacements invalidating the location of the later ones. Otherwise
;; replacements need to be made in reverse order. This can have implications
;; for performance, so m-buffer also provides functions for making markers nil;
;; there are also macros which help manage markers in `m-buffer-macro'.
;; Where possible, functions share interfaces. So most of the match functions
;; take a list of "match" arguments, either position or as a plist, which avoids
;; using lots of `nil' arguments. Functions operating on matches take a list of
;; `match-data' as returned by the match functions, making it easy to chain
;; matches.
;; This file is documented using lentic.el. Use
;; [[http://github.com/phillord/lentic-server][lentic-server]] to view.
;;; Status:
;; m-buffer.el is now stable and is expected to change only in
;; forward-compatible ways.
;;; Code:
;; #+begin_src emacs-lisp
(require 'seq)
(require 'm-buffer-macro)
;; #+end_src
;; ** Regexp Matching
;; We first provide a single match function, `m-bufffer-match' which converts
;; between Emacs' stateful matching and a more sequence-oriented interface.
;; This function also defines the "match" arguments which are a standard set of
;; arguments used throughout this package.
;; #+begin_src emacs-lisp
(defun m-buffer-match (&rest match)
"Return a list of all `match-data' for MATCH.
MATCH may be of the forms:
BUFFER REGEXP &optional MATCH-OPTIONS
WINDOW REGEXP &optional MATCH-OPTIONS
MATCH-OPTIONS
If BUFFER is given, search this buffer. If WINDOW is given search
the visible window. MATCH-OPTIONS is a plist with any of the
following keys:
:buffer -- the buffer to search
:regexp -- the regexp to search with
:begin -- the start of the region to search -- default point min
:end -- the end of the region to search -- default point max
:post-match -- function called after a match -- default nil
:widen -- if true, widen buffer first -- default nil
:case-fold-search value of `case-fold-search' during search.
If :default accept the current buffer-local value
:numeric -- if true, return integers not markers
If options are expressed in two places, the plist form takes
precedence over positional args. So calling with both a first
position buffer and a :buffer arg will use the second. Likewise,
if a window is given as first arg and :end is given, then
the :end value will be used.
REGEXP should advance point (i.e. not be zero-width) or the
function will loop infinitely. POST-MATCH can be used to avoid
this. The buffer is searched forward."
(apply #'m-buffer--match-1
(m-buffer--normalize-args match)))
;; #+end_src
;; The match function is actually implemented here in the `m-buffer--match-1'
;; function, with positional arguments.
;; #+begin_src emacs-lisp
(defun m-buffer--match-1 (buffer regexp begin end
post-match widen cfs
numeric)
"Return a list of `match-data'.
This is an internal function: please prefer `m-buffer-match'.
BUFFER -- the buffer.
REGEXP -- the regexp.
BEGIN -- the start of the region to search
END -- the end of the region to search
POST-MATCH -- function to run after each match
POST-MATCH is useful for zero-width matches which will otherwise
cause infinite loop. The buffer is searched forward. POST-MATCH
return can also be used to terminate the matching by returning nil.
WIDEN -- call widen first.
CFS -- Non-nil if searches and matches should ignore case.
NUMERIC -- Non-nil if we should return integers not markers."
;; #+end_src
;; We start by saving everything to ensure that we do not pollute the global
;; state. This means match-data, point, narrowing and current buffer! Hopefully
;; this is all the global state that exists and that we are changing.
;; #+begin_src emacs-lisp
(with-current-buffer
buffer
(save-match-data
(save-excursion
(save-restriction
(when widen (widen))
;; #+end_src
;; This let form is doing a number of things. It sets up a dynamic binding for
;; `case-fold-search' (which works even though we are using lexical binding),
;; ensures a non-nil value for =end-bound= and defines a sentinal value that
;; =post-match-return= can use to end early.
;; #+begin_src emacs-lisp
(let ((rtn nil)
(post-match-return t)
(end-bound (or end (point-max)))
;; over-ride default if necessary
(case-fold-search
(if (eq :default cfs)
case-fold-search
cfs)))
;; #+end_src
;; We start at the beginning. There was no particularly good reason for this, and
;; it would have made just as much sense to go backward.
;; #+begin_src emacs-lisp
(goto-char
(or begin
(point-min)))
(while
(and
;; #+end_src
;; The original purpose for =post-match-return= was for zero-width matches --
;; these do not advance point beyond their end, so the while loop never
;; terminates. Unfortunately, avoiding this depends on the regexp being called,
;; so we provide the most general solution of all.
;; As well as this, we check the return value of =post-match-return=, so as well
;; as advancing `point' by side-effect, we can also use it to terminate the look
;; at any point that we want; for example, we can terminate after the first match
;; which feels more efficient than searching the whole buffer then taking the
;; first match.
;; #+begin_src emacs-lisp
post-match-return
;; we need to check we are less than the end-bound
;; or re-search-forward will break
(<= (point) end-bound)
(re-search-forward
regexp end-bound
t))
;; #+end_src
;; Store the `match-data' in a backward list, run post-match. Finally, reverse
;; and terminate.
;; #+begin_src emacs-lisp
(setq rtn
(cons
(if numeric
(m-buffer-marker-to-pos-nil
(match-data))
(match-data))
rtn))
(when post-match
(setq post-match-return (funcall post-match))))
(reverse rtn)))))))
;; #+end_src
;; This method implements the argument list processing. I find this interface
;; fairly attractive to use since it takes the two "main" arguments -- buffer and
;; regexp -- as positional args optionally, and everything else as keywords. The
;; use of keywords is pretty much essential as have eight arguments most of which
;; are not essential.
;; This is fairly close to the logic provided by `cl-defun' which I wasn't aware
;; of when I wrote this. However `cl-defun' does not allow optional arguments
;; before keyword arguments -- all the optional arguments have to be given if we
;; are to use keywords.
;; #+begin_src emacs-lisp
(defun m-buffer--normalize-args (match-with)
"Manipulate args into a standard form and return as a list.
MATCH-WITH are these args. This is an internal function."
(let* (
;; split up into keyword and non keyword limits
(args
(seq-take-while
(lambda (x) (not (keywordp x)))
match-with))
(pargs
(seq-drop-while
(lambda (x) (not (keywordp x)))
match-with))
;; sort actual actual parameters
(first (car args))
;; buffer may be first
(buffer
(or (plist-get pargs :buffer)
(and (bufferp first) first)))
;; or window may be first
(window
(or (plist-get pargs :window)
(and (windowp first) first)))
;; regexp always comes second
(regexp
(or (plist-get pargs :regexp)
(nth 1 args)))
;; begin depends on other arguments
(begin
(or (plist-get pargs :begin)
(and window (window-start window))))
;; end depends on other arguments
(end
(or (plist-get pargs :end)
(and window (window-end window))))
;; pm
(post-match
(plist-get pargs :post-match))
;; widen
(widen
(plist-get pargs :widen))
;; case-fold-search this needs to overwrite the buffer contents iff
;; set, otherwise be ignored, so we need to distinguish a missing
;; property and a nil one
(cfs
(if (plist-member pargs :case-fold-search)
(plist-get pargs :case-fold-search)
:default))
;; numeric
(numeric
(plist-get pargs :numeric)))
(list buffer regexp begin end post-match widen cfs numeric)))
;; #+end_src
;; Finally, this function provides a link between the match function, and the
;; match manipulation functions. We can either choose to match once against a set
;; of arguments and then apply multiple manipulations on the returned match data.
;; Or just use the match manipulation function directly.
;; The first version of `m-buffer' did not include this but it required lots of
;; nested calls which seem inconvenient.
;; #+begin_example
;; (m-buffer-match-manipulate
;; (m-buffer-match (current-buffer) "hello"))
;; #+end_example
;; I think that convienience is worth the overhead.
;; #+begin_src emacs-lisp
(defun m-buffer-ensure-match (&rest match)
"Ensure that we have MATCH data.
If a single arg, assume it is match data and return. If multiple
args, assume they are of the form accepted by
`m-buffer-match'."
(cond
;; we have match data
((= 1 (length match))
(car match))
((< 1 (length match))
(apply #'m-buffer-match match))
(t
(error "Invalid arguments"))))
;; #+end_src
;; ** Match Data Manipulation Functions
;; These functions manipulate lists of either match-data or match arguments in
;; some way.
;; #+begin_src emacs-lisp
(defun m-buffer-buffer-for-match (match-data)
"Given some MATCH-DATA return the buffer for that data."
(marker-buffer (caar match-data)))
(defun m-buffer-match-nth-group (n match-data)
"Fetch the Nth group from MATCH-DATA."
(seq-map
(lambda (m)
(let ((drp
(seq-drop m (* 2 n))))
(list
(car drp) (cadr drp))))
match-data))
(defun m-buffer-match-begin-n (n &rest match)
"Return markers to the start of the Nth group in MATCH.
MATCH may be of any form accepted by `m-buffer-ensure-match'. Use
`m-buffer-nil-marker' after the markers have been finished with
or they will slow future use of the buffer until garbage collected."
(seq-map
(lambda (m)
(nth
(* 2 n) m))
(apply #'m-buffer-ensure-match match)))
(defun m-buffer-match-begin-n-pos (n &rest match)
"Return positions of the start of the Nth group in MATCH.
MATCH may be of any form accepted by `m-buffer-ensure-match'. If
`match-data' is passed markers will be set to nil after this
function. See `m-buffer-nil-marker' for details."
(m-buffer-marker-to-pos-nil
(apply #'m-buffer-match-begin-n
n match)))
(defun m-buffer-match-begin (&rest match)
"Return a list of markers to the start of MATCH.
MATCH may of any form accepted by `m-buffer-ensure-match'. Use
`m-buffer-nil-marker' after the markers have been used or they
will slow future changes to the buffer."
(apply #'m-buffer-match-begin-n 0 match))
(defun m-buffer-match-begin-pos (&rest match)
"Return a list of positions at the start of matcher.
MATCH may be of any form accepted by `m-buffer-ensure-match'.
If `match-data' is passed markers will be set to nil after this
function. See `m-buffer-nil-marker' for details."
(apply #'m-buffer-match-begin-n-pos 0 match))
(defun m-buffer-match-end-n (n &rest match)
"Return markers to the end of the match to the Nth group.
MATCH may be of any form accepted by `m-buffer-ensure-match'.
If `match-data' is passed markers will be set to nil after this
function. See `m-buffer-nil-marker' for details."
(seq-map
(lambda (m)
(nth
(+ 1 (* 2 n))
m))
(apply #'m-buffer-ensure-match match)))
(defun m-buffer-match-end-n-pos (n &rest match)
"Return positions of the end Nth group of MATCH.
MATCH may be of any form accepted by `m-buffer-ensure-match'.
If `match-data' is passed markers will be set to nil after this
function. See `m-buffer-nil-marker' for details."
(m-buffer-marker-to-pos-nil
(apply #'m-buffer-match-end-n-pos
n match)))
(defun m-buffer-match-end (&rest match)
"Return a list of markers to the end of MATCH to regexp in buffer.
MATCH may be of any form accepted by `m-buffer-ensure-match'. Use
`m-buffer-nil-marker' after the markers have been used or they
will slow future changes to the buffer."
(apply #'m-buffer-match-end-n 0 match))
(defun m-buffer-match-end-pos (&rest match)
"Return a list of positions to the end of the match.
MATCH may be of any form accepted by `m-buffer-ensure-match'.
If `match-data' is passed markers will be set to nil after this
function. See `m-buffer-nil-marker' for details."
(m-buffer-marker-to-pos-nil
(apply #'m-buffer-match-end match)))
;; #+end_src
;; ** Match Utility and Predicates
;; *** Subtraction
;; Some predicates and the ability to subtract to lists of matches from each
;; other. This makes up for limitations in Emacs regexp which can't do "match x
;; but not y".
;; #+begin_src emacs-lisp
(defun m-buffer-match-equal (m n)
"Return true if M and N are cover the same region.
Matches are equal if they match the same region; subgroups are
ignored."
(and
(equal
(car m)
(car n))
(equal
(cadr m)
(cadr n))))
;; #+end_src
;; A nice simple implementation for the general purpose solution.
;; Unfortunately, performance sucks, running in quadratic time.
;; #+begin_src emacs-lisp
(defun m-buffer-match-subtract (m n)
"Remove from M any match in N.
Matches are equivalent if overall they match the same
area; subgroups are ignored.
See also `m-buffer-match-exact-subtract' which often
runs faster but has some restrictions."
(seq-remove
(lambda (o)
(seq-some
(lambda (p)
(m-buffer-match-equal o p))
n))
m))
;; #+end_src
;; The ugly and complicated and less general solution. But it runs in linear
;; time.
;; #+begin_src emacs-lisp
(defun m-buffer-match-exact-subtract (m n)
"Remove from M any match in N.
Both M and N must be fully ordered, and any element in N must be
in M."
(if n
;; n-eaten contains the remaining elements of n that we haven't tested
;; for yet. We throw them away as we go
(let ((n-eaten n))
(seq-remove
(lambda (o)
(cond
;; n-eaten has been eaten. Check here or later "<" comparison crashes.
((not n-eaten)
;; return nil because we always want things in m now.
nil
)
;; we have a match so throw away the first element of n-eaten
;; which we won't need again.
((m-buffer-match-equal
(car n-eaten) o)
(progn
(setq n-eaten (seq-drop n-eaten 1))
t))
;; we should discard also if n-eaten 1 is less than o because, both
;; are sorted, so we will never match
((<
;; first half of the first match in n-eaten
(caar n-eaten)
;; first half of match
(car o))
(progn
(setq n-eaten (seq-drop n-eaten 1))
t))))
m))
m))
(defun m-buffer-in-match-p (matches position)
"Returns true is any of MATCHES contain POSITION."
(seq-some
(lambda (match)
(and
(<= (car match) position)
(<= position (cadr match))))
matches))
;; #+end_src
;; *** Partition
;; Partition one set of markers by another. This is useful for finding matched
;; pairs of markers.
;; #+begin_src emacs-lisp
(defun m-buffer--partition-by-marker(list partition)
"Given LIST, split at markers in PARTITION.
This is the main implementation for `m-buffer-partition-by-marker',
but assumes that partition starts with a very low value (or nil)."
(let* ((p-top (car-safe partition))
(p-val (car-safe (cdr-safe partition)))
(p-fn (lambda (n)
(or (not p-val)
(< n p-val)))))
(when list
(cons
(cons
p-top
(seq-take-while p-fn list))
(m-buffer--partition-by-marker
(seq-drop-while p-fn list)
(cdr partition))))))
(defun m-buffer-partition-by-marker (list partition)
"Given LIST of markers, split at markers in PARTITION.
Returns a list of lists. The first element of each list is nil or
the marker from PARTITION. The rest of the elements are those
elements in LIST which are at the same position or later in the
buffer than the element from PARTITION, but before the next
element from PARTITION.
Both LIST and PARTITION must be sorted."
;; TODO!
(m-buffer--partition-by-marker list (cons nil partition)))
;; #+end_src
;; ** Marker manipulation functions
;; These functions do things to markers rather than the areas of the buffers
;; indicated by the markers. This includes transforming between markers and
;; integer positions, and niling markers explicitly, which prevents slow down
;; before garbage collection.
;; #+begin_src emacs-lisp
(defun m-buffer-nil-marker (markers)
"Takes a (nested) list of MARKERS and nils them all.
Markers slow buffer movement while they are pointing at a
specific location, until they have been garbage collected. Niling
them prevents this. See Info node `(elisp) Overview of Markers'."
(seq-map
(lambda (marker)
(if (seqp marker)
(m-buffer-nil-marker marker)
(set-marker marker nil)))
markers))
(defun m-buffer-marker-to-pos (markers &optional postnil)
"Transforms a list of MARKERS to a list of positions.
If the markers are no longer needed, set POSTNIL to true, or call
`m-buffer-nil-marker' manually after use to speed future buffer
movement. Or use `m-buffer-marker-to-pos-nil'."
(seq-map
(lambda (marker)
(prog1
(marker-position marker)
(when postnil
(set-marker marker nil))))
markers))
(defun m-buffer-marker-to-pos-nil (markers)
"Transforms a list of MARKERS to a list of positions then nils.
See also `m-buffer-nil-markers'"
(m-buffer-marker-to-pos markers t))
(defun m-buffer-marker-tree-to-pos (marker-tree &optional postnil)
"Transforms a tree of markers to equivalent positions.
MARKER-TREE is the tree.
POSTNIL sets markers to nil afterwards."
(seq-map
(lambda (marker)
(if (seqp marker)
(m-buffer-marker-tree-to-pos marker postnil)
(prog1
(marker-position marker)
(when postnil
(set-marker marker nil)))))
marker-tree))
(defun m-buffer-marker-tree-to-pos-nil (marker-tree)
"Transforms a tree of markers to equivalent positions.
MARKER-TREE is the tree. Markers are niled afterwards."
(m-buffer-marker-tree-to-pos marker-tree t))
(defun m-buffer-marker-clone (marker-tree &optional type)
"Return a clone of MARKER-TREE.
The optional argument TYPE specifies the insertion type. See
`copy-marker' for details."
(seq-map
(lambda (marker)
(if (seqp marker)
(m-buffer-marker-clone marker type)
(copy-marker marker type)))
marker-tree))
(defun m-buffer-pos-to-marker (buffer positions)
"In BUFFER translates a list of POSITIONS to markers."
(seq-map
(lambda (pos)
(set-marker
(make-marker) pos buffer))
positions))
;; #+end_src
;; ** Replace, Delete, Extract
;; #+begin_src emacs-lisp
(defun m-buffer-replace-match (match-data replacement
&optional fixedcase literal subexp)
"Given a list of MATCH-DATA, replace with REPLACEMENT.
If FIXEDCASE do not alter the case of the replacement text.
If LITERAL insert the replacement literally.
SUBEXP should be a number indicating the regexp group to replace.
Returns markers to the start and end of the replacement. These
markers are part of MATCH-DATA, so niling them will percolate backward.
See also `replace-match'."
(save-excursion
(seq-map
(lambda (match)
(with-current-buffer
(marker-buffer (car match))
(save-match-data
(set-match-data match)
(replace-match
replacement fixedcase literal nil
(or subexp 0)))))
match-data))
;; we have match-data
(m-buffer-match-nth-group (or subexp 0) match-data))
(defun m-buffer-delete-match (match-data &optional subexp)
"Delete all MATCH-DATA.
SUBEXP should be a number indicating the regexp group to delete.
Returns markers to the start and end of the replacement. These
markers are part of MATCH_DATA, so niling them will percolate backward."
(m-buffer-replace-match match-data "" subexp))
(defun m-buffer-match-string (match-data &optional subexp)
"Return strings for MATCH-DATA optionally of group SUBEXP."
(seq-map
(lambda (match)
(with-current-buffer
(marker-buffer (car match))
(save-match-data
(set-match-data match)
(match-string
(or subexp 0)))))
match-data))
(defun m-buffer-match-string-no-properties (match-data &optional subexp)
"Return strings for MATCH-DATA optionally of group SUBEXP.
Remove all properties from return."
(seq-map
#'substring-no-properties
(m-buffer-match-string
match-data subexp)))
;; #+end_src
;; ** Match Things
;; Emacs comes with a set of in-built regexps most of which we use here.
;; We define `m-buffer-apply-join' first. The reason for this function is that
;; we want to take a list of match arguments and add to with, for instance, a
;; regular expression. We need to add these at the end because most of our
;; functions contain some positional arguments.
;; #+begin_src emacs-lisp
(defun m-buffer-apply-join (fn match &rest more-match)
(let*
((args
(seq-take-while
(lambda (x) (not (keywordp x)))
match))
(pargs
(seq-drop-while
(lambda (x) (not (keywordp x)))
match))
(more-keywords
(seq-map
#'car
(seq-partition more-match 2))))
(when
(seq-find
(lambda (keyword)
(plist-member pargs keyword))
more-keywords)
(error
"Match arg contradicts a defined argument."))
(apply fn (append args more-match pargs))))
;; #+end_src
;; For the following code, we use Emacs core regexps where possible.
;; #+begin_src emacs-lisp
(defun m-buffer-match-page (&rest match)
"Return a list of match data to all pages in MATCH.
MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(m-buffer-apply-join 'm-buffer-match
match :regexp page-delimiter))
;; #+end_src
;; The `paragraph-separate' regexp can match an empty region, so we need to start
;; each search at the beginning of the next line.
;; #+begin_src emacs-lisp
(defun m-buffer-match-paragraph-separate (&rest match)
"Return a list of match data to `paragraph-separate' in MATCH.
MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for futher details."
(m-buffer-apply-join
'm-buffer-match match :regexp paragraph-separate
:post-match 'm-buffer-post-match-forward-line))
(defvar m-buffer--line-regexp
"^.*$"
"Regexp to match a line.")
(defun m-buffer-match-line (&rest match)
"Return a list of match data to all lines.
MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS.
See `m-buffer-match for further details."
(m-buffer-apply-join
'm-buffer-match
match :regexp m-buffer--line-regexp
:post-match 'm-buffer-post-match-forward-char))
(defun m-buffer-match-line-start (&rest match)
"Return a list of match data to all line start.
MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(m-buffer-apply-join
'm-buffer-match-begin
match :regexp "^"
:post-match 'm-buffer-post-match-forward-char))
(defun m-buffer-match-line-end (&rest match)
"Return a list of match to line end.
MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(m-buffer-apply-join
'm-buffer-match-begin
match :regexp "$"
:post-match 'm-buffer-post-match-forward-char))
;; #+end_src
;; This is the first use of the =post-match= to terminate the loop, and was
;; actually the motivation for adding it. We automatically terminate after the
;; first match by simply returning nil.
;; #+begin_src emacs-lisp
(defun m-buffer-match-first (&rest match)
"Return the first match to MATCH.
This matches more efficiently than matching all matches and
taking the car. See `m-buffer-match' for further details of
MATCH."
(m-buffer-apply-join
#'m-buffer-match match
:post-match (lambda () nil)))
(defun m-buffer-match-first-line (&rest match)
"Return a match to the first line of MATCH.
This matches more efficiently than matching all lines and taking
the car. See `m-buffer-match' for further details of MATCH."
(m-buffer-apply-join
'm-buffer-match-first match
:regexp m-buffer--line-regexp))
(defun m-buffer-match-multi (regexps &rest match)
"Incrementally find matches to REGEXPS in MATCH.
Finds the first match to the first element of regexps, then
starting from the end of this match, the first match to the
second element of regexps and so forth. See `m-buffer-match' for
futher details of MATCH."
(when regexps
(let ((first-match
(m-buffer-apply-join
#'m-buffer-match-first
match
:regexp (car regexps))))
(append
first-match
(apply
#'m-buffer-match-multi
(cdr regexps)
(plist-put
match
:begin (car (m-buffer-match-end first-match))))))))
;; #+end_src
;; Emacs has a rather inconsistent interface here -- suddenly, we have a function
;; rather than a variable for accessing a regexp.
;; #+begin_src emacs-lisp
(defun m-buffer-match-sentence-end (&rest match)
"Return a list of match to sentence end.
MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(m-buffer-apply-join
'm-buffer-match-begin
match :regexp (sentence-end)))
(defun m-buffer-match-word (&rest match)
"Return a list of match to all words.
MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(m-buffer-apply-join
'm-buffer-match
match :regexp "\\\w+"))
(defun m-buffer-match-empty-line (&rest match)
"Return a list of match to all empty lines.
MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(m-buffer-apply-join
'm-buffer-match
match :regexp "^$"
:post-match 'm-buffer-post-match-forward-line))
(defun m-buffer-match-non-empty-line (&rest match)
"Return a list of match to all non-empty lines.
MATCH is fo the form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(m-buffer-apply-join
'm-buffer-match
match :regexp "^.+$"))
(defun m-buffer-match-whitespace-line (&rest match)
"Return match data to all lines with only whitespace characters.
Note empty lines are not included. MATCH is of form
BUFFER-OR-WINDOW MATCH-OPTIONS. See `m-buffer-match' for
further details."
(m-buffer-apply-join
'm-buffer-match
match :regexp "^\\s-+$"))
;; #+end_src
;; I don't think that there is a way to do this with regexps entirely, so we use
;; substraction.
;; #+begin_src emacs-lisp
(defun m-buffer-match-non-whitespace-line (&rest match)
"Return match data to all lines with at least one non-whitespace character.
Note empty lines do not contain any non-whitespace lines.
MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See
`m-buffer-match' for further details."
(seq-difference
(apply #'m-buffer-match-line match)
(apply #'m-buffer-match-whitespace-line match)))
;; Useful post-match functions
(defun m-buffer-post-match-forward-line ()
"Attempt to move forward one line, return true if success."
(= 0 (forward-line)))
(defun m-buffer-post-match-forward-char ()
"Attempts to move forward one char.
Returns true if succeeds."
(condition-case _e
(progn
(forward-char)
t)
(error 'end-of-buffer
nil)))
;; #+end_src
;; ** Apply Function to Match
;; These functions apply another function to some match-data. This is pretty
;; useful generically, but also I use it for many of the following functions.
;; #+begin_src emacs-lisp
(defun m-buffer-on-region (fn match-data)
"Apply FN to MATCH-DATA.
FN should take two args, the start and stop of each region.
MATCH-DATA can be any list of lists with two elements (or more)."
(m-buffer-on-region-nth-group fn 0 match-data))
(defun m-buffer-on-region-nth-group (fn n match-data)
"Apply FN to the Nth group of MATCH-DATA.
FN should take two args, the start and stop of each region.
MATCH-DATA can be any list of lists with two elements (or more)."
(seq-map
(lambda (x)
(apply fn x))
(m-buffer-match-nth-group n match-data)))
;; #+end_src
;; ** Overlay and Property Functions
;; Adding properties or overlays to match-data. The functionality here somewhat
;; overlaps with [[https://github.com/ShingoFukuyama/ov.el][ov.el]], which I didn't know about when I wrote this. It generally
;; works over overlays, or regexps, while m-buffer works over match-data.
;; #+begin_src emacs-lisp
(defun m-buffer-overlay-match (match-data &optional front-advance rear-advance)
"Return an overlay for all match to MATCH-DATA.
FRONT-ADVANCE and REAR-ADVANCE controls the borders of the
overlay as defined in `make-overlay'. Overlays do not scale that
well, so use `m-buffer-propertize-match' if you intend to make
and keep many of these.
See Info node `(elisp) Overlays' for further information."
(let ((buffer (m-buffer-buffer-for-match match-data)))
(m-buffer-on-region
(lambda (beginning end)
(make-overlay
beginning end buffer
front-advance rear-advance))
match-data)))
(defun m-buffer-add-text-property-match
(match-data properties)
"To MATCH-DATA add PROPERTIES.
See `add-text-property' for details of the format of properties.
Text properties are associated with the text and move with it. See
Info node `(elisp) Text Properties' for further details."
(m-buffer-on-region
(lambda (beginning end)
(add-text-properties beginning end properties))
match-data))
(defun m-buffer-put-text-property-match (match-data property value)
"To MATCH-DATA add PROPERTY wth VALUE.
See `put-text-property' for details of the format of properties.
Text properties are associated with the text and move with it. See
Info node `(elisp) Text Properties' for further details."
(m-buffer-on-region
(lambda (beginning end)
(put-text-property beginning end property value))
match-data))
(defun m-buffer-overlay-face-match (match-data face)
"To MATCH-DATA add FACE to the face property.
This is for use in buffers which do not have function `font-lock-mode'
enabled; otherwise use `m-buffer-overlay-font-lock-face-match'."
(seq-map
(lambda (ovly)
(overlay-put ovly 'face face))
(m-buffer-overlay-match match-data)))
(defun m-buffer-overlay-font-lock-face-match (match-data face)
"To MATCH-DATA add FACE to the face property.
This is for use in buffers which have variable `font-lock-mode' enabled;
otherwise use `m-buffer-overlay-face-match'."
(seq-map
(lambda (ovly)
(overlay-put ovly 'face face))
(m-buffer-overlay-match match-data)))
(defun m-buffer-text-property-face (match-data face)
"To MATCH-DATA apply FACE.
This is for use in buffers which do
not have variable `font-lock-mode' enabled; otherwise use
`m-buffer-text-property-font-lock-face'."
(m-buffer-put-text-property-match match-data
'face face))
(defun m-buffer-text-property-font-lock-face (match-data face)
"To MATCH-DATA apply FACE.
This is for use in buffers which have variable `font-lock-mode'
enabled; otherwise use `m-buffer-text-property-face'."
(m-buffer-put-text-property-match match-data
'font-lock-face face))
(provide 'm-buffer)
;;; m-buffer.el ends here
;; #+end_src
(define-package "m-buffer" "20240302.2255" "List-Oriented, Functional Buffer Manipulation"
'((seq "2.14"))
:commit "8a51de3366599e7fa52e37b596c9ce226b6f04c5" :authors
'(("Phillip Lord" . "phillip.lord@russet.org.uk"))
:maintainers
'(("Phillip Lord" . "phillip.lord@russet.rg.uk"))
:maintainer
'("Phillip Lord" . "phillip.lord@russet.rg.uk"))
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; m-buffer-macro.el --- Create and dispose of markers -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides some utility macros which help to support stateless
;; operation on buffers, by restoring global state after to what it was before
;; the macro starts.
;; These macros are quite useful, but with the exception of
;; `m-buffer-with-markers', they are mostly meant to underpin `m-buffer-at'. The
;; aim is that all the cases where one of these macros is used with a single form
;; from core Emacs should be provided by m-buffer-at (although this is not the
;; case yet). These macros might be more efficient if there are a lot of calls to
;; group together.
;;; Code:
;; ** Markers
;; Markers are generally much nicer than integers, but needs cleaning up
;; afterwards if a lot are created. It's possible to do this using
;; `m-buffer-nil-marker', but it can be a bit painful. This form looks like a
;; `let' form, but removes markers at the end.
;; #+begin_src emacs-lisp
(defmacro m-buffer-with-markers (varlist &rest body)
"Bind variables after VARLIST then eval BODY.
VARLIST is of the same form as `let'. All variables should
contain markers or collections of markers. All markers are niled
after BODY."
;; indent let part specially, and debug like let
(declare (indent 1)(debug let))
;; so, create a rtn var with make-symbol (for hygene)
(let* ((rtn-var (make-symbol "rtn-var"))
(marker-vars
(mapcar #'car varlist))
(full-varlist
(append
varlist
`((,rtn-var
(progn
,@body))))))
`(let* ,full-varlist
(m-buffer-nil-marker
(list ,@marker-vars))
,rtn-var)))
;; #+end_src
;; ** Point and Buffer
;; These macros are extensions of `with-current-buffer', and `save-excursion',
;; which set the current buffer and location.
;; #+begin_src emacs-lisp
(defmacro m-buffer-with-current-marker
(marker &rest body)
"At MARKER location run BODY."
(declare (indent 1) (debug t))
`(with-current-buffer
(marker-buffer ,marker)
(save-excursion
(goto-char ,marker)
,@body)))
(defmacro m-buffer-with-current-position
(buffer location &rest body)
"In BUFFER at LOCATION, run BODY."
(declare (indent 2)
(debug t))
`(with-current-buffer
,buffer
(save-excursion
(goto-char ,location)
,@body)))
;; #+end_src
;; Combines the last two!
;; #+begin_src emacs-lisp
(defmacro m-buffer-with-current-location
(location &rest body)
"At LOCATION, run BODY.
LOCATION should be a list. If a one element list, it is a marker.
If a two element, it is a buffer and position."
(declare (indent 1) (debug t))
;; multiple eval of location!
(let ((loc (make-symbol "loc")))
`(let ((,loc ,location))
(if (= 1 (length ,loc))
(m-buffer-with-current-marker
(nth 0 ,loc)
,@body)
(if (= 2 (length ,loc))
(m-buffer-with-current-position
(nth 0 ,loc)
(nth 1 ,loc)
,@body)
(error "m-buffer-with-current-location requires a list of one or two elements"))))))
(provide 'm-buffer-macro)
;;; m-buffer-macro.el ends here
;; #+end_src
#+TITLE: Manipulate the Contents of Emacs Buffers
#+AUTHOR: Phillip Lord
#+TEXINFO_DIR_CATEGORY: Emacs
# FIXME: Shouldn't `ox-texinfo` use sane defaults like the file's name
# for TEXINFO_DIR_TITLE and the TITLE for TEXINFO_DIR_DESC?
#+TEXINFO_DIR_TITLE: m-buffer-doc
#+TEXINFO_DIR_DESC: Manipulate the Contents of Emacs Buffers
#+INFOJS_OPT: view:info toc:nil
* Introduction
m-buffer provides functions for accessing and manipulating the contents of an
Emacs buffer. While Emacs already provides these features, m-buffer provides a
higher-level interaction. It achieves this in several ways: many of the
functions are list-orientated, so avoiding the need for iteration; it avoids
the use of global emacs state whenever it can be avoided, so avoiding
side-effects; and it provides a large library of functions supporting common
operations.
Core usage of buffer m-buffer is simple. For example, the following code
returns a list of all matches to the /regexp/ "m-buffer" in the
`current-buffer`.
#+BEGIN_SRC elisp
(m-buffer-match
(current-buffer)
"m-buffer")
#+END_SRC
m-buffer is also expanding. Other parts of m-buffer provide stateless
interaction with the existing buffer; for example, we can use the following to
fetch the point of any buffer:
#+BEGIN_SRC elisp
(m-buffer-at-point buffer)
#+END_SRC
These functions can help greatly when writing code which operates on two or
more buffers. It is also possible to check whether the status of a location --
either a buffer and position or a marker. For example, these calls are
equivalent to `eolp`.
#+BEGIN_SRC elisp
(m-buffer-at-eolp buffer position)
(m-buffer-at-eolp marker)
#+END_SRC
** Status
`m-buffer' is a work in progress, but much of it is now stable and the
interface should change only in forward-compatible ways for 1.0 release.
The individual files have statements about their stability.
* m-buffer
m-buffer.el provides list-orientated search both for any regexp and standard
regexps, as well as the ability to do things with these matches: replace, add
overlays or text-properties or, most generically of all, call any function on
matches.
#+include: "m-buffer.org" :minlevel 2
* m-buffer-at
m-buffer-at.el provides a set of stateless functions which for accessing data
about buffers, without requiring changing the `current-buffer'.
#+include: "m-buffer-at.org" :minlevel 2
* m-buffer-macro
m-buffer-macro.el provides some general purpose macros for:
- dealing with markers and their cleanup
- running code at a specific location
#+include: "m-buffer-macro.org" :minlevel 2
* m-buffer-benchmark
m-buffer-benchmark.el provides no functions, but is a set of benchmarks to
give some idea of how much overhead various m-buffer functions entail.
#+include: "m-buffer-benchmark.org" :minlevel 2
* Roadmap
** 0.11
Full lentic documentation using lentic-server
** 0.12
Completion of m-buffer-at with all the core buffer functions.
;;; m-buffer-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from m-buffer.el
(register-definition-prefixes "m-buffer" '("m-buffer-"))
;;; Generated autoloads from m-buffer-at.el
(register-definition-prefixes "m-buffer-at" '("m-buffer-at-"))
;;; Generated autoloads from m-buffer-macro.el
(register-definition-prefixes "m-buffer-macro" '("m-buffer-with-"))
;;; End of scraped data
(provide 'm-buffer-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; m-buffer-autoloads.el ends here
;;; m-buffer-at.el --- Stateless point functions -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Provides stateless equivalents to many core Emacs functions, that provide
;; information about a buffer. Most of these functions take either a buffer as
;; a parameter or a location, which is either a marker (with a non-nil buffer
;; and location) or a buffer and integer.
;; These functions are generally competitive with the originals in terms of
;; speed.
;;; Status:
;; There are lots more to do, but the interface should be stable.
;;; Code:
;; #+begin_src emacs-lisp
(require 'm-buffer-macro)
(defun m-buffer-at-point (buffer)
"Return the location of point in BUFFER.
See also `point'."
(with-current-buffer
buffer
(point)))
(defun m-buffer-at-eolp (&rest location)
"Return t if LOCATION is at the end of a line.
See also `eolp'."
(m-buffer-with-current-location
location
(eolp)))
(defun m-buffer-at-bolp (&rest location)
"Return t if LOCATION is at the begining of a line.
See also `bolp'"
(m-buffer-with-current-location
location
(bolp)))
(defun m-buffer-at-line-beginning-position (&rest location)
"Return the start of the line of LOCATION."
(m-buffer-with-current-location
location
(line-beginning-position)))
(defun m-buffer-at-line-end-position (&rest location)
"Return the end of the line of LOCATION."
(m-buffer-with-current-location
location
(line-end-position)))
(defun m-buffer-at-narrowed-p (buffer)
(with-current-buffer
buffer
(buffer-narrowed-p)))
(defun m-buffer-at-string (buffer)
(with-current-buffer
buffer
(buffer-string)))
(provide 'm-buffer-at)
;;; m-buffer-at.el ends here
;; #+end_src
;;; logstash-conf.el --- basic mode for editing logstash configuration
;; Copyright (C) 2014 Wilfred Hughes <me@wilfred.me.uk>
;;
;; Author: Wilfred Hughes <me@wilfred.me.uk>
;; Created: 21 October 2014
;; Version: 0.5
;;; Commentary:
;; Basic syntax highlighting and indentation for Logtash configuration
;; files. Does a better job than `conf-unix-mode', at least.
;;; License:
;; This file is not part of GNU Emacs.
;; However, it is distributed under the same license.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Code:
(defgroup logstash nil
"Major mode for editing Logstash configuration files."
:group 'languages)
(defcustom logstash-indent 4
"Indentation offset for `logstash-conf-mode'."
:group 'logstash
:type 'integer)
(defun logstash--open-paren-count ()
"Return the number of open brackets before point."
(nth 0 (syntax-ppss)))
(defun logstash-indent-line ()
"Indent the current line."
(interactive)
(let ((initial-column (current-column))
initial-indentation
correct-indentation-level)
;; Get the current indentation
(back-to-indentation)
(setq initial-indentation (current-column))
;; Remove it.
(while (not (zerop (current-column)))
(delete-char -1))
;; Step over trailing close curlies before counting.
(save-excursion
(while (looking-at "}")
(forward-char 1))
(setq correct-indentation-level (logstash--open-paren-count)))
;; Replace with the correct indentation.
(dotimes (_ (* logstash-indent correct-indentation-level))
(insert " "))
;; Restore point at the same offset on this line.
(let ((point-offset (- initial-column initial-indentation)))
(when (> point-offset 0)
(forward-char point-offset)))))
(defvar logstash-conf-mode-font-lock-keywords
`((,(regexp-opt '("if" "else" "in" "not" "and" "or" "nand" "xor") 'symbols)
. font-lock-keyword-face)
(,(regexp-opt '("input" "filter" "output") 'symbols)
. font-lock-builtin-face)
(,(regexp-opt '("true" "false") 'symbols)
. font-lock-constant-face)
("\\<\\([a-z_]+\\)\\>\s*{" 1 font-lock-function-name-face)
("\\[[a-z0-9@_.-]+\\]" . font-lock-variable-name-face)))
(defvar logstash-conf-mode-syntax-table
(let ((table (make-syntax-table)))
;; Treat # as a single-line comment.
(modify-syntax-entry ?# "<" table)
(modify-syntax-entry ?\n ">" table)
;; Single and double-quoted strings.
(modify-syntax-entry ?\" "\"" table)
(modify-syntax-entry ?\\ "\\" table)
(modify-syntax-entry ?' "\"" table)
table))
;;;###autoload
(define-derived-mode logstash-conf-mode prog-mode "Logstash"
"Major mode for editing logstash configuration files.
\\{logstash-conf-mode-map\\}"
(setq font-lock-defaults '(logstash-conf-mode-font-lock-keywords))
(setq-local indent-line-function #'logstash-indent-line)
(setq-local comment-start "# "))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.logstash\\'" . logstash-conf-mode))
;;;###autoload
(add-to-list 'interpreter-mode-alist '("logstash" . logstash-conf-mode))
(provide 'logstash-conf)
;;; logstash-conf.el ends here
(define-package "logstash-conf" "20210123.1949" "basic mode for editing logstash configuration" 'nil :commit "ec9b527191cd47d3b5947cb0ec3d6a8a57b121ea" :authors
'(("Wilfred Hughes" . "me@wilfred.me.uk"))
:maintainers
'(("Wilfred Hughes" . "me@wilfred.me.uk"))
:maintainer
'("Wilfred Hughes" . "me@wilfred.me.uk"))
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; logstash-conf-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from logstash-conf.el
(autoload 'logstash-conf-mode "logstash-conf" "\
Major mode for editing logstash configuration files.
\\{logstash-conf-mode-map\\}
(fn)" t)
(add-to-list 'auto-mode-alist '("\\.logstash\\'" . logstash-conf-mode))
(add-to-list 'interpreter-mode-alist '("logstash" . logstash-conf-mode))
(register-definition-prefixes "logstash-conf" '("logstash-"))
;;; End of scraped data
(provide 'logstash-conf-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; logstash-conf-autoloads.el ends here
#+TITLE: Lenticular Text For Emacs
#+AUTHOR: Phillip Lord
# FIXME: `ox-texinfo` should use sane defaults like the file's name
# for TEXINFO_DIR_TITLE and the TITLE for TEXINFO_DIR_DESC?
#+TEXINFO_DIR_CATEGORY: Emacs
#+TEXINFO_DIR_TITLE: * lentic: (lenticular).
#+TEXINFO_DIR_DESC: Lenticular Text For Emacs
#+INFOJS_OPT: view:info toc:nil
* Introduction
This package implements lenticular text: simultaneous editing and viewing of
the same (or closely related) text in two or more buffers. While lentic has
many potential uses it also enables a form of literate programming. This is
the literate documentation for lentic.
Documentation for each package is organised according to approximate usage in
documentation terms. So the core package (lentic) comes first, then that
associated with the mode, and then a package which is useless but good for
understanding how to configure lentic for new environments.
** Caveat
The general idea of using lentic to document itself is a good one; I think the
general principle of dogfooding making sense. It has a disadvantage, though.
At the moment, lentic is not finished, nor is the transformation that I am
using to generate the documentation. So, the output is currently not ideal;
this makes it both harder to read than ideal, nor the best advert for lentic.
It will improve!
* Getting Started
In this section, I describe how to use one particular use of lentic --
translating between Emacs-Lisp and Org-mode. This is not the only use of
lentic as it neither specific to Emacs-Lisp nor Org-mode, but it's an easy one
to get started with.
** Installing
Lentic can be installed from GNU ELPA, e.g. with ~M-x list-packages~.
Once "lentic" is installed, type ~M-x global-lentic-mode~.
** With existing lentic source
The easiest way to use lentic is with source which is already formatted
appropriately for lentic, including the source code for lentic.
First, clone the lentic repository. This contains a ~.dir-locals.el~ file, in
addition to the source, which tells lentic how to create a lentic-buffer.
#+begin_example
git clone https://github.com/phillord/lentic.git
#+end_example
Now, open lentic.el in Emacs. You should get prompted to accept a unsafe
directory local variable. If you trust me, then type "y" or "!".
To create the lentic buffer, press ~C-c,c~ or "Edit->Lentic->Create All",
followed by ~C-c,b~ or "Edit->Lentic->Split Below" to show both Emacs-Lisp and
Org-mode file at the same time.
** Converting legacy source
To convert some an existing source file called, say, blah.el into a lentic
file.
- Add ~;; #+BEGIN_SRC emacs-lisp~ after introductory comments but before any
source.
- Add ~;; #+END_SRC~ as the last line.
- Before the file header (if you have one!), add ~;;; Header:~
- Add a ~.dir-local.el~ as follows:
#+begin_src emacs-lisp
((emacs-lisp-mode
(lentic-init . lentic-orgel-org-init)))
#+end_src
You should now have something like this:
#+begin_src emacs-lisp
;;; blah.el --- stuff, stuff stuff
;;; Header:
;; This file is not part of Emacs
;;; Code:
;; #+BEGIN_SRC emacs-lisp
(provide 'blah)
;; #+END_SRC
#+end_src
Your buffer should now be set up for lentic. Either close and reopen or type
~M-x revert-buffer~ to ensure `lentic-init' has been configured.
To add documentation, I make heavy use of `org-babel-demarcate-block' to split
the single large Emacs-Lisp code blocks into smaller blocks as I go. The whole
buffer remains properly formatted throughout this way.
* Lentic
lentic.el is the central point of this package. It provides the base
configuration options, the hooks into emacs change notification and the
default transformation (which copies text exactly).
#+include: "lentic.org" :minlevel 2
* Lentic Mode
lentic-mode.el provides end-user functions for creating and manipulating
lentic buffers.
#+include: "lentic-mode.org" :minlevel 2
* Lentic Rot13
lentic-rot13.el is entirely useless for practical purposes but demonstrates
how new lenticular transformations can be configured.
#+include: "lentic-rot13.org" :minlevel 2
* Lentic Chunk
Lentic Block provides configurations where blocks of the buffer are
commented in one buffer and not in the others. There are quite a few
extensions of this configuration, including the one that is used to
document this file.
#+include: "lentic-chunk.org" :minlevel 2
* Lentic Asciidoc
A lentic block configuration for use with asciidoc.
#+include: "lentic-asciidoc.org" :minlevel 2
* Lentic Latex
A lentic block configuration for use with latex.
#+include: "lentic-latex-code.org" :minlevel 2
* Lentic Org
A lentic block configuration for use with org. This includes a more
specialised and complex transformation between Emacs-Lisp and Org.
#+include: "lentic-org.org" :minlevel 2
* Lentic Dev
Tools for developers of new configurations.
#+include: "lentic-dev.org" :minlevel 2
* Lentic Doc
Lentic has a self-hosting documentation system which is defined here.
#+include: "lentic-doc.org" :minlevel 2
;;; lentic.el --- One buffer as a view of another -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; Version: 0.12
;; Package-Requires: ((emacs "25") (m-buffer "0.13") (dash "2.5.0"))
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2024 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; `lentic' enables /lenticular text/: simultaneous editing and viewing of the
;; same (or closely related) text in two or more buffers, potentially in
;; different modes. Lenticular text is named after lenticular printing, which
;; produce images which change depending on the angle at which they are
;; viewed.
;; Sometimes, it would be nice to edit a file in two ways at once. For
;; instance, you might have a source file in a computational language with
;; richly marked documentation. As Emacs is a modal editor, it would be nice
;; to edit this file both in a mode for the computational language and for the
;; marked up documentation.
;; One solution to this is to use a single-mode which supports both types of
;; editing. The problem with this is that it is fundamentally difficult to
;; support two types of editing at the same time; more over, you need a new
;; mode for each combination. Another solution is to use one of the
;; multiple-mode tools which are available. The problem with this is that they
;; generally need some support from the modes in question. And, again, the
;; difficulty is supporting both forms of editing in the same environment. A
;; final problem is that it is not just the editing environment that needs to
;; be adapted; the programmatic environment needs to be untroubled by the
;; documentation, and the documentation environment untroubled by the program
;; code.
;; Lenticular text provides an alternative solution. Two lentic buffers, by
;; default, the share content but are otherwise independent. Therefore,
;; you can have two buffers open, each showing the content in different modes;
;; to switch modes, you simply switch buffers. The content, location of point,
;; and view are shared.
;; Moreover, lentic buffers can also perform a bi-directional transformation
;; between the two. If this is done, then the two can have different but
;; related text. This also solves the problem of integration with a
;; tool-chain; each lentic buffer can be associated with a different file and
;; a different syntax. For example, this file is, itself, lenticular text. It
;; can be viewed either as Emacs-Lisp or in Org-Mode. In Emacs-Lisp mode, this
;; text is commented out, in org-mode it is not.
;; In fact, although the default behaviour of lentic appears to keep the same
;; text in each buffer, even it uses this bi-directional transformation
;; capability; while the text is shared, the text properties are not. This is
;; a behaviour which differs between lentic buffers and indirect buffers. The
;; lentic buffers can therefore be in different modes without fighting each
;; other to set the text properties.
;; It is possible to configure the transformation for any two buffers in a
;; extensible way. Mostly I have concentrated on mode-specific operation,
;; but, for instance, I have also used this ability on a per-project basis
;; controlling, for instance, the location of the lentic-file.
;;; Usage:
;; lentic can be installed from GNU ELPA/Marmalade then add
;; (global-lentic-mode 1)
;; to your init file.
;; The main user entry points are accessible through the lentic edit menu, or
;; through `global-lentic-mode' which adds keybindings to create and manipulate
;; new lentic buffers. See `lentic-mode' commentary for more information.
;; By default, the lentic buffer created contains exactly the same contents as
;; the original buffer, but is otherwise separate; it can have a different major
;; modes, different syntax highlighting, invisible regions and even different
;; narrowing. Saving one buffer will save the other; killing the lentic buffer
;; does not affect the original, but killing the original also kills the lentic.
;; While this is somewhat useful, more generally a buffer will be configured to
;; produce a particular transformation. This can control many features of the
;; lentic, including the file name, major mode and an arbitrary transformation
;; between the two. Configuration is considered next.
;;; Configuration:
;; lentic buffers are configurable in a large number of ways. It is possible
;; to control the nature of the transformation, the default buffer name that a
;; lentic buffer takes, and the file location (or not) of the lentic buffer.
;; Lentic now supports any number of lentic buffers, in relatively arbitrary
;; geometries, although this requires additional support from the
;; configuration objects.
;; Configuration of a buffer happens in one of two places. First,
;; `lentic-init' is run when a lentic buffer is first created. This function
;; should return the configuration object, and is mostly designed for use as a
;; file-local or dir-local variable. This object is stored in the `lentic-config'
;; and all subsequent operation happens through this.
;; There are now a number of different configurations, which can be used for
;; general-purposes use as well as an extension points for subclass
;; configurations. The two most general configurations are:
;; - default: this copies all text exactly, but does not transfer
;; text-properties (which is the behaviour of indirect buffers). It is
;; possible to configure the default file or mode on a per-object basis.
;; - chunk: this is designed for programmatic syntaxes where chunks of code are
;; demarcated by start and end tags, and everything else is commented by
;; line-start comments. Comments are added or removed between the two buffers.
;; The second of these is extended in lentic-org.el to provide the
;; configuration for this file: there is a normal emacs-lisp file in one buffer
;; and an org-mode version in another. Other programmatic and documentation modes
;; are supported in other files.
;;; Status:
;; This is a beta release, but is now nearly feature complete. The core lentic
;; libraries should hopefully be fairly stable now, however, there is the
;; possibility that it will behave badly and may result in data loss. Please
;; use with care on files with backups.
;; Previous releases of this package were called "linked-buffer". I changed
;; this because I wanted a name for the general idea of text with two
;; visualisations; "linked text" doesn't work because it is sounds like
;; hyperlinked text.
;; Although it is still too early to guarantee, I hope that the current
;; configuration scheme will remain fixed, and subclass extensions should
;; require little change for the future.
;;; Code:
;; #+BEGIN_SRC emacs-lisp
(require 'eieio)
(require 'm-buffer)
(require 'm-buffer-at)
(require 'dash)
(defvar lentic-doc "lenticular.org")
(defvar lentic-doc-html-files '("lenticular.css"))
;; #+end_src
;; ** State
;; This section defines all of the variables that the basic state for lentic
;; is stored in. We deliberately have as few of these as possible, as this
;; makes re-initializing the state during development as straight-forward as
;; possible.
;; We start with `lentic-init' which provides the ability to define some default
;; configuration for a buffer. These are just functions which return
;; `lentic-configuration' objects. This is a slight step of indirection but is
;; essentially there to allow the use of file- or dir-local variables to define
;; the default behaviour for a given buffer. All the values have to be defined by
;; the user as safe, so we do not want too many different values.
;; #+begin_src emacs-lisp
(defvar lentic-init nil
"Function that initializes lentics for this buffer.
This should be one or a list of functions that each return a
`lentic-configuration' object.")
(make-variable-buffer-local 'lentic-init)
;; #+end_src
;; The `lentic-config' variable stores all of the configuration objects for each
;; lentic-buffer of this-buffer. Each lentic-buffer should have one configuration
;; object and is this configuration object that controls the behaviour and
;; updating of that lentic. As lentics are bi-directional, the `lentic-config'
;; variable should be -- for each lentic-configuration object in this-buffer
;; pointing to that-buffer there should be one in that-buffer pointing to
;; this-buffer. This variable has to `permanent-local' otherwise a new mode (or
;; typing `normal-mode') would break everything.
;; #+begin_src emacs-lisp
(defvar lentic-config nil
"Configuration for lentic.
This is a list of objects of the class `lentic-configuration'
lentic-configuration', which defines the way in which the text in
the different buffers is kept synchronized. This configuration is
resilient to changes of mode in the current buffer.")
(make-variable-buffer-local 'lentic-config)
(put 'lentic-config 'permanent-local t)
(defvar lentic-counter 0)
(defun lentic-config-name (buffer)
"Given BUFFER, return a name for the configuration object."
(format "lentic \"%s:%s\"" buffer (setq lentic-counter (+ 1 lentic-counter))))
;;;###autoload
(defvar lentic-init-functions nil
"All functions that can be used as `lentic-init' function.")
;; #+end_src
;; ** Base Configuration
;; This section defines the base class and generic methods for all
;; lentic-configuration objects. Most of the properties of this class define the
;; behaviour of the lentic-buffer -- in other words they are configuration.
;; However, there are a few properties which store state about the last
;; before-change event that occured which are used to percolate the changes
;; correctly. This is a handy place to store these, but are not really
;; end-user properties.
;; #+begin_src emacs-lisp
(defclass lentic-configuration ()
((this-buffer
:initarg :this-buffer
:documentation
"The this-buffer for this configuration. This should be the
current-buffer when this configuration is present in `lentic-config'." )
(that-buffer
:initarg :that-buffer
:documentation
"The that-buffer for this configuration. The that-buffer (if
live) should a lentic-configuration object for this-buffer in
its `lentic-config'." )
(creator
:initarg :creator ;; FIXME: Not used.
:initform nil
:documentation
"Non-nil if this lentic-configuration was used to create a
lentic view. This is used to determine the behaviour when the
buffer is killed: killing the creator kills all views, but killing
a view does not kill the creator.")
(delete-on-exit
:initarg :delete-on-exit
:initform nil
:documentation
"Non-nil if the file associated with this should be deleted on exit.")
(singleton ;; FIXME: Not used?
:initarg :singleton
:initform nil
:documentation
"Non-nil if only one lentic (and therefore object) of this type
can exist for a given buffer.")
(sync-point
:initarg :sync-point
:initform t
:documentation
"Non-nil if changes to the location of point in this-buffer
should be percolated into that-buffer.")
(last-change-start
:initarg :last-change-start ;; FIXME: Not used.
:initform nil
:documentation
"The location of the start of the last before-change event.
This should only be set by lentic.")
(last-change-start-converted
:initarg :last-change-start-converted ;; FIXME: Not used.
:initform nil
:documentation
"The location of the start of the last before-change event,
converted into the equivalent location in that-buffer. This
should only be set by lentic.")
(last-change-stop
:initarg :last-change-stop ;; FIXME: Not used.
:initform nil
:documentation
"The location of the stop of the last before-change event.
This should only be set by lentic." )
(last-change-stop-converted
:initarg :last-change-stop-converted ;; FIXME: Not used.
:initform nil
"The location of the stop of the last before-change event,
converted into the equivalent location in that-buffer. This
should only be set by lentic."))
"Configuration object for lentic which defines the behavior of
the lentic buffer.")
;; #+end_src
;; We define a set of generic methods. I am not entirely sure what the purpose of
;; generic methods are and whether I need them or not; I think it's just a place
;; to put the documentation.
;; #+begin_src emacs-lisp
(cl-defgeneric lentic-create (conf)
"Create the lentic for this configuration.
Given a `lentic-configuration' object, create the lentic
appropriate for that configurationuration. It is the callers
responsibility to check that buffer has not already been
created.")
(cl-defgeneric lentic-convert (conf location)
"Convert LOCATION in this-buffer to an equivalent location in
that-buffer. LOCATION is a numeric location, rather than a
marker. By equivalent, we mean the same semantic location as
determined by the transformation between the buffers. It is
possible that a given LOCATION could map to more than one
location in the lentic buffer.")
(cl-defgeneric lentic-clone (conf)
"Updates that-buffer to reflect the contents in this-buffer.
Updates at least the region that has been given between start and
stop in the this-buffer, into the region start-converted and
stop-converted in that-buffer.
Returns a list of the start location in that-buffer of the
change, the stop location in that-buffer of the change and the
length-before in that buffer of the region changed before the
change, if and only if the changes are exactly that suggested by
the START, STOP, _LENGTH-BEFORE, START-CONVERTED and
STOP-CONVERTED. Otherwise, this should return nil.")
;; #+end_src
;; We need an invert method because we can create the configuration object for a
;; this-buffer without actually creating that-buffer. This may happen at any
;; point in the future. So, the configuration object needs to be able to return
;; it's own inverse. This can be a configuration object of the same class which
;; is normal when the lentic transformation is symmetrical, or a different class
;; which is normal when the lentic transformation is asymmetrical.
;; #+begin_src emacs-lisp
(cl-defgeneric lentic-invert (conf)
"Return a new configuration object for the lentic buffer.
This method is called at the time that the lentic is created. It
is the callers responsibility to ensure that this is only called
at creation time and not subsequently. The invert function should
only return the configuration object and NOT create the lentic
buffer.")
;; #+end_src
;; `lentic-coexist?' has been created to cope with the case when a buffer has two
;; or more default views. We may wish to re-initialize all the default lentic
;; views. However, this is going to be problematic if some are already there --
;; we will end up with two many. In general, configurations which have been
;; created as a result of calls to the `lentic-init' functions should return
;; false here if there is another call to the same function. Lentic buffers which
;; are being used as a persistent view should generally return true here so that
;; as many can be created as required.
;; #+begin_src emacs-lisp
(cl-defgeneric lentic-coexist? (this-conf that-conf)
"Return non-nil if THIS-CONF and co-exist with THAT-CONF.
By co-exist this means that both configurations are valid for a
given buffer at the same time. A nil return indicates that there
should only be one of these two for a given buffer.")
;; #+end_src
;; I've implemented `lentic-this' and `lentic-that' as methods although I think I
;; have only over-ridden the implementation once in lentic-delayed which has
;; since been deleted anyway.
;; #+begin_src emacs-lisp
(cl-defmethod lentic-this ((conf lentic-configuration))
"Returns this-buffer for this configuration object.
In most cases, this is likely to be the `current-buffer' but
this should not be relied on."
(oref conf this-buffer))
(cl-defmethod lentic-that ((conf lentic-configuration))
"Returns the that-buffer for this configuration object.
This may return nil if there is not that-buffer, probably because
it has not been created."
(and (slot-boundp conf 'that-buffer)
(oref conf that-buffer)))
(cl-defmethod lentic-ensure-that ((conf lentic-configuration))
"Get the lentic for this configuration
or create it if it does not exist."
(or (lentic-that conf)
(lentic-create conf)))
;; #+end_src
;; This part of the user interface is not ideal at the moment. I need something
;; which allows me to see all the currently active lentic-buffers, but I am far
;; from convinced that the mode-line is the best place, since the mode-line gets
;; overly full for most users.
;; As a second problem, supporting mode-line display directly in the
;; configuration object seems right, and breaks the encapsulation between
;; lentic.el and lentic-mode.el. Probably this needs to be replaced by some sort
;; of status keyword return value.
;; #+begin_src emacs-lisp
(cl-defmethod lentic-mode-line-string ((conf lentic-configuration))
"Returns a mode-line string for this configuration object."
(when (slot-boundp conf 'that-buffer)
(let ((that (oref conf that-buffer)))
(if
(and that
(buffer-live-p that))
"on"
""))))
;; #+end_src
;; ** Default Configuration
;; This is the default implementation of a lentic configuration. It provides an
;; identity transformation at that string level -- the two buffers will (should!)
;; have identical `buffer-string' at all times. Or, more strictly, identical
;; without properties, so identical ~(buffer-substring-no-properties (point-min)
;; (point-max))~, which is not nearly so snappy.
;; We add two more properties to this class -- perhaps these should be pushed upwards.
;; #+begin_src emacs-lisp
(defclass lentic-default-configuration (lentic-configuration)
((lentic-file
:initform nil
:initarg :lentic-file
:documentation
"The name of the file that will be associated with that lentic buffer.")
(lentic-mode
:initform nil
:initarg :lentic-mode ;; FIXME: Not used.
:documentation
"The mode for that lentic buffer."))
"Configuration which maintains two lentics with the same contents.")
;; #+end_src
;; We add in a string transformation function here. There has no actual
;; function within lentic per se, but it is used in lentic-dev as something we
;; can advice. This avoids bulking up the code in lentic, while still allows
;; me to affect the transformation during development of new transforms.
;; #+begin_src emacs-lisp
(defun lentic-insertion-string-transform (string)
"Transform the STRING that is about to be inserted.
This function is not meant to do anything. It's useful to
advice."
string)
;; #+end_src
;; The default methods should be self-explanatory!
;; #+begin_src emacs-lisp
(cl-defmethod lentic-create ((conf lentic-default-configuration))
"Create an new lentic buffer. This creates the new buffer sets
the mode to the same as the main buffer or which ever is
specified in the configuration. The current contents of the main
buffer are copied."
;; make sure the world is ready for lentic buffers
(lentic-ensure-hooks)
;; create lentic
(let* ((this-buffer
(lentic-this conf))
(that-buffer
(generate-new-buffer
(format "*lentic: %s*"
(buffer-name
this-buffer))))
(sec-file (oref conf lentic-file))
(sec-mode
(or
;; the specified normal mode
(oref conf lentic-mode)
;; if we have a file try normal mode
(if sec-file
'normal-mode
;; otherwise the same mode as the main file
major-mode))))
(oset conf creator t)
;; make sure this-buffer knows about that-buffer
(oset conf that-buffer that-buffer)
;; init that-buffer with mode, file and config
;; the mode must be init'd after adding content in case there are any
;; file-local variables need to be evaled
;; insert the contents
(lentic-update-contents conf)
(with-current-buffer that-buffer
(when sec-mode
(funcall sec-mode))
(when sec-file
(set-visited-file-name sec-file))
(setq lentic-config
(list (lentic-invert conf))))
that-buffer))
(defun lentic--file-equal-p (f1 f2)
(let ((a1 (file-attributes f1))
(a2 (file-attributes f2)))
(and a1 (equal a1 a2))))
(cl-defmethod lentic-coexist? ((this-conf lentic-default-configuration)
that-conf)
"By default, we can have multiple lentic buffers with the same
configuration, unless specifically disallowed, or unless it has
the same associated file as pre-existing buffer (which is going
to break!)."
(and
(not (oref this-conf singleton))
(not
(and (oref this-conf lentic-file)
(oref that-conf lentic-file)
(lentic--file-equal-p
(oref this-conf lentic-file)
(oref that-conf lentic-file))))))
(cl-defmethod lentic-invert ((conf lentic-default-configuration))
"By default, return a clone of the existing object, but switch
the this and that buffers around. "
(clone
conf
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)
:sync-point (oref conf sync-point)))
(cl-defmethod lentic-convert ((_conf lentic-default-configuration)
location)
"The two buffers should be identical, so we just return the
same location."
location)
(cl-defmethod lentic-clone ((conf lentic-configuration)
&optional start stop _length-before
start-converted stop-converted)
"The default clone method cuts out the before region and pastes
in the new."
(let ((this-b (lentic-this conf))
(that-b (lentic-that conf)))
(with-current-buffer this-b
;;(lentic-log "this-b (point,start,stop)(%s,%s,%s)" (point) start stop)
(save-window-excursion
(save-restriction
(widen)
(let* ((start (or start (point-min)))
(stop (or stop (point-max))))
(with-current-buffer that-b
(save-restriction
(widen)
;; get the start location that we converted before the change.
;; lentic-convert is not reliable now, because the two
;; buffers do not share state until we have percolated it
(let ((converted-start
(max (point-min)
(or start-converted
(point-min))))
(converted-stop
(min (point-max)
(or stop-converted
(point-max)))))
(delete-region converted-start
converted-stop)
(save-excursion
(goto-char converted-start)
;; so this insertion is happening at the wrong place in block
;; comment -- in fact, it's happening one too early
(insert
(with-current-buffer this-b
;; want to see where it goes
;; hence the property
(lentic-insertion-string-transform
(buffer-substring-no-properties
start stop))))
(list converted-start
(+ converted-start (- stop start))
(- converted-stop converted-start))))))))))))
;;;###autoload
(defun lentic-default-init ()
"Default init function.
see `lentic-init' for details."
(lentic-default-configuration
:this-buffer (current-buffer)))
(add-to-list 'lentic-init-functions #'lentic-default-init)
;; #+end_src
;; ** Basic Operation
;; In this section, we define some utility functions and the hooks we need into
;; the core Emacs operations.
;; *** Utility
;; We start with some utility macros. These deal with the fact that a buffer can
;; have a lentic or not, and that even if it does that lentic does not need to be
;; live. This happens for instance if a lentic buffer is deleted -- the buffer
;; object will still be live (because the configuration object hangs on to it).
;; At some point, the hook system needs to clean this up by detecting the
;; buffer-kill and removing the configuration objection.
;; #+begin_src emacs-lisp
(defmacro lentic-when-lentic (&rest body)
"Evaluate BODY when the `current-buffer' has a lentic buffer."
(declare (debug t))
`(when (and
lentic-config
(-any?
(lambda (conf)
(-when-let
(buf (lentic-that conf))
(buffer-live-p buf)))
lentic-config))
,@body))
(defmacro lentic-when-buffer (buffer &rest body)
"When BUFFER is a live buffer eval BODY."
(declare (debug t)
(indent 1))
`(when (buffer-live-p ,buffer)
,@body))
(defmacro lentic-when-with-current-buffer (buffer &rest body)
"When BUFFER is a live buffer eval BODY with BUFFER current."
(declare (debug t)
(indent 1))
`(lentic-when-buffer ,buffer
(with-current-buffer ,buffer
,@body)))
(defmacro lentic-with-lentic-buffer (buffer &rest body)
"With BUFFER as current, eval BODY when BUFFER has a lentic."
(declare (debug t)
(indent 1))
`(lentic-when-with-current-buffer ,buffer
(when lentic-config
,@body)))
(defvar lentic-condition-case-disabled
noninteractive
"If non-nil throw exceptions from errors.
By default this is set to the value of noninteractive, so that
Emacs crashes with backtraces in batch." )
(defmacro lentic-condition-case-unless-disabled (var bodyform &rest handlers)
"Like `condition-case' but can be disabled like `condition-case-unless-debug'."
(declare (debug condition-case) (indent 2))
`(if lentic-condition-case-disabled
,bodyform
(condition-case-unless-debug ,var
,bodyform
,@handlers)))
(defmacro lentic-widen (conf &rest body)
"Widen both buffers in CONF, then evaluate BODY."
(declare (debug t)
(indent 1))
`(with-current-buffer
(lentic-that ,conf)
(save-restriction
(widen)
(with-current-buffer
(lentic-this ,conf)
(save-restriction
(widen)
,@body)))))
;; #+end_src
;; Recurse down the lentic tree to all lentic views.
;; #+begin_src emacs-lisp
(defun lentic-each (buffer fn &optional seen-buffer)
"Starting at BUFFER, call FN on every lentic-buffer.
FN should take a single argument which is the buffer.
SEEN-BUFFER is a list of buffers to ignore."
(lentic-with-lentic-buffer buffer
(setq seen-buffer (cons buffer seen-buffer))
(-map
(lambda (conf)
(let ((that
(lentic-that conf)))
(when (and (not (-contains? seen-buffer that))
(buffer-live-p that))
(funcall fn that)
(lentic-each that fn seen-buffer))))
lentic-config)))
(defun lentic-garbage-collect-config ()
"Remove non-live configs in current-buffer."
(setq lentic-config
(--filter
(buffer-live-p
(lentic-that it))
lentic-config)))
;; #+end_src
;; *** Initialisation
;; #+begin_src emacs-lisp
(defun lentic-ensure-init ()
"Ensure that the `lentic-init' has been run."
(lentic-garbage-collect-config)
(setq lentic-config
;; and attach to lentic-config
(-concat
lentic-config
;; return only those that can co-exist
(-filter
(lambda (this-conf)
(-all?
(lambda (that-conf)
(lentic-coexist? this-conf that-conf))
lentic-config))
(-map
(lambda (init)
;; instantiate a new conf object (but do not create the buffer)
(funcall init))
(if (not lentic-init)
'(lentic-default-init)
(-list lentic-init)))))))
(defun lentic-init-all-create ()
"Create all lentics fo the current buffer."
(lentic-ensure-init)
(-map
(lambda (conf)
(if (and
(slot-boundp conf 'that-buffer)
(buffer-live-p
(lentic-that conf)))
(lentic-that conf)
(lentic-create conf)))
(-list lentic-config)))
;; #+end_src
;; *** Hook System
;; The lentic hook system is relatively involved, unfortunately, and will
;; probably become more so. In so far as possible, though, all of the complexity
;; should be here, using the methods provided in the lentic-configuration object.
;; The complexity of the hook system and the fact that it is hooked deeply into
;; the core of Emacs can make it quite hard to debug. There are a number of
;; features put in place to help deal with this. These are:
;; - A logging system
;; - An emergency detection system.
;; - Two part hooks
;; Start by enabling hooks!
;; #+begin_src emacs-lisp
(defun lentic-ensure-hooks ()
"Ensures that the hooks that this mode requires are in place."
(add-hook 'post-command-hook
#'lentic-post-command-hook)
;; FIXME: Do we really need these hook functions to affect *all* buffers?
(add-hook 'after-change-functions
#'lentic-after-change-function)
(add-hook 'before-change-functions
#'lentic-before-change-function)
(add-hook 'after-save-hook
#'lentic-after-save-hook)
(add-hook 'kill-buffer-hook
#'lentic-kill-buffer-hook)
(add-hook 'kill-emacs-hook
#'lentic-kill-emacs-hook))
;; #+end_src
;; The logging system which allows post-mortem analysis of what lentic has done.
;; Originally, my plan was to leave logging in place so aid analysis of bug
;; reports, but this requires so much logging that it the log buffer becomes
;; impossible to analyse.
;; #+begin_src emacs-lisp
(defvar lentic-log nil)
(defmacro lentic-log (&rest rest)
"Log REST."
`(when lentic-log
(lentic-when-lentic
(let ((msg
(concat
(format ,@rest)
"\n")))
(princ msg #'external-debugging-output)))))
;; #+end_src
;; An emergency detection system. Several of the hooks in use (post-command-hook,
;; and the before- and after-change-functions) automatically remove hook
;; functions which give errors. In development, this means that all errors are
;; silently ignored and, worse, lentic continues in an inconsistent state with
;; some hooks working and some not. Lentic catches all errors, therefore, and
;; then drops into an "lentic-emergency" state, where all lentic functionality is
;; disabled. This is still a dangerous state as changes do not percolate, but at
;; least it should be predictable. The emergency state can be changed with
;; `lentic-unemergency' and `lentic-emergency'.
;; #+begin_src emacs-lisp
(defvar lentic-emergency nil
"Iff non-nil halt all lentic activity.
This is not the same as disabling lentic mode. It stops all
lentic related activity in all buffers; this happens as a result
of an error condition. If lentic was to carry on in these
circumstances, serious data loss could occur. In normal use, this
variable will only be set as a result of a problem with the code;
it is not recoverable from a user perspective.
It is useful to toggle this state on during development. Once
enabled, buffers will not update automaticaly but only when
explicitly told to. This is much easier than try to debug errors
happening on the after-change-hooks. The
function `lentic-emergency' and `lentic-unemergency' functions
enable this.")
(defvar lentic-emergency-debug nil
"Iff non-nil, lentic will store change data, even
during a `lentic-emergency'.
Normally, `lentic-emergency' disables all activity, but this makes
testing incremental changes charge. With this variable set, lentic will
attempt to store enough change data to operate manually. This does require
running some lentic code (notably `lentic-convert'). This is low
risk code, but may still be buggy, and so setting this variable can cause
repeated errors.")
(defun lentic-emergency ()
"Stop lentic from working due to code problem."
(interactive)
(setq lentic-emergency t)
(lentic-update-all-display))
(defun lentic-unemergency ()
"Start lentic working after stop due to code problem."
(interactive)
(setq lentic-emergency nil)
(lentic-update-all-display))
(defun lentic-hook-fail (err hook)
"Give an informative message when we have to fail.
ERR is the error. HOOK is the hook type."
(message "lentic mode has failed on \"%s\" hook: %s "
hook (error-message-string err))
(lentic-emergency)
(with-output-to-temp-buffer "*lentic-fail*"
(princ "There has been an error in lentic-mode.\n")
(princ "The following is debugging information\n\n")
(princ (format "Hook: %s\n" hook))
(princ (error-message-string err)))
(select-window (get-buffer-window "*lentic-fail*")))
;; #+end_src
;; As a byproduct of the last, lentic also has two part hooks: the real hook
;; function which just handles errors and calls the second function which does
;; the work. This make it possible to call the second function interactively,
;; without catching errors (so that they can be debugged) or causing the
;; lentic-emergency state. There are some utility functions in lentic-dev for
;; running hooks which require arguments.
;; **** General Hook
;; Start by handling saving, killing and general connecting with the Emacs
;; behaviour.
;; #+begin_src emacs-lisp
(defun lentic-after-save-hook ()
"Error protected call to real after save hook."
(unless lentic-emergency
(lentic-condition-case-unless-disabled err
(lentic-after-save-hook-1)
(error
(lentic-hook-fail err "after-save-hook")))))
(defun lentic-after-save-hook-1 ()
"Respond to a save in the `current-buffer'.
This also saves every lentic which is file-associated."
(lentic-each
(current-buffer)
(lambda (buffer)
(with-current-buffer
buffer
(when (buffer-file-name)
(save-buffer))))))
(defvar lentic-kill-retain nil
"If non-nil retain files even if requested to delete on exit.")
(defun lentic-kill-buffer-hook ()
"Error protected call to real `kill-buffer-hook'."
(unless lentic-emergency
(lentic-condition-case-unless-disabled err
(lentic-kill-buffer-hook-1)
(error
(lentic-hook-fail err "kill-buffer-hook")))))
(defvar lentic--killing-p nil)
(defun lentic-kill-buffer-hook-1 ()
"Respond to any buffer being killed.
If this killed buffer is lentic and is `creator', then kill all
lentic-buffers recursively. If the buffer is `delete-on-exit',
then remove any associated file."
(lentic-when-lentic
(when
(and
(--any?
(oref it delete-on-exit)
lentic-config)
;; might not exist if we not saved yet!
(file-exists-p buffer-file-name)
;; if we are cloning in batch, we really do not want to kill
;; everything at the end
(not noninteractive)
;; or we have blocked this anyway
(not lentic-kill-retain))
(delete-file buffer-file-name))
;; if we were the creator buffer, blitz the lentics (which causes their
;; files to delete also).
;; FIXME: "-p" is for *p*redicates, not boolean values.
(defvar lentic-killing-p)
(let ((lentic-killing-p t))
(when
(and
(not lentic-killing-p)
(--any?
(oref it creator)
lentic-config))
(lentic-each
(current-buffer)
#'kill-buffer)))))
(defun lentic-kill-emacs-hook ()
"Error protected call to real `kill-emacs-hook'."
(unless lentic-emergency
(lentic-condition-case-unless-disabled err
(lentic-kill-emacs-hook-1)
(error
(lentic-hook-fail err "kill-emacs-hook")))))
(defun lentic-kill-emacs-hook-1 ()
"Respond to `kill-emacs-hook.
This removes any files associated with lentics which are
marked as :delete-on-exit."
(-map
(lambda (buffer)
(lentic-with-lentic-buffer
buffer
(-map
(lambda (conf)
(and
(oref conf delete-on-exit)
(file-exists-p buffer-file-name)
(not noninteractive)
(delete-file (buffer-file-name))))
lentic-config)))
(buffer-list)))
;; #+end_src
;; **** Change Hooks
;; Handling and percolating changes is the most complex part of lentic, made more
;; complex still by the decision to support multiple buffers (why did I do that
;; to myself?).
;; The `post-command-hook' just percolates location of point through all the
;; lentic buffers.
;; #+begin_src emacs-lisp
(defun lentic-post-command-hook ()
"Update point according to config, with error handling."
(unless lentic-emergency
(lentic-condition-case-unless-disabled err
(progn
;; we test for this later anyway, but this makes it easier to debug.
(when lentic-config
(lentic-post-command-hook-1 (current-buffer))))
(error
(lentic-hook-fail err "post-command-hook")))))
(defun lentic-post-command-hook-1 (buffer &optional seen-buffer)
"Update point in BUFFER according to config.
SEEN-BUFFER is a list of lentics that have already been updated."
(lentic-with-lentic-buffer
buffer
;; now we have seen this buffer don't look again
(setq seen-buffer (cons buffer seen-buffer))
;; for all configurations
(-map
(lambda (config)
(let ((that
(lentic-that config)))
;; check for the termination condition
(unless (-contains? seen-buffer that)
(lentic-when-buffer
that
;; then update and recurse
(lentic-update-point config))
(lentic-post-command-hook-1 (lentic-that config) seen-buffer))))
lentic-config)))
;; #+end_src
;; The `after-change-function' is by far the most complex of the hooks. This is because
;; we have to percolate the changes from the buffer that has changed as a result
;; of the user doing something to all the other buffers. In theory, this should be
;; straight-forward: combined with the `before-change-function', the data from
;; the `after-change-function' defines a "dirty region" which we need to update
;; by copying from the parent and then doing what ever transformation needs to
;; happen. The problem is that that the contract from the configuration objects'
;; `lentic-clone' method is that *at least* the dirty region will be replaced.
;; `lentic-clone' can actually replace much more than this, and often needs to do
;; so, to ensure a consistent transformation.
;; So, when a lentic-buffer updates it needs to update it's own dirty region but
;; also return the dirty region that it has created, so that any lentic buffers
;; that it in turn has that are still to be updated can be so. Or, if it doesn't,
;; we just assume the whole buffer is dirty which is safe but inefficient.
;; The main after-change-function also stores the its arguments if we are in
;; debug mode which allows me to run `lentic-after-change-function-1'
;; interactively with the correct arguments.
;; #+begin_src emacs-lisp
(defvar lentic-emergency-last-change nil)
(make-variable-buffer-local 'lentic-emergency-last-change)
(defun lentic-after-change-transform (_buffer _start _stop _length-before)
"Function called after every change percolated by lentic.
This function does nothing and is meant for advising. See
lentic-dev."
)
(defun lentic-after-change-function (start stop length-before)
"Run change update according to `lentic-config'.
Errors are handled.
START is at most the start of the change.
STOP is at least the end of the change.
LENGTH-BEFORE is the length of the area before the change."
;; store values in case we want to use them
(when lentic-emergency-debug
(setq lentic-emergency-last-change (list start stop length-before)))
(unless lentic-emergency
(lentic-condition-case-unless-disabled err
(lentic-after-change-function-1
(current-buffer) start stop length-before)
(error
(lentic-hook-fail err "after change")))))
(defun lentic-after-change-function-1
(buffer start stop
length-before &optional seen-buffer)
"Run change update according to `lentic-config'.
BUFFER is the changed buffer.
START is at most the start of the change.
STOP is at least the end of the change.
LENGTH-BEFORE is the length of the area before the change.
SEEN-BUFFER is a list of buffers to which we have already percolated
the change."
(lentic-with-lentic-buffer buffer
(setq seen-buffer (cons buffer seen-buffer))
(-map
(lambda (config)
(unless
(or (-contains? seen-buffer (lentic-that config))
(not (buffer-live-p (lentic-that config))))
(let ((updates
(or
(lentic-update-contents config
start stop length-before)
'(nil nil nil))))
(apply #'lentic-after-change-transform
(lentic-that config)
updates)
(lentic-after-change-function-1
(lentic-that config)
(nth 0 updates)
(nth 1 updates)
(nth 2 updates)
seen-buffer))))
lentic-config)))
;; #+end_src
;; We also need to store the location of the area to be changed before the change
;; happens. Further, we need to convert this at this time to the cognate
;; positions in the lentic buffers. This is because it is only before the change
;; that this-buffer and the lentic buffers are in a consistent state; after the
;; change, this-buffer will have changes not percolated to other buffers. By
;; making this conversion now, we can ease the implementation of the
;; `lentic-convert' function because it does not have to cope with buffers with
;; inconsistent content.
;; #+begin_src emacs-lisp
(defun lentic-before-change-function (start stop)
"Error protected call to real `before-change-function'.
START is at most the start of the change.
STOP is at least the end of the change."
(unless (and
lentic-emergency
(not lentic-emergency-debug))
(lentic-condition-case-unless-disabled err
(lentic-before-change-function-1 (current-buffer) start stop)
(error
(lentic-hook-fail err "before change")))))
(defun lentic-before-change-function-1 (buffer start stop &optional seen-buffer)
"Calculate change position in all lentic buffers.
BUFFER is the buffer being changed.
START is at most the start of the change.
STOP is at least the end of the change.
SEEN-BUFFER is a list of buffers to which the change has been percolated."
(lentic-with-lentic-buffer buffer
(setq seen-buffer (cons buffer seen-buffer))
(-map
(lambda (config)
(unless
(or (-contains? seen-buffer (lentic-that config))
;; convert uses that buffer
(not (buffer-live-p (lentic-that config))))
(lentic-widen
config
(oset config last-change-start start)
(oset config
last-change-start-converted
(lentic-convert
config
start))
(oset config last-change-stop stop)
(oset config
last-change-stop-converted
(lentic-convert
config
stop))
(lentic-before-change-function-1
(lentic-that config)
(oref config last-change-start-converted)
(oref config last-change-stop-converted)
seen-buffer))))
lentic-config)))
;; #+end_src
;; The `lentic-update-contents' actually transfers changes from one buffer to all
;; the lentics. Unfortunately before-change-function and after-change-function
;; are not always consistent with each other. So far the main culprit I have
;; found is `subst-char-in-region', which is used under the hood of
;; `fill-paragraph'. On the b-c-f this reports the real start of the change and
;; the *maximal* end, while on the a-c-f it reports both the real start and real
;; end. Unfortunately, we did our conversion to the cognate positions in the
;; b-c-f *and* we need these values.
;; The overestimate give inconsistency between the length before on a-c-f (which
;; is the actual length) and the difference between b-c-f start and stop (which
;; is the maximal change). Unfortunately, this can also occur in some correct
;; circumstances -- replace-match for example can both insert and change
;; simultaneously.
;; So, the only solution that I have is to use a heuristic to detect /skew/ --
;; when I think the b-c-f and a-c-f are inconsistent, and if it finds it, then
;; use a full clone (i.e. the whole buffer is dirty).
;; I need to do a full survey of all the functions that call b-c-f/a-c-f (there
;; are not that many of them!) and rewrite them to all do-the-right thing. Need
;; to learn C first!
;; #+begin_src emacs-lisp
(defun lentic-update-contents (conf &optional start stop length-before)
"Update the contents of that-buffer with the contents of this-buffer.
update mechanism depends on CONF.
START is at most the start of the change.
STOP is at least the end of the change.
LENGTH-BEFORE is the length of area before the change."
(let ((inhibit-read-only t)
(no-fall-back
(and start stop length-before)))
(when
(and no-fall-back
(< (+ start length-before) (oref conf last-change-stop)))
(let ((diff
(- (oref conf last-change-stop)
(+ start length-before))))
(lentic-log "Skew detected %s" this-command)
(cl-incf length-before diff)
(cl-incf stop diff)))
(m-buffer-with-markers
((start-converted
(when
(and no-fall-back
(oref conf last-change-start-converted))
(set-marker (make-marker)
(oref conf last-change-start-converted)
(lentic-that conf))))
(stop-converted
(when
(and no-fall-back
(oref conf last-change-stop-converted))
(set-marker (make-marker)
(oref conf last-change-stop-converted)
(lentic-that conf)))))
;; used these, so dump them
(oset conf last-change-start nil)
(oset conf last-change-start-converted nil)
(oset conf last-change-stop nil)
(oset conf last-change-stop-converted nil)
(lentic-widen
conf
(if (not no-fall-back)
(lentic-clone conf)
(lentic-clone conf start stop length-before
start-converted stop-converted))))))
(defun lentic-update-point (conf)
"Update the location of point in that-buffer to reflect this-buffer.
This also attempts to update any windows so that they show the
same top-left location. Update details depend on CONF."
;; only sync when we are told to!
(when (oref conf sync-point)
(let* ((from-point
(lentic-convert
conf
(m-buffer-at-point
(lentic-this conf))))
(from-window-start
(lentic-convert
conf
(window-start
(get-buffer-window
(lentic-this conf))))))
;; clone point in buffer important when the buffer is NOT visible in a
;; window at all
;;(lentic-log "sync(front-point)(%s)" from-point)
(with-current-buffer
(lentic-that conf)
(goto-char from-point))
;; now clone point in all the windows that are showing the buffer
;; and set the start of the window which is a reasonable attempt to show
;; the same thing.
(mapc
(lambda (window)
(with-selected-window window
(progn
(goto-char from-point)
(set-window-start window from-window-start))))
(get-buffer-window-list (lentic-that conf))))))
;; #+end_src
;; Ugly, ugly, ugly. Not happy with mode-line behaviour anyway, so this will
;; probably change into the future.
;; #+begin_src emacs-lisp
;; put this here so we don't have to require lentic-mode to ensure that the
;; mode line is updated.
(defun lentic-update-display ()
"Update the display with information about lentic's state."
(when (fboundp 'lentic-mode-update-mode-line)
(lentic-mode-update-mode-line)))
(defun lentic-update-all-display ()
(when (fboundp 'lentic-mode-update-all-display)
(lentic-mode-update-all-display)))
;; #+end_src
;; *** Utility
;; Just a couple of convenience functions for operating on eieio objects. The
;; native `oset' only allows setting a single property-value pair which is
;; irritating syntactically, and it does not return the object which prevents
;; function chaining. Taken together, these really simplify construction of
;; objects.
;; #+begin_src emacs-lisp
(defun lentic-m-oset (obj &rest plist)
"On OBJ set all properties in PLIST.
Returns OBJ. See also `lentic-a-oset'"
(lentic-a-oset obj plist))
(defun lentic-a-oset (obj plist)
"On OBJ, set all properties in PLIST.
This is a utility function which just does the same as oset, but
for lots of things at once. Returns OBJ."
(dolist (n (-partition 2 plist))
(eieio-oset obj (car n) (cadr n)))
obj)
;; #+end_src
;; ** Batch Functions
;; These functions are for batch operation on lentic buffers. Mostly, these
;; are useful for writing tests, but they can be useful for generating
;; the lentic form of a file during any automated pipeline.
;; #+begin_src emacs-lisp
(defun lentic-batch-clone-and-save-with-config (filename init)
"Open FILENAME, set INIT function, then clone and save.
This function does potentially evil things if the file or the
lentic is open already."
(let ((retn))
(with-current-buffer
(find-file-noselect filename)
(setq lentic-init init)
(with-current-buffer
(car
(lentic-init-all-create))
(setq retn lentic-config)
(save-buffer)
(kill-buffer))
(kill-buffer))
retn))
(defun lentic-batch-clone-with-config
(filename init)
"Open FILENAME, set INIT function, then clone.
Return the lentic contents without properties."
(let ((retn nil))
(with-current-buffer
(find-file-noselect filename)
(setq lentic-init init)
(with-current-buffer
(car
(lentic-init-all-create))
(setq retn
(buffer-substring-no-properties
(point-min)
(point-max)))
(set-buffer-modified-p nil)
;; don't delete -- we haven't saved but there
;; might already be a file with the same name,
;; which will get deleted
(oset (car lentic-config) delete-on-exit nil)
(kill-buffer))
(set-buffer-modified-p nil)
(kill-buffer))
retn))
(provide 'lentic)
;;; lentic.el ends here
;; #+END_SRC
;;; lentic-script.el -- Config for scripts -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2016-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; #+begin_src emacs-lisp
(require 'lentic-cookie)
(require 'lentic-chunk)
(require 'lentic-org)
(defvar lentic-script-temp-location
temporary-file-directory "/lentic-script")
;;;###autoload
;; We need to copy this entire form into the autoloads file. If we use a
;; normal autoload, it force loading of the entire package when it is called
;; during autoload which defeats the point. Unfortunately, autoload files are
;; normally dynamically bound, and we use closures. The eval form addresses
;; both of these simultaneously.
(eval
'(defun lentic-script-hook (mode-hook init)
(add-to-list 'lentic-init-functions init)
(add-hook mode-hook
(lambda nil
(unless (bound-and-true-p lentic-init)
(setq lentic-init init)))))
t)
(defun lentic-script--lentic-file-2 (file)
(concat
lentic-script-temp-location
(substring
(file-name-sans-extension file)
1)
".org"))
(defun lentic-script--lentic-file-1 (file)
(let ((l
(lentic-script--lentic-file-2 file)))
(make-directory (file-name-directory l) t)
l))
(defun lentic-script-lentic-file ()
(lentic-script--lentic-file-1 (buffer-file-name)))
;;;###autoload
(defun lentic-python-script-init ()
(lentic-org-python-oset
(lentic-cookie-unmatched-commented-chunk-configuration
:lentic-file
(lentic-script-lentic-file))))
;;;###autoload
(lentic-script-hook 'python-mode-hook
'lentic-python-script-init)
;;;###autoload
(defun lentic-bash-script-init ()
(lentic-cookie-unmatched-commented-chunk-configuration
:this-buffer (current-buffer)
:comment "## "
:comment-stop "#\\+BEGIN_SRC sh"
:comment-start "#\\+END_SRC"
:lentic-file
(lentic-script-lentic-file)))
;;;###autoload
(lentic-script-hook 'shell-mode-hook
'lentic-bash-script-init)
;;;###autoload
(defun lentic-lua-script-init ()
(lentic-cookie-unmatched-commented-chunk-configuration
:this-buffer (current-buffer)
:comment "-- "
:comment-stop "#\\+BEGIN_SRC lua"
:comment-start "#\\+END_SRC"
:case-fold-search nil
:lentic-file
(lentic-script-lentic-file)))
;;;###autoload
(lentic-script-hook 'lua-mode-hook
#'lentic-lua-script-init)
(provide 'lentic-script)
;;; lentic-script ends here
;; #+end_src
;;; lentic-rot13.el --- rot13 support for lentic -*- lexical-binding: t; -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; At some point in your life you may find yourself thinking, what would the
;; text that I am writing now look like in rot13? Of course, you could just
;; convert it, but really is to see the visualisation as you type. That
;; would be useful!
;; Now you can.
;; Or more seriously, this is meant as a minimal example of how do implement a
;; new lentic-buffer-configuration.
;;; Code:
;; #+BEGIN_SRC emacs-lisp
(require 'lentic)
(require 'rot13)
;; #+end_src
;; Lentic uses EIEIO objects to define the transformation between lentic buffers.
;; In this case, we extend the default configuration class. We need to add
;; nothing to the base class or constructor; all changes happen with the generic
;; methods.
;; #+begin_src emacs-lisp
(defclass lentic-rot13-configuration (lentic-default-configuration) ())
;; #+end_src
;; The clone method defines how to keep the buffers in sync. We defer most of the
;; work to the superclass method, and then simply rot13 the region that has
;; changed.
;; The semantics of the parameters are a little complex. The =start= and =stop=
;; parameters define the region in =this= buffer that has been changed, while
;; =start-converted= and =stop-converted= define the equivalent region *before*
;; the change in =that= buffer.
;; In this example, we are making implicit use of the fact that we can convert
;; directly between a location in the two buffers. In future versions of
;; =lentic-clone= will probably return the changed region directly.
;; #+begin_src emacs-lisp
(cl-defmethod lentic-clone ((conf lentic-rot13-configuration)
&optional start stop &rest _)
(cl-call-next-method)
;; and rot13 it!
(with-current-buffer
(lentic-that conf)
(save-restriction
(rot13-region
(or start (point-min))
(or stop (point-max))))))
;; #+end_src
;; Lentic buffers have a bi-directional link between them. So, while /this/
;; buffer may create /that/ buffer, after the initial creation, the two are
;; equivalent lenticular views of each other. In terms of lentic, therefore, at
;; creation time, we need to be able to /invert/ the configuration of /this/
;; buffer to create a configuration for /that/ buffer which defines the
;; transformation from /that/ to /this/.
;; In this case, the rot13 transformation is symmetrical, so the conversion from
;; /that/ to /this/ uses an object of the same class as from /this/ to /that/.
;; #+begin_src emacs-lisp
(cl-defmethod lentic-invert ((conf lentic-rot13-configuration))
(lentic-rot13-configuration
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)))
;; #+end_src
;; And, finally, we need to create a function which will construct a new object.
;; This has to be no-args because it is added as a symbol to `lentic-config'. It
;; is this function which creates the configuration for initial buffer.
;; #+begin_src emacs-lisp
(defun lentic-rot13-init ()
(lentic-rot13-configuration
:this-buffer (current-buffer)))
(provide 'lentic-rot13)
;;; lentic-rot13.el ends here
;; #+END_SRC
(define-package "lentic" "20240303.1456" "One buffer as a view of another"
'((emacs "25")
(m-buffer "0.13")
(dash "2.5.0"))
:commit "180c1082c016de790f9e6596b63329657c83ce20" :authors
'(("Phillip Lord" . "phillip.lord@russet.org.uk"))
:maintainers
'(("Phillip Lord" . "phillip.lord@russet.org.uk"))
:maintainer
'("Phillip Lord" . "phillip.lord@russet.org.uk"))
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; lentic-ox.el --- Exporter backend for orgel documentation -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; An org-mode exporter for lentic.
;;; Code:
;; #+begin_src emacs-lisp
(require 'ox-html)
(require 'dash)
;; Define an exporter
(org-export-define-derived-backend 'lentic
'html
:filters-alist
'((:filter-parse-tree . lentic-ox-filter-parse-tree)
(:filter-section . lentic-ox-filter-section)))
;; Main export function
(defun lentic-ox-html-export-to-html ()
"Export the current buffer to a HTML file."
(interactive)
(let* ((extension (concat "." org-html-extension))
(file (org-export-output-file-name extension))
(org-export-coding-system org-html-coding-system)
(org-html-htmlize-output-type 'css)
(org-html-postamble nil)
(org-html-use-infojs t)
(org-html-head
"<link rel=\"stylesheet\" type=\"text/css\" href=\"http://phillord.github.io/lentic/include/lenticular.css\" />"))
(org-export-to-file 'lentic file)))
(defvar lentic-ox-no-export-headers '("Header")
"List of headers to which noexport tags should be added.")
(defun lentic-ox-filter-parse-tree (tree _back-end _info)
"Filter preventing the export of specific headers.
TREE is the parse tree. BACK-END is the symbol specifying
back-end used for export. INFO is a plist used as a communication
channel."
(org-element-map tree 'headline
(lambda (head)
(if (-contains?
lentic-ox-no-export-headers
(org-element-property
:raw-value
head))
(org-element-put-property
head :tags
(cons "noexport"
(org-element-property :tags head)))
head)))
tree)
(defun lentic-ox-filter-section (section back-end info)
"Currently does nothing useful."
section back-end info
(org-element-property :parent section)
section
)
(provide 'lentic-ox)
;;; lentic-ox.el ends here
;; #+end_src
;;; lentic-org.el --- org support for lentic -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides lentic for org and emacs-lisp files. This enables a
;; literate form of programming with Elisp, using org mode to provide
;; documentation mark up.
;; It provides too main ways of integrating between org and emacs-lisp. The
;; first which we call org-el (or el-org) is a relatively simple translation
;; between the two modes.
;; #+BEGIN_SRC emacs-lisp
(require 'cl-lib)
(require 'rx)
(require 'lentic-chunk)
(require 'm-buffer-at)
;; #+END_SRC
;;; Code:
;; ** Simple org->el
;; The simple transformation between org and elisp is to just comment out
;; everything that is not inside a BEGIN_SRC/END_SRC chunk. This provides only
;; minimal advantages over the embedded org mode environment. Org, for instance,
;; allows native fontification of the embedded code (i.e. elisp will be coloured
;; like elisp!), which is something that org-el translation also gives for free;
;; in this case of org-el, however, when the code is high-lighted, the org mode
;; text is visually reduced to `comment-face'. The other key advantage is
;; familiarity; it is possible to switch to the `emacs-lisp-mode' buffer and
;; eval-buffer, region or expression using all the standard keypresses.
;; One problem with this mode is that elisp has a first line semantics for
;; file-local variables. This is a particular issue if setting `lexical-binding'.
;; In a literate org file, this might appear on the first line of the
;; embedded lisp, but it will *not* appear in first line of an emacs-lisp
;; lentic, so the file will be interpreted with dynamic binding.
;; *** Implementation
;; The implementation is a straight-forward use of `lentic-chunk' with
;; regexps for org source chunks. It currently takes no account of
;; org-mode :tangle directives -- so all lisp in the buffer will be present in
;; the emacs-lisp mode lentic.
;; #+BEGIN_SRC emacs-lisp
(defun lentic-org-oset (conf)
(lentic-m-oset
conf
'this-buffer (current-buffer)
'comment ";; "
'comment-stop "#\\+BEGIN_SRC emacs-lisp.*"
'comment-start "#\\+END_SRC"))
;;;###autoload
(defun lentic-org-el-init ()
(lentic-org-oset
(lentic-unmatched-uncommented-chunk-configuration
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".el"))))
(add-to-list 'lentic-init-functions #'lentic-org-el-init)
;;;###autoload
(defun lentic-el-org-init ()
(lentic-org-oset
(lentic-unmatched-commented-chunk-configuration
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".org"))))
(add-to-list 'lentic-init-functions #'lentic-el-org-init)
;; #+END_SRC
;; ** orgel->org
;; In this section, we define a different transformation from what we call an
;; orgel file. This is a completely valid emacs-lisp file which transforms
;; cleanly into a valid org file. This requires constraits on both the emacs-lisp
;; and org representation. However, most of the features of both modes are
;; available.
;; The advantages of orgel files over a tangle-able literate org file are
;; several. The main one, however, is that the =.el= file remains a source
;; format. It can be loaded directly by Emacs with `load-library' or `require'.
;; Developers downloading from a VCS will find the =.el= file rather than looking
;; for an =.org= file. Developers wishing to offer patches can do so to the =.el=
;; file. Finally, tools which work over =.el= such as checkdoc will still work.
;; Finally, there is no disjoint between the org file and the emacs-lisp
;; comments. The commentary section, for example, can be edited using `org-mode'
;; rather than as comments in an elisp code chunk.
;; The disadvantages are that the structure of the org file is not arbitrary; it
;; most follow a specific structure. Without an untangling process, things like
;; noweb references will not work.
;; The transformation (orgel -> org) works as follows:
;; - the first line summary is transformed into a comment in org
;; - all single word ";;;" headers are transformed into level 1 org headings.
;; - ";;" comments are removed except inside emacs-lisp source chunks.
;; *** Converting an Existing file
;; It is relatively simple to convert an existing emacs-lisp file, so that it
;; will work with the orgel transformation. orgel files work with (nearly) all
;; existing Emacs-Lisp documentaton standards but have a few extra bits added
;; in to work with org.
;; Current ";;;" section demarcation headers in emacs-lisp are used directly
;; and are transformed into Section 1 headings in org-mode. Unfortunately, in
;; emacs-lisp the header is *not* explicitly marked -- it's just the start
;; to the ";;; Commentary:" header. To enable folding of the header,
;; therefore, you need to introduce a ";;; Header:" line *after* the first line.
;; You may also wish to add a ";;; Footer:" heading as well.
;; Secondly, mark *all* of the code with org-mode source demarks. Finally, set
;; `lentic-init' to `lentic-orgel-org-init' (normally with a
;; file-local or dir-local variable). Now lentic can be started. The
;; header will appear as normal text in the org-mode buffer, with all other
;; comments inside a source chunk. You can now move through the buffer splitting
;; the source chunk (with `org-babel-demarcate-block' which has to win a prize
;; for the most obscurely named command), and move comments out of the source
;; chunk into the newly created text chunk.
;; *** Limitations
;; Currently, the implementation still requires some extra effort from the elisp
;; side, in that lisp must be marked up as a source code block. The short term
;; fix would be to add some functionality like `org-babel-demarcate-block' to
;; emacs-lisp-mode. Even better would to automatically add source markup when "("
;; was pressed at top level (if paredit were active, then it would also be
;; obvious where to put the close). Finally, have both `lentic-org' and
;; `org-mode' just recognise emacs-lisp as a source entity *without* any further
;; markup.
;; Finally, I don't like the treatment of the summary line -- ideally this should
;; appear somewhere in the org file not as a comment. I am constrained by the
;; start of file semantics of both =.org= and =.el= so this will probably remain.
;; The content can always be duplicated which is painful, but the summary line is
;; unlikely to get updated regularly.
;; *** Implementation
;; The main transformation issue is the first line. An =.el= file has a summary
;; at the top. This is checked by checkdoc, used by the various lisp management
;; tools, which in turn impacts on the packaging tools. Additionally, lexical
;; binding really must be set here.
;; We solve this problem by transforming the first line ";;;" into "# #". Having
;; three characters means that the width is maintained. It also means I can
;; distinguish between this kind of comment and an "ordinary" `org-mode' comment;
;; in practice, this doesn't matter, because I only check on the first line. The
;; space is necessary because `org-mode' doesn't recognised "###" as a comment.
;; Another possibility would be to transform the summary line into a header. I
;; choose against this because first it's not really a header being too long and
;; second `org-mode' uses the space before the first header to specify, for
;; example, properties relevant to the entire tree. This is prevented if I make
;; the first line a header 1.
;; **** org to orgel
;; Here we define a new class or org-to-orgel, as well as clone function which
;; adds the ";;;" header transformation in addition to the normal chunk semantics
;; from the superclass. Currently only single word headers are allowed which
;; seems consistent with emacs-lisp usage.
;; #+BEGIN_SRC emacs-lisp
(defclass lentic-org-to-orgel-configuration
(lentic-unmatched-chunk-configuration lentic-uncommented-chunk-configuration)
())
(defun lentic-org--first-line-fixup (conf first-line-end)
"Fixup the first line of an org->orgel file.
This swaps lines of form:
;; ;;; or
# #
into
;;;"
(m-buffer-replace-match
(m-buffer-match
(lentic-that conf)
;; we can be in one of two states depending on whether we have made a new
;; clone or an incremental change
(rx
(and line-start ";; "
(submatch (or ";;;"
"# #"))))
:end first-line-end)
";;;"))
(defun lentic-org--h1-fixup-from-start (conf first-line-end)
"Fixup h1 with start
This swaps lines of form
;; * Header
or
;; * Header :tag:
into
;;; Header: :tag:"
(m-buffer-replace-match
(m-buffer-match
(lentic-that conf)
(rx
(and line-start ";; * "
(submatch (1+ word))
(optional
(submatch
(0+ " ")
":" (1+ word) ":"))))
:begin first-line-end)
";;; \\1:\\2"))
(defun lentic-org--h1-fixup-from-semi (conf first-line-end)
"Fixup h1 with semis"
(m-buffer-replace-match
(m-buffer-match
(lentic-that conf)
(rx
(and line-start
";; ;;; "
(submatch (1+ word))
(optional ":")
(optional
(submatch
(0+ " ")
":" (1+ word) ":"))))
:begin first-line-end)
";;; \\1:\\2"))
(cl-defmethod lentic-clone
((conf lentic-org-to-orgel-configuration)
&optional start stop length-before
start-converted stop-converted)
;; do everything else to the buffer
(m-buffer-with-markers
((first-line
(m-buffer-match-first-line
(lentic-this conf)))
(header-one-line
(m-buffer-match
(lentic-this conf)
(rx line-start
"* " (0+ word)
(optional (1+ " ")
":" (1+ word) ":")
line-end)
:begin (cl-cadar first-line)))
(special-lines
(-concat first-line header-one-line)))
;; check whether we are in a special line -- if so widen the change extent
(let*
((start-in-special
(when
(and
start
(m-buffer-in-match-p
special-lines start))
(m-buffer-at-line-beginning-position
(lentic-this conf)
start)))
(start (or start-in-special start))
(start-converted
(if start-in-special
(m-buffer-at-line-beginning-position
(lentic-that conf)
start-converted)
start-converted))
(stop-in-special
(when
(and
stop
(m-buffer-in-match-p
special-lines stop))
(m-buffer-at-line-end-position
(lentic-this conf)
stop)))
(stop (or stop-in-special stop))
(stop-converted
(if stop-in-special
(m-buffer-at-line-end-position
(lentic-that conf)
stop-converted)
stop-converted))
(clone-return
(cl-call-next-method conf start stop length-before
start-converted stop-converted))
(first-line-end-match
(cl-cadar
(m-buffer-match-first-line
(lentic-that conf))))
;; can't just use or here because we need non-short circuiting
(c1 (lentic-org--first-line-fixup conf first-line-end-match))
;; replace big headers, in either of their two states
(c2 (lentic-org--h1-fixup-from-start conf first-line-end-match))
(c3 (lentic-org--h1-fixup-from-semi conf first-line-end-match)))
(if (or start-in-special stop-in-special c1 c2 c3)
nil
clone-return))))
(cl-defmethod lentic-convert
((conf lentic-org-to-orgel-configuration)
location)
(let ((converted (cl-call-next-method conf location)))
(m-buffer-with-current-position
(oref conf this-buffer)
location
(beginning-of-line)
(if (looking-at
(rx (submatch "* ")
(submatch (1+ word))
(optional (1+ " ")
":" (1+ word) ":")
line-end))
(cond
((= location (nth 2 (match-data)))
(m-buffer-at-line-beginning-position
(oref conf that-buffer)
converted))
((< location (nth 5 (match-data)))
(- converted 1))
(t
converted))
converted))))
(cl-defmethod lentic-invert
((conf lentic-org-to-orgel-configuration))
(lentic-m-oset
(lentic-orgel-org-init)
'that-buffer
(lentic-this conf)))
;;;###autoload
(defun lentic-org-orgel-init ()
(lentic-org-oset
(lentic-org-to-orgel-configuration
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".el"))))
(add-to-list 'lentic-init-functions #'lentic-org-orgel-init)
;; #+END_SRC
;; **** orgel->org
;; And the orgel->org implementation. Currently, this means that I have all the
;; various regexps in two places which is a bit ugly. I am not sure how to stop
;; this.
;; #+BEGIN_SRC emacs-lisp
(defvar lentic-orgel-org-init-hook nil)
;; shut byte compiler up and define var for setq-local
(defvar org-archive-default-command)
(defun lentic-orgel-org-init-default-hook (conf)
;; Better to open all trees in lentic so that both buffers appears the same
;; size.
(outline-show-all)
;; Archiving very easy to and almost always a disaster when it removes an
;; entire tree from the buffer.
(require 'org-archive)
;; shorten the fill column by 3, so that the emacs-lisp buffer is the
;; correct width.
(set-fill-column
(with-current-buffer
(lentic-that conf)
(- fill-column 3)))
(setq-local org-archive-default-command
(let ((old-archive
org-archive-default-command))
(lambda ()
(interactive)
(if (yes-or-no-p
"Really archive in lentic mode? ")
(funcall old-archive)
(message "Archiving aborted"))))))
(add-hook 'lentic-orgel-org-init-hook
#'lentic-orgel-org-init-default-hook)
(defclass lentic-orgel-to-org-configuration
(lentic-unmatched-chunk-configuration lentic-commented-chunk-configuration)
())
(cl-defmethod lentic-create ((conf lentic-orgel-to-org-configuration))
(let ((buf
(cl-call-next-method conf)))
(with-current-buffer
buf
(run-hook-with-args 'lentic-orgel-org-init-hook conf))
buf))
(cl-defmethod lentic-clone ((conf lentic-orgel-to-org-configuration) &rest _)
;; do everything else to the buffer
(let* ((clone-return (cl-call-next-method))
(m1
(m-buffer-replace-match
(m-buffer-match
(lentic-that conf)
";;; "
:end
(cl-cadar
(m-buffer-match-first-line
(lentic-that conf))))
"# # "))
(m2
(m-buffer-replace-match
(m-buffer-match (lentic-that conf)
(rx line-start ";;; "
(submatch (0+ word))
":"
(optional
(submatch
(0+ " ")
":" (1+ word) ":"))
line-end))
"* \\1\\2")))
(unless
;; update some stuff
(or m1 m2)
;; and return clone-return unless we have updated stuff in which case
;; return nil
clone-return)))
(cl-defmethod lentic-convert
((conf lentic-orgel-to-org-configuration)
location)
;; if we are a header one and we are *after* the first :, then just call
;; next-method.
(let* ((cnm
(cl-call-next-method conf location))
(line-start-that
(m-buffer-at-line-beginning-position
(oref conf that-buffer) cnm))
(line-start-this
(m-buffer-at-line-beginning-position
(oref conf this-buffer) location)))
(if
(m-buffer-with-current-position
(oref conf this-buffer)
location
(beginning-of-line)
(looking-at
(rx ";;; "
(1+ word)
(submatch ":")
(optional (1+ " ")
":" (1+ word) ":"))))
;; hey global state!
(let ((colon (nth 3 (match-data))))
;; if in the comments, just return the start of the
;; line, if we are after the comments but before the colon, fudge
;; it. If we are after the colon, count from the end
(cond
((> 3 (- location line-start-this))
line-start-that)
((> location colon)
cnm)
(t
(+ cnm 1))))
cnm)))
(cl-defmethod lentic-invert
((conf lentic-orgel-to-org-configuration))
(lentic-m-oset
(lentic-org-orgel-init)
'delete-on-exit t
'that-buffer (lentic-this conf)))
;;;###autoload
(defun lentic-orgel-org-init ()
(lentic-org-oset
(lentic-orgel-to-org-configuration
;; we don't really need a file and could cope without, but org mode assumes
;; that the buffer is file name bound when it exports. As it happens, this
;; also means that file saving is possible which in turn saves the el file
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".org"))))
(add-to-list 'lentic-init-functions #'lentic-orgel-org-init)
;; #+END_SRC
;; ** org->clojure
;; #+BEGIN_SRC emacs-lisp
(defun lentic-org-clojure-oset (conf)
(lentic-m-oset
conf
'this-buffer (current-buffer)
'comment ";; "
'comment-stop "#\\+BEGIN_SRC clojure.*"
'comment-start "#\\+END_SRC"))
;;;###autoload
(defun lentic-org-clojure-init ()
(lentic-org-clojure-oset
(lentic-unmatched-uncommented-chunk-configuration
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".clj"))))
(add-to-list 'lentic-init-functions #'lentic-org-clojure-init)
;;;###autoload
(defun lentic-clojure-org-init ()
(lentic-org-clojure-oset
(lentic-unmatched-commented-chunk-configuration
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".org"))))
(add-to-list 'lentic-init-functions #'lentic-clojure-org-init)
;; #+END_SRC
;; ** org->python
;; #+begin_src emacs-lisp
(defun lentic-org-python-oset (conf)
(lentic-m-oset
conf
'this-buffer (current-buffer)
'comment "## "
'comment-stop "#\\+BEGIN_SRC python.*"
'comment-start "#\\+END_SRC"))
;;;###autoload
(defun lentic-org-python-init ()
(lentic-org-python-oset
(lentic-unmatched-uncommented-chunk-configuration
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".py"))))
(add-to-list 'lentic-init-functions #'lentic-org-python-init)
;;;###autoload
(defun lentic-python-org-init ()
(lentic-org-python-oset
(lentic-unmatched-commented-chunk-configuration
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".org"))))
(add-to-list 'lentic-init-functions #'lentic-python-org-init)
;; #+end_src
;;; Footer:
;; Declare the end of the file, and add file-local support for orgel->org
;; transformation. Do not use lentics on this file while changing the
;; lisp in the file without backing up first!
;; #+BEGIN_SRC emacs-lisp
(provide 'lentic-org)
;;; lentic-org.el ends here
;; #+END_SRC
;;; lentic-mode.el --- minor mode for lentic buffers -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2024 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A minor mode for creating and manipulated lentic buffers.
;;; Code:
;; ** Preliminaries
;; #+begin_src emacs-lisp
(require 'lentic)
(require 'lentic-doc)
;; #+end_src
;; ** Utility
;; #+begin_src emacs-lisp
(defun lentic-mode-lentic-list (buffer)
"Return a list of all lentics for BUFFER.
Lentics are listed in an undefined order."
(lentic-mode--lentic-list-1 buffer nil))
(defun lentic-mode--lentic-list-1 (buffer _seen-buffer)
(let ((buffers))
(lentic-each
buffer
(lambda (b)
(push b buffers)))
buffers))
(defun lentic-mode-buffer-list (buffer &optional frame)
"Returns a list of all lentics for BUFFER.
Lentics are listed in the same order as in fundamental
`buffer-list'. or the frame local if FRAME is specified."
(let ((lentic-list
(lentic-mode-lentic-list buffer)))
(-filter
(lambda (b)
(-contains? lentic-list b))
(buffer-list frame))))
(defun lentic-mode-find-next-lentic-buffer (buffer &optional frame)
(car
(--drop-while
(eq buffer it)
(lentic-mode-buffer-list
buffer (or frame (selected-frame))))))
(defun lentic-mode-find-next-visible-lentic-buffer (buffer &optional frame)
(car
(--drop-while
(or (eq buffer it)
(not (get-buffer-window it frame)))
(lentic-mode-buffer-list
buffer (or frame (selected-frame))))))
(defun lentic-mode-find-next-non-visible-lentic-buffer (buffer &optional frame)
(car
(--drop-while
(or (eq buffer it)
(get-buffer-window it frame))
(lentic-mode-buffer-list
buffer (or frame (selected-frame))))))
;; #+end_src
;; ** Window and Buffer Functions
;; #+begin_src emacs-lisp
(defun lentic-mode-show-buffer-in-window (before-buffer new-buffer)
(let* ((buffer-window (get-buffer-window before-buffer))
(before-window-start
(window-start buffer-window))
(before-window-point
(m-buffer-at-point before-buffer)))
(set-window-buffer
buffer-window
new-buffer)
(set-window-start
buffer-window
before-window-start)
(goto-char before-window-point)
(bury-buffer before-buffer)))
;;;###autoload
(defun lentic-mode-create-from-init (&optional force)
(interactive "P")
(lentic-garbage-collect-config)
(if (and lentic-config (not force))
(message "Already initialized. C-u to force.")
(let ((before (length lentic-config))
(all (lentic-init-all-create)))
(message "Created %s buffers"
(- (length all)
before)))))
;;;###autoload
(defun lentic-mode-next-lentic-buffer ()
"Move the lentic buffer into the current window, creating if necessary."
(interactive)
(lentic-mode-show-buffer-in-window
(current-buffer)
(lentic-mode-find-next-lentic-buffer (current-buffer))))
;;;###autoload
(defun lentic-mode-split-window-below ()
"Move lentic buffer to the window below, creating if needed."
(interactive)
(-when-let
(next
(lentic-mode-find-next-non-visible-lentic-buffer
(current-buffer)))
(set-window-buffer
(split-window-below)
next)
next))
;;;###autoload
(defun lentic-mode-split-window-right ()
"Move lentic buffer to the window right, creating if needed."
(interactive)
(-when-let
(next
(lentic-mode-find-next-non-visible-lentic-buffer
(current-buffer)))
(set-window-buffer
(split-window-right)
next)
next))
;;;###autoload
(defun lentic-mode-show-all-lentic ()
(interactive)
(delete-other-windows)
(while
(lentic-mode-split-window-below))
(balance-windows))
(defun lentic-mode-swap-buffer-windows (a b)
"Swaps the window that two buffers are displayed in.
A and B are the buffers."
(let ((window-a (get-buffer-window a))
(window-b (get-buffer-window b)))
(when window-a
(set-window-buffer
window-a b))
(when window-b
(set-window-buffer
window-b a))))
;;;###autoload
(defun lentic-mode-move-lentic-window ()
"Move the next lentic buffer into the current window.
If the lentic is currently being displayed in another window,
then the current-buffer will be moved into that window. See also
`lentic-mode-swap-buffer-windows' and `lentic-mode-next-buffer'."
(interactive)
(let ((before-window-start
(window-start (get-buffer-window)))
(before-window-point
(point)))
(lentic-mode-swap-buffer-windows
(current-buffer)
(or
(lentic-mode-find-next-visible-lentic-buffer
(current-buffer))
(lentic-mode-find-next-lentic-buffer
(current-buffer))))
(set-window-start
(selected-window)
before-window-start)
(goto-char before-window-point)))
;;;###autoload
(defun lentic-mode-swap-lentic-window ()
"Swap the window of the buffer and lentic.
If both are current displayed, swap the windows they
are displayed in, which keeping current buffer.
See also `lentic-mode-move-lentic-window'."
(interactive)
(let ((next
(lentic-mode-find-next-visible-lentic-buffer
(current-buffer))))
(if (not next)
(message "Cannot swap windows when only one is visible")
(lentic-mode-swap-buffer-windows
(current-buffer)
next)
(when (window-live-p
(get-buffer-window
(current-buffer)))
(select-window
(get-buffer-window
(current-buffer)))))))
(defun lentic-mode-create-new-view ()
(let* ((conf (lentic-default-init))
(_ (oset conf
:sync-point nil))
(that (lentic-create conf)))
(setq lentic-config
(cons conf lentic-config))
that))
;;;###autoload
(defun lentic-mode-create-new-view-in-selected-window ()
(interactive)
(set-window-buffer
(selected-window)
(lentic-mode-create-new-view)))
(defun lentic-mode-force-clone-1 ()
(lentic-when-lentic
(let ((inhibit-modification-hooks t))
(lentic-after-change-function
(point-min) (point-max)
(- (point-max) (point-min))))))
(defun lentic-mode-force-clone ()
(interactive)
(when (yes-or-no-p "Force Clone of the current buffer? ")
(lentic-mode-force-clone-1)))
;; #+end_src
;; ** Minor Mode
;; #+begin_src emacs-lisp
;;;###autoload
(defun lentic-mode-toggle-auto-sync-point ()
(interactive)
(lentic-when-lentic
(oset lentic-config sync-point
(not (oref lentic-config sync-point)))))
(defvar lentic-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c ,c") #'lentic-mode-create-from-init)
(define-key map (kbd "C-c ,v")
#'lentic-mode-create-new-view-in-selected-window)
(define-key map (kbd "C-c ,n") #'lentic-mode-next-lentic-buffer)
(define-key map (kbd "C-c ,s") #'lentic-mode-swap-lentic-window)
(define-key map (kbd "C-c ,h") #'lentic-mode-move-lentic-window)
(define-key map (kbd "C-c ,b") #'lentic-mode-split-window-below)
(define-key map (kbd "C-c ,t") #'lentic-mode-split-window-right)
(define-key map (kbd "C-c ,f") #'lentic-mode-insert-file-local)
(define-key map (kbd "C-c ,a") #'lentic-mode-show-all-lentic)
map)
"Keymap for lentic-minor-mode")
(defcustom lentic-mode-line-lighter "Lentic"
"Default mode lighter for lentic"
:group 'lentic
:type 'string)
(defvar-local lentic-mode-line (format " %s[]" lentic-mode-line-lighter))
(defun lentic-mode-update-mode-line ()
(setq lentic-mode-line
(format " %s[%s]"
lentic-mode-line-lighter
(mapconcat #'lentic-mode-line-string
lentic-config
","))))
(defun lentic-mode-update-all-display ()
(if lentic-emergency
(setq lentic-mode-line
(format " %s[Emergency]" lentic-mode-line-lighter))
(dolist (b (buffer-list))
(lentic-when-with-current-buffer b
(lentic-mode-update-mode-line)))
(force-mode-line-update t)))
;; ** lentic self-doc
;; #+begin_src: emacs-lisp
;;;###autoload
(defun lentic-mode-doc-eww-view ()
(interactive)
(lentic-doc-eww-view 'lentic))
;;;###autoload
(defun lentic-mode-doc-external-view ()
(interactive)
(lentic-doc-external-view 'lentic))
;;;###autoload
(define-minor-mode lentic-mode
"Documentation"
:lighter lentic-mode-line)
;; FIXME: Cannot autoload this before `lentic.el' is loaded since otherwise
;; we get (void-variable lentic-config) errors in redisplay.
;; ;;;###autoload
(easy-menu-change
'("Edit")
"Lentic"
'(["Create All" lentic-mode-create-from-init
:active (not lentic-config)]
["Create View" lentic-mode-create-new-view-in-selected-window]
["Next" lentic-mode-next-lentic-buffer
:active lentic-config]
["Split Below" lentic-mode-split-window-below
:active lentic-config]
["Split Right" lentic-mode-split-window-right
:active lentic-config]
["Show All" lentic-mode-show-all-lentic
:active lentic-config]
["Swap" lentic-mode-swap-lentic-window
:active lentic-config]
["Force Clone" lentic-mode-force-clone
:active lentic-config]
["Insert File Local" lentic-mode-insert-file-local]
["Read Doc (eww)" lentic-mode-doc-eww-view]
["Read Doc (external)" lentic-mode-doc-external-view]
))
;;;###autoload
(defun lentic-mode-insert-file-local (init-function)
(interactive
(list (completing-read
"Lentic init function: "
(mapcar
#'symbol-name
lentic-init-functions)
nil 'confirm)))
(add-file-local-variable 'lentic-init (intern init-function)))
;;;###autoload
(define-globalized-minor-mode global-lentic-mode
lentic-mode
lentic-mode-on)
(defun lentic-mode-on ()
(lentic-mode 1))
;; #+end_src
(provide 'lentic-mode)
;;; lentic-mode.el ends here
;;; lentic-markdown.el -- Markdown literate programming -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; Version: 0.1
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A `lentic-chunk-configuration' environment where one buffer is markdown
;; and the other is some programming language. Only fenced code blocks
;; are supported as indentation based blocks is challenging.
;;; Code:
(require 'lentic-chunk)
(defun lentic-markdown-clojure-oset (conf)
(lentic-m-oset
conf
'this-buffer (current-buffer)
'comment ";; "
'comment-start "```$"
'comment-stop "```{.*}$"))
(defun lentic-clojure-to-markdown-new ()
(lentic-markdown-clojure-oset
(lentic-commented-chunk-configuration
:lentic-file
(concat (file-name-sans-extension buffer-file-name) ".md"))))
;;;###autoload
(defun lentic-clojure-markdown-init ()
(lentic-clojure-to-markdown-new))
(add-to-list 'lentic-init-functions #'lentic-clojure-markdown-init)
(provide 'lentic-markdown)
;; #+begin_src emacs-lisp
;;; lentic-latex-code.el -- Latex literate programming -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; Version: 0.1
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A `lentic-chunk-configuration' environment where one buffer is latex
;; and the other is some programming language, with code chunks marked up with
;; a =\begin{code}\end{code}= environment.
;; The code environment is not normally defined and has been picked for this
;; reason. It avoids defining multiple init functions for different macros;
;; instead the code chunks can be interpreted using what ever environment the
;; author wants, by defining the code environment first.
;;; Code:
;; #+begin_src emacs-lisp
(require 'lentic-chunk)
(defun lentic-latex-clojure-oset (conf)
(lentic-m-oset
conf
'this-buffer (current-buffer)
'comment ";; "
'comment-start "\\\\end{code}"
'comment-stop "\\\\begin{code}"))
(defun lentic-clojure-to-latex-new ()
(lentic-latex-clojure-oset
(lentic-commented-chunk-configuration
:lentic-file
(concat (file-name-sans-extension buffer-file-name) ".tex"))))
;;;###autoload
(defun lentic-clojure-latex-init ()
(lentic-clojure-to-latex-new))
(add-to-list 'lentic-init-functions #'lentic-clojure-latex-init)
(defun lentic-latex-to-clojure-new ()
(lentic-latex-clojure-oset
(lentic-uncommented-chunk-configuration
:lentic-file
(concat (file-name-sans-extension buffer-file-name) ".clj"))))
;;;###autoload
(defun lentic-latex-clojure-init ()
(lentic-latex-to-clojure-new))
(add-to-list 'lentic-init-functions #'lentic-latex-clojure-init)
;;;###autoload
(defun lentic-clojure-latex-delayed-init ()
(lentic-delayed-init #'lentic-clojure-latex-init))
(add-to-list 'lentic-init-functions #'lentic-clojure-latex-delayed-init)
;;;###autoload
(defun lentic-haskell-latex-init ()
(lentic-default-configuration
:this-buffer (current-buffer)
:lentic-file
(concat
(file-name-sans-extension buffer-file-name)
".tex")))
(add-to-list 'lentic-init-functions #'lentic-haskell-latex-init)
(provide 'lentic-latex-code)
;;; lentic-latex-code ends here
;; #+end_src
;;; lentic-doc.el --- Generate and View Documentation -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Lentic's self-hosting documentation system.
;;; Code:
;; #+begin_src emacs-lisp
(require 'eww)
(require 'ox-html)
(require 'browse-url)
(require 'lentic)
(require 'lentic-org)
(require 'lentic-ox)
;; #+end_src
;; #+begin_src emacs-lisp
(defvar lentic-doc--includes
'(("http://phillord.github.io/lentic/include/lenticular.css" .
"include/lenticular.css")
("http://orgmode.org/org-info.js" .
"include/org-info.js")
))
;; #+end_src
;; ** Orgify Package
;; #+begin_src emacs-lisp
(defun lentic-doc-stringify (str-or-sym)
(if (symbolp str-or-sym)
(symbol-name str-or-sym)
str-or-sym))
(defun lentic-doc-all-files-of-package (package)
"Fetch all the files that are part of package.
This function assumes that all the files are in one place and
follow the standard naming convention of using the package name
as a prefix. "
(let* ((main-file
(locate-library package))
(dir
(file-name-directory main-file))
(prefix
(concat dir package))
(others
(file-expand-wildcards
(concat prefix "*.el")))
(scripts
(file-expand-wildcards
(concat prefix "*.els"))))
(-remove
(lambda (file)
;; FIXME: Shouldn't this regexp have a \\' to make sure it matches the
;; end of the name?
(string-match-p "-\\(pkg\\|autoloads\\).el" file))
(append others scripts))))
(defun lentic-doc-orgify-if-necessary (file)
(let* ((target
(concat
(file-name-sans-extension file)
".org"))
(locked
(or (file-locked-p file)
(file-locked-p target)))
(open
(or
(get-file-buffer file)
(get-file-buffer target))))
(unless (or locked open)
(when (file-newer-than-file-p file target)
(let ((lentic-kill-retain t))
(lentic-batch-clone-and-save-with-config
file 'lentic-orgel-org-init))))))
(defun lentic-doc-orgify-all-if-necessary (files)
(-map 'lentic-doc-orgify-if-necessary files))
(defun lentic-doc-orgify-package (package)
(lentic-doc-orgify-all-if-necessary
(lentic-doc-all-files-of-package
(lentic-doc-stringify package))))
;; #+end_src
;; ** htmlify package
;; #+begin_src emacs-lisp
(defun lentic-doc-htmlify-package (package)
(let ((package
(lentic-doc-stringify package)))
(lentic-doc-orgify-package package)
(with-current-buffer
(find-file-noselect
(lentic-doc-package-start-source package))
(lentic-ox-html-export-to-html))))
;; #+end_src
;; #+begin_src emacs-lisp
;; remove when it gets into f.el
(defun lentic-f-swap-ext (file ext)
"Return FILE but with EXT as the new extension.
EXT must not be nil or empty."
(if (member ext '(nil ""))
(error "extension cannot be empty or nil")
(concat (file-name-sans-extension file) "." ext)))
(defun lentic-doc-package-start-source (package)
(let ((doc-var
(intern
(concat package "-doc"))))
(if (boundp doc-var)
;; if it is set to a boolean return the implicit start
(if (booleanp
(symbol-value doc-var))
(lentic-doc-package-implicit-start-source package)
(expand-file-name
(symbol-value doc-var)
(file-name-directory (locate-library package))))
;; get the default
(let*
((main-file
(locate-library package))
(doc-file
(when main-file
(expand-file-name
(concat
(file-name-sans-extension main-file)
"-doc.org")
(file-name-directory main-file)))))
(when
(and doc-file
(file-exists-p doc-file))
doc-file)))))
(defun lentic-doc-package-implicit-start-source (package)
(-if-let (lib (locate-library package))
(let ((start
(lentic-f-swap-ext
lib
"org")))
(if (file-exists-p start)
start))))
(defun lentic-doc-package-doc-file (package)
(lentic-f-swap-ext
(lentic-doc-package-start-source package)
"html"))
(defvar lentic-doc-allowed-files nil)
(defun lentic-doc-ensure-allowed-html (package)
(let ((var (intern (concat package "-doc-html-files"))))
(if (boundp var)
(mapc
(lambda (f)
(add-to-list 'lentic-doc-allowed-files f))
(symbol-value var)))))
(defun lentic-doc-ensure-doc (package)
(lentic-doc-ensure-allowed-html package)
(unless (file-exists-p
(lentic-doc-package-doc-file package))
(lentic-doc-htmlify-package package)))
(defvar lentic-doc-lentic-features nil)
(defun lentic-doc-all-lentic-features-capture()
(setq lentic-doc-lentic-features
(cons
(length features)
(-map
(lambda (feat)
(symbol-name feat))
(-filter
(lambda (feat)
(lentic-doc-package-start-source
(symbol-name feat)))
features)))))
(defun lentic-doc-all-lentic-features ()
(unless
(and lentic-doc-lentic-features
(equal
(car lentic-doc-lentic-features)
(length features)))
(lentic-doc-all-lentic-features-capture))
(cdr lentic-doc-lentic-features))
(defun lentic-doc-external-view (package)
(interactive
(list
(completing-read
"Package Name: "
(lentic-doc-all-lentic-features))))
(let ((package (lentic-doc-stringify package)))
(lentic-doc-ensure-doc package)
(browse-url-default-browser
(lentic-doc-package-doc-file package))))
(defun lentic-doc-eww-view (package)
(interactive
(list
(completing-read
"Package Name: "
(lentic-doc-all-lentic-features))))
(let ((package (lentic-doc-stringify package)))
(lentic-doc-ensure-doc package)
(eww-open-file
(lentic-doc-package-doc-file package))))
(provide 'lentic-doc)
;; #+end_src
;;; lentic-dev.el --- Tools for developers -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2014-2024 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Developing support for new forms of lentic buffers is not trivial. This
;; file provides some support functions for doing so.
;;; Code:
;; #+begin_src emacs-lisp
(require 'lentic)
;; #+end_src
;; ** Manual Updates
;; Usually, lentic uses Emacs hooks to percolate changes in one buffer to
;; another. Unfortunately, all the hooks that do this not only silently discard
;; errors, but they delete the offending function from the hook. So, post-mortem
;; debugging is hard. Step-through is also hard since it happens in the command
;; loop.
;; Lentic has a function for disabling its functionality (due to breakage
;; rather than just normal switching it off), called `linked-buffer-emergency'
;; (and the inverse `linked-buffer-unemergency'). In this emergency state, we
;; can still run the hooks manually, which is by far the best way to debug them.
;; For the `lentic-test-after-change-function' to work `lentic-emergency-debug'
;; must be set. It is also critical that only a single change has happened before
;; this function is called -- otherwise the result of the previous change are
;; deleted, and the lentic buffers will update in an inconsistent and haphazard
;; way.
;; #+begin_src emacs-lisp
;;;###autoload
(defun lentic-dev-after-change-function ()
"Run the change functions out of the command loop.
Using this function is the easiest way to test an new
`lentic-clone' method, as doing so in the command loop is
painful for debugging. Set variable `lentic-emergency' to
true to disable command loop functionality."
(interactive)
(message "Running after change with args: %s"
lentic-emergency-last-change)
(apply #'lentic-after-change-function-1
lentic-emergency-last-change))
;;;###autoload
(defun lentic-dev-post-command-hook ()
"Run the post-command functions out of the command loop.
Using this function is the easiest way to test an new
`lentic-convert' method, as doing so in the command loop is
painful for debugging. Set variable `lentic-emergency' to
true to disable command loop functionality."
(interactive)
(lentic-post-command-hook-1 (current-buffer) '()))
;;;###autoload
(defun lentic-dev-after-save-hook ()
(interactive)
(let ((lentic-emergency nil))
(lentic-mode-after-save-hook)))
;;;###autoload
(defun lentic-dev-mode-buffer-list-update-hook ()
(interactive)
(let ((lentic-emergency nil))
(lentic-mode-buffer-list-update-hook)))
;;;###autoload
(defun lentic-dev-kill-buffer-hook ()
(interactive)
(let ((lentic-emergency nil))
(lentic-kill-buffer-hook)))
;;;###autoload
(defun lentic-dev-kill-emacs-hook ()
(interactive)
(let ((lentic-emergency nil))
(lentic-kill-emacs-hook)))
;;;###autoload
(defun lentic-dev-reinit ()
"Recall the init function regardless of current status.
This can help if you have change the config object and need
to make sure there is a new one."
(interactive)
(setq lentic-config nil)
(lentic-ensure-init))
;; #+end_src
;; ** Font-Lock changes
;; These commands enable or disable fontification of changes that lentic has
;; percolated. This is very useful for incremental changes; it's the only
;; practical way of seeing what has been copied.
;; The exact behaviour of this depends on the mode of the buffer displaying the
;; lentic buffer. Sometimes, the natural buffer fontification functions just
;; change the font back to whatever the syntax suggests. In this case, try
;; switching off `font-lock-mode'.
;; #+begin_src emacs-lisp
(defvar lentic-dev-insert-face 'font-lock-keyword-face
"Start face to use for inserted text.")
;;;###autoload
(defun lentic-dev-random-face ()
"Change the insertion face to a random one."
(interactive)
(setq lentic-dev-insert-face
(nth (random (length (face-list)))
(face-list)))
(message "Insert face is now %s"
(propertize
"this"
'face
lentic-dev-insert-face)))
(defun lentic-dev--face-transform (string)
(propertize
string
'font-lock-face
lentic-dev-insert-face
'face
lentic-dev-insert-face))
;;;###autoload
(define-minor-mode lentic-dev-enable-insertion-marking
"Enable font locking properties for inserted text."
:global t
:group 'lentic-dev
(if lentic-dev-enable-insertion-marking
(advice-add 'lentic-insertion-string-transform :override
#'lentic-dev--face-transform)
(advice-remove 'lentic-insertion-string-transform
#'lentic-dev--face-transform)))
(defun lentic-dev--pulse-transform (buffer start stop &rest _)
(with-current-buffer
buffer
(pulse-momentary-highlight-region
(or start (point-min))
(or stop (point-max)))))
;;;###autoload
(define-minor-mode lentic-dev-enable-insertion-pulse
"Enable momentary pulsing for inserted text."
:global t
:group 'lentic-dev
(if lentic-dev-enable-insertion-pulse
(advice-add 'lentic-after-change-transform :after
#'lentic-dev--pulse-transform)
(advice-remove 'lentic-after-change-transform
#'lentic-dev--pulse-transform)))
(defun lentic-dev-edebug-trace-mode ()
(setq edebug-initial-mode 'continue)
(setq edebug-trace t))
(defun lentic-dev-highlight-markers ()
(interactive)
(m-buffer-overlay-font-lock-face-match
(lentic-blk-marker-boundaries
(car lentic-config)
(current-buffer))
'highlight))
(provide 'lentic-dev)
;;; lentic-dev.el ends here
;; #+end_src
;;; lentic-cookie.el -- Lentic with a magic cookie -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the GPL License, Version 3.0.
;; Copyright (C) 2016-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
;; #+begin_src emacs-lisp
(require 'lentic)
(require 'lentic-chunk)
(defclass lentic-cookie-uncommented-configuration
(lentic-configuration)
()
:documentation "Configuration for a magic cookie containing
lentic buffer that is not commented.")
(defun lentic-cookie--uncommented-fixup-first-line-1 (buffer first-line-end
comment)
"Fixup the first line.
BUFFER is the buffer.
FIRST-LINE-END is the location of the end of the line.
BUFFER is the buffer *with* the comments rather than *without*
despite the name of the function!"
(m-buffer-nil-marker
(m-buffer-replace-match
(m-buffer-match
buffer
(rx-to-string
`(and line-start
(or
;; the line may have been commented during the update
,comment
;; the line may have the comment from org-mode
"# ")
;; and this is the actual start
"#!"))
:end first-line-end)
"#!")))
(defun lentic-cookie-uncommented-fixup-first-line (conf first-line-end)
"Fixup the first line.
CONF is the `lentic-configuration' object.
FIRST-LINE-END is the location of the end of the line."
(lentic-cookie--uncommented-fixup-first-line-1
(lentic-that conf) first-line-end
(oref conf comment)))
(cl-defmethod lentic-clone
((conf lentic-cookie-uncommented-configuration)
&optional start stop length-before
start-converted stop-converted)
(let ((clone-return
(cl-call-next-method conf start stop
length-before start-converted stop-converted)))
(if (lentic-cookie-uncommented-fixup-first-line
conf
(cl-cadar
(m-buffer-match-first-line
(lentic-this conf)
:numeric t)))
nil
clone-return)))
(defclass lentic-cookie-commented-configuration
(lentic-configuration)
()
:documentation "Configuration for magic cookie containing lentic file that is
commented.")
(defun lentic-cookie--commented-fixup-first-line-1 (buffer first-line-end)
"Fixup the first line.
BUFFER is the buffer.
FIRST-LINE-END is the location of the end of the line.
BUFFER is the buffer *without* the comments rather than *with*
despite the name of the function!"
(m-buffer-nil-marker
(m-buffer-replace-match
(m-buffer-match
buffer
(rx
(and line-start
(0+ anything)
"#!"))
:end first-line-end)
"# #!")))
(defun lentic-cookie-commented-fixup-first-line (conf first-line-end)
"Fixup the first line.
CONF is the `lentic-configuration' object.
FIRST-LINE-END is the location of the end of the line."
(lentic-cookie--commented-fixup-first-line-1
(lentic-that conf) first-line-end))
(cl-defmethod lentic-clone
((conf lentic-cookie-commented-configuration)
&optional start stop &rest _)
(let ((clone-return (cl-call-next-method)))
(if
(or
;; next method has done strange things
(not clone-return)
;; calling method is broad
(not start)
(not stop)
(m-buffer-with-markers
((first-line
(m-buffer-match-first-line
(lentic-this conf))))
(or
(m-buffer-in-match-p
first-line start)
(m-buffer-in-match-p
first-line stop))))
(progn
(lentic-cookie-commented-fixup-first-line
conf
(cl-cadar
(m-buffer-match-first-line
(lentic-this conf)
:numeric t)))
nil)
clone-return)))
(defclass lentic-cookie-unmatched-uncommented-chunk-configuration
(lentic-unmatched-uncommented-chunk-configuration
lentic-cookie-uncommented-configuration)
())
(cl-defmethod lentic-invert
((conf lentic-cookie-unmatched-uncommented-chunk-configuration))
(lentic-cookie-unmatched-commented-chunk-configuration
;; FIXME: Factor this out
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)
:comment (oref conf comment)
:comment-start (oref conf comment-start)
:comment-stop (oref conf comment-stop)))
(defclass lentic-cookie-unmatched-commented-chunk-configuration
(lentic-unmatched-commented-chunk-configuration
lentic-cookie-commented-configuration)
())
(cl-defmethod lentic-invert
((conf lentic-cookie-unmatched-commented-chunk-configuration))
(lentic-cookie-unmatched-uncommented-chunk-configuration
;; FIXME: Factor this out
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)
:comment (oref conf comment)
:comment-start (oref conf comment-start)
:comment-stop (oref conf comment-stop)))
(provide 'lentic-cookie)
;;; lentic-cookie ends here
;;; lentic-chunk.el --- Comment chunks in one buffer -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the LGPL License, Version 3.0.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; This program is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Lesser General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or (at your
;; option) any later version.
;; This program is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License
;; for more details.
;; You should have received a copy of the GNU Lesser General Public License
;; along with this program. If not, see http://www.gnu.org/licenses/.
;;; Commentary:
;; Lentic-chunk provides support for editing lentic buffers where there are large
;; documentation chunks in one view which must be commented out in the other,
;; where the chunks are demarked with some kind of delimitor.
;; This form is generally useful for forms of literate programming. For example,
;; we might embed Emacs-Lisp within LaTeX like so:
;; #+BEGIN_EXAMPLE
;; \begin{code}
;; (message "hello")
;; \end{code}
;; #+END_EXAMPLE
;; In this case, the =\begin{code}= macro defines the start of the code chunk. In
;; the code-centric view any lines not enclosed by the markers will be
;; commented-out, ensure that the documentation does not interfere with whatever
;; programming language is being used.
;; The implementation provided here is reasonably efficient, with only small
;; change regions being percolated.
;; This package does not provide any direct end-user configurations. These are
;; provided elsewhere.
;;; Code:
;; The implementation
;; ** Chunk Configuration
;; #+begin_src emacs-lisp
(require 'm-buffer)
(require 'm-buffer-at)
(require 'lentic)
(defclass lentic-chunk-configuration (lentic-default-configuration)
((comment :initarg :comment
:documentation "The comment character")
(comment-start :initarg :comment-start
:documentation
"Demarcation for the start of the commenting region")
(comment-stop :initarg :comment-stop
:documentation
"Demarcaction for the end of the commenting region.")
(case-fold-search :initarg :case-fold-search
:documentation
"Should match be case sensitive"
:initform :default)
(valid :initarg :valid
:documentation "True if markers in the buffer are valid"
:initform t))
:documentation "Base configuration for chunked lentics.
A chunked lentic is one where chunks of the buffer have a
start of line chunk comment in one buffer but not the other."
:abstract t)
(cl-defmethod lentic-mode-line-string ((conf lentic-chunk-configuration))
(if (not
(oref conf valid))
"invalid"
(cl-call-next-method conf)))
(cl-defmethod lentic-chunk-comment-start-regexp
((conf lentic-chunk-configuration))
;; todo -- what does this regexp do?
(format "^\\(%s\\)?%s"
(oref conf comment)
(oref conf comment-start)))
(cl-defmethod lentic-chunk-comment-stop-regexp
((conf lentic-chunk-configuration))
(format "^\\(%s\\)?%s"
(oref conf comment)
(oref conf comment-stop)))
(cl-defmethod lentic-chunk-line-start-comment
((conf lentic-chunk-configuration))
(concat "^"
(oref conf comment)))
(defun lentic-chunk-uncomment-region (conf begin end buffer)
"Given CONF, remove start-of-line characters in region.
Region is between BEGIN and END in BUFFER. CONF is a
function `lentic-configuration' object."
;;(lentic-log "uncomment-region (%s,%s)" begin end)
(m-buffer-with-markers
((comments
(m-buffer-match
buffer
(lentic-chunk-line-start-comment conf)
:begin begin :end end)))
(m-buffer-replace-match comments "")))
(defun lentic-chunk-uncomment-buffer (conf markers begin end buffer)
"Given CONF, a `lentic-configuration' object, remove all
start of line comment-characters in appropriate chunks. Changes
should only have occurred between BEGIN and END in BUFFER."
(-map
(lambda (pairs)
(let
((chunk-begin (car pairs))
(chunk-end (cadr pairs)))
(when
(and (>= end chunk-begin)
(>= chunk-end begin))
(lentic-chunk-uncomment-region
conf chunk-begin chunk-end buffer))))
markers))
(defun lentic-chunk-comment-region (conf begin end buffer)
"Given CONF, a `lentic-configuration' object, add
start of line comment characters beween BEGIN and END in BUFFER."
(m-buffer-with-markers
((line-match
(m-buffer-match
buffer
"\\(^\\).+$"
:begin begin :end end))
(comment-match
(m-buffer-match
buffer
;; start to end of line which is what this regexp above matches
(concat
(lentic-chunk-line-start-comment conf)
".*")
:begin begin :end end)))
(m-buffer-replace-match
(m-buffer-match-exact-subtract line-match comment-match)
(oref conf comment) nil nil 1)))
(defun lentic-chunk-comment-buffer (conf markers begin end buffer)
"Given CONF, a `lentic-configuration' object, add
start of line comment-characters. Changes should only have occurred
between BEGIN and END in BUFFER."
;; we need these as markers because the begin and end position need to
;; move as we change the buffer, in the same way that the marker boundary
;; markers do.
(m-buffer-with-markers
((begin (set-marker (make-marker) begin buffer))
(end (set-marker (make-marker) end buffer)))
(-map
;; comment each of these regions
(lambda (pairs)
(let
((chunk-begin (car pairs))
(chunk-end (cadr pairs)))
(when
(and (>= end chunk-begin)
(>= chunk-end begin))
(lentic-chunk-comment-region
conf chunk-begin chunk-end buffer))))
markers)))
(cl-defmethod lentic-chunk-marker-boundaries ((conf lentic-chunk-configuration)
buffer)
"Given CONF, a `lentic-configuration' object, find
demarcation markers. Returns a list of start end cons pairs.
`point-min' is considered to be an implicit start and `point-max'
an implicit stop."
(let* ((match-chunk
(lentic-chunk-match
conf buffer))
(match-start
(car match-chunk))
(match-end
(cadr match-chunk)))
(if
(= (length match-start)
(length match-end))
(progn
(unless
(oref conf valid)
(oset conf valid t)
(lentic-update-display))
(with-current-buffer buffer
(-zip-with
#'list
;; start comment markers
;; plus the start of the region
(cons
(set-marker (make-marker) (point-min) buffer)
match-start)
;; end comment markers
;; plus the end of the buffer
(append
match-end
(list (set-marker (make-marker) (point-max) buffer))))))
;; delimiters do not match so return error value
(lentic-log "delimiters do not match")
(when (oref conf valid)
(oset conf valid nil)
(lentic-update-display))
:unmatched)))
(cl-defmethod lentic-chunk-match ((conf lentic-chunk-configuration)
buffer)
(list
(m-buffer-match-begin
buffer
(lentic-chunk-comment-start-regexp conf)
:case-fold-search (oref conf case-fold-search))
(m-buffer-match-end
buffer
(lentic-chunk-comment-stop-regexp conf)
:case-fold-search (oref conf case-fold-search))))
(cl-defmethod lentic-convert ((conf lentic-chunk-configuration)
location)
"Converts a LOCATION in buffer FROM into one from TO.
This uses a simple algorithm; we pick the same line and then
count from the end, until we get to location, always staying on
the same line. This works since the buffers are identical except
for changes to the beginning of the line. It is also symmetrical
between the two buffers; we don't care which one has comments."
;; current information comes inside a with-current-buffer. so, we capture
;; data as a list rather than having two with-current-buffers.
(let ((line-plus
(with-current-buffer
(lentic-this conf)
(save-excursion
;; move to location or line-end-position may be wrong
(goto-char location)
(list
;; we are converting the location, so we need the line-number
(line-number-at-pos location)
;; and the distance from the end
(- (line-end-position)
location))))))
(with-current-buffer
(lentic-that conf)
(save-excursion
(goto-char (point-min))
;; move forward to the line in question
(forward-line (1- (car line-plus)))
;; don't move from the line in question
(max (line-beginning-position)
;; but move in from the end
(- (line-end-position)
(cadr line-plus)))))))
(defclass lentic-commented-chunk-configuration
(lentic-chunk-configuration)
()
"Configuration for chunked lentic with comments.")
(defclass lentic-uncommented-chunk-configuration
(lentic-chunk-configuration)
()
"Configuration for chunked lentic without comments.")
(cl-defmethod lentic-clone
((conf lentic-commented-chunk-configuration)
&optional start stop length-before start-converted stop-converted)
"Update the contents in the lentic without comments"
;;(lentic-log "chunk-clone-uncomment (from):(%s)" conf)
(let*
;; we need to detect whether start or stop are in the comment region at
;; the beginning of the file. We check this by looking at :that-buffer
;; -- if we are in the magic region, then we must be at the start of
;; line. In this case, we copy the entire line as it is in a hard to
;; predict state. This is slightly over cautious (it also catches first
;; character), but this is safe, it only causes the occasional
;; unnecessary whole line copy. In normal typing "whole line" will be
;; one character anyway
((start-in-comment
(when
(and start
(m-buffer-at-bolp
(lentic-that conf)
start-converted))
(m-buffer-at-line-beginning-position
(lentic-this conf)
start)))
(start (or start-in-comment start))
(start-converted
(if start-in-comment
(m-buffer-at-line-beginning-position
(lentic-that conf)
start-converted)
start-converted))
;; likewise for stop
(stop-in-comment
(when
(and stop
(m-buffer-at-bolp
(lentic-that conf)
stop-converted))
(m-buffer-at-line-end-position
(lentic-this conf)
stop)))
(stop (or stop-in-comment stop))
(stop-converted
(if stop-in-comment
(m-buffer-at-line-end-position
(lentic-that conf)
stop-converted)
stop-converted)))
;; log when we have gone long
(if (or start-in-comment stop-in-comment)
(lentic-log "In comment: %s %s"
(when start-in-comment
"start")
(when stop-in-comment
"stop")))
;; now clone the buffer, recording the return value unless either the
;; start or the stop is in comment, in which case we need a nil.
(let* ((clone-return
(cl-call-next-method conf start stop length-before
start-converted stop-converted))
(clone-return
(unless (or start-in-comment stop-in-comment)
clone-return))
;; record the validity of the buffer as it was
(validity (oref conf valid))
(markers
(lentic-chunk-marker-boundaries
conf
(lentic-that conf))))
(cond
;; we are unmatched, but we used to be valid, which means that we
;; have just become invalid, so we want to do a full clone
;; straight-away to make sure that both buffers are now identical
((and
(equal :unmatched
markers)
validity)
(cl-call-next-method conf))
;; we are unmatched, and we were unmatched before. We have already
;; done the incremental clone, so stop.
((equal :unmatched markers)
nil)
;; we have matched delimiters but we were not matched before. This
;; means we will have done an identity clone which means that other
;; buffer will be all commented up. So remove all comments and clean
;; up all the markers
((not validity)
(m-buffer-with-markers
((markers markers))
(lentic-chunk-uncomment-buffer
conf
markers
(lentic-convert conf (point-min))
(lentic-convert conf (point-max))
(lentic-that conf))
))
(t
;; just uncomment the bit we have cloned.
(lentic-chunk-uncomment-buffer
conf
markers
;; the buffer at this point has been copied over, but is in an
;; inconsistent state (because it may have comments that it should
;; not). Still, the convertor should still work because it counts from
;; the end
(lentic-convert
conf
;; point-min if we know nothing else
(or start (point-min)))
(lentic-convert
conf
;; if we have a stop
(if stop
;; take stop (if we have got longer) or
;; start length before (if we have got shorter)
(max stop
(+ start length-before))
(point-max)))
(lentic-that conf))))
clone-return)))
(cl-defmethod lentic-invert
((conf lentic-commented-chunk-configuration))
(lentic-uncommented-chunk-configuration
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)
:comment (oref conf comment)
:comment-start (oref conf comment-start)
:comment-stop (oref conf comment-stop)))
(cl-defmethod lentic-clone
((conf lentic-uncommented-chunk-configuration)
&optional start stop length-before start-converted stop-converted)
"Update the contents in the lentic without comments."
;;(lentic-log "chunk-clone-comment conf):(%s)" conf)
(let*
((start-at-bolp
(when
(and start
(m-buffer-at-bolp
(lentic-this conf)
start))
(m-buffer-at-line-beginning-position
(lentic-that conf)
start-converted)))
(start-converted (or start-at-bolp start-converted)))
(if (or start-at-bolp)
(lentic-log "In comment: %s"
(when start-at-bolp
"start")))
(let* ((clone-return
(cl-call-next-method conf start stop length-before
start-converted stop-converted))
(clone-return
(unless start-at-bolp
clone-return))
(validity (oref conf valid))
(markers
(lentic-chunk-marker-boundaries
conf
(lentic-that conf))))
(cond
((and (equal :unmatched markers)
validity)
(cl-call-next-method conf))
((equal :unmatched markers)
nil)
((not validity)
(m-buffer-with-markers
((markers markers))
(lentic-chunk-comment-buffer
conf
markers
(lentic-convert conf (point-min))
(lentic-convert conf (point-max))
(lentic-that conf))))
(t
(lentic-chunk-comment-buffer
conf
markers
;; the buffer at this point has been copied over, but is in an
;; inconsistent state (because it may have comments that it should
;; not). Still, the convertor should still work because it counts from
;; the end
(lentic-convert
conf
;; point-min if we know nothing else
(or start (point-min)))
(lentic-convert
conf
;; if we have a stop
(if stop
;; take stop (if we have got longer) or
;; start length before (if we have got shorter)
(max stop
(+ start length-before))
(point-max)))
(lentic-that conf))))
clone-return)))
(cl-defmethod lentic-invert
((conf lentic-uncommented-chunk-configuration))
(lentic-commented-chunk-configuration
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)
:comment (oref conf comment)
:comment-start (oref conf comment-start)
:comment-stop (oref conf comment-stop)))
;; #+end_src
;; ** Unmatched Chunk Configuration
;; Unmatched chunks are those when the number of "start" delimitors and "end"
;; delimitors are not the same. The motivating example here was org-mode where
;; the =begin_src= tags name the language but the =end_src= do not. Hence, one
;; org file with two languages break lentic.
;; The solution is to search for the start tags and then take just the next stop
;; tag, a solution we already use for asciidoc. The disadvantage is that the
;; buffer can no longer become invalid which is useful for detecting accidentally
;; mis-matched tags.
;; The implementation is provided by the `lentic-unmatched-chunk-configuration'
;; class, which is then mixed-in with the two subclasses.
;; #+begin_src emacs-lisp
(defclass lentic-unmatched-chunk-configuration ()
()
:documentation "Configuration for chunked lentics where the
markers are not necessarily paired. Instead for every open chunk
marker, the next close marker is used, and all others are
ignored."
:abstract t)
(cl-defmethod lentic-chunk-marker-boundaries
((conf lentic-unmatched-chunk-configuration)
buffer)
"Given CONF, a `lentic-configuration' object, find
demarcation markers. Returns a list of start end cons pairs.
`point-min' is considered to be an implicit start and `point-max'
an implicit stop."
(let* ((match-chunk
(lentic-chunk-match
conf buffer))
(match-start
(car match-chunk))
(match-end
(cadr match-chunk)))
(let* ((part
(-drop-while
(lambda (n)
(not (car n)))
(m-buffer-partition-by-marker
match-start match-end)))
(zipped
(with-current-buffer buffer
(-zip-with
#'list
(cons (point-min-marker)
(-map #'cadr part))
(-snoc
(-map #'car part)
(point-max-marker))))))
zipped)))
(defclass lentic-unmatched-commented-chunk-configuration
(lentic-unmatched-chunk-configuration
lentic-commented-chunk-configuration)
())
(cl-defmethod lentic-invert
((conf lentic-unmatched-commented-chunk-configuration))
(lentic-unmatched-uncommented-chunk-configuration
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)
:comment (oref conf comment)
:comment-start (oref conf comment-start)
:comment-stop (oref conf comment-stop)))
(defclass lentic-unmatched-uncommented-chunk-configuration
(lentic-unmatched-chunk-configuration
lentic-uncommented-chunk-configuration)
())
(cl-defmethod lentic-invert
((conf lentic-unmatched-uncommented-chunk-configuration))
(lentic-unmatched-commented-chunk-configuration
:this-buffer (lentic-that conf)
:that-buffer (lentic-this conf)
:comment (oref conf comment)
:comment-start (oref conf comment-start)
:comment-stop (oref conf comment-stop)))
(provide 'lentic-chunk)
;;; lentic-chunk.el ends here
;; #+end_src
;;; lentic-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from lentic.el
(defvar lentic-init-functions nil "\
All functions that can be used as `lentic-init' function.")
(autoload 'lentic-default-init "lentic" "\
Default init function.
see `lentic-init' for details.")
(register-definition-prefixes "lentic" '("lentic-"))
;;; Generated autoloads from lentic-asciidoc.el
(autoload 'lentic-clojure-asciidoc-init "lentic-asciidoc")
(autoload 'lentic-asciidoc-clojure-init "lentic-asciidoc")
(add-to-list 'lentic-init-functions #'lentic-asciidoc-clojure-init)
(autoload 'lentic-asciidoc-el-init "lentic-asciidoc")
(add-to-list 'lentic-init-functions #'lentic-asciidoc-el-init)
(register-definition-prefixes "lentic-asciidoc" '("lentic-"))
;;; Generated autoloads from lentic-chunk.el
(register-definition-prefixes "lentic-chunk" '("lentic-"))
;;; Generated autoloads from lentic-cookie.el
(register-definition-prefixes "lentic-cookie" '("lentic-cookie-"))
;;; Generated autoloads from lentic-dev.el
(autoload 'lentic-dev-after-change-function "lentic-dev" "\
Run the change functions out of the command loop.
Using this function is the easiest way to test an new
`lentic-clone' method, as doing so in the command loop is
painful for debugging. Set variable `lentic-emergency' to
true to disable command loop functionality." t)
(autoload 'lentic-dev-post-command-hook "lentic-dev" "\
Run the post-command functions out of the command loop.
Using this function is the easiest way to test an new
`lentic-convert' method, as doing so in the command loop is
painful for debugging. Set variable `lentic-emergency' to
true to disable command loop functionality." t)
(autoload 'lentic-dev-after-save-hook "lentic-dev" nil t)
(autoload 'lentic-dev-mode-buffer-list-update-hook "lentic-dev" nil t)
(autoload 'lentic-dev-kill-buffer-hook "lentic-dev" nil t)
(autoload 'lentic-dev-kill-emacs-hook "lentic-dev" nil t)
(autoload 'lentic-dev-reinit "lentic-dev" "\
Recall the init function regardless of current status.
This can help if you have change the config object and need
to make sure there is a new one." t)
(autoload 'lentic-dev-random-face "lentic-dev" "\
Change the insertion face to a random one." t)
(defvar lentic-dev-enable-insertion-marking nil "\
Non-nil if Lentic-Dev-Enable-Insertion-Marking mode is enabled.
See the `lentic-dev-enable-insertion-marking' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `lentic-dev-enable-insertion-marking'.")
(custom-autoload 'lentic-dev-enable-insertion-marking "lentic-dev" nil)
(autoload 'lentic-dev-enable-insertion-marking "lentic-dev" "\
Enable font locking properties for inserted text.
This is a global minor mode. If called interactively, toggle the
`Lentic-Dev-Enable-Insertion-Marking mode' mode. If the prefix
argument is positive, enable the mode, and if it is zero or
negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `(default-value
\\='lentic-dev-enable-insertion-marking)'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
(fn &optional ARG)" t)
(defvar lentic-dev-enable-insertion-pulse nil "\
Non-nil if Lentic-Dev-Enable-Insertion-Pulse mode is enabled.
See the `lentic-dev-enable-insertion-pulse' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `lentic-dev-enable-insertion-pulse'.")
(custom-autoload 'lentic-dev-enable-insertion-pulse "lentic-dev" nil)
(autoload 'lentic-dev-enable-insertion-pulse "lentic-dev" "\
Enable momentary pulsing for inserted text.
This is a global minor mode. If called interactively, toggle the
`Lentic-Dev-Enable-Insertion-Pulse mode' mode. If the prefix
argument is positive, enable the mode, and if it is zero or
negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `(default-value \\='lentic-dev-enable-insertion-pulse)'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "lentic-dev" '("lentic-dev-"))
;;; Generated autoloads from lentic-doc.el
(register-definition-prefixes "lentic-doc" '("lentic-"))
;;; Generated autoloads from lentic-latex-code.el
(autoload 'lentic-clojure-latex-init "lentic-latex-code")
(autoload 'lentic-latex-clojure-init "lentic-latex-code")
(autoload 'lentic-clojure-latex-delayed-init "lentic-latex-code")
(autoload 'lentic-haskell-latex-init "lentic-latex-code")
(register-definition-prefixes "lentic-latex-code" '("lentic-"))
;;; Generated autoloads from lentic-markdown.el
(autoload 'lentic-clojure-markdown-init "lentic-markdown")
(register-definition-prefixes "lentic-markdown" '("lentic-"))
;;; Generated autoloads from lentic-mode.el
(autoload 'lentic-mode-create-from-init "lentic-mode" "\
(fn &optional FORCE)" t)
(autoload 'lentic-mode-next-lentic-buffer "lentic-mode" "\
Move the lentic buffer into the current window, creating if necessary." t)
(autoload 'lentic-mode-split-window-below "lentic-mode" "\
Move lentic buffer to the window below, creating if needed." t)
(autoload 'lentic-mode-split-window-right "lentic-mode" "\
Move lentic buffer to the window right, creating if needed." t)
(autoload 'lentic-mode-show-all-lentic "lentic-mode" nil t)
(autoload 'lentic-mode-move-lentic-window "lentic-mode" "\
Move the next lentic buffer into the current window.
If the lentic is currently being displayed in another window,
then the current-buffer will be moved into that window. See also
`lentic-mode-swap-buffer-windows' and `lentic-mode-next-buffer'." t)
(autoload 'lentic-mode-swap-lentic-window "lentic-mode" "\
Swap the window of the buffer and lentic.
If both are current displayed, swap the windows they
are displayed in, which keeping current buffer.
See also `lentic-mode-move-lentic-window'." t)
(autoload 'lentic-mode-create-new-view-in-selected-window "lentic-mode" nil t)
(autoload 'lentic-mode-toggle-auto-sync-point "lentic-mode" nil t)
(autoload 'lentic-mode-doc-eww-view "lentic-mode" nil t)
(autoload 'lentic-mode-doc-external-view "lentic-mode" nil t)
(autoload 'lentic-mode "lentic-mode" "\
Documentation
This is a minor mode. If called interactively, toggle the
`Lentic mode' mode. If the prefix argument is positive, enable
the mode, and if it is zero or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `lentic-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
(fn &optional ARG)" t)
(autoload 'lentic-mode-insert-file-local "lentic-mode" "\
(fn INIT-FUNCTION)" t)
(put 'global-lentic-mode 'globalized-minor-mode t)
(defvar global-lentic-mode nil "\
Non-nil if Global Lentic mode is enabled.
See the `global-lentic-mode' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `global-lentic-mode'.")
(custom-autoload 'global-lentic-mode "lentic-mode" nil)
(autoload 'global-lentic-mode "lentic-mode" "\
Toggle Lentic mode in all buffers.
With prefix ARG, enable Global Lentic mode if ARG is positive;
otherwise, disable it.
If called from Lisp, toggle the mode if ARG is `toggle'.
Enable the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
Lentic mode is enabled in all buffers where `lentic-mode-on' would do
it.
See `lentic-mode' for more information on Lentic mode.
(fn &optional ARG)" t)
(register-definition-prefixes "lentic-mode" '("lentic-mode-"))
;;; Generated autoloads from lentic-org.el
(autoload 'lentic-org-el-init "lentic-org")
(autoload 'lentic-el-org-init "lentic-org")
(autoload 'lentic-org-orgel-init "lentic-org")
(autoload 'lentic-orgel-org-init "lentic-org")
(autoload 'lentic-org-clojure-init "lentic-org")
(autoload 'lentic-clojure-org-init "lentic-org")
(autoload 'lentic-org-python-init "lentic-org")
(autoload 'lentic-python-org-init "lentic-org")
(register-definition-prefixes "lentic-org" '("lentic-org"))
;;; Generated autoloads from lentic-ox.el
(register-definition-prefixes "lentic-ox" '("lentic-ox-"))
;;; Generated autoloads from lentic-rot13.el
(register-definition-prefixes "lentic-rot13" '("lentic-rot13-"))
;;; Generated autoloads from lentic-script.el
(eval '(defun lentic-script-hook (mode-hook init) (add-to-list 'lentic-init-functions init) (add-hook mode-hook (lambda nil (unless (bound-and-true-p lentic-init) (setq lentic-init init))))) t)
(autoload 'lentic-python-script-init "lentic-script")
(lentic-script-hook 'python-mode-hook 'lentic-python-script-init)
(autoload 'lentic-bash-script-init "lentic-script")
(lentic-script-hook 'shell-mode-hook 'lentic-bash-script-init)
(autoload 'lentic-lua-script-init "lentic-script")
(lentic-script-hook 'lua-mode-hook #'lentic-lua-script-init)
(register-definition-prefixes "lentic-script" '("lentic-script-"))
;;; End of scraped data
(provide 'lentic-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; lentic-autoloads.el ends here
;;; lentic-asciidoc.el --- asciidoc support for lentic -*- lexical-binding: t -*-
;;; Header:
;; This file is not part of Emacs
;; Author: Phillip Lord <phillip.lord@russet.org.uk>
;; Maintainer: Phillip Lord <phillip.lord@russet.org.uk>
;; The contents of this file are subject to the GPL License, Version 3.0.
;;
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Lentic buffers with asciidoc [source] blocks.
;;; Code:
;; #+begin_src emacs-lisp
(require 'lentic)
(require 'lentic-chunk)
(require 'm-buffer)
(defun lentic-asciidoc-oset (conf)
(lentic-m-oset
conf
'this-buffer (current-buffer)
'comment ";; "))
(defun lentic-asciidoc-commented-new ()
(lentic-asciidoc-oset
(lentic-commented-asciidoc-configuration
"lb-commented-clojure asciidoc"
:lentic-file
(concat
(file-name-sans-extension
(buffer-file-name)) ".adoc"))))
;;;###autoload
(defun lentic-clojure-asciidoc-init ()
(lentic-asciidoc-commented-new))
(add-to-list 'lentic-init-functions #'lentic-clojure-asciidoc-init)
(defun lentic-asciidoc-uncommented-new ()
(lentic-asciidoc-oset
(lentic-uncommented-asciidoc-configuration
"lb-uncommented-clojure-asciidoc"
:lentic-file
(concat
(file-name-sans-extension
(buffer-file-name)) ".clj"))))
;;;###autoload
(defun lentic-asciidoc-clojure-init ()
(lentic-asciidoc-uncommented-new))
;;;###autoload
(add-to-list 'lentic-init-functions #'lentic-asciidoc-clojure-init)
;; ** Support Emacs-Lisp
;;;###autoload
(defun lentic-asciidoc-el-init ()
(lentic-asciidoc-oset
(lentic-uncommented-asciidoc-configuration
"temp"
:lentic-file
(concat
(file-name-sans-extension
buffer-file-name)
".el"))))
;;;###autoload
(add-to-list 'lentic-init-functions #'lentic-asciidoc-el-init)
(defclass lentic-commented-asciidoc-configuration
(lentic-commented-chunk-configuration)
((srctags :initarg :srctags
:documentation "Language tags in source chunk"
:initform '("clojure" "lisp")))
"Lentic buffer config for asciidoc and other code.")
(defclass lentic-uncommented-asciidoc-configuration
(lentic-uncommented-chunk-configuration)
((srctags :initarg :srctags
:documentation "Language tags in source chunk"
:initform '("clojure" "lisp")))
"Lentic buffer config for asciidoc and other code")
(defun lentic-splitter (l)
"Returns a function which for use as a partition predicate.
The returned function returns the first element of L until it is
passed a value higher than the first element, then it returns the
second element and so on."
#'(lambda (x)
(when
(and l
(< (car l) x))
(setq l (-drop 1 l)))
(car l)))
(defun lentic-partition-after-source (l-source l-dots)
"Given a set of markers l-source, partition the markers in
l-dots.
The source markers represent [source] markers, so we take the
next matches to \"....\" immediately after a [source] marker.
This should remove other \"....\" matches.
"
(-partition-by
(lentic-splitter l-source)
(-drop-while
(lambda (x)
(and l-source
(< x (car l-source))))
l-dots)))
(defun lentic-chunk-match-asciidoc
(conf buffer)
(let* ((source
(m-buffer-match-begin
buffer
(format ";* *\\[source,%s\\]"
(regexp-opt
(oref conf srctags)))))
;; this could also be a start of title
(dots
(m-buffer-match buffer
"^;* *----"))
(source-start
(lentic-partition-after-source
source
(m-buffer-match-begin
dots)))
(source-end
(lentic-partition-after-source
source (m-buffer-match-end dots))))
(when source
(list
(-map 'cadr source-start)
(-map 'car source-end)))))
(cl-defmethod lentic-chunk-match
((conf lentic-commented-asciidoc-configuration) buffer)
(lentic-chunk-match-asciidoc conf buffer))
(cl-defmethod lentic-chunk-match
((conf lentic-uncommented-asciidoc-configuration) buffer)
(lentic-chunk-match-asciidoc conf buffer))
(cl-defmethod lentic-invert
((conf lentic-commented-asciidoc-configuration))
(lentic-m-oset (lentic-asciidoc-uncommented-new)
'that-buffer (lentic-this conf)))
(cl-defmethod lentic-invert
((conf lentic-uncommented-asciidoc-configuration))
(lentic-m-oset (lentic-asciidoc-commented-new)
'that-buffer (lentic-this conf)))
(provide 'lentic-asciidoc)
;;; lentic-asciidoc.el ends here
;; #+end_src
;;; kv.el --- key/value data structure functions
;; Copyright (C) 2012 Nic Ferrier
;; Author: Nic Ferrier <nferrier@ferrier.me.uk>
;; Keywords: lisp
;; Version: 0.0.19
;; Maintainer: Nic Ferrier <nferrier@ferrier.me.uk>
;; Created: 7th September 2012
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Some routines for working with key/value data structures like
;; hash-tables and alists and plists.
;; This also takes over the dotassoc stuff and provides it separately.
;;; Code:
(eval-when-compile (require 'cl))
(defun kvalist->hash (alist &rest hash-table-args)
"Convert ALIST to a HASH.
HASH-TABLE-ARGS are passed to the hash-table creation."
(let ((table (apply 'make-hash-table hash-table-args)))
(mapc
(lambda (pair)
(puthash (car pair) (cdr pair) table))
alist)
table))
(defun kvhash->alist (hash &optional func)
"Convert HASH to an ALIST.
Optionally filter through FUNC, only non-nil values returned from
FUNC are stored as the resulting value against the converted
key."
(when hash
(let (store)
(maphash
(lambda (key value)
(when key
(if (and (functionp func))
(let ((res (funcall func key value)))
(when res
(setq store (acons key res store))))
;; else no filtering, just return
(setq store (acons key value store)))))
hash)
store)))
(defun kvfa (key alist receive)
"Call RECEIVE with whatever comes out of ALIST for KEY.
RECEIVE can do whatever destructuring you want, the first
argument is always the car of the alist pair."
(apply receive (let ((a (assoc key alist)))
(append (list (car a))
(if (listp (cdr a))(cdr a)(list (cdr a)))))))
(defun kva (key alist)
"Retrieve the value assigned to KEY in ALIST.
This uses `assoc' as the lookup mechanism."
(cdr (assoc key alist)))
(defun kvaq (key alist)
"Retrieve the value assigned to KEY in ALIST.
This uses `assq' as the lookup mechanism."
(cdr (assq key alist)))
(defun kvaqc (key alist)
"Retrieve the value assigned to KEY in ALIST.
This uses first the `assq' and then `assoc' as the lookup
mechanism."
(cdr (or (assq key alist)
(assoc key alist))))
(defun kvassoc= (key value alist)
"Is the value assocd to KEY in ALIST equal to VALUE?
Returns the value looked up by KEY that passes, so normally:
KEY . VALUE
"
(let ((v (assoc key alist)))
(and v (equal (cdr v) value) v)))
(defun kvassoqc (key alist)
"String or symbol assoc."
(let ((v (or
(assq (if (symbolp key) key (intern key)) alist)
(or (assoc key alist)
;; not sure about this behaviour... see test
(assoc (symbol-name key) alist))))) v))
(defun kvassoq= (key value alist)
"Test the VALUE with the value bound to KEY in ALIST.
The lookup mechanism is to ensure the key is a symbol and then
use assq. Hence the name of the function being a mix of assoc
and assq.
Returns the value looked up by KEY that passes, so normally:
KEY . VALUE
"
(let ((v (kvassoqc key alist)))
(and v (equal (cdr v) value) v)))
(defun kvmatch (key regex alist)
"Test the value with KEY in ALIST matches REGEX."
(let ((v (kvassoqc key alist)))
(and v (string-match regex (cdr v)) v)))
(defun* kvquery->func (query &key
(equal-func 'kvassoc=)
(match-func 'kvmatch))
"Turn a simple QUERY expression into a filter function.
EQUAL-FUNC is the function that implements the equality
predicate.
MATCH-FUNC is the function that implements the match predicate.
The query language is:
| a b - true if a or b is true
& a b - true only if a and b is true
= a b - true if a equals b as per the EQUAL-FUNC
~ a b - true if a matches b as per the MATCH-FUNC
So, for example:
(|(= a b)(= c d))
Means: if `a' equals `b', or if `c' equals `d' then the
expression is true."
(flet ((query-parse (query)
(let ((part (car query))
(rest (cdr query)))
(cond
((eq part '|)
(cons 'or
(loop for i in rest
collect (query-parse i))))
((eq part '&)
(cons 'and
(loop for i in rest
collect (query-parse i))))
((eq part '~)
(destructuring-bind (field value) rest
(list match-func field value (quote record))))
((eq part '=)
(destructuring-bind (field value) rest
(list equal-func field value (quote record))))))))
(eval `(lambda (record) ,(query-parse query)))))
(defun kvplist2get (plist2 keyword value)
"Get the plist with KEYWORD / VALUE from the list of plists."
(loop for plist in plist2
if (equal (plist-get plist keyword) value)
return plist))
(defun kvthing->keyword (str-or-symbol)
"Convert STR-OR-SYMBOL into a keyword symbol."
(let ((str
(cond
((symbolp str-or-symbol) (symbol-name str-or-symbol))
((stringp str-or-symbol) str-or-symbol))))
(intern
(if (eq (aref str 0) ?:) str (concat ":" str)))))
(defun kvalist->plist (alist)
"Convert an alist to a plist."
;; Why doesn't elisp provide this?
(loop for pair in alist
append (list
(kvthing->keyword
(car pair))
(cdr pair))))
(defun kvacons (&rest args)
"Make an alist from the plist style args."
(kvplist->alist args))
(defun keyword->symbol (keyword)
"A keyword is a symbol leading with a :.
Converting to a symbol means dropping the :."
(if (keywordp keyword)
(intern (substring (symbol-name keyword) 1))
keyword))
(defun kvplist->alist (plist &optional keys-are-keywords)
"Convert PLIST to an alist.
The keys are expected to be :prefixed and the colons are removed
unless KEYS-ARE-KEYWORDS is `t'.
The keys in the resulting alist are always symbols."
(when plist
(loop for (key value . rest) on plist by 'cddr
collect
(cons (if keys-are-keywords
key
(keyword->symbol key))
value))))
(defun kvalist2->plist (alist2)
"Convert a list of alists too a list of plists."
(loop for alist in alist2
append
(list (kvalist->plist alist))))
(defun kvalist->keys (alist)
"Get just the keys from the alist."
(mapcar (lambda (pair) (car pair)) alist))
(defun kvalist->values (alist)
"Get just the values from the alist."
(mapcar (lambda (pair) (cdr pair)) alist))
(defun kvalist-sort (alist pred)
"Sort ALIST (by key) with PRED."
(sort alist (lambda (a b) (funcall pred (car a) (car b)))))
(defun kvalist-sort-by-value (alist pred)
"Sort ALIST by value with PRED."
(sort alist (lambda (a b) (funcall pred (cdr a) (cdr b)))))
(defun kvalist->filter-keys (alist &rest keys)
"Return the ALIST filtered to the KEYS list.
Only pairs where the car is a `member' of KEYS will be returned."
(loop for a in alist
if (member (car a) keys)
collect a))
(defun kvplist->filter-keys (plist &rest keys)
"Filter the plist to just those matching KEYS.
`kvalist->filter-keys' is actually used to do this work."
(let ((symkeys
(loop for k in keys
collect (let ((strkey (symbol-name k)))
(if (equal (substring strkey 0 1) ":")
(intern (substring strkey 1))
k)))))
(kvalist->plist
(apply
'kvalist->filter-keys
(cons (kvplist->alist plist) symkeys)))))
(defun kvplist2->filter-keys (plist2 &rest keys)
"Return the PLIST2 (a list of plists) filtered to the KEYS."
(loop for plist in plist2
collect (apply 'kvplist->filter-keys (cons plist keys))))
(defun kvalist2->filter-keys (alist2 &rest keys)
"Return the ALIST2 (a list of alists) filtered to the KEYS."
(loop for alist in alist2
collect (apply 'kvalist->filter-keys (cons alist keys))))
(defun kvalist2->alist (alist2 car-key cdr-key &optional proper)
"Reduce the ALIST2 (a list of alists) to a single alist.
CAR-KEY is the key of each alist to use as the resulting key and
CDR-KEY is the key of each alist to user as the resulting cdr.
For example, if CAR-KEY is `email' and CDR-KEY is `name' the
records:
'((user . \"nic\")(name . \"Nic\")(email . \"nic@domain\")
(user . \"jim\")(name . \"Jim\")(email . \"jim@domain\"))
could be reduced to:
'((\"nic@domain\" . \"Nic\")
(\"jim@domain\" . \"Jic\"))
If PROPER is `t' then the alist is a list of proper lists, not
cons cells."
(loop for alist in alist2
collect (apply (if proper 'list 'cons)
(list
(assoc-default car-key alist)
(assoc-default cdr-key alist)))))
(defun kvalist-keys->* (alist fn)
"Convert the keys of ALIST through FN."
(mapcar
(lambda (pair)
(cons
(funcall fn (car pair))
(cdr pair)))
alist))
(defun* kvalist-keys->symbols (alist &key (first-fn 'identity))
"Convert the keys of ALIST into symbols.
If key parameter FIRST-FN is present it should be a function
which will be used to first transform the string key. A popular
choice might be `downcase' for example, to cause all symbol keys
to be lower-case."
(kvalist-keys->*
alist
(lambda (key)
(intern (funcall first-fn (format "%s" key))))))
(defun kvalist2-filter (alist2 fn)
"Filter the list of alists with FN."
(let (value)
(loop for rec in alist2
do (setq value (funcall fn rec))
if value
collect rec)))
(defun kvidentity (a b)
"Returns a cons of A B."
(cons a b))
(defun kvcar (a b)
"Given A B returns A."
a)
(defun kvcdr (a b)
"Given A B returns B."
b)
(defun kvcmp (a b)
"Do a comparison of the two values using printable syntax.
Use this as the function to pass to `sort'."
(string-lessp (if a (format "%S" a) "")
(if b (format "%S" b) "")))
(defun kvqsort (lst)
"Do a sort using `kvcmp'."
(sort lst 'kvcmp))
(progn
(put 'kvalist-key
'error-conditions
'(error))
(put 'kvalist-key
'error-message
"No such key found in alist."))
(defun kvalist-set-value! (alist key value)
"Destructively set the value of KEY to VALUE in ALIST.
If the assoc is not found this adds it to alist."
(let ((cell (assoc key alist)))
(if (consp cell)
(setcdr cell value)
;; Else what to do?
(signal 'kvalist-key (list alist key)))))
(defun kvdotassoc-fn (expr table func)
"Use the dotted EXPR to access deeply nested data in TABLE.
EXPR is a dot separated expression, either a symbol or a string.
For example:
\"a.b.c\"
or:
'a.b.c
If the EXPR is a symbol then the keys of the alist are also
expected to be symbols.
TABLE is expected to be an alist currently.
FUNC is some sort of `assoc' like function."
(let ((state table)
(parts
(if (symbolp expr)
(mapcar
'intern
(split-string (symbol-name expr) "\\."))
;; Else it's a string
(split-string expr "\\."))))
(catch 'break
(while (listp parts)
(let ((traverse (funcall func (car parts) state)))
(setq parts (cdr parts))
(if parts
(setq state (cdr traverse))
(throw 'break (cdr traverse))))))))
(defun kvdotassoc (expr table)
"Dotted expression handling with `assoc'."
(kvdotassoc-fn expr table 'assoc))
(defun kvdotassq (expr table)
"Dotted expression handling with `assq'."
(kvdotassoc-fn expr table 'assq))
(defun kvdotassoc= (expr value table)
(let ((v (kvdotassoc expr table)))
(and v (equal v value) v)))
(defalias 'dotassoc 'kvdotassoc)
(defalias 'dotassq 'kvdotassq)
;; Thank you taylanub for this wonderful abstraction.
(defmacro kv--destructuring-map (map-function args sequence &rest body)
"Helper macro for `destructuring-mapcar' and `destructuring-map'."
(declare (indent 3))
(let ((entry (gensym)))
`(,map-function (lambda (,entry)
(destructuring-bind ,args ,entry ,@body))
,sequence)))
(defmacro kvmap-bind (args sexp seq)
"A hybrid of `destructuring-bind' and `mapcar'
ARGS shall be of the form used with `destructuring-bind'
Unlike most other mapping forms this is a macro intended to be
used for structural transformations, so the expected usage will
be that ARGS describes the structure of the items in SEQ, and
SEXP will describe the structure desired."
(declare (indent 2))
`(kv--destructuring-map mapcar ,args ,seq ,sexp))
(defalias 'map-bind 'kvmap-bind)
(defun kvplist-merge (&rest plists)
"Merge the 2nd and subsequent plists into the first.
Values set by lists to the left are clobbered."
(let ((result (car plists))
(plists (cdr plists)))
(loop for plist in plists do
(loop for (key val) on plist by 'cddr do
(setq result (plist-put result key val))))
result))
(provide 'kv)
(provide 'dotassoc)
;;; kv.el ends here
(define-package "kv" "20140108.1534" "key/value data structure functions" 'nil :commit "721148475bce38a70e0b678ba8aa923652e8900e" :authors
'(("Nic Ferrier" . "nferrier@ferrier.me.uk"))
:maintainers
'(("Nic Ferrier" . "nferrier@ferrier.me.uk"))
:maintainer
'("Nic Ferrier" . "nferrier@ferrier.me.uk")
:keywords
'("lisp"))
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; kv-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from kv.el
(register-definition-prefixes "kv" '("dotass" "keyword->symbol" "map-bind"))
;;; End of scraped data
(provide 'kv-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; kv-autoloads.el ends here
;;; esxml.el --- Library for working with xml via esxml and sxml
;; Copyright (C) 2012
;; Author: Vanya Izaksonas-Smith <izak0002 at umn dot edu>
;; Maintainer: Vanya Izaksonas-Smith
;; URL: https://github.com/tali713/esxml
;; Created: 15th August 2012
;; Version: 0.3.7
;; Keywords: tools, lisp, comm
;; Description: A library for easily generating XML/XHTML in elisp
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This is XML/XHTML done with S-Expressions in EmacsLisp. Simply,
;; this is the easiest way to write HTML or XML in Lisp.
;;
;; This library uses the native form of XML representation as used by
;; many libraries already included within emacs. This representation
;; will be referred to as "esxml" throughout this library. See
;; `esxml-to-xml' for a concise description of the format.
;;
;; This library is not intended to be used directly by a user, though
;; it certainly could be. It could be used to generate static html,
;; or use a library like `elnode' to serve dynamic pages. Or even to
;; extract a form from a site to produce an API.
;;
;; TODO: Better documentation, more convenience.
;;
;; NOTICE: Code base will be transitioning to using pcase instead of
;; destructuring bind wherever possible. If this leads to hard to
;; debug code, please let me know, and I will do whatever I can to
;; resolve these issues.
;;
;;; Code:
(require 'cl-lib)
(require 'xml)
(require 'pcase)
(defun string-trim-whitespace (string)
"A simple function, strips the whitespace from beginning and
end of the string. Leaves all other whitespace untouched."
(replace-regexp-in-string
(rx string-start (* whitespace)
(group (+? anything))
(* whitespace) string-end)
"\\1"
string))
(defun esxml-trim-ws (esxml)
"This may cause problems, is intended for parsing xml into sxml
but may eroneously delete desirable white space."
(if (stringp esxml) (string-trim-whitespace esxml)
(pcase-let ((`(,tag ,attrs . ,body) esxml))
`(,tag ,attrs
,@(mapcar 'esxml-trim-ws body)))))
(defun attrp (attr)
"Returns t if attr is a an esxml attribute.
An esxml attribute is a cons of the form (symbol . string)"
(and (consp attr)
(symbolp (car attr))
(stringp (cdr attr))))
(defun esxml--convert-pair (attr)
"Converts from cons cell to attribute pair. Not intended for
general use."
(pcase-let ((`(,car . ,cdr) attr))
(cl-check-type cdr string)
(concat (symbol-name car)
"="
(prin1-to-string (xml-escape-string cdr)))))
(defun attrsp (attrs)
"Returns t if attrs is a list of esxml attributes.
See: `attrp'"
(and (listp attrs)
(cl-every (lambda (attr)
(and (consp attr)
(symbolp (car attr))
(stringp (cdr attr))))
attrs)))
(defun esxml-validate-form (esxml)
"A fast esxml validator. Will error on invalid subparts making
it suitable for hindsight testing."
(cond ((stringp esxml) nil)
((< (length esxml) 2)
(error "%s is too short to be a valid esxml expression" esxml))
(t (pcase-let ((`(,tag ,attrs . ,body) esxml))
(cl-check-type tag symbol)
(cl-check-type attrs attrs)
(mapcar 'esxml-validate-form body)))))
;; While the following could certainly have been written using format,
;; concat makes them easier to read. Update later if neccesary for
;; efficiency.
;; Though at first glance the recursive nature of this function might
;; give one pause, since xml is a recursive data type, a recursive
;; parser is an optimal strategy. each node will be visited exactly
;; once during the transformation.
;;
;; Further, since a string is a terminal node and since xml can be
;; represented as a string, non dynamic portions of the page may be
;; precached quite easily.
(defun esxml--to-xml-recursive (esxml)
(pcase esxml
((pred stringp)
(xml-escape-string esxml))
(`(raw-string ,string)
(cl-check-type string stringp)
string)
(`(comment nil ,body)
(concat "<!-- " body " -->"))
(`(,tag ,attrs . ,body)
;; code goes here to catch invalid data.
(concat "<" (symbol-name tag)
(when attrs
(concat " " (mapconcat 'esxml--convert-pair attrs " ")))
(if body
(concat ">" (mapconcat 'esxml--to-xml-recursive body "")
"</" (symbol-name tag) ">")
"/>")))))
(defun esxml-to-xml (esxml)
"This translates an esxml expression, i.e. that which is returned
by xml-parse-region. The structure is defined as any of the
following forms:
- A string.
STRING
STRING: the string it is returned with entities escaped
- A list where the first element is the raw-string symbol and the
second is a string.
(raw-string STRING)
STRING: the string is returned unchanged. This allows for caching
of any constant parts, such as headers and footers.
- A list where the first element is the comment symbol and the
second is a string.
(comment STRING)
STRING: the string is embedded in a HTML comment.
- A list where the first element is the tag, the second is
an alist of attribute value pairs and the remainder of the list
is 0 or more esxml elements.
(TAG ATTRS &rest BODY)
TAG: is the tag and must be a symbol.
ATTRS: is an alist of attribute pairs each pair must be of the
form (KEY . VALUE).
KEY: is the name of the attribute and must be a symbol.
VALUE: is the value of the attribute and must be a string.
BODY: is zero or more esxml expressions. Having no body forms
implies that the tag should be self closed. If there is
one or more body forms the tag will always be explicitly
closed, even if they are the empty string."
(condition-case nil
(esxml--to-xml-recursive esxml)
(error (esxml-validate-form esxml))))
(defun pp-esxml-to-xml (esxml)
"This translates an esxml expresion as `esxml-to-xml' but
indents it for ease of human readability, it is necessarily
slower and will produce longer output."
(pcase esxml
((pred stringp)
(xml-escape-string esxml))
(`(raw-string ,string)
(cl-check-type string stringp)
string)
(`(comment nil ,body)
(concat "<!-- " body " -->"))
(`(,tag ,attrs . ,body)
(cl-check-type tag symbol)
(cl-check-type attrs attrs)
(concat "<" (symbol-name tag)
(when attrs
(concat " " (mapconcat 'esxml--convert-pair attrs " ")))
(if body
(concat ">" (if (cl-every 'stringp body)
(mapconcat 'identity body " ")
(concat "\n"
(replace-regexp-in-string
"^" " "
(mapconcat 'pp-esxml-to-xml body "\n"))
"\n"))
"</" (symbol-name tag) ">")
"/>")))
(_
(error "%s is not a valid esxml expression" esxml))))
(defun sxml-to-esxml (sxml)
"Translates sxml to esxml so the common standard can be used.
See: http://okmij.org/ftp/Scheme/SXML.html. Additionally,
(*RAW-STRING* \"string\") is translated to (raw-string
\"string\")."
(pcase sxml
(`(*RAW-STRING* ,body)
`(raw-string ,body))
(`(*COMMENT* ,body)
`(comment nil ,body))
(`(,tag (@ . ,attrs) . ,body)
`(,tag ,(mapcar (lambda (attr)
(cons (car attr)
(or (cadr attr)
(prin1-to-string (car attr)))))
attrs)
,@(mapcar 'sxml-to-esxml body)))
(`(,tag . ,body)
`(,tag nil
,@(mapcar 'sxml-to-esxml body)))
((and sxml (pred stringp)) sxml)))
(defun sxml-to-xml (sxml)
"Translates sxml to xml, via esxml, hey it's only a constant
factor. :)"
(esxml-to-xml (sxml-to-esxml sxml)))
;; TODO: make agnostic with respect to libxml vs xml.el
(defun xml-to-esxml (string &optional trim)
(with-temp-buffer
(insert string)
(let ((parse-tree (libxml-parse-xml-region (point-min)
(point-max))))
(if trim
(esxml-trim-ws parse-tree)
parse-tree))))
;; TODO, move to esxpath when mature
(defun esxml-get-by-key (esxml key value)
"Returns a list of all elements whose wttribute KEY match
VALUE. KEY should be a symbol, and VALUE should be a string.
Will not recurse below a match."
(unless (stringp esxml)
(pcase-let ((`(,tag ,attrs . ,body) esxml))
(if (equal value
(assoc-default key attrs))
(list esxml)
(apply 'append (mapcar (lambda (sexp)
(esxml-get-by-key sexp key value))
body))))))
(defun esxml-get-tags (esxml tags)
"Returns a list of all elements whose tag is a member of TAGS.
TAGS should be a list of tags to be matched against. Will not
recurse below a match."
(unless (stringp esxml)
(pcase-let ((`(,tag ,attrs . ,body) esxml))
(if (member tag tags)
(list esxml)
(apply 'append (mapcar (lambda (sexp)
(esxml-get-tags sexp tags))
body))))))
(defun esxml-get-forms (esxml)
"Returns a list of all forms."
(esxml-get-tags esxml '(form)))
;; taken from kv
(defmacro esxml-destructuring-mapcar (args sexp seq)
(declare (indent 2))
(let ((entry (make-symbol "entry")))
`(mapcar (lambda (,entry)
(cl-destructuring-bind ,args ,entry ,sexp))
,seq)))
(provide 'esxml)
;;; esxml.el ends here
;;; esxml-query.el --- select esxml nodes jQuery-style
;; Copyright (C) 2017 Vasilij Schneidermann <mail@vasilij.de>
;; Author: Vasilij Schneidermann <mail@vasilij.de>
;; Maintainer: Vasilij Schneidermann
;; Version: 0.1.1
;; Keywords: data, lisp
;; Package-Requires: ((cl-lib "0.1"))
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Traditionally people pick one of the following options when faced
;; with the task of extracting data from XML in Emacs Lisp:
;;
;; - Using regular expressions on the unparsed document
;; - Manual tree traversal with `assoc', `car' and `cdr'
;;
;; Browsers faced a similar problem until jQuery happened, shortly
;; afterwards they started providing the `node.querySelector' and
;; `node.querySelectorAll' API for retrieving one or all nodes
;; matching a given CSS selector. This code implements the same API
;; with the `esxml-query' and `esxml-query-all' functions. The
;; following table summarizes the currently supported modifiers and
;; combinators:
;;
;; | Name | Supported? | Syntax |
;; |------------------------------------+------------+-------------|
;; | Namespaces | No | foo|bar |
;; | Commas | Yes | foo, bar |
;; | Descendant combinator | Yes | foo bar |
;; | Child combinator | Yes | foo>bar |
;; | Adjacent sibling combinator | No | foo+bar |
;; | General sibling combinator | No | foo~bar |
;; | Universal selector | Yes | * |
;; | Type selector | Yes | tag |
;; | ID selector | Yes | #foo |
;; | Class selector | Yes | .foo |
;; | Attribute selector | Yes | [foo] |
;; | Exact match attribute selector | Yes | [foo=bar] |
;; | Prefix match attribute selector | Yes | [foo^=bar] |
;; | Suffix match attribute selector | Yes | [foo$=bar] |
;; | Substring match attribute selector | Yes | [foo*=bar] |
;; | Include match attribute selector | Yes | [foo~=bar] |
;; | Dash match attribute selector | Yes | [foo|=bar] |
;; | Attribute selector modifiers | No | [foo=bar i] |
;; | Pseudo elements | No | ::foo |
;; | Pseudo classes | No | :foo |
;;; Code:
(require 'cl-lib)
;;; CSS selector parsing
;; https://www.w3.org/TR/selectors/#w3cselgrammar
;; https://www.w3.org/TR/selectors4/#grammar
;; https://www.w3.org/TR/2003/WD-css3-syntax-20030813/#detailed-grammar
;; https://www.w3.org/TR/2003/WD-css3-syntax-20030813/#tokenization
;; you might be wondering why I'm using both level 3 and 4 standards,
;; well, the level 3 one has a buggy lexer section whereas level 4
;; omits crucial parser definitions, so both have to be used...
;; TODO: support :not
(defvar esxml--css-selector-token-matchers
(let* ((h "[0-9a-f]")
(nl "\n\\|\r\n\\|\r\\|\f")
(nonascii "[\200-\U0010ffff]")
(unicode (format "\\\\%s\\{1,6\\}[ \t\r\n\f]?" h))
(escape (format "\\(?:%s\\)\\|\\\\[ -~\200-\U0010ffff]" unicode))
(nmstart (format "[a-z_]\\|%s\\|\\(?:%s\\)" nonascii escape))
(nmchar (format "[a-z0-9_-]\\|%s\\|\\(?:%s\\)" nonascii escape))
(num "[0-9]+\\|[0-9]*\\.[0-9]+")
(string1 (format "\"\\(?:[\t !#$%%&(-~]\\|\\\\\\(?:%s\\)\\|'\\|%s\\|\\(?:%s\\)\\)*\"" nl nonascii escape))
(string2 (format "'\\(?:[\t !#$%%&(-~]\\|\\\\\\(?:%s\\)\\|\"\\|%s\\|\\(?:%s\\)\\)*'" nl nonascii escape))
(ident (format "[-]?\\(?:%s\\)\\(?:%s\\)*" nmstart nmchar))
(unit (format "[-]?\\(?:%s\\)\\(?:%s\\)+" nmstart nmchar))
(name (format "\\(?:%s\\)+" nmchar)))
`((whitespace . "[ \t\r\n\f]+")
(string . ,(format "\\(?:%s\\|%s\\)" string1 string2))
(ident . ,ident)
(hash . ,(format "#%s" name))
(function . ,(format "%s(" ident))
(number . ,num)
(dimension . ,(format "\\(?:%s\\)%s" num unit))
(prefix-match . "\\^=")
(suffix-match . "\\$=")
(substring-match . "\\*=")
(include-match . "~=")
(dash-match . "|=")
(comma . ",")
(gt . ">")
(plus . "\\+")
(minus . "-")
(tilde . "~")
(asterisk . "\\*")
(period . "\\.")
(equals . "=")
(colon . ":")
(lbracket . "\\[")
(rbracket . "\\]")
(rparen . ")"))))
(defun esxml--tokenize-css-selector (string)
(let (result)
(with-temp-buffer
(insert string)
(goto-char (point-min))
(while (not (eobp))
(let ((max-length 0)
longest)
(dolist (matcher esxml--css-selector-token-matchers)
(let ((id (car matcher))
(re (cdr matcher)))
(when (looking-at re)
(let* ((token (match-string 0))
(length (length token)))
(when (> length max-length)
(setq max-length length)
(setq longest (cons id token)))))))
(when (not longest)
(error "Invalid token detected: %s"
(buffer-substring (point) (point-max))))
(push longest result)
(goto-char (+ (point) max-length)))))
(nreverse result)))
;; the alternative is creating a mutable object with peek/next methods
;; and passing it around, so I chose the one requiring less typing, a
;; dynamically bound variable :<
(defvar esxml--token-stream)
;; TODO: support :not
;; css-selector:
;; css-selector-list;
;; css-selector-list:
;; complex-css-selector [ comma whitespace* complex-css-selector ]*;
;; complex-css-selector:
;; compound-css-selector [ css-combinator compound-css-selector ]* whitespace*;
;; css-combinator:
;; whitespace+ | whitespace* [ '>' | '+' | '~' ] whitespace*;
;; compound-css-selector:
;; css-type-selector css-modifier* | css-modifier+;
;; css-type-selector:
;; IDENT | *;
;; css-modifier:
;; css-id | css-class | css-attrib | css-pseudo;
;; css-id:
;; HASH;
;; css-class:
;; '.' IDENT;
;; css-attrib:
;; '[' whitespace* css-attrib-name ']'
;; | '[' whitespace* css-attrib-name css-attrib-match css-attrib-value whitespace* ']';
;; css-attrib-name:
;; IDENT whitespace*;
;; css-attrib-match:
;; [ '=' | PREFIX-MATCH | SUFFIX-MATCH | SUBSTRING-MATCH | INCLUDE-MATCH | DASH-MATCH ] whitespace*;
;; css-attrib-value:
;; IDENT | STRING;
;; css-pseudo:
;; ':' ':'? [ IDENT | css-functional-pseudo ];
;; css-functional-pseudo:
;; FUNCTION whitespace* [ css-expression whitespace* ]+ ')';
;; css-expression:
;; '+' | '-' | DIMENSION | NUMBER | STRING | IDENT
(defun esxml-query-css-escape (string)
"Returns escaped version of STRING for use in selectors.
The logic used here corresponds to the CSS.escape API as
specified in https://drafts.csswg.org/cssom/#the-css.escape()-method."
(let (chars)
(dotimes (i (length string))
(let* ((char (aref string i))
(unprintablep (or (and (>= char ?\u0001) (<= char ?\u001f))
(= char ?\u007f)))
(nonasciip (>= char ?\u0080))
(digitp (and (>= char ?\u0030) (<= char ?\u0039)))
(upperp (and (>= char ?\u0041) (<= char ?\u005a)))
(lowerp (and (>= char ?\u0061) (<= char ?\u007a))))
(cond
((= char ?\u0000)
(push ?\ufffd chars))
(unprintablep
(dolist (char (string-to-list (format "\\%x " char)))
(push char chars)))
((and (= i 0) digitp)
(dolist (char (string-to-list (format "\\%x " char)))
(push char chars)))
((and (= i 1) digitp (= (aref string 0) ?-))
(dolist (char (string-to-list (format "\\%x " char)))
(push char chars)))
((and (= i 0) (= char ?-) (= (length string) 1))
(push ?\\ chars)
(push char chars))
((or nonasciip (= char ?-) (= char ?_) digitp upperp lowerp)
(push char chars))
(t
(push ?\\ chars)
(push char chars)))))
(concat (nreverse chars))))
(defun esxml--parse-css-identifier (string)
;; https://www.w3.org/TR/css-syntax-3/#consume-string-token
(let* ((code-points (string-to-list string))
chars
token)
(while code-points
(let ((char (pop code-points)))
(if (= char ?\\)
(let ((char (pop code-points)))
(cond
((not char))
((= char ?\n))
((or (and (>= char ?0) (<= char ?9))
(and (>= char ?a) (<= char ?f))
(and (>= char ?A) (<= char ?F)))
(let ((i 0)
(hex-chars (list char)))
(while (and (< i 5) code-points)
(let ((char (car code-points)))
(if (or (and (>= char ?0) (<= char ?9))
(and (>= char ?a) (<= char ?f))
(and (>= char ?A) (<= char ?F)))
(push (pop code-points) hex-chars)
(setq i 5)))
(setq i (1+ i)))
(let ((char (car code-points)))
(when (and char (= char ?\s))
(pop code-points)))
(let* ((hex-token (concat (nreverse hex-chars)))
(code-point (string-to-number hex-token 16)))
(if (or (zerop code-point)
(and (>= code-point ?\ud800) (<= code-point ?\udfff))
(> code-point ?\U0010ffff))
(push ?\ufffd chars)
(push code-point chars)))))
(t ; unspecified: non-hex digit
(push char chars))))
(push char chars))))
(concat (nreverse chars))))
(defun esxml--parse-css-string-literal (string)
(esxml--parse-css-identifier (substring string 1 -1)))
(defmacro esxml--with-parse-shorthands (&rest body)
`(cl-macrolet ((peek () '(car esxml--token-stream))
(next () '(pop esxml--token-stream))
(accept (type) `(and (peek) (eq (car (peek)) ,type)
(cdr (next))))
(eat-whitespace () '(while (accept 'whitespace))))
,@body))
(def-edebug-spec esxml--with-parse-shorthands (body))
(defun esxml-parse-css-selector (string)
"Parse CSS selector STRING into a list of alists.
Each alist represents a complex CSS selector. The result can be
passed to `esxml-query' and `esxml-query-all' as the selector
argument."
(let* ((esxml--token-stream (esxml--tokenize-css-selector string))
(result (esxml--parse-css-selector-list)))
(when esxml--token-stream
(error "Trailing garbage: %s"
(mapconcat 'cdr esxml--token-stream "")))
result))
(defun esxml--parse-css-selector-list ()
(esxml--with-parse-shorthands
(let ((first (esxml--parse-complex-css-selector))
result)
(when (not first)
(error "Expected at least one selector"))
(push first result)
(while (accept 'comma)
(eat-whitespace)
(let ((selector (esxml--parse-complex-css-selector)))
(when (not selector)
(error "Expected selector after comma"))
(push selector result)))
(nreverse result))))
(defun esxml--parse-complex-css-selector ()
(esxml--with-parse-shorthands
(let ((first (esxml--parse-compound-css-selector))
result done)
(when first
(push first result)
(while (not done)
(let ((combinator (esxml--parse-css-combinator)))
(if combinator
(let ((compound (esxml--parse-compound-css-selector)))
(cond
(compound
(setq result (append (list compound combinator) result)))
;; allow whitespace before comma
((not (eq (car (peek)) 'comma))
(error "Trailing combinator"))))
(setq done t))))
(nreverse result)))))
(defun esxml--parse-css-combinator ()
(esxml--with-parse-shorthands
;; NOTE: whitespace-surrounded combinators are distinguished from
;; whitespace-only ones by checking whether there has been
;; whitespace followed by a non-blank combinator
(let ((leading-whitespace-p (eq (car (peek)) 'whitespace))
result)
(eat-whitespace)
(let ((type (car (peek))))
(cond
((member type '(gt plus tilde))
(next)
(cond
((eq type 'gt)
(setq result '((combinator . child))))
((eq type 'plus)
(setq result '((combinator . direct-sibling))))
((eq type 'tilde)
(setq result '((combinator . indirect-sibling)))))
(eat-whitespace))
(leading-whitespace-p
(setq result '((combinator . descendant))))
(t nil)))
result)))
(defun esxml--parse-compound-css-selector ()
(esxml--with-parse-shorthands
(let ((type-selector (esxml--parse-css-type-selector))
done
result)
;; NOTE: css-type-selector css-modifier* | css-modifier+; is
;; equivalent to: [ css-type-selector | css-modifier ] css-modifier*;
(if type-selector
(push type-selector result)
(let ((modifier (esxml--parse-css-modifier)))
(if modifier
(push modifier result)
;; NOTE: this allows the trailing combinator error to be thrown
(setq done t))))
(while (not done)
(let ((modifier (esxml--parse-css-modifier)))
(if modifier
(push modifier result)
(setq done t))))
(when (> (cl-count 'id result :key 'car) 1)
(error "Only one id selector allowed per compound"))
(nreverse result))))
(defun esxml--parse-css-type-selector ()
(esxml--with-parse-shorthands
(let ((token (peek)))
(cond
((eq (car token) 'ident)
(next)
(cons 'tag (intern (esxml--parse-css-identifier (cdr token)))))
((eq (car token) 'asterisk)
(next)
'(wildcard))
(t nil)))))
(defun esxml--parse-css-modifier ()
(or (esxml--parse-css-id)
(esxml--parse-css-class)
(esxml--parse-css-attrib)
(esxml--parse-css-pseudo)))
(defun esxml--parse-css-id ()
(esxml--with-parse-shorthands
(let ((value (accept 'hash)))
(when value
(cons 'id (substring value 1))))))
(defun esxml--parse-css-class ()
(esxml--with-parse-shorthands
(when (accept 'period)
(let ((value (accept 'ident)))
(if value
(cons 'class value)
(error "Expected identifier after period"))))))
(defun esxml--parse-css-attrib ()
(esxml--with-parse-shorthands
(let (result)
(when (accept 'lbracket)
(eat-whitespace)
(let ((name (esxml--parse-css-attrib-name)))
(when (not name)
(error "Expected attribute name"))
(push (cons 'name (esxml--parse-css-identifier name)) result)
(when (not (accept 'rbracket))
(let ((match (esxml--parse-css-attrib-match)))
(when (not match)
(error "Expected attribute matcher"))
(let ((value (esxml--parse-css-attrib-value)))
(when (not value)
(error "Expected attribute value"))
(eat-whitespace)
(when (not (accept 'rbracket))
(error "Unterminated attribute"))
(push (cons match value) result)))))
(cons 'attribute (nreverse result))))))
(defun esxml--parse-css-attrib-name ()
(esxml--with-parse-shorthands
(let ((name (accept 'ident)))
(when name
(eat-whitespace)
name))))
(defun esxml--parse-css-attrib-match ()
(esxml--with-parse-shorthands
(let (result)
(cond
((accept 'equals)
(setq result 'exact-match))
((accept 'prefix-match)
(setq result 'prefix-match))
((accept 'suffix-match)
(setq result 'suffix-match))
((accept 'substring-match)
(setq result 'substring-match))
((accept 'include-match)
(setq result 'include-match))
((accept 'dash-match)
(setq result 'dash-match)))
(eat-whitespace)
result)))
(defun esxml--parse-css-attrib-value ()
(esxml--with-parse-shorthands
(let ((token (peek)))
(cond
((eq (car token) 'ident)
(next)
(esxml--parse-css-identifier (cdr token)))
((eq (car token) 'string)
(next)
(esxml--parse-css-string-literal (cdr token)))
(t nil)))))
(defun esxml--parse-css-pseudo ()
(esxml--with-parse-shorthands
(let (result type)
(when (accept 'colon)
(if (accept 'colon)
(setq type 'pseudo-element)
(setq type 'pseudo-class))
(let ((functional (esxml--parse-css-functional-pseudo)))
(if functional
(if (eq type 'pseudo-class)
(let ((value (car functional))
(args (cdr functional)))
(push (cons 'name (esxml--parse-css-identifier value)) result)
(push (cons 'args args) result))
(error "Pseudo-elements may not have arguments"))
(let ((value (accept 'ident)))
(if value
(push (cons 'name (esxml--parse-css-identifier value)) result)
(error "Expected function or identifier")))))
(cons type (nreverse result))))))
(defun esxml--parse-css-functional-pseudo ()
(esxml--with-parse-shorthands
(let ((function (accept 'function))
result)
(when function
(push (substring function 0 -1) result)
(eat-whitespace)
(let ((expression (esxml--parse-css-expression))
done)
(eat-whitespace)
(when (not expression)
(error "Expected at least one expression for function"))
(push expression result)
(while (not done)
(setq expression (esxml--parse-css-expression))
(if expression
(progn
(push expression result)
(eat-whitespace))
(setq done t))))
(when (not (accept 'rparen))
(error "Unterminated function argument list"))
(nreverse result)))))
(defun esxml--parse-css-expression ()
(esxml--with-parse-shorthands
(let ((token (peek)))
(cond
((accept 'plus)
'(operator . +))
((accept 'minus)
'(operator . -))
((eq (car token) 'dimension)
(next)
(cons 'dimension (esxml--parse-css-identifier (cdr token))))
((eq (car token) 'number)
(next)
(cons 'number (string-to-number (cdr token))))
((eq (car token) 'string)
(next)
(cons 'string (esxml--parse-css-string-literal (cdr token))))
((eq (car token) 'ident)
(next)
(cons 'ident (esxml--parse-css-identifier (cdr token))))
(t nil)))))
;;; tree traversal
;; TODO: these helpers should be part of esxml.el
(defun esxml-branch-p (node)
"Non-nil if NODE refers to an esxml branch."
(and (listp node)
(>= (length node) 2)
(symbolp (car node))
(listp (cadr node))))
(defun esxml-node-tag (node)
"Returns the tag of NODE if available."
(and (esxml-branch-p node)
(car node)))
(defun esxml-node-attributes (node)
"Returns the attributes of NODE if available."
(and (esxml-branch-p node)
(cadr node)))
(defun esxml-node-attribute (attribute node)
"Returns the attribute ATTRIBUTE of NODE if available."
(and (esxml-branch-p node)
(cdr (assq attribute (cadr node)))))
(defun esxml-node-children (node)
"Returns the children of NODE if available."
(and (esxml-branch-p node)
(nthcdr 2 node)))
(defun esxml-find-node (pred root)
"Locates a node satisfying PRED starting from ROOT.
Returns the node or nil if none found."
(if (funcall pred root)
root
(cl-some (lambda (node) (esxml-find-node pred node))
(esxml-node-children root))))
(defun esxml-visit-nodes (function root)
"Visit nodes by calling FUNCTION on each starting from ROOT."
(funcall function root)
(mapc (lambda (node) (esxml-visit-nodes function node))
(esxml-node-children root)))
(defun esxml-find-nodes (pred root)
"Locates all nodes satisfying PRED starting from ROOT.
Returns a list of the nodes or nil if none found."
(let ((acc '()))
(esxml-visit-nodes
(lambda (node)
(when (funcall pred node)
(push node acc)))
root)
(nreverse acc)))
(defun esxml-find-descendant (pred root)
"Locates a node satisfying PRED starting from ROOT's children.
Returns the node or nil if none found."
(cl-some (lambda (node) (esxml-find-node pred node))
(esxml-node-children root)))
(defun esxml-find-descendants (pred root)
"Locates all nodes satisfying PRED starting from ROOT's children.
Returns a list of the nodes or nil if none found."
(cl-mapcan (lambda (node) (esxml-find-nodes pred node))
(esxml-node-children root)))
(defun esxml-find-child (pred root)
"Locates a node satisfying PRED among ROOT's children.
Returns the node or nil if none found."
(cl-some (lambda (node) (when (funcall pred node) node))
(esxml-node-children root)))
(defun esxml-find-children (pred root)
"Locates all nodes satisfying PRED among ROOT's children.
Returns a list of the nodes or nil if none found."
(mapcar (lambda (node) (when (funcall pred node) node))
(esxml-node-children root)))
(defun esxml--node-with-children (node children)
(let ((tag (esxml-node-tag node))
(attributes (esxml-node-attributes node)))
(append (list tag attributes) children)))
(defun esxml--node-with-attributes (node attributes)
(let ((tag (esxml-node-tag node))
(children (esxml-node-children node)))
(append (list tag attributes) children)))
(defun esxml-tree-map (function root)
"Returns a copy of ROOT with FUNCTION applied to each node."
(if (esxml-branch-p root)
(esxml--node-with-children
(funcall function root)
(mapcar (lambda (node) (esxml-tree-map function node))
(esxml-node-children root)))
(funcall function root)))
(defvar esxml--symbol (make-symbol "id"))
(defun esxml--decorate-tree (root)
(let ((i 0))
(esxml-tree-map
(lambda (node)
(let ((attribute (cons esxml--symbol i))
(attributes (esxml-node-attributes node)))
(setq attributes (append (list attribute) attributes))
(setq i (1+ i))
(if (esxml-branch-p node)
(esxml--node-with-attributes node attributes)
node)))
root)))
(defun esxml--undecorate-node (node)
(if (esxml-branch-p node)
(let ((attributes (esxml-node-attributes node)))
(esxml--node-with-attributes node (assq-delete-all esxml--symbol
attributes)))
node))
(defun esxml--retrieve-decoration (node)
(esxml-node-attribute esxml--symbol node))
;;; querying
;; NOTE: supporting structural pseudo functions, direct siblings and
;; indirect siblings requires breadth instead of depth traversal,
;; something that could be emulated without zippers if you had the
;; parent of the node (and the position of the child)...
(defun esxml--node-matches-attribute-p (node modifier)
(let ((attributes (esxml-node-attributes node))
haystack)
(cl-every
(lambda (item)
(let ((type (car item))
(value (cdr item)))
(cond
((eq type 'name)
(let ((match (assq (intern value) attributes)))
(setq haystack (cdr match))
match))
((eq type 'exact-match)
(equal haystack value))
((eq type 'prefix-match)
(string-prefix-p value haystack))
((eq type 'suffix-match)
(string-suffix-p value haystack))
((eq type 'substring-match)
(string-match-p (regexp-quote value) haystack))
((eq type 'include-match)
(member value (split-string haystack " ")))
((eq type 'dash-match)
(or (equal value haystack)
(string-match-p (format "^%s-" (regexp-quote value)) haystack)))
(t (error "Unknown attribute modifier")))))
modifier)))
(defun esxml--node-matches-modifier-p (node type value)
(cond
((eq type 'wildcard)
t)
((eq type 'tag)
(equal (esxml-node-tag node) value))
((eq type 'id)
(equal (esxml-node-attribute 'id node) value))
((eq type 'class)
(let ((class (esxml-node-attribute 'class node)))
(and class (member value (split-string class " ")))))
((eq type 'attribute)
(esxml--node-matches-attribute-p node value))
;; TODO: support structural pseudo functions
;; TODO: error out on invalid pseudo-class arguments
(t (error "Unimplemented attribute type: %s" type))))
(defun esxml--find-node-for (attributes)
(lambda (node)
(cl-every
(lambda (attribute)
(let ((type (car attribute))
(value (cdr attribute)))
(esxml--node-matches-modifier-p node type value)))
attributes)))
(defun esxml--find-nodes (root combinator attributes)
(let* ((type (cdr (assq 'combinator combinator)))
(walker (cond
((not type)
'esxml-find-nodes)
((eq type 'descendant)
'esxml-find-descendants)
((eq type 'child)
'esxml-find-children)
;; TODO: support direct sibling
;; TODO: support indirect sibling
(t (error "Unimplemented combinator %s" combinator)))))
(funcall walker (esxml--find-node-for attributes) root)))
(defun esxml--query (selector root)
(let* ((attributes (pop selector))
combinator
(result (esxml--find-nodes root nil attributes)))
(while (and result selector)
(setq combinator (pop selector))
(setq attributes (pop selector))
(setq result (cl-mapcan
(lambda (node)
(esxml--find-nodes node combinator attributes))
result))
(setq result (delq nil result)))
result))
(defun esxml--delete-dups (items test)
(let ((seen (make-hash-table :test test))
result)
(while items
(let ((item (pop items)))
(when (not (gethash item seen))
(push item result)
(puthash item t seen))))
(nreverse result)))
(defun esxml-query-all (selector root)
"Locates all nodes satisfying SELECTOR starting from ROOT.
SELECTOR must be a string containing a CSS selector or a parsed
CSS selector returned by `esxml-parse-css-selector'. Returns a
list of the nodes or nil if none found."
(when (stringp selector)
(setq selector (esxml-parse-css-selector selector)))
(if (= (length selector) 1)
;; no commas, we can only get the same nodes repeatedly
(esxml--delete-dups (esxml--query (car selector) root) 'eq)
;; commas, nodes might be the same *and* in the wrong order
(setq root (esxml--decorate-tree root))
(let (result)
(while selector
(setq result (nconc result (esxml--query (pop selector) root))))
(setq result (cl-sort result '< :key 'esxml--retrieve-decoration))
(setq result (cl-delete-duplicates result :test '=
:key 'esxml--retrieve-decoration))
(mapcar (lambda (node) (esxml--undecorate-node node)) result))))
(defun esxml-query (selector root)
"Locates a node satisfying SELECTOR starting from ROOT.
SELECTOR must be a string containing a CSS selector or a parsed
CSS selector returned by `esxml-parse-css-selector'. Returns the
node or nil if none found."
;; NOTE: you can do a bit less work (the savings decrease the more
;; branches the query discards), but it's simpler and safer to just
;; have the same algorithm for both entry points
(car (esxml-query-all selector root)))
(provide 'esxml-query)
;;; esxml-query.el ends here
(define-package "esxml" "20230308.2254" "Library for working with xml via esxml and sxml"
'((emacs "24.1")
(kv "0.0.5")
(cl-lib "0.5"))
:commit "225693096a587492d76bf696d1f0c25c61f7d531" :authors
'(("Vanya Izaksonas-Smith <izak0002 at umn dot edu>"))
:maintainer
'("Vanya Izaksonas-Smith")
:keywords
'("tools" "lisp" "comm")
:url "https://github.com/tali713/esxml")
;; Local Variables:
;; no-byte-compile: t
;; End:
;;; esxml-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
;; Generated by the `loaddefs-generate' function.
;; This file is part of GNU Emacs.
;;; Code:
(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
;;; Generated autoloads from esxml.el
(register-definition-prefixes "esxml" '("attr" "esxml-" "pp-esxml-to-xml" "string-trim-whitespace" "sxml-to-" "xml-to-esxml"))
;;; Generated autoloads from esxml-query.el
(register-definition-prefixes "esxml-query" '("esxml-"))
;;; End of scraped data
(provide 'esxml-autoloads)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; no-native-compile: t
;; coding: utf-8-emacs-unix
;; End:
;;; esxml-autoloads.el ends here