psi-jack
/
ultimate-vim
mirror of
1
0
Fork 0
Code Issues Releases Wiki Activity

Add support for Scheme and Racket language.

This commit is contained in:
Kurtis Moxley 2022-06-05 18:14:25 +08:00
parent ea73a5a99d
commit e371e16382
129 changed files with 67865 additions and 587 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
sources_non_forked/guile.vim/COPYING.txt
View File

@ -1,19 +0,0 @@
Copyright (c) 2019 HiPhish
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

42
sources_non_forked/guile.vim/README.rst
View File

@ -1,42 +0,0 @@
.. default-role:: code
###########################
GNU Guile support for Vim
###########################
This plugin extends Vim's Scheme support to include the additions to the
language provided by the `GNU Guile`_ implementation. The plugin automatically
detects whether a Scheme file is a Guile file and adds syntax highlighting for
Guile's special forms.
Installation
############
Install this like any other Vim plugin.
Using the plugin
################
When a Guile buffer has been detected its `filetype` option will be set to the
value `scheme.guile`. This uses Vim's dotted file type (see `:h 'filetype'`) in
order to allow users to keep using their setting any plugins for Scheme in
addition to this.
Guile is detected by either looking for a shebang in the first line (see
`4.3.1 The Top of a Script File`_ in the Guile manual), or by scanning the file
for an occurrence of `define-module` or `use-modules`. This is not absolutely
reliable, but it should work for the vast majority of cases.
License
#######
Released under the MIT (Expat) license, see the COPYING_ file for details.
.. ----------------------------------------------------------------------------
.. _GNU Guile: http://www.gnu.org/software/guile/
.. _COPYING: COPYING.txt
.. _4.3.1 The Top of a Script File: info:guile.info#The%20Top%20of%20a%20Script%20File

43
sources_non_forked/guile.vim/autoload/guile.vim
View File

@ -1,43 +0,0 @@
" License: The MIT License (MIT) {{{
" Copyright (c) 2019 HiPhish
"
" Permission is hereby granted, free of charge, to any person obtaining a
" copy of this software and associated documentation files (the
" "Software"), to deal in the Software without restriction, including
" without limitation the rights to use, copy, modify, merge, publish,
" distribute, sublicense, and/or sell copies of the Software, and to permit
" persons to whom the Software is furnished to do so, subject to the
" following conditions:
"
" The above copyright notice and this permission notice shall be included
" in all copies or substantial portions of the Software.
"
" THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
" OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
" MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN
" NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
" DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
" OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE
" USE OR OTHER DEALINGS IN THE SOFTWARE.
" }}}
" -----------------------------------------------------------------------------
" Detect whether the file is a Guile file.
"
" Try to find Guile-specific forms, e.g. the Guile shebang or a define-module
" expression.
" -----------------------------------------------------------------------------
function! guile#detect()
" Guile uses the shebang in the first line
if getline(1) =~? '\v^#!.*[Gg]uile'
return 1
endif
" Search for a module definition
let l:save_cursor = getcurpos()
call cursor(1, 1)
if search('\v\(\s*(define-module|use-modules)\s*\(', 'c', 0, 1000)
return 1
endif
call setpos('.', l:save_cursor)
return 0
endfunction

36
sources_non_forked/guile.vim/ftdetect/scheme.vim
View File

@ -1,36 +0,0 @@
" License: The MIT License (MIT) {{{
" Copyright (c) 2019 HiPhish
"
" Permission is hereby granted, free of charge, to any person obtaining a
" copy of this software and associated documentation files (the
" "Software"), to deal in the Software without restriction, including
" without limitation the rights to use, copy, modify, merge, publish,
" distribute, sublicense, and/or sell copies of the Software, and to permit
" persons to whom the Software is furnished to do so, subject to the
" following conditions:
"
" The above copyright notice and this permission notice shall be included
" in all copies or substantial portions of the Software.
"
" THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
" OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
" MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN
" NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
" DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
" OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE
" USE OR OTHER DEALINGS IN THE SOFTWARE.
" }}}
" Safely adjust to file type to not include `guile` more than once
function! s:adjust_ft()
for l:ft in split(&filetype, '\v\.')
if l:ft == 'guile'
return
endif
endfor
let &ft.='.guile'
endfunction
augroup filetypedetect
autocmd BufRead,BufNewFile *scm if guile#detect() | call s:adjust_ft() | endif
augroup end

184
sources_non_forked/guile.vim/logo.svg
View File

@ -1,184 +0,0 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<!-- Created with Inkscape (http://www.inkscape.org/) -->
<svg
xmlns:dc="http://purl.org/dc/elements/1.1/"
xmlns:cc="http://creativecommons.org/ns#"
xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
xmlns:svg="http://www.w3.org/2000/svg"
xmlns="http://www.w3.org/2000/svg"
xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
width="512"
height="512"
viewBox="0 0 511.99995 512"
id="svg4268"
version="1.1"
inkscape:version="0.92.4 (5da689c313, 2019-01-14)"
sodipodi:docname="logo.svg">
<defs
id="defs4270" />
<sodipodi:namedview
id="base"
pagecolor="#ffffff"
bordercolor="#666666"
borderopacity="1.0"
inkscape:pageopacity="0.0"
inkscape:pageshadow="2"
inkscape:zoom="0.71223882"
inkscape:cx="396.59138"
inkscape:cy="218.04935"
inkscape:document-units="px"
inkscape:current-layer="g3880"
showgrid="false"
units="px"
height="200px"
showguides="true"
inkscape:guide-bbox="true"
inkscape:window-width="1253"
inkscape:window-height="685"
inkscape:window-x="421"
inkscape:window-y="220"
inkscape:window-maximized="0" />
<metadata
id="metadata4273">
<rdf:RDF>
<cc:Work
rdf:about="">
<dc:format>image/svg+xml</dc:format>
<dc:type
rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
<dc:title></dc:title>
</cc:Work>
</rdf:RDF>
</metadata>
<g
inkscape:label="Capa 1"
inkscape:groupmode="layer"
id="layer1"
transform="translate(0,-540.36216)">
<g
transform="translate(747.52659,-1312.6768)"
id="g3880"
inkscape:export-filename="favicon.png"
inkscape:export-xdpi="90"
inkscape:export-ydpi="90">
<path
sodipodi:nodetypes="ccsccsc"
inkscape:connector-curvature="0"
style="fill:#f2f2f2;fill-opacity:0.9956522;stroke:none;stroke-width:2.58588266"
d="m -461.9174,1885.039 v 65.7391 c 74.01318,14.0043 130.02299,79.5383 130.02299,158.2609 0,78.7225 -56.00981,144.2562 -130.02299,158.2608 v 65.7392 c 109.72779,-14.6046 194.39081,-109.3294 194.39081,-224 0,-114.6709 -84.66302,-209.3955 -194.39081,-224 z"
id="path4028" />
<g
transform="matrix(0.59020223,0,0,0.59020223,-698.53366,1863.4146)"
id="layer1-3">
<g
transform="matrix(1.532388,0,0,1.3939671,-54.912136,-41.792396)"
id="g3699">
<path
style="fill:#019833;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="M 260.50744,170.69515 105.98412,340.79094 259.8636,510.178 414.38691,340.08221 Z"
id="path2836"
inkscape:connector-curvature="0" />
<path
style="fill:#66fe98;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="M 259.8636,171.40389 V 156.52051 L 91.819492,341.49967 h 14.164628 z"
id="path2838"
inkscape:connector-curvature="0" />
<path
id="path2840"
d="m 259.47729,171.40389 v -14.88338 l 168.0441,184.97916 h -14.16463 z"
style="fill:#45fe02;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
inkscape:connector-curvature="0" />
<path
id="path2842"
d="M 259.8636,511.17022 V 526.0536 L 91.819492,341.07444 h 14.164628 z"
style="fill:#017d17;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
inkscape:connector-curvature="0" />
<path
style="fill:none;stroke:#000000;stroke-width:18.91431427;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
d="m 122.99448,175.30643 h 108.35396 l 6.60139,7.26665 v 22.30116 l -5.23559,7.01608 H 220.87725 V 322.64438 L 322.85744,211.89032 H 306.0125 l -5.9185,-7.01608 v -23.55403 l 5.46323,-5.51264 h 109.71976 l 5.46322,6.01379 v 22.05058 L 172.61878,484.01452 H 144.39212 L 136.22179,478.822 V 210.88803 h -13.68257 l -5.00795,-5.51264 v -23.55403 z"
id="path3650"
inkscape:connector-curvature="0" />
<path
style="fill:#005d04;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="M 259.47729,511.17022 V 526.0536 L 427.52139,341.07444 H 413.35676 Z"
id="path2844"
inkscape:connector-curvature="0" />
<path
id="path2846"
d="M 259.41018,155.14848 90.734026,340.82339 258.70737,525.72467 427.38353,340.04975 Z"
style="fill:none;stroke:#000000;stroke-width:5.67429399;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
inkscape:connector-curvature="0" />
<path
style="fill:#fefefe;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m 232.50008,186.64163 6.11655,-3.54366 -6.27751,-6.91014 H 123.04607 l -5.55319,6.11281 v 23.1224 l 6.15679,6.77725 2.93756,-6.77725 -3.86308,-4.2524 v -16.30085 l 2.89731,-2.83492 H 229.9247 Z"
id="path3640"
inkscape:connector-curvature="0" />
<path
style="fill:none;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
id="path3632"
d="m 828.9375,369.5 -4.28125,4.28125 V 389.5 l 3.75,3.75 h 19.8125 v 15.1875 L 717.15625,541.28125 V 393.4375 h 21.78125 l 4.46875,-4.46875 V 373.0625 l -4.125,-3.1875 h -114.625 l -3.75,3.75 v 16.25 l 3.8125,3.8125 h 19.9375 v 272.25 l 3.75,3.75 H 671.0625 L 945.71875,386.28125 v -12.5 L 941.4375,369.5 Z"
transform="matrix(0.90138601,0,0,0.99222542,-437.42287,-185.30615)"
inkscape:connector-curvature="0" />
<path
style="fill:#fefefe;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m 143.48158,204.87424 v 270.62073 l 3.18688,4.0092 -2.49916,5.24301 -7.06148,-7.74876 v -265.1081 z"
id="path3646"
inkscape:connector-curvature="0" />
<path
style="fill:#808080;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m 125.82451,204.87424 -1.82108,6.51494 h 13.2028 l 7.2843,-6.51494 z"
id="path3644"
inkscape:connector-curvature="0" />
<path
style="fill:#fefefe;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m 307.18636,212.19144 2.89731,-6.55577 -4.18501,-4.2524 v -14.52901 l 4.82886,-5.31551 H 411.4896 l 3.86308,5.66987 5.4727,-4.2524 -5.63366,-6.20141 H 306.86443 l -5.39221,5.93564 v 23.29957 l 5.59342,5.80276 m -87.54309,111.87785 -10.52288,28.10566 118.7898,-131.1155 v -15.59211 z"
id="path3638"
inkscape:connector-curvature="0" />
<path
style="fill:#808080;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m 232.25896,185.83056 5.2356,-3.75862 v 22.8023 l -6.03231,6.64023 h -11.72317 v 112.38277 l -10.69882,27.81381 V 204.87424 h 19.57656 l 3.64214,-3.25747 z"
id="path3642"
inkscape:connector-curvature="0" />
<path
style="fill:#cccccc;fill-opacity:1;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
id="path3622"
d="m 828.9375,369.5 -4.28125,4.28125 V 389.5 l 3.75,3.75 h 19.8125 v 15.1875 L 717.15625,541.28125 V 393.4375 h 21.78125 l 4.46875,-4.46875 V 373.0625 l -4.125,-3.1875 h -114.625 l -3.75,3.75 v 16.25 l 3.8125,3.8125 h 19.9375 v 272.25 l 3.75,3.75 H 671.0625 L 945.71875,386.28125 v -12.5 L 941.4375,369.5 Z"
transform="matrix(0.90138601,0,0,0.99222542,-437.42287,-185.30615)"
inkscape:connector-curvature="0" />
<path
style="fill:#808080;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m 415.35268,185.9329 5.49849,-3.49448 v 21.92152 L 171.46006,484.88124 H 144.9826 l 2.52966,-5.5331 h 20.28119 L 415.03076,198.33573 Z"
id="path3636"
inkscape:connector-curvature="0" />
<path
style="fill:#808080;fill-opacity:1;stroke:#000000;stroke-width:0.94571567px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m 327.29631,205.25009 -5.57703,6.38966 h -14.56861 l 3.41452,-6.38966 c 0.11382,0 16.73112,0 16.73112,0 z"
id="path3652"
inkscape:connector-curvature="0" />
<g
id="g3673"
transform="matrix(0.90138601,0,0,0.99222542,-92.530288,-192.23791)">
<path
d="m 399.78125,560 a 1.2330102,1.2330102 0 0 0 -0.5625,0.28125 l -5.3125,4.5625 A 1.2330102,1.2330102 0 0 0 393.5625,565.375 L 388.25,580.25 a 1.2330102,1.2330102 0 0 0 0.28125,1.28125 l 4.0625,4.0625 a 1.2330102,1.2330102 0 0 0 0.875,0.34375 H 409.875 a 1.2330102,1.2330102 0 0 0 0.875,-0.34375 l 4.28125,-4.3125 a 1.2330102,1.2330102 0 0 0 0.3125,-0.53125 l 4.5625,-15.65625 a 1.2330102,1.2330102 0 0 0 -0.3125,-1.21875 l -3.53125,-3.53125 A 1.2330102,1.2330102 0 0 0 415.1875,560 h -15.15625 a 1.2330102,1.2330102 0 0 0 -0.25,0 z m -30.0625,41.9375 a 1.2330102,1.2330102 0 0 0 -0.9375,0.90625 l -2.03125,8.0625 a 1.2330102,1.2330102 0 0 0 1.1875,1.53125 h 9.65625 l -23.9375,68.34375 a 1.2330102,1.2330102 0 0 0 1.15625,1.625 h 34.84375 a 1.2330102,1.2330102 0 0 0 1.1875,-0.84375 l 2.28125,-7.34375 a 1.2330102,1.2330102 0 0 0 -1.1875,-1.59375 h -7.875 L 407.75,603.5625 a 1.2330102,1.2330102 0 0 0 -1.15625,-1.625 h -36.625 a 1.2330102,1.2330102 0 0 0 -0.25,0 z m 110.875,0.25 a 1.2330102,1.2330102 0 0 0 -0.6875,0.40625 l -7.25,8.1875 H 461.125 l -7.6875,-7.96875 a 1.2330102,1.2330102 0 0 0 -0.875,-0.375 H 425.03125 A 1.2330102,1.2330102 0 0 0 423.875,603.25 l -2.53125,7.5625 a 1.2330102,1.2330102 0 0 0 1.15625,1.625 h 7.375 l -22.9375,67.59375 a 1.2330102,1.2330102 0 0 0 1.15625,1.625 h 29.3125 a 1.2330102,1.2330102 0 0 0 1.15625,-0.8125 l 2.25,-6.59375 a 1.2330102,1.2330102 0 0 0 -1.15625,-1.625 h -5.125 l 14.625,-46.03125 H 475.625 l -16.6875,53.46875 a 1.2330102,1.2330102 0 0 0 1.1875,1.59375 h 28.28125 a 1.2330102,1.2330102 0 0 0 1.125,-0.75 l 2.53125,-6.0625 a 1.2330102,1.2330102 0 0 0 -1.125,-1.6875 h -5.125 l 14.875,-46.8125 h 25.1875 l -16.9375,53.71875 a 1.2330102,1.2330102 0 0 0 1.1875,1.59375 h 31.0625 a 1.2330102,1.2330102 0 0 0 1.15625,-0.78125 l 2.53125,-6.59375 a 1.2330102,1.2330102 0 0 0 -1.15625,-1.65625 h -6.15625 l 18.71875,-60.78125 a 1.2330102,1.2330102 0 0 0 -0.1875,-1.125 l -5.8125,-7.8125 a 1.2330102,1.2330102 0 0 0 -1,-0.46875 H 527.0625 a 1.2330102,1.2330102 0 0 0 -0.90625,0.375 l -7,7.6875 h -12.25 l -7.25,-7.9375 a 1.2330102,1.2330102 0 0 0 -0.90625,-0.375 h -17.90625 a 1.2330102,1.2330102 0 0 0 -0.25,0 z"
id="path3671"
style="fill:#cccccc;fill-opacity:1;stroke:#000000;stroke-width:8;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:10;stroke-dasharray:none;stroke-opacity:1"
inkscape:connector-curvature="0" />
<path
style="fill:#cccccc;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:10;stroke-dasharray:none;stroke-opacity:1"
id="path3665"
d="m 400.03125,561.21875 -5.3125,4.5625 -5.3125,14.875 4.0625,4.0625 H 409.875 l 4.28125,-4.3125 4.5625,-15.65625 -3.53125,-3.53125 z m -30.0625,41.9375 -2.03125,8.0625 h 11.375 l -24.5,69.96875 h 34.84375 l 2.28125,-7.34375 h -9.59375 l 24.25,-70.6875 z m 110.875,0.25 L 473.25,612 h -12.625 l -8.0625,-8.34375 h -27.53125 l -2.53125,7.5625 h 9.09375 l -23.5,69.21875 h 29.3125 l 2.25,-6.59375 h -6.8125 L 448.25,625.375 h 29.0625 l -17.1875,55.0625 h 28.28125 l 2.53125,-6.0625 h -6.8125 l 15.65625,-49.25 h 27.78125 l -17.4375,55.3125 h 31.0625 l 2.53125,-6.59375 H 535.875 l 19.21875,-62.375 -5.8125,-7.8125 H 527.0625 l -7.34375,8.0625 h -13.375 l -7.59375,-8.3125 z"
inkscape:connector-curvature="0" />
</g>
</g>
</g>
<path
sodipodi:nodetypes="csccscc"
inkscape:connector-curvature="0"
id="path4030"
d="m -521.13579,1885.039 c -109.72778,14.6045 -194.3908,109.3291 -194.3908,224 0,114.6706 84.66302,209.3954 194.3908,224 v -65.7392 c -74.0132,-14.0046 -130.02298,-79.5383 -130.02298,-158.2608 0,-78.7226 56.00978,-144.2566 130.02298,-158.2609 z"
style="fill:#d0343f;fill-opacity:1;stroke:none;stroke-width:2.58588266" />
</g>
</g>
</svg>
Side by Side

Before

Width:  |  Height:  |  Size: 13 KiB

6
sources_non_forked/guile.vim/makefile
View File

@ -1,6 +0,0 @@
VIM = nvim
.PHONY: check
check:
@VADER_OUTPUT_FILE=/dev/stdout $(VIM) --headless -c 'Vader! test/*.vader'

106
sources_non_forked/guile.vim/syntax/guile.vim
View File

@ -1,106 +0,0 @@
" License: The MIT License (MIT) {{{
" Copyright (c) 2019 HiPhish
"
" Permission is hereby granted, free of charge, to any person obtaining a
" copy of this software and associated documentation files (the
" "Software"), to deal in the Software without restriction, including
" without limitation the rights to use, copy, modify, merge, publish,
" distribute, sublicense, and/or sell copies of the Software, and to permit
" persons to whom the Software is furnished to do so, subject to the
" following conditions:
"
" The above copyright notice and this permission notice shall be included
" in all copies or substantial portions of the Software.
"
" THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
" OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
" MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN
" NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
" DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
" OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE
" USE OR OTHER DEALINGS IN THE SOFTWARE.
" }}}
" GNU Guile syntax highlighting for extensions to Scheme
scriptencoding utf-8
" =============================================================================
" Multi-line comments, used for the shebang
syntax region guileComment start='\v<#!' end='\v!#'
" Keywords
syntax match guileKeyword '\v<#:[^ ()]+>'
" ===[ Special keywords ]======================================================
" Special keywords
syntax keyword guileSyntax define*
syntax keyword guileSyntax define-public
syntax keyword guileSyntax define-module
syntax keyword guileSyntax define-accessor
syntax keyword guileSyntax define-class
syntax keyword guileSyntax define-enumeration
syntax keyword guileSyntax define-inlinable
syntax keyword guileSyntax define-syntax-parameter
syntax keyword guileSyntax λ
syntax keyword guileSyntax lambda*
syntax keyword guileSyntax use-modules
syntax keyword guileSyntax call-with-input-file
syntax keyword guileSyntax call-with-input-string
syntax keyword guileSyntax call-with-output-file
syntax keyword guileSyntax call-with-output-string
syntax keyword guileSyntax call-with-prompt
syntax keyword guileSyntax call-with-trace
syntax keyword guileSyntax eval-when
syntax keyword guileSyntax syntax-parameterize
syntax keyword guileSyntax with-error-to-file
syntax keyword guileSyntax with-error-to-port
syntax keyword guileSyntax with-error-to-string
syntax keyword guileSyntax with-fluid*
syntax keyword guileSyntax with-fluids
syntax keyword guileSyntax with-fluids*
syntax keyword guileSyntax with-input-from-port
syntax keyword guileSyntax with-input-from-string
syntax keyword guileSyntax with-output-to-port
syntax keyword guileSyntax with-output-to-string
" Macros
syntax keyword guileSyntaxSyntax define-syntax-rule
" ===[ Literals ]==============================================================
" Boolean literals
syntax keyword guileBoolean #true
syntax keyword guileBoolean #false
" Unspecified literal (e.g. the return value of '(if #f #f)')
syntax match guileConstant '\v<#\<unspecified\>>'
" Byte vector literal
syntax match guileQuote '\v<\zs#vu8\ze\('
" Number literals
syntax match guileNumber '\v<#[bB][+-]?[0-1]+>'
syntax match guileNumber '\v<#[oO][+-]?[0-7]+>'
syntax match guileNumber '\v<#[dD][+-]?\d+>'
syntax match guileNumber '\v<#[xX][+-]?[0-9a-fA-F]+>'
syntax match guileNumber '\v<#[eE][+-]?(\d+\.\d*|\d*\.\d+|\d+)>' " Exact
syntax match guileNumber '\v<(\+|-)(inf|nan)\.0>' " NaN and infinity
" =============================================================================
highlight link guileComment schemeComment
highlight link guileQuote schemeQuote
highlight link guileSyntax schemeSyntax
highlight link guileSyntaxSyntax schemeSyntaxSyntax
highlight link guileBoolean schemeBoolean
highlight link guileConstant schemeConstant
highlight link guileNumber schemeNumber
highlight link guileKeyword Type

25
sources_non_forked/guile.vim/test/detect.vader
View File

@ -1,25 +0,0 @@
# Test whether Guile is being detected
Given (Detect by shebang):
#!/usr/local/bin/guile -s
!#
Execute:
Assert guile#detect()
Given (Detect by define-module):
(define-module (foo bar))
Execute:
Assert guile#detect()
Given (Detect by use-modules):
(use-modules (foo bar))
Execute:
Assert guile#detect()
-----------------------------------------------------------------------------
# Test whether the file type is adjusted when a Guile file is edited
Execute (File type adjustment):
edit test/nonsense.scm
Then:
AssertEqual 'scheme.guile', &ft
bwipeout!

7
sources_non_forked/guile.vim/test/nonsense.scm
View File

@ -1,7 +0,0 @@
#!/usr/local/bin/guile -s
!#
;;; This is a nonsense file, meant to test whether the file type is adjusted
;;; properly. The Guile detection itself is tested separately.
(display "Hello from Guile!")
(newline)

119
sources_non_forked/guile.vim/test/syntax.vader
View File

@ -1,119 +0,0 @@
# Note: For simplicity we will not check the syntax highlighting of fixed
# keywords like 'define-public', only the highlighting of patterns
Given scheme.guile (Multi-line comment):
#!/usr/local/bin/guile -s
!#
#! This is a
multi-line comment !#
Execute:
for i in range(1, 25)
AssertEqual 'guileComment', SyntaxAt(1, i)
endfor
AssertEqual 'guileComment', SyntaxAt(2, 1)
AssertEqual 'guileComment', SyntaxAt(2, 2)
for i in range(1, 12)
AssertEqual 'guileComment', SyntaxAt(3, i)
endfor
for i in range(1, 21)
AssertEqual 'guileComment', SyntaxAt(4, i)
endfor
-----------------------------------------------------------------------------
Given scheme.guile (keywords):
#:keyword
#:key-word
Execute:
for i in range(1, 9)
AssertEqual 'guileKeyword', SyntaxAt(1, i)
endfor
for i in range(1, 10)
AssertEqual 'guileKeyword', SyntaxAt(2, i)
endfor
-----------------------------------------------------------------------------
Given scheme.guile (Boolean literals):
#true
#false
Execute:
for i in range(1, 5)
AssertEqual 'guileBoolean', SyntaxAt(1, i)
endfor
for i in range(1, 6)
AssertEqual 'guileBoolean', SyntaxAt(2, i)
endfor
-----------------------------------------------------------------------------
Given scheme.guile (Unspecified object representation):
#<unspecified>
Execute:
for i in range(1, 14)
AssertEqual 'guileConstant', SyntaxAt(1, i)
endfor
-----------------------------------------------------------------------------
Given scheme.guile (Bytevector literal):
#vu8(1 2 3 4)
Execute:
for i in range(1, 4)
AssertEqual 'guileQuote', SyntaxAt(1, i)
endfor
-----------------------------------------------------------------------------
Given scheme.guile (Integer number literals):
#b0101 #b+0101 #b-0101 #B0101 #B+0101 #B-0101
#o0237 #o+0237 #o-0237 #O0237 #O+0237 #O-0237
#d0239 #d+0239 #d-0239 #D0239 #D+0239 #D-0239
#x03AF #x+03AF #x-03AF #X03AF #X+03AF #X-03AF
#x03af #x+03af #x-03af #X03af #X+03af #X-03af
Execute:
for i in range(1, 5)
for j in range(1, 6)
for k in [0, 7, 15, 23, 30, 38]
AssertEqual 'guileNumber', SyntaxAt(i, k + j)
endfor
endfor
endfor
-----------------------------------------------------------------------------
Given scheme.guile (Exact decimal number literls):
#e012345 #e+01234 #e-01234 #E012345 #E+01234 #E-01234
#e.12345 #e+.1234 #e-.1234 #E.12345 #E+.1234 #E-.1234
#e0.1234 #e+0.123 #e-0.123 #E0.1234 #E+0.123 #E-0.123
Execute:
for line in [1, 2]
for offset in range(0, 5)
for column in range(1, 8)
AssertEqual 'guileNumber', SyntaxAt(line, offset * 9 + column)
endfor
endfor
endfor
-----------------------------------------------------------------------------
Given scheme.guile (Infinity and NaN literals):
+inf.0 -inf.0 +nan.0 -nan.0
Execute:
for offset in range(0, 3)
for i in range(1, 6)
AssertEqual 'guileNumber', SyntaxAt(1, offset * 7 + i)
endfor
endfor
-----------------------------------------------------------------------------
Given scheme.guile (Syntax-rule macro):
(define-syntax-rule (first-of expr expr* ...)
expr)
Execute:
for i in range(2, 19)
AssertEqual 'guileSyntaxSyntax', SyntaxAt(1, i)
endfor

1
sources_non_forked/slimv/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
doc/tags

71
sources_non_forked/slimv/.hgtags Normal file
View File

@ -0,0 +1,71 @@
757fcf4f9ec8dd355562e43955d58a1d1e058cd4 0.1
8f4d3ce88b2f1b17df960b143f7bd54d6b794aa8 0.1.1
c62731098ea9d3dad0d788c65fa4ff917399bd2c 0.1.2
2bca8504ba3537d4503d31cb6193ad8c0a0bcef6 0.1.3
70624b5323657c6b58b6c8a0797fe609070b4d9e 0.1.4
005fd272660d330ff021a4ca00897e55cdb69d30 0.2.0
42a1717c1cff96a8798d8df0a03fba991976af27 0.2.1
09036b7be53d6185d44dab46a3aab5b9b6e26f06 0.2.2
0ea663fc393c7b01dbeb1f2e5b73d56bab1d5810 0.3.0
0ea663fc393c7b01dbeb1f2e5b73d56bab1d5810 0.3.0
0000000000000000000000000000000000000000 0.3.0
0000000000000000000000000000000000000000 0.3.0
46b4a0c3ce6b833eec22485419ca241925f051ab 0.3.0
46b4a0c3ce6b833eec22485419ca241925f051ab 0.3.0
0000000000000000000000000000000000000000 0.3.0
fe355cee2ebbaabba06ee189569fd08072be659f 0.4.0
6b7c608d1be092a040585bc583c3ba0ffc06588f 0.4.1
f3379999fd93d4dd371a64cdaa5a70164ffc49d5 0.5.2
522a7b80552b11ca4de218dc4e1aceb012a00ad4 0.5.0
f3379999fd93d4dd371a64cdaa5a70164ffc49d5 0.5.2
0000000000000000000000000000000000000000 0.5.2
f3379999fd93d4dd371a64cdaa5a70164ffc49d5 0.5.1
0000000000000000000000000000000000000000 0.5.2
4d82e4dcd9d8c02b7e8f4c90553e29d7925738fe 0.5.2
f4d0d22d0d985e4e0c378dd6e8f1a96f94277b64 0.5.4
8ac0c3a2657079283394549bd6e2ab8b8ab0293d 0.5.5
962b3932c08537ede2c4ca73fb19470702ee1329 0.5.3
94fb2d92b804c4a93a4088a336d4b63c410d1f17 0.5.6
0000000000000000000000000000000000000000 0.3.0
08e87d29ff8aca59efc7b94a10356a8c1b49d77f 0.3.0
d7b7e75927f8537aa32c85d3f3c6b3fb86830d8b 0.6.0
b01612a1723b2f13c8a08578e9417ee669480da4 0.6.1
b01612a1723b2f13c8a08578e9417ee669480da4 0.6.2
fb43c9f5e6dd07dfc9190a1bf10f63d8f87676f7 0.6.3
fb43c9f5e6dd07dfc9190a1bf10f63d8f87676f7 0.6.3
0000000000000000000000000000000000000000 0.6.3
b01612a1723b2f13c8a08578e9417ee669480da4 0.6.2
0000000000000000000000000000000000000000 0.6.2
0000000000000000000000000000000000000000 0.6.2
fb43c9f5e6dd07dfc9190a1bf10f63d8f87676f7 0.6.2
0000000000000000000000000000000000000000 0.6.3
4959f842561eabf8c5cdcfc241019ed7747a4432 0.6.3
f77d0a6ed18a09c64fd312883d9d3b54052ce2d4 0.7.0
fdaacef3274ecf2cf12a3040675dfd879a797592 0.7.1
7c65e28865449e02e9b700d131e9e154300a037c 0.7.2
d954edf262b2ad25d554c7981104d4e1bf9cdfd4 0.7.3
0ad03f87ebf52f17b410a4fa1a928768167bd907 0.7.4
8c508324035a7fb1a0e6696e2e9a1f45366320e9 0.7.5
6fa96bd1d6d9f15e3c4db1aadae2b11543873ba7 0.7.6
5c1dd729b5ab0371426d7ca9ed97a5d501cda095 0.7.7
ee22ddd1ad0ca9935970d515cab286c3e0c75670 0.8.0
2dcdc990159c5e1b5981bdb6e36e47a898eef119 0.8.1
19387d57e1960208c96cb4ac5db5ab44494d7723 0.8.2
806fe91db6004c8eb11974e10e4ae546a8a6dd01 0.8.3
788b4720a17d7017632e65fd4a964c4e3bbfcb40 0.8.4
dbc305b7b56b49954b32081f722f3a94e8d6a8cf 0.8.5
d68ef87e6af6f079e9df7ca913112088da30ad7b 0.8.6
2fd4e021ba4a846b880ef1a89cfee657a3e66f3f 0.9.0
0778e2463cc72303949f9e8d2096c901bbea4eb7 0.9.1
5d61cd8f1d3fa6c81bd1cb63d324be70311d7733 0.9.2
6d5949774edb4c180d88bcaf2831b16e69454faf 0.9.3
af724df4e135098fa357debccc13e675543b978c 0.9.4
e422038c0bc829e7c79ac9500b0c7fd79b78a395 0.9.5
a7ba9b3a2435f88e3ff71367de22119c67b22958 0.9.6
02922c38bb8b1cd45ac69fad04965f37d7239f58 0.9.7
a481ad3fbefea06300c64a73ff856619b7af8334 0.9.8
28ef6c33a8941f16e849cc0905d93d7c80fab26d 0.9.9
537dfa6be0cf6f8a5a4e8012cee792652a22e535 0.9.10
0794ee20d24bd6be62e76ef3e21bff55e46a0403 0.9.11
638686453739bb51d37690546deef9e5e76dfb83 0.9.12
7a9461ef266914a04e143f12e3a203cbe22c85df 0.9.13

152
sources_non_forked/slimv/README.txt Normal file
View File

@ -0,0 +1,152 @@
--------------------------------------------------------------------------------
slimv.vim
--------------------------------------------------------------------------------
Superior Lisp Interaction Mode for Vim ("SLIME for Vim")
Vim script
created by
Tamas Kovacs
--------------------------------------------------------------------------------
Description
--------------------------------------------------------------------------------
Slimv is a SWANK client for Vim, similarly to SLIME for Emacs. SWANK is a TCP server for Emacs, which runs a Common Lisp, Clojure or Scheme REPL and provides a socket interface for evaluating, compiling, debugging, profiling lisp code. The SWANK server is embedded in Slimv, but you can also use your own SWANK installation.
Slimv opens the lisp REPL (Read-Eval-Print Loop) inside a Vim buffer. Lisp commands may be entered and executed in the REPL buffer, just as in a regular REPL.
Slimv supports SLIME's debugger, inspector, profiler, cross reference, arglist, indentation, symbol name completion functions. The script also has a Common Lisp Hyperspec lookup feature and it is able to lookup symbols in the Clojure API, as well as in JavaDoc.
Slimv comes with Paredit Mode, which is similar to the functionality of paredit.el in Emacs. Paredit Mode tries to maintain the balanced state of matched characters (parenthesis marks, square and curly braces, double quotes). Matched characters are inserted and removed in pairs, also when working with a block of text (well, mostly). Slimv also implements many paredit.el s-expression handling functions, like Split/Join/Wrap/Splice/Raise. Slurpage and Barfage known from Emacs is also possible but in a different fashion: you don't move the list element in or out of the list, rather you move the opening or closing parenthesis over the element or sub-list.
Please visit the Slimv Tutorial for a more complete introduction:
https://kovisoft.github.io/slimv-tutorial/tutorial.html
Please find the most recent development version in the repository:
https://github.com/kovisoft/slimv
Here follows a list of Slimv commands, any similarity with SLIME's menu is not coincidental. :)
Edit commands:
* Close Form
* Complete Symbol
* Function Arglist
* Paredit Toggle
Evaluation commands:
* Eval Defun
* Eval Current Expression
* Eval Region
* Eval Buffer
* Interactive Eval
* Undefine Function
Debug commands:
* Macroexpand-1
* Macroexpand All
* Toggle Trace
* Untrace All
* Disassemble
* Set Breakpoint
* Break on Exception
* Inspect
* Abort
* Quit to Toplevel
* Continue
* Restart Frame
* List Threads
* Kill Thread
* Debug Thread
Compile commands:
* Compile Defun
* Compile and Load File
* Compile File
* Compile Region
Cross Reference commands
* Who Calls
* Who References
* Who Sets
* Who Binds
* Who Macroexpands
* Who Specializes
* List Callers
* List Callees
Profile commands:
* Toggle Profile
* Profile by Substring
* Unprofile All
* Show Profiled
* Profile Report
* Profile Reset
Documentation commands:
* Describe Symbol
* Apropos
* Hyperspec
* Generate Tags
REPL commands:
* Connect to Server
* Interrupt Lisp Process
* Send Input
* Close and Send Input
* Set Package
* Previous Input
* Next Input
* Clear REPL
For more information see the included documentation.
---------------------------------------------------------------------------------------------
Installation details
---------------------------------------------------------------------------------------------
Extract the zip archive into your vimfiles or runtime directory.
Slimv works on Windows, Linux and Mac OS X (via Terminal.app), Cygwin is supported. The script requires the following programs installed on your system:
* Vim with Python feature enabled
* Python (must be the same Python version that was Vim compiled against)
* Lisp (any Common Lisp with SLIME support) or Clojure or MIT Scheme (Linux only)
Vim's Python version can be identified with the :ver command, look for the -DDYNAMIC_PYTHON_DLL=\"pythonXX\" string (if you have it). Another way of determining Vim's Python version:
:execute (has('python3') ? "python3" : "python") . " import sys; print(sys.version)"
Slimv tries to autodetect your Lisp/Clojure/Slime installation directories. If it fails to determine the correct directories, then you need to enter the command to start the SWANK server into your vimrc file.
Linux example:
let g:slimv_swank_cmd = '! xterm -e sbcl --load /usr/share/common-lisp/source/slime/start-swank.lisp &'
Windows example:
let g:slimv_swank_cmd = '!start "c:/Program Files/Lisp Cabinet/bin/ccl/wx86cl.exe" -l "c:/Program Files/Lisp Cabinet/site/lisp/slime/start-swank.lisp"'
Mac OS X example:
let g:slimv_swank_cmd = '!osascript -e "tell application \"Terminal\" to do script \"sbcl --load ~/.vim/slime/start-swank.lisp\""'
For Clojure use the g:slimv_swank_clojure option, e.g.:
let g:slimv_swank_clojure = '! xterm -e lein swank &'
- For pure text-based console without XTerm
If you only have `SSH` and can not use `XTerm`, you can use `tmux` or `screen` instead.
Linux example with `tmux`:
let g:slimv_swank_cmd = '! tmux new-window -d -n REPL-SBCL "sbcl --load ~/.vim/bundle/slimv/slime/start-swank.lisp"'
Linux example with `screen`:
let g:slimv_swank_cmd = '! screen -d -m -t REPL-SBCL sbcl --load ~/.vim/bundle/slimv/slime/start-swank.lisp'
Mac OS X example with `tmux`:
let g:slimv_swank_cmd = '!osascript -e "! tmux new-window -d -n REPL-SBCL "sbcl --load ~/.vim/bundle/slimv/slime/start-swank.lisp"'
See the included documentation for more complete installation and customization instructions.
vim:et:wrap:

490
sources_non_forked/slimv/doc/paredit.txt Normal file
View File

@ -0,0 +1,490 @@
*paredit.txt* Paredit Last Change: 05 Apr 2021
Paredit Mode for Vim *paredit* *slimv-paredit*
Version 0.9.14
The paredit.vim plugin performs structured editing of s-expressions used in
the Lisp, Clojure, Scheme programming languages. It may come as part of Slimv
but it is also distributed separately as a standalone plugin.
|paredit-mode| Paredit mode
|paredit-keys| Paredit keybindings
|paredit-options| Paredit options
===============================================================================
PAREDIT MODE *paredit-mode*
*parentheses*
Paredit mode is a special editing mode that keeps all matched characters
(parentheses, square and curly braces, double quotes) balanced, i.e. all opening
characters have a matching closing character. Most text entering and erasing
commands try to maintain the balanced state, so no single matched character is
added or deleted, they are entered or removed in pairs.
The function takes care of strings and comments, so no parenthesis and square
bracket balancing is performed inside a string or comment.
Please note that [] and {} pairs are not balanced for Lisp filetypes, only
for Clojure and Scheme.
The idea is taken from the paredit mode of Emacs, but not all paredit.el
editing functions are implemented or behave exactly the same way as they do
in Emacs.
When you enter a '(' then a matching ')' is automatically inserted.
If needed, spaces before and/or after the '()' pair are added.
When you press ')' in insert mode then there's no need to insert a closing
parenthesis mark (it is already there), so the cursor is simply advanced past
the next closing parenthesis (then the next outer closing parenthesis, etc.).
The result of this is however that when entering text with paredit mode
you can use the same keystrokes as without paredit mode and you get the same
result. Of course you can choose to not enter the closing parenthesis (as
required without paredit mode), because it is already there.
When you are trying to delete a ')' alone then it is not possible, the cursor
is simply moved inside the list, where all regular characters can be deleted.
When the list is finally empty: '()', then the deletion of the opening '('
makes both parentheses erased at once, so the balanced state is maintained.
All the above holds for [...] and "..." character pairs.
When you are deleting multiple characters at once, e.g. deleting a whole line,
or deleting till the end of the line, etc, then the deletion logic of a single
character is iterated. This means that the whole line or the characters till
the end of the line, etc are not necessarily deleted all. Depending on the
number of open/close parentheses, square or curly braces, double quotes some
of them might be kept in order to maintain the balanced state.
For example if you press D in Normal mode to delete till the end of line
between the a and b parameters of the following Clojure function definition:
(defn myfunc [a b c] (+ a b c))
^--- press D here
then the closing ] as well as the last closing ) will not be deleted, because
in the list you have an ( and a [ to be matched, so the result will be:
(defn myfunc [a])
If you are deleting multiple lines, then the above process is performed for
all lines involved. If a line was not completely cleared, then it is joined
with the next line and the process continues.
Of course not all Vim commands are compatible with the paredit mode (e.g.
you can yank and paste unbalanced code snippet, or comment out an asymmetrical
part of the code), and there is also the possibility to edit the source code
with paredit mode switched off or with another editor to make it unbalanced.
When paredit mode detects that the underlying code is not balanced, then the
paredit functionality is suspended until the top level form balance is fixed.
As soon as all parens are matched, the paredit mode is automatically resumed.
Paredit needs "syntax on" to identify the syntax elements of the underlying
code, so if syntax is switched off, then paredit will not be suspended inside
comments or strings.
Slurpage and Barfage known from Emacs is also possible but in a different
fashion: you don't move the symbols but move the opening or closing parenthesis
over the symbol or a sub-list. This way you can move any symbol or sub-list
into or out of the current list. It is not possible to move the parenthesis
over its pair, so for example if you move the opening parenthesis to the right,
then it will stop at the matched closing parenthesis.
Paredit mode is set by default for .lisp, .cl, .clj, cljs, .scm and .rkt files,
but it is possible to switch it off by putting the following statement in the
.vimrc file:
let g:paredit_mode = 0
You can enable paredit mode for other file types as well. Here is how to set
it for Arc files in your .vimrc (assuming you have a filetype 'arc' defined):
au FileType arc call PareditInitBuffer()
Paredit is part of Slimv, but it is also distributed separately as a standalone
plugin. If you indend to use the SWANK client and/or Slimv's indentation and
syntax functions, then please install the Slimv plugin. Otherwise you may want
to install the Paredit plugin thus omitting other unnecessary files.
===============================================================================
PAREDIT KEYBINDINGS *paredit-keys*
Here follows a list of paredit keybindings:
Insert Mode:
( Inserts '()' and moves the cursor inside. Also adds leading
or trailing spaces when needed.
Inserts '(' when inside comment or string.
) Moves the cursor to the next closing parenthesis mark of
the current list. When pressed again then moves to the next
outer closing parenthesis, etc, until the closing of the
top level form is reached.
Inserts ')' when inside comment or string.
If |g:paredit_electric_return| is on then it also re-gathers
electric returns when appropriate.
[ Inserts '[]' and moves the cursor inside. Also adds leading
or trailing spaces when needed.
Inserts '[' when inside comment or string.
] Moves the cursor to the next closing square bracket of the
current list. When pressed again then moves to the next
outer closing square bracket, etc, until the closing of the
top level form is reached.
Inserts ']' when inside comment or string.
If |g:paredit_electric_return| is on then it also re-gathers
electric returns when appropriate.
{ Inserts '{}' and moves the cursor inside. Also adds leading
or trailing spaces when needed.
Inserts '{' when inside comment or string.
} Moves the cursor to the next closing curly brace of the
current list. When pressed again then moves to the next
outer closing curly brace, etc, until the closing of the
top level form is reached.
Inserts '}' when inside comment or string.
If |g:paredit_electric_return| is on then it also re-gathers
electric returns when appropriate.
" When outside of string, inserts '""' and moves the cursor
inside. When inside string then moves to the closing '"'.
Inserts '"' when inside comment. Also insert '"' when inside
string and preceded by a '\'.
<BS> When about to delete a (, ), [, ], or " and there are other
characters inside, then just skip it to the left. When
about to delete the opening part of the matched character
with nothing inside, then the whole empty list is removed.
<Del> When about to delete a (, ), [, ], or " and there are other
characters inside, then just skip it to the right. When
about to delete the closing part of the matched character
with nothing inside, then the whole empty list is removed.
<Enter> If |g:paredit_electric_return| is on then insert an
"electric return", i.e. create an empty line by inserting
two newline characters.
Normal Mode:
( Finds opening '(' of the current list. Can be pressed
repeatedly until the opening of the top level form reached.
) Finds closing ')' of the current list. Can be pressed
repeatedly until the closing of the top level form reached.
[[ Go to the start of current/previous defun.
]] Go to the start of next defun.
<Leader>< If standing on a delimiter (parenthesis or square bracket)
then moves it to the left by slurping or barfing the
s-expression to the left, depending on the direction of the
delimiter:
Pressing '<' when standing on a ')' makes the s-expression
to the left of the ')' going out of the current list.
Pressing '<' when standing on a '(' makes the s-expression
to the left of the '(' coming into the current list.
For example pressing <Leader>< at position marked with |:
(aaa bbb|) ---> (aaa|) bbb
aaa |(bbb) ---> |(aaa bbb)
<Leader>> If standing on a delimiter (parenthesis or square bracket)
then moves it to the right by slurping or barfing the
s-expression to the right, depending on the direction of the
delimiter:
Pressing '>' when standing on a '(' makes the s-expression
to the right of the '(' going out of the current list.
Pressing '>' when standing on a ')' makes the s-expression
to the right of the ')' coming into the current list.
For example pressing <Leader>< at position marked with |:
(aaa|) bbb ---> (aaa bbb|)
|(aaa bbb) ---> aaa |(bbb)
<Leader>J Join two subsequent lists or strings. The first one must end
before the cursor, the second one must start after the
cursor position.
For example pressing <Leader>J at position marked with |:
(aaa)| (bbb) ---> (aaa |bbb)
"aaa"| "bbb" ---> "aaa |bbb"
<Leader>O Split ("Open") current list or string at the cursor position.
Opposite of Join. Key O is selected because for the original
Vim mapping J and O are also kind of opposites.
For example pressing <Leader>O at position marked with |:
(aaa |bbb) ---> (aaa) |(bbb)
"aaa|bbb" ---> "aaa" |"bbb"
<Leader>W Wrap the current symbol in a pair of parentheses. The cursor
<Leader>w( is then positioned on the opening parenthesis, as wrapping
is usually done because one wants to call a function with
the symbol as parameter, so by pressing "a" one can enter
the function name right after the newly inserted "(".
For example pressing <Leader>W at position marked with |:
(aaa b|bb ccc) ---> (aaa |(bbb) ccc)
<Leader>w[ Wrap the current symbol in a pair of square brackets,
similarly to <Leader>W.
For example pressing <Leader>w[ at position marked with |:
(aaa b|bb ccc) ---> (aaa |[bbb] ccc)
<Leader>w{ Wrap the current symbol in a pair of curly braces,
similarly to <Leader>W.
For example pressing <Leader>w{ at position marked with |:
(aaa b|bb ccc) ---> (aaa |{bbb} ccc)
<Leader>w" Wrap the current symbol in a pair of double quotes,
similarly to <Leader>W.
For example pressing <Leader>w" at position marked with |:
(aaa b|bb ccc) ---> (aaa "bbb|" ccc)
<Leader>S Splice the current list into the containing list, i.e.
remove the opening and closing parens. Opposite of wrap.
For example pressing <Leader>S at position marked with |:
(aaa (b|bb ccc) ddd) ---> (aaa |bbb ccc ddd)
<Leader><Up> Splice the current list into the containing list by deleting
everything backward from the cursor position up to the
opening paren.
For example pressing <Leader><Up> at position marked with |:
(aaa (bbb |ccc) ddd) ---> (aaa |ccc ddd)
<Leader><Down> Splice the current list into the containing list by deleting
everything forward from the cursor position up to the
closing paren.
For example pressing <Leader><Down> at position marked with |:
(aaa (bbb| ccc) ddd) ---> (aaa |bbb ddd)
<Leader>I Raise the current symbol, i.e. replace the current list with
the current symbol by deleting everything else (except the
symbol) in the list, including the enclosing pair of parens.
For example pressing <Leader>I at position marked with |:
(aaa (b|bb ccc) ddd) ---> (aaa |bbb ddd)
x or <Del> When about to delete a (, ), [, ], or " and there are other
characters inside, then just skip it to the right. When
about to delete the closing part of the matched character
with nothing inside, then the whole empty list is removed.
When preceded by a <count> value then delete this many
characters.
X When about to delete a (, ), [, ], or " and there are other
characters inside, then just skip it to the left. When
about to delete the opening part of the matched character
with nothing inside, then the whole empty list is removed.
D Keep deleting characters towards the end of line,
maintaining the balanced state, i.e. keep the number of
opening and closing parens the same.
C Same as 'D' but go to insert mode at the end.
s Same as 'x' but go to insert mode at the end.
dd Delete whole line by keeping the balanced state, i.e.
keep the number of opening and closing parens the same.
When preceded by a <count> value then delete this many
lines.
cc Same as 'dd' but go to insert mode at the end.
d{motion} Delete text till {motion}. Keeps text balanced, so if the
surrounded text contains unpaired matched characters then
they are not removed.
c{motion} Delete text till {motion} and start insert mode. Keeps text
balanced just like d{motion}.
p Put the text after the cursor with all unbalanced matched
characters removed.
P Put the text before the cursor with all unbalanced matched
characters removed.
Visual Mode:
( Finds opening '(' of the current list and selects the whole
list. Can be pressed repeatedly until the top level form
selected.
) Finds closing ')' of the current list and selects the whole
list. Can be pressed repeatedly until the top level form
selected.
d Delete the current visual selection. Keeps text balanced,
x so the the selection contains unpaired matched characters
<Del> then they are not removed.
c Delete the current visual selection and start insert mode.
Keeps text balanced just like the 'd' command.
<Leader>W Wrap the current visual selection in a pair of parentheses.
<Leader>w( The visual selection is kept.
<Leader>w[ Wrap the current visual selection in a pair of square
brackets. The visual selection is kept.
<Leader>w{ Wrap the current visual selection in a pair of curly braces.
The visual selection is kept.
<Leader>w" Wrap the current visual selection in a pair of double
quotes. The visual selection is kept.
Please note that if variable |g:paredit_shortmaps| is nonzero then the
following normal mode mappings don't get a <Leader> prefix, they are mapped
to existing (but infrequently used) Vim functions and instead the original Vim
functions are mapped with the <Leader> prefix:
<, >, J, O, W, S
Vim has many built-in mappings for manipulating s-expressions. Here follows a
list of useful commands, these are not defined by paredit.vim, they are
available even when paredit mode is switched off.
% Find the matching pair of the parenthesis the cursor is
standing on.
d% Delete till the matching parenthesis. Normally it is used
when the cursor is standing on a parenthesis (works with
square or curly braces as well). If not standing on a
parenthesis then deletes left till the first opening paren,
so this command may also be used to delete an s-expression
that is right before the cursor.
daw Delete a word. Can be used to delete a list element, the
cursor may be placed anywhere in the element.
da( Delete the innermost s-expression. The cursor may be placed
anywhere inside the s-expression.
di( Same as da( but does not delete the enclosing parens.
===============================================================================
PAREDIT OPTIONS *paredit-options*
|g:paredit_disable_clojure| If defined, paredit is disabled for clojure files.
|g:paredit_disable_ftindent| If defined, filetype indent files are not loaded.
|g:paredit_disable_ftplugin| If defined, filetype plugins are not loaded.
|g:paredit_disable_hy| If defined, paredit is disabled for hy files.
|g:paredit_disable_lisp| If defined, paredit is disabled for lisp files.
|g:paredit_disable_scheme| If defined, paredit is disabled for scheme files.
|g:paredit_disable_shen| If defined, paredit is disabled for shen files.
|g:paredit_disable_janet| If defined, paredit is disabled for janet files.
|g:paredit_electric_return| If nonzero, electric return feature is enabled.
|g:paredit_map_func| Specifies a function to be used for defining
custom keybindings for Paredit
|g:paredit_unmap_func| Specifies a function to be used for removing
custom keybindings for Paredit
|g:paredit_smartjump| If nonzero, '(' and ')' also target square brackets
and curly braces when editing Clojure or Scheme.
|g:paredit_leader| Custom <Leader> setting for Paredit.
|g:paredit_matchlines| Number of lines to look backward and forward
when checking if the current form is balanced.
|g:paredit_mode| If nonzero, paredit mode is switched on.
|g:paredit_shortmaps| If nonzero, paredit is remapping some one-letter
Vim commands that are not frequently used.
*g:paredit_disable_clojure*
*g:paredit_disable_lisp*
*g:paredit_disable_scheme*
*g:paredit_disable_shen*
*g:paredit_disable_janet*
If defined then paredit is disabled for the given file type. Useful to use
a different plugin for a specific file type, but keep using paredit for the
others.
*g:paredit_disable_ftindent*
*g:paredit_disable_ftplugin*
If defined then filetype indent files or plugins are not loaded. By default
paredit triggers 'filetype plugin on' and 'filetype indent on', these options
disable the corresponding feature.
*g:paredit_electric_return*
*newline*
*carriage-return*
If nonzero then "electric return" feature is enabled. This means that when an
<Enter> is pressed before a closing paren in insert mode, paredit will actually
insert two newlines creating an empty line. The extra newline is consumed at
pressing the next closing paren. This feature allows linewise editing of the
subform entered in the next (empty) line.
In other words <Enter> "opens" parenthetical expressions while editing, ')'
"closes" them.
Please note that electric return is disabled for the REPL buffer if Slimv
option |g:slimv_repl_simple_eval| is nonzero. In this case <Enter> is used
to send the command line to the swank server for evaluation.
Please find a video demonstration of the electric return feature here:
https://kovisoft.github.io/slimv-tutorial/openparen.gif
*g:paredit_map_func*
This option specifies a function to be used for defining custom keybindings
for Paredit. The function takes no argument and returns no value.
By default function 'PareditMapKeys' is called.
*g:paredit_unmap_func*
This option specifies a function to be used for removing custom keybindings
for Paredit. The function takes no argument and returns no value.
By default function 'PareditUnmapKeys' is called.
*g:paredit_smartjump*
If nonzero, this option changes the behavior of '(' and ')' in normal and visual
modes when editing Clojure or Scheme. Rather than jumping to nearest open or close
parenthesis, instead the cursor will jump to the nearest '(', '[', or '{' if
you press '(', and it will jump to the nearest ')', ']', or '}' if you press
')'. This option makes it much easier to navigate nested Clojure data
structures. It does nothing if the filetype is not clojure or Scheme.
*g:paredit_leader*
This option allows a custom <Leader> setting for the Paredit keybindings.
By default it has the same value as |mapleader|. If neither g:paredit_leader
nor mapleader are defined then the default <Leader> is "," in Paredit.
Example:
let g:paredit_leader = '\'
If this is set in the .vimrc then Wrap will be mapped to \W instead of ,W.
There is a separate |g:slimv_leader| option for the general Slimv keybindings.
*g:paredit_matchlines*
Number of lines to look backward and forward when checking if the current
top level form is balanced in paredit mode. Default is 100.
*g:paredit_mode*
If nonzero then paredit mode is switched on, i.e. the plugin tries to keep the
balanced state of parens. This is the default behaviour.
*g:paredit_shortmaps*
If nonzero, paredit is remapping some one-letter normal mode Vim commands that
are not frequently used. These are <, >, J, O, W, S. The original function of
these maps then can be reached via <Leader> (which is the "," character
by default in Paredit).
Otherwise these paredit functions can be reached via <Leader> maintaining the
original functions of these keys.
===============================================================================
vim:tw=80:et:wrap:ft=help:norl:

2317
sources_non_forked/slimv/doc/slimv.txt Normal file
View File

File diff suppressed because it is too large Load Diff

3
sources_non_forked/slimv/ftdetect/clojure.vim Normal file
View File

@ -0,0 +1,3 @@
au BufNewFile,BufRead *.clj setf clojure
au BufNewFile,BufRead *.cljs setf clojure

202
sources_non_forked/slimv/ftplugin/clojure/slimv-clojure.vim Normal file
View File

@ -0,0 +1,202 @@
" slimv-clojure.vim:
" Clojure filetype plugin for Slimv
" Version: 0.9.13
" Last Change: 04 May 2014
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if exists("b:slimv_did_ftplugin") || exists("g:slimv_disable_clojure")
finish
endif
" ---------- Begin part loaded once ----------
if !exists( 'g:slimv_clojure_loaded' )
let g:slimv_clojure_loaded = 1
" Transform filename so that it will not contain spaces
function! s:TransformFilename( name )
if match( a:name, ' ' ) >= 0
return fnamemodify( a:name , ':8' )
else
return a:name
endif
endfunction
" Build a Clojure startup command by adding
" all clojure*.jar files found to the classpath
function! s:BuildStartCmd( lisps )
let cp = s:TransformFilename( a:lisps[0] )
let cp_delim = g:slimv_windows ? ';' : ':'
let i = 1
while i < len( a:lisps )
let cp = cp . cp_delim . s:TransformFilename( a:lisps[i] )
let i = i + 1
endwhile
" Try to find swank-clojure and add it to classpath
let swanks = split( globpath( &runtimepath, 'swank-clojure'), '\n' )
if len( swanks ) > 0
let cp = cp . cp_delim . s:TransformFilename( swanks[0] )
endif
return ['java -cp ' . cp . ' clojure.main', 'clojure']
endfunction
" Try to autodetect Clojure executable
" Returns list [Clojure executable, Clojure implementation]
function! SlimvAutodetect( preferred )
" Firts try the most basic setup: everything in the path
if executable( 'lein' )
return ['"lein repl"', 'clojure']
endif
if executable( 'cake' )
return ['"cake repl"', 'clojure']
endif
if executable( 'clojure' )
return ['clojure', 'clojure']
endif
let lisps = []
if executable( 'clojure.jar' )
let lisps = ['clojure.jar']
endif
if executable( 'clojure-contrib.jar' )
let lisps = lisps + 'clojure-contrib.jar'
endif
if len( lisps ) > 0
return s:BuildStartCmd( lisps )
endif
" Check if Clojure is bundled with Slimv
let lisps = split( globpath( &runtimepath, 'swank-clojure/clojure*.jar'), '\n' )
if len( lisps ) > 0
return s:BuildStartCmd( lisps )
endif
" Try to find Clojure in the PATH
let path_delim = g:slimv_windows ? ';' : ':'
let path = substitute( $PATH, path_delim, ',', 'g' )
let lisps = split( globpath( path, 'clojure*.jar' ), '\n' )
if len( lisps ) > 0
return s:BuildStartCmd( lisps )
endif
if g:slimv_windows
" Try to find Clojure on the standard installation places
let lisps = split( globpath( 'c:/*clojure*,c:/*clojure*/lib', 'clojure*.jar' ), '\n' )
if len( lisps ) > 0
return s:BuildStartCmd( lisps )
endif
else
" Try to find Clojure in the home directory
let lisps = split( globpath( '/usr/local/bin/*clojure*', 'clojure*.jar' ), '\n' )
if len( lisps ) > 0
return s:BuildStartCmd( lisps )
endif
let lisps = split( globpath( '~/*clojure*', 'clojure*.jar' ), '\n' )
if len( lisps ) > 0
return s:BuildStartCmd( lisps )
endif
endif
return ['', '']
endfunction
" Try to find out the Clojure implementation
function! SlimvImplementation()
if exists( 'g:slimv_impl' ) && g:slimv_impl != ''
" Return Lisp implementation if defined
return tolower( g:slimv_impl )
endif
return 'clojure'
endfunction
" Try to autodetect SWANK and build the command to load the SWANK server
function! SlimvSwankLoader()
" First autodetect Leiningen and Cake
if executable( 'lein' )
if globpath( '~/.lein/plugins', 'lein-ritz*.jar' ) != ''
return '"lein ritz ' . g:swank_port . '"'
else
return '"lein swank"'
endif
elseif executable( 'cake' )
return '"cake swank"'
else
" Check if swank-clojure is bundled with Slimv
let swanks = split( globpath( &runtimepath, 'swank-clojure/swank/swank.clj'), '\n' )
if len( swanks ) == 0
return ''
endif
let sclj = substitute( swanks[0], '\', '/', "g" )
return g:slimv_lisp . ' -i "' . sclj . '" -e "(swank.swank/start-repl)" -r'
endif
endfunction
" Filetype specific initialization for the REPL buffer
function! SlimvInitRepl()
set filetype=clojure
endfunction
" Lookup symbol in the list of Clojure Hyperspec symbol databases
function! SlimvHyperspecLookup( word, exact, all )
if !exists( 'g:slimv_cljapi_loaded' )
runtime ftplugin/**/slimv-cljapi.vim
endif
if !exists( 'g:slimv_javadoc_loaded' )
runtime ftplugin/**/slimv-javadoc.vim
endif
let symbol = []
if exists( 'g:slimv_cljapi_db' )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_cljapi_db, g:slimv_cljapi_root, symbol )
endif
if exists( 'g:slimv_javadoc_db' )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_javadoc_db, g:slimv_javadoc_root, symbol )
endif
if exists( 'g:slimv_cljapi_user_db' )
" Give a choice for the user to extend the symbol database
if exists( 'g:slimv_cljapi_user_root' )
let user_root = g:slimv_cljapi_user_root
else
let user_root = ''
endif
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_cljapi_user_db, user_root, symbol )
endif
return symbol
endfunction
" Implementation specific REPL initialization
function! SlimvReplInit( lisp_version )
" Import functions commonly used in REPL but not present when not running in repl mode
if a:lisp_version[0:2] >= '1.3'
call SlimvSendSilent( ["(use '[clojure.repl :only (source apropos dir pst doc find-doc)])",
\ "(use '[clojure.java.javadoc :only (javadoc)])",
\ "(use '[clojure.pprint :only (pp pprint)])"] )
elseif a:lisp_version[0:2] >= '1.2'
call SlimvSendSilent( ["(use '[clojure.repl :only (source apropos)])",
\ "(use '[clojure.java.javadoc :only (javadoc)])",
\ "(use '[clojure.pprint :only (pp pprint)])"] )
endif
endfunction
" Source Slimv general part
runtime ftplugin/**/slimv.vim
endif "!exists( 'g:slimv_clojure_loaded' )
" ---------- End of part loaded once ----------
runtime ftplugin/**/lisp.vim
" Must be called for each lisp buffer
call SlimvInitBuffer()
" Don't initiate Slimv again for this buffer
let b:slimv_did_ftplugin = 1

66
sources_non_forked/slimv/ftplugin/iterm.applescript Executable file
View File

@ -0,0 +1,66 @@
#! /usr/bin/osascript
-- joinList from Geert Vanderkelen @ bit.ly/1gRPYbH
-- toDo push new terminal to background after creation
to joinList(aList, delimiter)
set retVal to ""
set prevDelimiter to AppleScript's text item delimiters
set AppleScript's text item delimiters to delimiter
set retVal to aList as string
set AppleScript's text item delimiters to prevDelimiter
return retVal
end joinList
-- theSplit from iTerm version check example @ https://goo.gl/dSbQYU
on theSplit(theString, theDelimiter)
set oldDelimiters to AppleScript's text item delimiters
set AppleScript's text item delimiters to theDelimiter
set theArray to every text item of theString
set AppleScript's text item delimiters to oldDelimiters
return theArray
end theSplit
-- IsModernVersion from iTerm version check example @ https://goo.gl/dSbQYU
on IsModernVersion(version)
set myArray to my theSplit(version, ".")
set major to item 1 of myArray
set minor to item 2 of myArray
set veryMinor to item 3 of myArray
if major < 2 then
return false
end if
if major > 2 then
return true
end if
if minor < 9 then
return false
end if
if minor > 9 then
return true
end if
if veryMinor < 20140903 then
return false
end if
return true
end IsModernVersion
on run arg
set thecommand to joinList(arg, " ")
tell application "iTerm"
activate
if my IsModernVersion(version) then
set myterm to (create window with default profile)
set mysession to current session of myterm
else
set myterm to (make new teminal)
tell myterm
set mysession to (launch session "Default")
end tell
end if
tell myterm
tell mysession
write text thecommand
end tell
end tell
end tell
end run

199
sources_non_forked/slimv/ftplugin/lisp/slimv-lisp.vim Normal file
View File

@ -0,0 +1,199 @@
" slimv-lisp.vim:
" Lisp filetype plugin for Slimv
" Version: 0.9.13
" Last Change: 04 May 2014
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if exists("b:did_ftplugin") || exists("g:slimv_disable_lisp")
finish
endif
" Handle cases when lisp dialects explicitly use the lisp filetype plugins
if &ft == "clojure" && exists("g:slimv_disable_clojure")
finish
endif
if &ft == "scheme" && exists("g:slimv_disable_scheme")
finish
endif
" ---------- Begin part loaded once ----------
if !exists( 'g:slimv_lisp_loaded' )
let g:slimv_lisp_loaded = 1
" Descriptor array for various lisp implementations
" The structure of an array element is:
" [ executable, implementation, platform, search path]
" where:
" executable - may contain wildcards but only if a search path is present
" platform - 'w' (Windows) or 'l' (Linux = non-Windows), '' for all
" search path - commma separated list, may contain wildcard characters
let s:lisp_desc = [
\ [ 'sbcl', 'sbcl', '', '' ],
\ [ 'clisp', 'clisp', '', '' ],
\ [ 'gcl', 'clisp', '', '' ],
\ [ 'cmucl', 'cmu', '', '' ],
\ [ 'ecl', 'ecl', '', '' ],
\ [ 'acl', 'allegro', '', '' ],
\ [ 'mlisp', 'allegro', '', '' ],
\ [ 'mlisp8', 'allegro', '', '' ],
\ [ 'alisp', 'allegro', '', '' ],
\ [ 'alisp8', 'allegro', '', '' ],
\ [ 'lwl', 'lispworks', '', '' ],
\ [ 'ccl', 'clozure', '', '' ],
\ [ 'wx86cl64', 'clozure', 'w64', '' ],
\ [ 'wx86cl', 'clozure', 'w', '' ],
\ [ 'lx86cl', 'clozure', 'l', '' ],
\ [ '*lisp.exe', 'clisp', 'w',
\ 'c:/*lisp*,c:/*lisp*/*,c:/*lisp*/bin/*,c:/Program Files/*lisp*,c:/Program Files/*lisp*/*,c:/Program Files/*lisp*/bin/*' ],
\ [ 'gcl.exe', 'clisp', 'w', 'c:/gcl*,c:/Program Files/gcl*' ],
\ [ 'cmucl.exe', 'cmu', 'w', 'c:/cmucl*,c:/Program Files/cmucl*' ],
\ [ '*lisp*.exe', 'allegro', 'w', 'c:/acl*,c:/Program Files/acl*,c:/Program Files/*lisp*/bin/acl*' ],
\ [ 'ecl.exe', 'ecl', 'w', 'c:/ecl*,c:/Program Files/ecl*' ],
\ [ 'wx86cl64.exe', 'clozure', 'w64', 'c:/ccl*,c:/Program Files/ccl*,c:/Program Files/*lisp*/bin/ccl*' ],
\ [ 'wx86cl.exe', 'clozure', 'w', 'c:/ccl*,c:/Program Files/ccl*,c:/Program Files/*lisp*/bin/ccl*' ],
\ [ 'sbcl.exe', 'sbcl', 'w', 'c:/sbcl*,c:/Program Files/sbcl*,c:/Program Files/*lisp*/bin/sbcl*'] ]
" Try to autodetect Lisp executable
" Returns list [Lisp executable, Lisp implementation]
function! SlimvAutodetect( preferred )
for lisp in s:lisp_desc
if lisp[2] =~ 'w' && !g:slimv_windows
" Valid only on Windows
elseif lisp[2] == 'w64' && $ProgramW6432 == ''
" Valid only on 64 bit Windows
elseif lisp[2] == 'l' && g:slimv_windows
" Valid only on Linux
elseif a:preferred != '' && a:preferred != lisp[1]
" Not the preferred implementation
elseif lisp[3] != ''
" A search path is given
let lisps = split( globpath( lisp[3], lisp[0] ), '\n' )
if len( lisps ) > 0
return [lisps[0], lisp[1]]
endif
else
" Single executable is given without path
if executable( lisp[0] )
return lisp[0:1]
endif
endif
endfor
return ['', '']
endfunction
" Try to find out the Lisp implementation
function! SlimvImplementation()
if exists( 'g:slimv_impl' ) && g:slimv_impl != ''
" Return Lisp implementation if defined
return tolower( g:slimv_impl )
endif
let lisp = tolower( g:slimv_lisp )
if match( lisp, 'sbcl' ) >= 0
return 'sbcl'
endif
if match( lisp, 'cmu' ) >= 0
return 'cmu'
endif
if match( lisp, 'acl' ) >= 0 || match( lisp, 'alisp' ) >= 0 || match( lisp, 'mlisp' ) >= 0
return 'allegro'
endif
if match( lisp, 'ecl' ) >= 0
return 'ecl'
endif
if match( lisp, 'x86cl' ) >= 0
return 'clozure'
endif
if match( lisp, 'lwl' ) >= 0
return 'lispworks'
endif
return 'clisp'
endfunction
" Try to autodetect SWANK and build the command to load the SWANK server
function! SlimvSwankLoader()
" First check if SWANK is bundled with Slimv
let swanks = split( globpath( &runtimepath, 'slime/start-swank.lisp'), '\n' )
if len( swanks ) == 0
" Try to find SWANK in the standard SLIME installation locations
if g:slimv_windows || g:slimv_cygwin
let swanks = split( globpath( 'c:/slime/,c:/*lisp*/slime/,c:/*lisp*/site/lisp/slime/,c:/Program Files/*lisp*/site/lisp/slime/', 'start-swank.lisp' ), '\n' )
else
let swanks = split( globpath( '/usr/share/common-lisp/source/slime/', 'start-swank.lisp' ), '\n' )
endif
endif
if len( swanks ) == 0
return ''
endif
" Build proper SWANK loader command for the Lisp implementation used
if g:slimv_impl == 'sbcl' || g:slimv_impl == 'ecl'
return '"' . g:slimv_lisp . '" --load "' . swanks[0] . '"'
elseif g:slimv_impl == 'clisp'
return '"' . g:slimv_lisp . '" -i "' . swanks[0] . '"'
elseif g:slimv_impl == 'allegro'
return '"' . g:slimv_lisp . '" -L "' . swanks[0] . '"'
elseif g:slimv_impl == 'cmu'
return '"' . g:slimv_lisp . '" -load "' . swanks[0] . '"'
else
return '"' . g:slimv_lisp . '" -l "' . swanks[0] . '"'
endif
endfunction
" Filetype specific initialization for the REPL buffer
function! SlimvInitRepl()
set filetype=lisp
endfunction
" Lookup symbol in the list of Lisp Hyperspec symbol databases
function! SlimvHyperspecLookup( word, exact, all )
if !exists( 'g:slimv_clhs_loaded' )
runtime ftplugin/**/slimv-clhs.vim
endif
let symbol = []
if exists( 'g:slimv_clhs_loaded' )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_clhs, g:slimv_clhs_root, symbol )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_issues, g:slimv_clhs_root, symbol )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_chapters, g:slimv_clhs_root, symbol )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_control_chars, g:slimv_clhs_root, symbol )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_macro_chars, g:slimv_clhs_root, symbol )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_loop, g:slimv_clhs_root, symbol )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_arguments, g:slimv_clhs_root, symbol )
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_glossary, g:slimv_clhs_root, symbol )
endif
if exists( 'g:slimv_clhs_user_db' )
" Give a choice for the user to extend the symbol database
if exists( 'g:slimv_clhs_user_root' )
let user_root = g:slimv_clhs_user_root
else
let user_root = ''
endif
let symbol = SlimvFindSymbol( a:word, a:exact, a:all, g:slimv_clhs_user_db, user_root, symbol )
endif
return symbol
endfunction
" Source Slimv general part
runtime ftplugin/**/slimv.vim
endif "!exists( 'g:slimv_lisp_loaded' )
" ---------- End of part loaded once ----------
runtime ftplugin/**/lisp.vim
" Must be called for each lisp buffer
call SlimvInitBuffer()
" Don't load another plugin for this buffer
let b:did_ftplugin = 1

60
sources_non_forked/slimv/ftplugin/r/slimv-r.vim Normal file
View File

@ -0,0 +1,60 @@
" slimv-r.vim:
" R filetype plugin for Slimv
" Version: 0.9.13
" Last Change: 04 May 2014
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if exists("b:did_ftplugin")
finish
endif
" ---------- Begin part loaded once ----------
if !exists( 'g:slimv_lisp_loaded' )
let g:slimv_lisp_loaded = 1
" Try to autodetect Lisp executable
" Returns list [Lisp executable, Lisp implementation]
function! SlimvAutodetect( preferred )
return ['R', 'R']
endfunction
" Try to find out the Lisp implementation
function! SlimvImplementation()
return 'R'
endfunction
" Try to autodetect SWANK and build the command to load the SWANK server
function! SlimvSwankLoader()
endfunction
" Filetype specific initialization for the REPL buffer
function! SlimvInitRepl()
set filetype=r
endfunction
" Lookup symbol in the list of Lisp Hyperspec symbol databases
function! SlimvHyperspecLookup( word, exact, all )
return [ a:word ]
endfunction
" Source Slimv general part
runtime ftplugin/**/slimv.vim
endif "!exists( 'g:slimv_lisp_loaded' )
" ---------- End of part loaded once ----------
"runtime ftplugin/**/r.vim
" Must be called for each lisp buffer
call SlimvInitBuffer()
" Don't load another plugin for this buffer
let b:did_ftplugin = 1

91
sources_non_forked/slimv/ftplugin/scheme/slimv-scheme.vim Normal file
View File

@ -0,0 +1,91 @@
" slimv-scheme.vim:
" Scheme filetype plugin for Slimv
" Version: 0.9.13
" Last Change: 04 May 2014
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if exists("b:did_ftplugin") || exists("g:slimv_disable_scheme")
finish
endif
" ---------- Begin part loaded once ----------
if !exists( 'g:slimv_scheme_loaded' )
let g:slimv_scheme_loaded = 1
" Try to autodetect Scheme executable
" Returns list [Scheme executable, Scheme implementation]
function! SlimvAutodetect( preferred )
" Currently only MIT Scheme on Linux
if executable( 'scheme' )
" MIT Scheme
return ['scheme', 'mit']
endif
return ['', '']
endfunction
" Try to find out the Scheme implementation
function! SlimvImplementation()
if exists( 'g:slimv_impl' ) && g:slimv_impl != ''
" Return Lisp implementation if defined
return tolower( g:slimv_impl )
endif
return 'mit'
endfunction
" Try to autodetect SWANK and build the command to load the SWANK server
function! SlimvSwankLoader()
if g:slimv_impl == 'mit'
if exists( 'g:scheme_builtin_swank' ) && g:scheme_builtin_swank
" MIT Scheme contains a built-in swank server since version 9.1.1
return 'scheme --eval "(let loop () (start-swank) (loop))"'
endif
let swanks = split( globpath( &runtimepath, 'slime/contrib/swank-mit-scheme.scm'), '\n' )
if len( swanks ) == 0
return ''
endif
return '"' . g:slimv_lisp . '" --load "' . swanks[0] . '"'
endif
return ''
endfunction
" Filetype specific initialization for the REPL buffer
function! SlimvInitRepl()
set filetype=scheme
endfunction
" Lookup symbol in the Hyperspec
function! SlimvHyperspecLookup( word, exact, all )
" No Hyperspec support for Scheme at the moment
let symbol = []
return symbol
endfunction
" Source Slimv general part
runtime ftplugin/**/slimv.vim
endif "!exists( 'g:slimv_scheme_loaded' )
" ---------- End of part loaded once ----------
runtime ftplugin/**/lisp.vim
" The balloonexpr of MIT-Scheme is broken. Disable it.
let g:slimv_balloon = 0
" The fuzzy completion of MIT-Scheme is broken. Disable it.
let g:slimv_simple_compl = 1
" Must be called for each lisp buffer
call SlimvInitBuffer()
" Don't load another plugin for this buffer
let b:did_ftplugin = 1

2236
sources_non_forked/slimv/ftplugin/slimv-clhs.vim Normal file
View File

File diff suppressed because it is too large Load Diff

759
sources_non_forked/slimv/ftplugin/slimv-cljapi.vim Normal file
View File

@ -0,0 +1,759 @@
" slimv-cljapi.vim:
" Clojure API lookup support for Slimv
" Version: 0.9.6
" Last Change: 12 Mar 2012
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if &cp || exists( 'g:slimv_cljapi_loaded' )
finish
endif
let g:slimv_cljapi_loaded = 1
" Root of the Clojure API
if !exists( 'g:slimv_cljapi_root' )
let g:slimv_cljapi_root = 'http://clojure.github.com/clojure/'
endif
if !exists( 'g:slimv_cljapi_db' )
let g:slimv_cljapi_db = [
\["*", "clojure.core-api.html\\#clojure.core/*"],
\["*'", "clojure.core-api.html\\#clojure.core/*'"],
\["*1", "clojure.core-api.html\\#clojure.core/*1"],
\["*2", "clojure.core-api.html\\#clojure.core/*2"],
\["*3", "clojure.core-api.html\\#clojure.core/*3"],
\["*agent*", "clojure.core-api.html\\#clojure.core/*agent*"],
\["*clojure-version*", "clojure.core-api.html\\#clojure.core/*clojure-version*"],
\["*command-line-args*", "clojure.core-api.html\\#clojure.core/*command-line-args*"],
\["*compile-files*", "clojure.core-api.html\\#clojure.core/*compile-files*"],
\["*compile-path*", "clojure.core-api.html\\#clojure.core/*compile-path*"],
\["*e", "clojure.core-api.html\\#clojure.core/*e"],
\["*err*", "clojure.core-api.html\\#clojure.core/*err*"],
\["*file*", "clojure.core-api.html\\#clojure.core/*file*"],
\["*flush-on-newline*", "clojure.core-api.html\\#clojure.core/*flush-on-newline*"],
\["*in*", "clojure.core-api.html\\#clojure.core/*in*"],
\["*ns*", "clojure.core-api.html\\#clojure.core/*ns*"],
\["*out*", "clojure.core-api.html\\#clojure.core/*out*"],
\["*print-dup*", "clojure.core-api.html\\#clojure.core/*print-dup*"],
\["*print-length*", "clojure.core-api.html\\#clojure.core/*print-length*"],
\["*print-level*", "clojure.core-api.html\\#clojure.core/*print-level*"],
\["*print-meta*", "clojure.core-api.html\\#clojure.core/*print-meta*"],
\["*print-readably*", "clojure.core-api.html\\#clojure.core/*print-readably*"],
\["*read-eval*", "clojure.core-api.html\\#clojure.core/*read-eval*"],
\["*unchecked-math*", "clojure.core-api.html\\#clojure.core/*unchecked-math*"],
\["*warn-on-reflection*", "clojure.core-api.html\\#clojure.core/*warn-on-reflection*"],
\["+", "clojure.core-api.html\\#clojure.core/+"],
\["+'", "clojure.core-api.html\\#clojure.core/+'"],
\["-", "clojure.core-api.html\\#clojure.core/-"],
\["-'", "clojure.core-api.html\\#clojure.core/-'"],
\["->", "clojure.core-api.html\\#clojure.core/->"],
\["->>", "clojure.core-api.html\\#clojure.core/->>"],
\["..", "clojure.core-api.html\\#clojure.core/.."],
\["/", "clojure.core-api.html\\#clojure.core//"],
\["<", "clojure.core-api.html\\#clojure.core/<"],
\["<=", "clojure.core-api.html\\#clojure.core/<="],
\["=", "clojure.core-api.html\\#clojure.core/="],
\["==", "clojure.core-api.html\\#clojure.core/=="],
\[">", "clojure.core-api.html\\#clojure.core/>"],
\[">=", "clojure.core-api.html\\#clojure.core/>="],
\["accessor", "clojure.core-api.html\\#clojure.core/accessor"],
\["aclone", "clojure.core-api.html\\#clojure.core/aclone"],
\["add-classpath", "clojure.core-api.html\\#clojure.core/add-classpath"],
\["add-watch", "clojure.core-api.html\\#clojure.core/add-watch"],
\["agent", "clojure.core-api.html\\#clojure.core/agent"],
\["agent-error", "clojure.core-api.html\\#clojure.core/agent-error"],
\["agent-errors", "clojure.core-api.html\\#clojure.core/agent-errors"],
\["aget", "clojure.core-api.html\\#clojure.core/aget"],
\["alength", "clojure.core-api.html\\#clojure.core/alength"],
\["alias", "clojure.core-api.html\\#clojure.core/alias"],
\["all-ns", "clojure.core-api.html\\#clojure.core/all-ns"],
\["alter", "clojure.core-api.html\\#clojure.core/alter"],
\["alter-meta!", "clojure.core-api.html\\#clojure.core/alter-meta!"],
\["alter-var-root", "clojure.core-api.html\\#clojure.core/alter-var-root"],
\["amap", "clojure.core-api.html\\#clojure.core/amap"],
\["ancestors", "clojure.core-api.html\\#clojure.core/ancestors"],
\["and", "clojure.core-api.html\\#clojure.core/and"],
\["apply", "clojure.core-api.html\\#clojure.core/apply"],
\["areduce", "clojure.core-api.html\\#clojure.core/areduce"],
\["array-map", "clojure.core-api.html\\#clojure.core/array-map"],
\["aset", "clojure.core-api.html\\#clojure.core/aset"],
\["aset-boolean", "clojure.core-api.html\\#clojure.core/aset-boolean"],
\["aset-byte", "clojure.core-api.html\\#clojure.core/aset-byte"],
\["aset-char", "clojure.core-api.html\\#clojure.core/aset-char"],
\["aset-double", "clojure.core-api.html\\#clojure.core/aset-double"],
\["aset-float", "clojure.core-api.html\\#clojure.core/aset-float"],
\["aset-int", "clojure.core-api.html\\#clojure.core/aset-int"],
\["aset-long", "clojure.core-api.html\\#clojure.core/aset-long"],
\["aset-short", "clojure.core-api.html\\#clojure.core/aset-short"],
\["assert", "clojure.core-api.html\\#clojure.core/assert"],
\["assoc", "clojure.core-api.html\\#clojure.core/assoc"],
\["assoc!", "clojure.core-api.html\\#clojure.core/assoc!"],
\["assoc-in", "clojure.core-api.html\\#clojure.core/assoc-in"],
\["associative?", "clojure.core-api.html\\#clojure.core/associative?"],
\["atom", "clojure.core-api.html\\#clojure.core/atom"],
\["await", "clojure.core-api.html\\#clojure.core/await"],
\["await-for", "clojure.core-api.html\\#clojure.core/await-for"],
\["bases", "clojure.core-api.html\\#clojure.core/bases"],
\["bean", "clojure.core-api.html\\#clojure.core/bean"],
\["bigdec", "clojure.core-api.html\\#clojure.core/bigdec"],
\["bigint", "clojure.core-api.html\\#clojure.core/bigint"],
\["biginteger", "clojure.core-api.html\\#clojure.core/biginteger"],
\["binding", "clojure.core-api.html\\#clojure.core/binding"],
\["bit-and", "clojure.core-api.html\\#clojure.core/bit-and"],
\["bit-and-not", "clojure.core-api.html\\#clojure.core/bit-and-not"],
\["bit-clear", "clojure.core-api.html\\#clojure.core/bit-clear"],
\["bit-flip", "clojure.core-api.html\\#clojure.core/bit-flip"],
\["bit-not", "clojure.core-api.html\\#clojure.core/bit-not"],
\["bit-or", "clojure.core-api.html\\#clojure.core/bit-or"],
\["bit-set", "clojure.core-api.html\\#clojure.core/bit-set"],
\["bit-shift-left", "clojure.core-api.html\\#clojure.core/bit-shift-left"],
\["bit-shift-right", "clojure.core-api.html\\#clojure.core/bit-shift-right"],
\["bit-test", "clojure.core-api.html\\#clojure.core/bit-test"],
\["bit-xor", "clojure.core-api.html\\#clojure.core/bit-xor"],
\["boolean", "clojure.core-api.html\\#clojure.core/boolean"],
\["boolean-array", "clojure.core-api.html\\#clojure.core/boolean-array"],
\["booleans", "clojure.core-api.html\\#clojure.core/booleans"],
\["bound-fn", "clojure.core-api.html\\#clojure.core/bound-fn"],
\["bound-fn*", "clojure.core-api.html\\#clojure.core/bound-fn*"],
\["bound?", "clojure.core-api.html\\#clojure.core/bound?"],
\["butlast", "clojure.core-api.html\\#clojure.core/butlast"],
\["byte", "clojure.core-api.html\\#clojure.core/byte"],
\["byte-array", "clojure.core-api.html\\#clojure.core/byte-array"],
\["bytes", "clojure.core-api.html\\#clojure.core/bytes"],
\["case", "clojure.core-api.html\\#clojure.core/case"],
\["cast", "clojure.core-api.html\\#clojure.core/cast"],
\["char", "clojure.core-api.html\\#clojure.core/char"],
\["char-array", "clojure.core-api.html\\#clojure.core/char-array"],
\["char-escape-string", "clojure.core-api.html\\#clojure.core/char-escape-string"],
\["char-name-string", "clojure.core-api.html\\#clojure.core/char-name-string"],
\["char?", "clojure.core-api.html\\#clojure.core/char?"],
\["chars", "clojure.core-api.html\\#clojure.core/chars"],
\["class", "clojure.core-api.html\\#clojure.core/class"],
\["class?", "clojure.core-api.html\\#clojure.core/class?"],
\["clear-agent-errors", "clojure.core-api.html\\#clojure.core/clear-agent-errors"],
\["clojure-version", "clojure.core-api.html\\#clojure.core/clojure-version"],
\["coll?", "clojure.core-api.html\\#clojure.core/coll?"],
\["comment", "clojure.core-api.html\\#clojure.core/comment"],
\["commute", "clojure.core-api.html\\#clojure.core/commute"],
\["comp", "clojure.core-api.html\\#clojure.core/comp"],
\["comparator", "clojure.core-api.html\\#clojure.core/comparator"],
\["compare", "clojure.core-api.html\\#clojure.core/compare"],
\["compare-and-set!", "clojure.core-api.html\\#clojure.core/compare-and-set!"],
\["compile", "clojure.core-api.html\\#clojure.core/compile"],
\["complement", "clojure.core-api.html\\#clojure.core/complement"],
\["concat", "clojure.core-api.html\\#clojure.core/concat"],
\["cond", "clojure.core-api.html\\#clojure.core/cond"],
\["condp", "clojure.core-api.html\\#clojure.core/condp"],
\["conj", "clojure.core-api.html\\#clojure.core/conj"],
\["conj!", "clojure.core-api.html\\#clojure.core/conj!"],
\["cons", "clojure.core-api.html\\#clojure.core/cons"],
\["constantly", "clojure.core-api.html\\#clojure.core/constantly"],
\["construct-proxy", "clojure.core-api.html\\#clojure.core/construct-proxy"],
\["contains?", "clojure.core-api.html\\#clojure.core/contains?"],
\["count", "clojure.core-api.html\\#clojure.core/count"],
\["counted?", "clojure.core-api.html\\#clojure.core/counted?"],
\["create-ns", "clojure.core-api.html\\#clojure.core/create-ns"],
\["create-struct", "clojure.core-api.html\\#clojure.core/create-struct"],
\["cycle", "clojure.core-api.html\\#clojure.core/cycle"],
\["dec", "clojure.core-api.html\\#clojure.core/dec"],
\["dec'", "clojure.core-api.html\\#clojure.core/dec'"],
\["decimal?", "clojure.core-api.html\\#clojure.core/decimal?"],
\["declare", "clojure.core-api.html\\#clojure.core/declare"],
\["definline", "clojure.core-api.html\\#clojure.core/definline"],
\["defmacro", "clojure.core-api.html\\#clojure.core/defmacro"],
\["defmethod", "clojure.core-api.html\\#clojure.core/defmethod"],
\["defmulti", "clojure.core-api.html\\#clojure.core/defmulti"],
\["defn", "clojure.core-api.html\\#clojure.core/defn"],
\["defn-", "clojure.core-api.html\\#clojure.core/defn-"],
\["defonce", "clojure.core-api.html\\#clojure.core/defonce"],
\["defprotocol", "clojure.core-api.html\\#clojure.core/defprotocol"],
\["defrecord", "clojure.core-api.html\\#clojure.core/defrecord"],
\["defstruct", "clojure.core-api.html\\#clojure.core/defstruct"],
\["deftype", "clojure.core-api.html\\#clojure.core/deftype"],
\["delay", "clojure.core-api.html\\#clojure.core/delay"],
\["delay?", "clojure.core-api.html\\#clojure.core/delay?"],
\["deliver", "clojure.core-api.html\\#clojure.core/deliver"],
\["denominator", "clojure.core-api.html\\#clojure.core/denominator"],
\["deref", "clojure.core-api.html\\#clojure.core/deref"],
\["derive", "clojure.core-api.html\\#clojure.core/derive"],
\["descendants", "clojure.core-api.html\\#clojure.core/descendants"],
\["disj", "clojure.core-api.html\\#clojure.core/disj"],
\["disj!", "clojure.core-api.html\\#clojure.core/disj!"],
\["dissoc", "clojure.core-api.html\\#clojure.core/dissoc"],
\["dissoc!", "clojure.core-api.html\\#clojure.core/dissoc!"],
\["distinct", "clojure.core-api.html\\#clojure.core/distinct"],
\["distinct?", "clojure.core-api.html\\#clojure.core/distinct?"],
\["doall", "clojure.core-api.html\\#clojure.core/doall"],
\["dorun", "clojure.core-api.html\\#clojure.core/dorun"],
\["doseq", "clojure.core-api.html\\#clojure.core/doseq"],
\["dosync", "clojure.core-api.html\\#clojure.core/dosync"],
\["dotimes", "clojure.core-api.html\\#clojure.core/dotimes"],
\["doto", "clojure.core-api.html\\#clojure.core/doto"],
\["double", "clojure.core-api.html\\#clojure.core/double"],
\["double-array", "clojure.core-api.html\\#clojure.core/double-array"],
\["doubles", "clojure.core-api.html\\#clojure.core/doubles"],
\["drop", "clojure.core-api.html\\#clojure.core/drop"],
\["drop-last", "clojure.core-api.html\\#clojure.core/drop-last"],
\["drop-while", "clojure.core-api.html\\#clojure.core/drop-while"],
\["empty", "clojure.core-api.html\\#clojure.core/empty"],
\["empty?", "clojure.core-api.html\\#clojure.core/empty?"],
\["ensure", "clojure.core-api.html\\#clojure.core/ensure"],
\["enumeration-seq", "clojure.core-api.html\\#clojure.core/enumeration-seq"],
\["error-handler", "clojure.core-api.html\\#clojure.core/error-handler"],
\["error-mode", "clojure.core-api.html\\#clojure.core/error-mode"],
\["eval", "clojure.core-api.html\\#clojure.core/eval"],
\["even?", "clojure.core-api.html\\#clojure.core/even?"],
\["every-pred", "clojure.core-api.html\\#clojure.core/every-pred"],
\["every?", "clojure.core-api.html\\#clojure.core/every?"],
\["extend", "clojure.core-api.html\\#clojure.core/extend"],
\["extend-protocol", "clojure.core-api.html\\#clojure.core/extend-protocol"],
\["extend-type", "clojure.core-api.html\\#clojure.core/extend-type"],
\["extenders", "clojure.core-api.html\\#clojure.core/extenders"],
\["extends?", "clojure.core-api.html\\#clojure.core/extends?"],
\["false?", "clojure.core-api.html\\#clojure.core/false?"],
\["ffirst", "clojure.core-api.html\\#clojure.core/ffirst"],
\["file-seq", "clojure.core-api.html\\#clojure.core/file-seq"],
\["filter", "clojure.core-api.html\\#clojure.core/filter"],
\["find", "clojure.core-api.html\\#clojure.core/find"],
\["find-keyword", "clojure.core-api.html\\#clojure.core/find-keyword"],
\["find-ns", "clojure.core-api.html\\#clojure.core/find-ns"],
\["find-var", "clojure.core-api.html\\#clojure.core/find-var"],
\["first", "clojure.core-api.html\\#clojure.core/first"],
\["flatten", "clojure.core-api.html\\#clojure.core/flatten"],
\["float", "clojure.core-api.html\\#clojure.core/float"],
\["float-array", "clojure.core-api.html\\#clojure.core/float-array"],
\["float?", "clojure.core-api.html\\#clojure.core/float?"],
\["floats", "clojure.core-api.html\\#clojure.core/floats"],
\["flush", "clojure.core-api.html\\#clojure.core/flush"],
\["fn", "clojure.core-api.html\\#clojure.core/fn"],
\["fn?", "clojure.core-api.html\\#clojure.core/fn?"],
\["fnext", "clojure.core-api.html\\#clojure.core/fnext"],
\["fnil", "clojure.core-api.html\\#clojure.core/fnil"],
\["for", "clojure.core-api.html\\#clojure.core/for"],
\["force", "clojure.core-api.html\\#clojure.core/force"],
\["format", "clojure.core-api.html\\#clojure.core/format"],
\["frequencies", "clojure.core-api.html\\#clojure.core/frequencies"],
\["future", "clojure.core-api.html\\#clojure.core/future"],
\["future-call", "clojure.core-api.html\\#clojure.core/future-call"],
\["future-cancel", "clojure.core-api.html\\#clojure.core/future-cancel"],
\["future-cancelled?", "clojure.core-api.html\\#clojure.core/future-cancelled?"],
\["future-done?", "clojure.core-api.html\\#clojure.core/future-done?"],
\["future?", "clojure.core-api.html\\#clojure.core/future?"],
\["gen-class", "clojure.core-api.html\\#clojure.core/gen-class"],
\["gen-interface", "clojure.core-api.html\\#clojure.core/gen-interface"],
\["gensym", "clojure.core-api.html\\#clojure.core/gensym"],
\["get", "clojure.core-api.html\\#clojure.core/get"],
\["get-in", "clojure.core-api.html\\#clojure.core/get-in"],
\["get-method", "clojure.core-api.html\\#clojure.core/get-method"],
\["get-proxy-class", "clojure.core-api.html\\#clojure.core/get-proxy-class"],
\["get-thread-bindings", "clojure.core-api.html\\#clojure.core/get-thread-bindings"],
\["get-validator", "clojure.core-api.html\\#clojure.core/get-validator"],
\["group-by", "clojure.core-api.html\\#clojure.core/group-by"],
\["hash", "clojure.core-api.html\\#clojure.core/hash"],
\["hash-map", "clojure.core-api.html\\#clojure.core/hash-map"],
\["hash-set", "clojure.core-api.html\\#clojure.core/hash-set"],
\["identical?", "clojure.core-api.html\\#clojure.core/identical?"],
\["identity", "clojure.core-api.html\\#clojure.core/identity"],
\["if-let", "clojure.core-api.html\\#clojure.core/if-let"],
\["if-not", "clojure.core-api.html\\#clojure.core/if-not"],
\["ifn?", "clojure.core-api.html\\#clojure.core/ifn?"],
\["import", "clojure.core-api.html\\#clojure.core/import"],
\["in-ns", "clojure.core-api.html\\#clojure.core/in-ns"],
\["inc", "clojure.core-api.html\\#clojure.core/inc"],
\["inc'", "clojure.core-api.html\\#clojure.core/inc'"],
\["init-proxy", "clojure.core-api.html\\#clojure.core/init-proxy"],
\["instance?", "clojure.core-api.html\\#clojure.core/instance?"],
\["int", "clojure.core-api.html\\#clojure.core/int"],
\["int-array", "clojure.core-api.html\\#clojure.core/int-array"],
\["integer?", "clojure.core-api.html\\#clojure.core/integer?"],
\["interleave", "clojure.core-api.html\\#clojure.core/interleave"],
\["intern", "clojure.core-api.html\\#clojure.core/intern"],
\["interpose", "clojure.core-api.html\\#clojure.core/interpose"],
\["into", "clojure.core-api.html\\#clojure.core/into"],
\["into-array", "clojure.core-api.html\\#clojure.core/into-array"],
\["ints", "clojure.core-api.html\\#clojure.core/ints"],
\["io!", "clojure.core-api.html\\#clojure.core/io!"],
\["isa?", "clojure.core-api.html\\#clojure.core/isa?"],
\["iterate", "clojure.core-api.html\\#clojure.core/iterate"],
\["iterator-seq", "clojure.core-api.html\\#clojure.core/iterator-seq"],
\["juxt", "clojure.core-api.html\\#clojure.core/juxt"],
\["keep", "clojure.core-api.html\\#clojure.core/keep"],
\["keep-indexed", "clojure.core-api.html\\#clojure.core/keep-indexed"],
\["key", "clojure.core-api.html\\#clojure.core/key"],
\["keys", "clojure.core-api.html\\#clojure.core/keys"],
\["keyword", "clojure.core-api.html\\#clojure.core/keyword"],
\["keyword?", "clojure.core-api.html\\#clojure.core/keyword?"],
\["last", "clojure.core-api.html\\#clojure.core/last"],
\["lazy-cat", "clojure.core-api.html\\#clojure.core/lazy-cat"],
\["lazy-seq", "clojure.core-api.html\\#clojure.core/lazy-seq"],
\["let", "clojure.core-api.html\\#clojure.core/let"],
\["letfn", "clojure.core-api.html\\#clojure.core/letfn"],
\["line-seq", "clojure.core-api.html\\#clojure.core/line-seq"],
\["list", "clojure.core-api.html\\#clojure.core/list"],
\["list*", "clojure.core-api.html\\#clojure.core/list*"],
\["list?", "clojure.core-api.html\\#clojure.core/list?"],
\["load", "clojure.core-api.html\\#clojure.core/load"],
\["load-file", "clojure.core-api.html\\#clojure.core/load-file"],
\["load-reader", "clojure.core-api.html\\#clojure.core/load-reader"],
\["load-string", "clojure.core-api.html\\#clojure.core/load-string"],
\["loaded-libs", "clojure.core-api.html\\#clojure.core/loaded-libs"],
\["locking", "clojure.core-api.html\\#clojure.core/locking"],
\["long", "clojure.core-api.html\\#clojure.core/long"],
\["long-array", "clojure.core-api.html\\#clojure.core/long-array"],
\["longs", "clojure.core-api.html\\#clojure.core/longs"],
\["loop", "clojure.core-api.html\\#clojure.core/loop"],
\["macroexpand", "clojure.core-api.html\\#clojure.core/macroexpand"],
\["macroexpand-1", "clojure.core-api.html\\#clojure.core/macroexpand-1"],
\["make-array", "clojure.core-api.html\\#clojure.core/make-array"],
\["make-hierarchy", "clojure.core-api.html\\#clojure.core/make-hierarchy"],
\["map", "clojure.core-api.html\\#clojure.core/map"],
\["map-indexed", "clojure.core-api.html\\#clojure.core/map-indexed"],
\["map?", "clojure.core-api.html\\#clojure.core/map?"],
\["mapcat", "clojure.core-api.html\\#clojure.core/mapcat"],
\["max", "clojure.core-api.html\\#clojure.core/max"],
\["max-key", "clojure.core-api.html\\#clojure.core/max-key"],
\["memfn", "clojure.core-api.html\\#clojure.core/memfn"],
\["memoize", "clojure.core-api.html\\#clojure.core/memoize"],
\["merge", "clojure.core-api.html\\#clojure.core/merge"],
\["merge-with", "clojure.core-api.html\\#clojure.core/merge-with"],
\["meta", "clojure.core-api.html\\#clojure.core/meta"],
\["methods", "clojure.core-api.html\\#clojure.core/methods"],
\["min", "clojure.core-api.html\\#clojure.core/min"],
\["min-key", "clojure.core-api.html\\#clojure.core/min-key"],
\["mod", "clojure.core-api.html\\#clojure.core/mod"],
\["name", "clojure.core-api.html\\#clojure.core/name"],
\["namespace", "clojure.core-api.html\\#clojure.core/namespace"],
\["namespace-munge", "clojure.core-api.html\\#clojure.core/namespace-munge"],
\["neg?", "clojure.core-api.html\\#clojure.core/neg?"],
\["newline", "clojure.core-api.html\\#clojure.core/newline"],
\["next", "clojure.core-api.html\\#clojure.core/next"],
\["nfirst", "clojure.core-api.html\\#clojure.core/nfirst"],
\["nil?", "clojure.core-api.html\\#clojure.core/nil?"],
\["nnext", "clojure.core-api.html\\#clojure.core/nnext"],
\["not", "clojure.core-api.html\\#clojure.core/not"],
\["not-any?", "clojure.core-api.html\\#clojure.core/not-any?"],
\["not-empty", "clojure.core-api.html\\#clojure.core/not-empty"],
\["not-every?", "clojure.core-api.html\\#clojure.core/not-every?"],
\["not=", "clojure.core-api.html\\#clojure.core/not="],
\["ns", "clojure.core-api.html\\#clojure.core/ns"],
\["ns-aliases", "clojure.core-api.html\\#clojure.core/ns-aliases"],
\["ns-imports", "clojure.core-api.html\\#clojure.core/ns-imports"],
\["ns-interns", "clojure.core-api.html\\#clojure.core/ns-interns"],
\["ns-map", "clojure.core-api.html\\#clojure.core/ns-map"],
\["ns-name", "clojure.core-api.html\\#clojure.core/ns-name"],
\["ns-publics", "clojure.core-api.html\\#clojure.core/ns-publics"],
\["ns-refers", "clojure.core-api.html\\#clojure.core/ns-refers"],
\["ns-resolve", "clojure.core-api.html\\#clojure.core/ns-resolve"],
\["ns-unalias", "clojure.core-api.html\\#clojure.core/ns-unalias"],
\["ns-unmap", "clojure.core-api.html\\#clojure.core/ns-unmap"],
\["nth", "clojure.core-api.html\\#clojure.core/nth"],
\["nthnext", "clojure.core-api.html\\#clojure.core/nthnext"],
\["nthrest", "clojure.core-api.html\\#clojure.core/nthrest"],
\["num", "clojure.core-api.html\\#clojure.core/num"],
\["number?", "clojure.core-api.html\\#clojure.core/number?"],
\["numerator", "clojure.core-api.html\\#clojure.core/numerator"],
\["object-array", "clojure.core-api.html\\#clojure.core/object-array"],
\["odd?", "clojure.core-api.html\\#clojure.core/odd?"],
\["or", "clojure.core-api.html\\#clojure.core/or"],
\["parents", "clojure.core-api.html\\#clojure.core/parents"],
\["partial", "clojure.core-api.html\\#clojure.core/partial"],
\["partition", "clojure.core-api.html\\#clojure.core/partition"],
\["partition-all", "clojure.core-api.html\\#clojure.core/partition-all"],
\["partition-by", "clojure.core-api.html\\#clojure.core/partition-by"],
\["pcalls", "clojure.core-api.html\\#clojure.core/pcalls"],
\["peek", "clojure.core-api.html\\#clojure.core/peek"],
\["persistent!", "clojure.core-api.html\\#clojure.core/persistent!"],
\["pmap", "clojure.core-api.html\\#clojure.core/pmap"],
\["pop", "clojure.core-api.html\\#clojure.core/pop"],
\["pop!", "clojure.core-api.html\\#clojure.core/pop!"],
\["pop-thread-bindings", "clojure.core-api.html\\#clojure.core/pop-thread-bindings"],
\["pos?", "clojure.core-api.html\\#clojure.core/pos?"],
\["pr", "clojure.core-api.html\\#clojure.core/pr"],
\["pr-str", "clojure.core-api.html\\#clojure.core/pr-str"],
\["prefer-method", "clojure.core-api.html\\#clojure.core/prefer-method"],
\["prefers", "clojure.core-api.html\\#clojure.core/prefers"],
\["print", "clojure.core-api.html\\#clojure.core/print"],
\["print-str", "clojure.core-api.html\\#clojure.core/print-str"],
\["printf", "clojure.core-api.html\\#clojure.core/printf"],
\["println", "clojure.core-api.html\\#clojure.core/println"],
\["println-str", "clojure.core-api.html\\#clojure.core/println-str"],
\["prn", "clojure.core-api.html\\#clojure.core/prn"],
\["prn-str", "clojure.core-api.html\\#clojure.core/prn-str"],
\["promise", "clojure.core-api.html\\#clojure.core/promise"],
\["proxy", "clojure.core-api.html\\#clojure.core/proxy"],
\["proxy-mappings", "clojure.core-api.html\\#clojure.core/proxy-mappings"],
\["proxy-super", "clojure.core-api.html\\#clojure.core/proxy-super"],
\["push-thread-bindings", "clojure.core-api.html\\#clojure.core/push-thread-bindings"],
\["pvalues", "clojure.core-api.html\\#clojure.core/pvalues"],
\["quot", "clojure.core-api.html\\#clojure.core/quot"],
\["rand", "clojure.core-api.html\\#clojure.core/rand"],
\["rand-int", "clojure.core-api.html\\#clojure.core/rand-int"],
\["rand-nth", "clojure.core-api.html\\#clojure.core/rand-nth"],
\["range", "clojure.core-api.html\\#clojure.core/range"],
\["ratio?", "clojure.core-api.html\\#clojure.core/ratio?"],
\["rational?", "clojure.core-api.html\\#clojure.core/rational?"],
\["rationalize", "clojure.core-api.html\\#clojure.core/rationalize"],
\["re-find", "clojure.core-api.html\\#clojure.core/re-find"],
\["re-groups", "clojure.core-api.html\\#clojure.core/re-groups"],
\["re-matcher", "clojure.core-api.html\\#clojure.core/re-matcher"],
\["re-matches", "clojure.core-api.html\\#clojure.core/re-matches"],
\["re-pattern", "clojure.core-api.html\\#clojure.core/re-pattern"],
\["re-seq", "clojure.core-api.html\\#clojure.core/re-seq"],
\["read", "clojure.core-api.html\\#clojure.core/read"],
\["read-line", "clojure.core-api.html\\#clojure.core/read-line"],
\["read-string", "clojure.core-api.html\\#clojure.core/read-string"],
\["realized?", "clojure.core-api.html\\#clojure.core/realized?"],
\["reduce", "clojure.core-api.html\\#clojure.core/reduce"],
\["reductions", "clojure.core-api.html\\#clojure.core/reductions"],
\["ref", "clojure.core-api.html\\#clojure.core/ref"],
\["ref-history-count", "clojure.core-api.html\\#clojure.core/ref-history-count"],
\["ref-max-history", "clojure.core-api.html\\#clojure.core/ref-max-history"],
\["ref-min-history", "clojure.core-api.html\\#clojure.core/ref-min-history"],
\["ref-set", "clojure.core-api.html\\#clojure.core/ref-set"],
\["refer", "clojure.core-api.html\\#clojure.core/refer"],
\["refer-clojure", "clojure.core-api.html\\#clojure.core/refer-clojure"],
\["reify", "clojure.core-api.html\\#clojure.core/reify"],
\["release-pending-sends", "clojure.core-api.html\\#clojure.core/release-pending-sends"],
\["rem", "clojure.core-api.html\\#clojure.core/rem"],
\["remove", "clojure.core-api.html\\#clojure.core/remove"],
\["remove-all-methods", "clojure.core-api.html\\#clojure.core/remove-all-methods"],
\["remove-method", "clojure.core-api.html\\#clojure.core/remove-method"],
\["remove-ns", "clojure.core-api.html\\#clojure.core/remove-ns"],
\["remove-watch", "clojure.core-api.html\\#clojure.core/remove-watch"],
\["repeat", "clojure.core-api.html\\#clojure.core/repeat"],
\["repeatedly", "clojure.core-api.html\\#clojure.core/repeatedly"],
\["replace", "clojure.core-api.html\\#clojure.core/replace"],
\["replicate", "clojure.core-api.html\\#clojure.core/replicate"],
\["require", "clojure.core-api.html\\#clojure.core/require"],
\["reset!", "clojure.core-api.html\\#clojure.core/reset!"],
\["reset-meta!", "clojure.core-api.html\\#clojure.core/reset-meta!"],
\["resolve", "clojure.core-api.html\\#clojure.core/resolve"],
\["rest", "clojure.core-api.html\\#clojure.core/rest"],
\["restart-agent", "clojure.core-api.html\\#clojure.core/restart-agent"],
\["resultset-seq", "clojure.core-api.html\\#clojure.core/resultset-seq"],
\["reverse", "clojure.core-api.html\\#clojure.core/reverse"],
\["reversible?", "clojure.core-api.html\\#clojure.core/reversible?"],
\["rseq", "clojure.core-api.html\\#clojure.core/rseq"],
\["rsubseq", "clojure.core-api.html\\#clojure.core/rsubseq"],
\["satisfies?", "clojure.core-api.html\\#clojure.core/satisfies?"],
\["second", "clojure.core-api.html\\#clojure.core/second"],
\["select-keys", "clojure.core-api.html\\#clojure.core/select-keys"],
\["send", "clojure.core-api.html\\#clojure.core/send"],
\["send-off", "clojure.core-api.html\\#clojure.core/send-off"],
\["seq", "clojure.core-api.html\\#clojure.core/seq"],
\["seq?", "clojure.core-api.html\\#clojure.core/seq?"],
\["seque", "clojure.core-api.html\\#clojure.core/seque"],
\["sequence", "clojure.core-api.html\\#clojure.core/sequence"],
\["sequential?", "clojure.core-api.html\\#clojure.core/sequential?"],
\["set", "clojure.core-api.html\\#clojure.core/set"],
\["set-error-handler!", "clojure.core-api.html\\#clojure.core/set-error-handler!"],
\["set-error-mode!", "clojure.core-api.html\\#clojure.core/set-error-mode!"],
\["set-validator!", "clojure.core-api.html\\#clojure.core/set-validator!"],
\["set?", "clojure.core-api.html\\#clojure.core/set?"],
\["short", "clojure.core-api.html\\#clojure.core/short"],
\["short-array", "clojure.core-api.html\\#clojure.core/short-array"],
\["shorts", "clojure.core-api.html\\#clojure.core/shorts"],
\["shuffle", "clojure.core-api.html\\#clojure.core/shuffle"],
\["shutdown-agents", "clojure.core-api.html\\#clojure.core/shutdown-agents"],
\["slurp", "clojure.core-api.html\\#clojure.core/slurp"],
\["some", "clojure.core-api.html\\#clojure.core/some"],
\["some-fn", "clojure.core-api.html\\#clojure.core/some-fn"],
\["sort", "clojure.core-api.html\\#clojure.core/sort"],
\["sort-by", "clojure.core-api.html\\#clojure.core/sort-by"],
\["sorted-map", "clojure.core-api.html\\#clojure.core/sorted-map"],
\["sorted-map-by", "clojure.core-api.html\\#clojure.core/sorted-map-by"],
\["sorted-set", "clojure.core-api.html\\#clojure.core/sorted-set"],
\["sorted-set-by", "clojure.core-api.html\\#clojure.core/sorted-set-by"],
\["sorted?", "clojure.core-api.html\\#clojure.core/sorted?"],
\["special-symbol?", "clojure.core-api.html\\#clojure.core/special-symbol?"],
\["spit", "clojure.core-api.html\\#clojure.core/spit"],
\["split-at", "clojure.core-api.html\\#clojure.core/split-at"],
\["split-with", "clojure.core-api.html\\#clojure.core/split-with"],
\["str", "clojure.core-api.html\\#clojure.core/str"],
\["string?", "clojure.core-api.html\\#clojure.core/string?"],
\["struct", "clojure.core-api.html\\#clojure.core/struct"],
\["struct-map", "clojure.core-api.html\\#clojure.core/struct-map"],
\["subs", "clojure.core-api.html\\#clojure.core/subs"],
\["subseq", "clojure.core-api.html\\#clojure.core/subseq"],
\["subvec", "clojure.core-api.html\\#clojure.core/subvec"],
\["supers", "clojure.core-api.html\\#clojure.core/supers"],
\["swap!", "clojure.core-api.html\\#clojure.core/swap!"],
\["symbol", "clojure.core-api.html\\#clojure.core/symbol"],
\["symbol?", "clojure.core-api.html\\#clojure.core/symbol?"],
\["sync", "clojure.core-api.html\\#clojure.core/sync"],
\["take", "clojure.core-api.html\\#clojure.core/take"],
\["take-last", "clojure.core-api.html\\#clojure.core/take-last"],
\["take-nth", "clojure.core-api.html\\#clojure.core/take-nth"],
\["take-while", "clojure.core-api.html\\#clojure.core/take-while"],
\["test", "clojure.core-api.html\\#clojure.core/test"],
\["the-ns", "clojure.core-api.html\\#clojure.core/the-ns"],
\["thread-bound?", "clojure.core-api.html\\#clojure.core/thread-bound?"],
\["time", "clojure.core-api.html\\#clojure.core/time"],
\["to-array", "clojure.core-api.html\\#clojure.core/to-array"],
\["to-array-2d", "clojure.core-api.html\\#clojure.core/to-array-2d"],
\["trampoline", "clojure.core-api.html\\#clojure.core/trampoline"],
\["transient", "clojure.core-api.html\\#clojure.core/transient"],
\["tree-seq", "clojure.core-api.html\\#clojure.core/tree-seq"],
\["true?", "clojure.core-api.html\\#clojure.core/true?"],
\["type", "clojure.core-api.html\\#clojure.core/type"],
\["unchecked-add", "clojure.core-api.html\\#clojure.core/unchecked-add"],
\["unchecked-add-int", "clojure.core-api.html\\#clojure.core/unchecked-add-int"],
\["unchecked-byte", "clojure.core-api.html\\#clojure.core/unchecked-byte"],
\["unchecked-char", "clojure.core-api.html\\#clojure.core/unchecked-char"],
\["unchecked-dec", "clojure.core-api.html\\#clojure.core/unchecked-dec"],
\["unchecked-dec-int", "clojure.core-api.html\\#clojure.core/unchecked-dec-int"],
\["unchecked-divide-int", "clojure.core-api.html\\#clojure.core/unchecked-divide-int"],
\["unchecked-double", "clojure.core-api.html\\#clojure.core/unchecked-double"],
\["unchecked-float", "clojure.core-api.html\\#clojure.core/unchecked-float"],
\["unchecked-inc", "clojure.core-api.html\\#clojure.core/unchecked-inc"],
\["unchecked-inc-int", "clojure.core-api.html\\#clojure.core/unchecked-inc-int"],
\["unchecked-int", "clojure.core-api.html\\#clojure.core/unchecked-int"],
\["unchecked-long", "clojure.core-api.html\\#clojure.core/unchecked-long"],
\["unchecked-multiply", "clojure.core-api.html\\#clojure.core/unchecked-multiply"],
\["unchecked-multiply-int", "clojure.core-api.html\\#clojure.core/unchecked-multiply-int"],
\["unchecked-negate", "clojure.core-api.html\\#clojure.core/unchecked-negate"],
\["unchecked-negate-int", "clojure.core-api.html\\#clojure.core/unchecked-negate-int"],
\["unchecked-remainder-int", "clojure.core-api.html\\#clojure.core/unchecked-remainder-int"],
\["unchecked-short", "clojure.core-api.html\\#clojure.core/unchecked-short"],
\["unchecked-subtract", "clojure.core-api.html\\#clojure.core/unchecked-subtract"],
\["unchecked-subtract-int", "clojure.core-api.html\\#clojure.core/unchecked-subtract-int"],
\["underive", "clojure.core-api.html\\#clojure.core/underive"],
\["update-in", "clojure.core-api.html\\#clojure.core/update-in"],
\["update-proxy", "clojure.core-api.html\\#clojure.core/update-proxy"],
\["use", "clojure.core-api.html\\#clojure.core/use"],
\["val", "clojure.core-api.html\\#clojure.core/val"],
\["vals", "clojure.core-api.html\\#clojure.core/vals"],
\["var-get", "clojure.core-api.html\\#clojure.core/var-get"],
\["var-set", "clojure.core-api.html\\#clojure.core/var-set"],
\["var?", "clojure.core-api.html\\#clojure.core/var?"],
\["vary-meta", "clojure.core-api.html\\#clojure.core/vary-meta"],
\["vec", "clojure.core-api.html\\#clojure.core/vec"],
\["vector", "clojure.core-api.html\\#clojure.core/vector"],
\["vector-of", "clojure.core-api.html\\#clojure.core/vector-of"],
\["vector?", "clojure.core-api.html\\#clojure.core/vector?"],
\["when", "clojure.core-api.html\\#clojure.core/when"],
\["when-first", "clojure.core-api.html\\#clojure.core/when-first"],
\["when-let", "clojure.core-api.html\\#clojure.core/when-let"],
\["when-not", "clojure.core-api.html\\#clojure.core/when-not"],
\["while", "clojure.core-api.html\\#clojure.core/while"],
\["with-bindings", "clojure.core-api.html\\#clojure.core/with-bindings"],
\["with-bindings*", "clojure.core-api.html\\#clojure.core/with-bindings*"],
\["with-in-str", "clojure.core-api.html\\#clojure.core/with-in-str"],
\["with-local-vars", "clojure.core-api.html\\#clojure.core/with-local-vars"],
\["with-meta", "clojure.core-api.html\\#clojure.core/with-meta"],
\["with-open", "clojure.core-api.html\\#clojure.core/with-open"],
\["with-out-str", "clojure.core-api.html\\#clojure.core/with-out-str"],
\["with-precision", "clojure.core-api.html\\#clojure.core/with-precision"],
\["with-redefs", "clojure.core-api.html\\#clojure.core/with-redefs"],
\["with-redefs-fn", "clojure.core-api.html\\#clojure.core/with-redefs-fn"],
\["xml-seq", "clojure.core-api.html\\#clojure.core/xml-seq"],
\["zero?", "clojure.core-api.html\\#clojure.core/zero?"],
\["zipmap", "clojure.core-api.html\\#clojure.core/zipmap"],
\["Diff", "clojure.data-api.html\\#clojure.data/Diff"],
\["EqualityPartition", "clojure.data-api.html\\#clojure.data/EqualityPartition"],
\["diff", "clojure.data-api.html\\#clojure.data/diff"],
\["diff-similar", "clojure.data-api.html\\#clojure.data/diff-similar"],
\["equality-partition", "clojure.data-api.html\\#clojure.data/equality-partition"],
\["inspect", "clojure.inspector-api.html\\#clojure.inspector/inspect"],
\["inspect-table", "clojure.inspector-api.html\\#clojure.inspector/inspect-table"],
\["inspect-tree", "clojure.inspector-api.html\\#clojure.inspector/inspect-tree"],
\["browse-url", "clojure.java.browse-api.html\\#clojure.java.browse/browse-url"],
\["Coercions", "clojure.java.io-api.html\\#clojure.java.io/Coercions"],
\["IOFactory", "clojure.java.io-api.html\\#clojure.java.io/IOFactory"],
\["as-file", "clojure.java.io-api.html\\#clojure.java.io/as-file"],
\["as-relative-path", "clojure.java.io-api.html\\#clojure.java.io/as-relative-path"],
\["as-url", "clojure.java.io-api.html\\#clojure.java.io/as-url"],
\["copy", "clojure.java.io-api.html\\#clojure.java.io/copy"],
\["delete-file", "clojure.java.io-api.html\\#clojure.java.io/delete-file"],
\["file", "clojure.java.io-api.html\\#clojure.java.io/file"],
\["input-stream", "clojure.java.io-api.html\\#clojure.java.io/input-stream"],
\["make-input-stream", "clojure.java.io-api.html\\#clojure.java.io/make-input-stream"],
\["make-output-stream", "clojure.java.io-api.html\\#clojure.java.io/make-output-stream"],
\["make-parents", "clojure.java.io-api.html\\#clojure.java.io/make-parents"],
\["make-reader", "clojure.java.io-api.html\\#clojure.java.io/make-reader"],
\["make-writer", "clojure.java.io-api.html\\#clojure.java.io/make-writer"],
\["output-stream", "clojure.java.io-api.html\\#clojure.java.io/output-stream"],
\["reader", "clojure.java.io-api.html\\#clojure.java.io/reader"],
\["resource", "clojure.java.io-api.html\\#clojure.java.io/resource"],
\["writer", "clojure.java.io-api.html\\#clojure.java.io/writer"],
\["add-local-javadoc", "clojure.java.javadoc-api.html\\#clojure.java.javadoc/add-local-javadoc"],
\["add-remote-javadoc", "clojure.java.javadoc-api.html\\#clojure.java.javadoc/add-remote-javadoc"],
\["javadoc", "clojure.java.javadoc-api.html\\#clojure.java.javadoc/javadoc"],
\["sh", "clojure.java.shell-api.html\\#clojure.java.shell/sh"],
\["with-sh-dir", "clojure.java.shell-api.html\\#clojure.java.shell/with-sh-dir"],
\["with-sh-env", "clojure.java.shell-api.html\\#clojure.java.shell/with-sh-env"],
\["demunge", "clojure.main-api.html\\#clojure.main/demunge"],
\["load-script", "clojure.main-api.html\\#clojure.main/load-script"],
\["main", "clojure.main-api.html\\#clojure.main/main"],
\["repl", "clojure.main-api.html\\#clojure.main/repl"],
\["repl-caught", "clojure.main-api.html\\#clojure.main/repl-caught"],
\["repl-exception", "clojure.main-api.html\\#clojure.main/repl-exception"],
\["repl-prompt", "clojure.main-api.html\\#clojure.main/repl-prompt"],
\["repl-read", "clojure.main-api.html\\#clojure.main/repl-read"],
\["root-cause", "clojure.main-api.html\\#clojure.main/root-cause"],
\["skip-if-eol", "clojure.main-api.html\\#clojure.main/skip-if-eol"],
\["skip-whitespace", "clojure.main-api.html\\#clojure.main/skip-whitespace"],
\["stack-element-str", "clojure.main-api.html\\#clojure.main/stack-element-str"],
\["with-bindings", "clojure.main-api.html\\#clojure.main/with-bindings"],
\["*print-base*", "clojure.pprint-api.html\\#clojure.pprint/*print-base*"],
\["*print-miser-width*", "clojure.pprint-api.html\\#clojure.pprint/*print-miser-width*"],
\["*print-pprint-dispatch*", "clojure.pprint-api.html\\#clojure.pprint/*print-pprint-dispatch*"],
\["*print-pretty*", "clojure.pprint-api.html\\#clojure.pprint/*print-pretty*"],
\["*print-radix*", "clojure.pprint-api.html\\#clojure.pprint/*print-radix*"],
\["*print-right-margin*", "clojure.pprint-api.html\\#clojure.pprint/*print-right-margin*"],
\["*print-suppress-namespaces*", "clojure.pprint-api.html\\#clojure.pprint/*print-suppress-namespaces*"],
\["cl-format", "clojure.pprint-api.html\\#clojure.pprint/cl-format"],
\["formatter", "clojure.pprint-api.html\\#clojure.pprint/formatter"],
\["formatter-out", "clojure.pprint-api.html\\#clojure.pprint/formatter-out"],
\["fresh-line", "clojure.pprint-api.html\\#clojure.pprint/fresh-line"],
\["get-pretty-writer", "clojure.pprint-api.html\\#clojure.pprint/get-pretty-writer"],
\["pp", "clojure.pprint-api.html\\#clojure.pprint/pp"],
\["pprint", "clojure.pprint-api.html\\#clojure.pprint/pprint"],
\["pprint-indent", "clojure.pprint-api.html\\#clojure.pprint/pprint-indent"],
\["pprint-logical-block", "clojure.pprint-api.html\\#clojure.pprint/pprint-logical-block"],
\["pprint-newline", "clojure.pprint-api.html\\#clojure.pprint/pprint-newline"],
\["pprint-tab", "clojure.pprint-api.html\\#clojure.pprint/pprint-tab"],
\["print-length-loop", "clojure.pprint-api.html\\#clojure.pprint/print-length-loop"],
\["print-table", "clojure.pprint-api.html\\#clojure.pprint/print-table"],
\["set-pprint-dispatch", "clojure.pprint-api.html\\#clojure.pprint/set-pprint-dispatch"],
\["with-pprint-dispatch", "clojure.pprint-api.html\\#clojure.pprint/with-pprint-dispatch"],
\["write", "clojure.pprint-api.html\\#clojure.pprint/write"],
\["write-out", "clojure.pprint-api.html\\#clojure.pprint/write-out"],
\["TypeReference", "clojure.reflect-api.html\\#clojure.reflect/TypeReference"],
\["flag-descriptors", "clojure.reflect-api.html\\#clojure.reflect/flag-descriptors"],
\["reflect", "clojure.reflect-api.html\\#clojure.reflect/reflect"],
\["resolve-class", "clojure.reflect-api.html\\#clojure.reflect/resolve-class"],
\["type-reflect", "clojure.reflect-api.html\\#clojure.reflect/type-reflect"],
\["typename", "clojure.reflect-api.html\\#clojure.reflect/typename"],
\["apropos", "clojure.repl-api.html\\#clojure.repl/apropos"],
\["demunge", "clojure.repl-api.html\\#clojure.repl/demunge"],
\["dir", "clojure.repl-api.html\\#clojure.repl/dir"],
\["dir-fn", "clojure.repl-api.html\\#clojure.repl/dir-fn"],
\["doc", "clojure.repl-api.html\\#clojure.repl/doc"],
\["find-doc", "clojure.repl-api.html\\#clojure.repl/find-doc"],
\["pst", "clojure.repl-api.html\\#clojure.repl/pst"],
\["root-cause", "clojure.repl-api.html\\#clojure.repl/root-cause"],
\["set-break-handler!", "clojure.repl-api.html\\#clojure.repl/set-break-handler!"],
\["source", "clojure.repl-api.html\\#clojure.repl/source"],
\["source-fn", "clojure.repl-api.html\\#clojure.repl/source-fn"],
\["stack-element-str", "clojure.repl-api.html\\#clojure.repl/stack-element-str"],
\["thread-stopper", "clojure.repl-api.html\\#clojure.repl/thread-stopper"],
\["difference", "clojure.set-api.html\\#clojure.set/difference"],
\["index", "clojure.set-api.html\\#clojure.set/index"],
\["intersection", "clojure.set-api.html\\#clojure.set/intersection"],
\["join", "clojure.set-api.html\\#clojure.set/join"],
\["map-invert", "clojure.set-api.html\\#clojure.set/map-invert"],
\["project", "clojure.set-api.html\\#clojure.set/project"],
\["rename", "clojure.set-api.html\\#clojure.set/rename"],
\["rename-keys", "clojure.set-api.html\\#clojure.set/rename-keys"],
\["select", "clojure.set-api.html\\#clojure.set/select"],
\["subset?", "clojure.set-api.html\\#clojure.set/subset?"],
\["superset?", "clojure.set-api.html\\#clojure.set/superset?"],
\["union", "clojure.set-api.html\\#clojure.set/union"],
\["e", "clojure.stacktrace-api.html\\#clojure.stacktrace/e"],
\["print-cause-trace", "clojure.stacktrace-api.html\\#clojure.stacktrace/print-cause-trace"],
\["print-stack-trace", "clojure.stacktrace-api.html\\#clojure.stacktrace/print-stack-trace"],
\["print-throwable", "clojure.stacktrace-api.html\\#clojure.stacktrace/print-throwable"],
\["print-trace-element", "clojure.stacktrace-api.html\\#clojure.stacktrace/print-trace-element"],
\["root-cause", "clojure.stacktrace-api.html\\#clojure.stacktrace/root-cause"],
\["blank?", "clojure.string-api.html\\#clojure.string/blank?"],
\["capitalize", "clojure.string-api.html\\#clojure.string/capitalize"],
\["escape", "clojure.string-api.html\\#clojure.string/escape"],
\["join", "clojure.string-api.html\\#clojure.string/join"],
\["lower-case", "clojure.string-api.html\\#clojure.string/lower-case"],
\["replace", "clojure.string-api.html\\#clojure.string/replace"],
\["replace-first", "clojure.string-api.html\\#clojure.string/replace-first"],
\["reverse", "clojure.string-api.html\\#clojure.string/reverse"],
\["split", "clojure.string-api.html\\#clojure.string/split"],
\["split-lines", "clojure.string-api.html\\#clojure.string/split-lines"],
\["trim", "clojure.string-api.html\\#clojure.string/trim"],
\["trim-newline", "clojure.string-api.html\\#clojure.string/trim-newline"],
\["triml", "clojure.string-api.html\\#clojure.string/triml"],
\["trimr", "clojure.string-api.html\\#clojure.string/trimr"],
\["upper-case", "clojure.string-api.html\\#clojure.string/upper-case"],
\["apply-template", "clojure.template-api.html\\#clojure.template/apply-template"],
\["do-template", "clojure.template-api.html\\#clojure.template/do-template"],
\["*load-tests*", "clojure.test-api.html\\#clojure.test/*load-tests*"],
\["*stack-trace-depth*", "clojure.test-api.html\\#clojure.test/*stack-trace-depth*"],
\["are", "clojure.test-api.html\\#clojure.test/are"],
\["assert-any", "clojure.test-api.html\\#clojure.test/assert-any"],
\["assert-predicate", "clojure.test-api.html\\#clojure.test/assert-predicate"],
\["compose-fixtures", "clojure.test-api.html\\#clojure.test/compose-fixtures"],
\["deftest", "clojure.test-api.html\\#clojure.test/deftest"],
\["deftest-", "clojure.test-api.html\\#clojure.test/deftest-"],
\["do-report", "clojure.test-api.html\\#clojure.test/do-report"],
\["file-position", "clojure.test-api.html\\#clojure.test/file-position"],
\["function?", "clojure.test-api.html\\#clojure.test/function?"],
\["get-possibly-unbound-var", "clojure.test-api.html\\#clojure.test/get-possibly-unbound-var"],
\["inc-report-counter", "clojure.test-api.html\\#clojure.test/inc-report-counter"],
\["is", "clojure.test-api.html\\#clojure.test/is"],
\["join-fixtures", "clojure.test-api.html\\#clojure.test/join-fixtures"],
\["report", "clojure.test-api.html\\#clojure.test/report"],
\["run-all-tests", "clojure.test-api.html\\#clojure.test/run-all-tests"],
\["run-tests", "clojure.test-api.html\\#clojure.test/run-tests"],
\["set-test", "clojure.test-api.html\\#clojure.test/set-test"],
\["successful?", "clojure.test-api.html\\#clojure.test/successful?"],
\["test-all-vars", "clojure.test-api.html\\#clojure.test/test-all-vars"],
\["test-ns", "clojure.test-api.html\\#clojure.test/test-ns"],
\["test-var", "clojure.test-api.html\\#clojure.test/test-var"],
\["testing", "clojure.test-api.html\\#clojure.test/testing"],
\["testing-contexts-str", "clojure.test-api.html\\#clojure.test/testing-contexts-str"],
\["testing-vars-str", "clojure.test-api.html\\#clojure.test/testing-vars-str"],
\["try-expr", "clojure.test-api.html\\#clojure.test/try-expr"],
\["with-test", "clojure.test-api.html\\#clojure.test/with-test"],
\["with-test-out", "clojure.test-api.html\\#clojure.test/with-test-out"],
\["clojure.test.junit", "clojure.test-api.html\\#clojure.test.junit"],
\["with-junit-output", "clojure.test-api.html\\#clojure.test.junit/with-junit-output"],
\["clojure.test.tap", "clojure.test-api.html\\#clojure.test.tap"],
\["print-tap-diagnostic", "clojure.test-api.html\\#clojure.test.tap/print-tap-diagnostic"],
\["print-tap-fail", "clojure.test-api.html\\#clojure.test.tap/print-tap-fail"],
\["print-tap-pass", "clojure.test-api.html\\#clojure.test.tap/print-tap-pass"],
\["print-tap-plan", "clojure.test-api.html\\#clojure.test.tap/print-tap-plan"],
\["with-tap-output", "clojure.test-api.html\\#clojure.test.tap/with-tap-output"],
\["keywordize-keys", "clojure.walk-api.html\\#clojure.walk/keywordize-keys"],
\["macroexpand-all", "clojure.walk-api.html\\#clojure.walk/macroexpand-all"],
\["postwalk", "clojure.walk-api.html\\#clojure.walk/postwalk"],
\["postwalk-demo", "clojure.walk-api.html\\#clojure.walk/postwalk-demo"],
\["postwalk-replace", "clojure.walk-api.html\\#clojure.walk/postwalk-replace"],
\["prewalk", "clojure.walk-api.html\\#clojure.walk/prewalk"],
\["prewalk-demo", "clojure.walk-api.html\\#clojure.walk/prewalk-demo"],
\["prewalk-replace", "clojure.walk-api.html\\#clojure.walk/prewalk-replace"],
\["stringify-keys", "clojure.walk-api.html\\#clojure.walk/stringify-keys"],
\["walk", "clojure.walk-api.html\\#clojure.walk/walk"],
\["parse", "clojure.xml-api.html\\#clojure.xml/parse"],
\["append-child", "clojure.zip-api.html\\#clojure.zip/append-child"],
\["branch?", "clojure.zip-api.html\\#clojure.zip/branch?"],
\["children", "clojure.zip-api.html\\#clojure.zip/children"],
\["down", "clojure.zip-api.html\\#clojure.zip/down"],
\["edit", "clojure.zip-api.html\\#clojure.zip/edit"],
\["end?", "clojure.zip-api.html\\#clojure.zip/end?"],
\["insert-child", "clojure.zip-api.html\\#clojure.zip/insert-child"],
\["insert-left", "clojure.zip-api.html\\#clojure.zip/insert-left"],
\["insert-right", "clojure.zip-api.html\\#clojure.zip/insert-right"],
\["left", "clojure.zip-api.html\\#clojure.zip/left"],
\["leftmost", "clojure.zip-api.html\\#clojure.zip/leftmost"],
\["lefts", "clojure.zip-api.html\\#clojure.zip/lefts"],
\["make-node", "clojure.zip-api.html\\#clojure.zip/make-node"],
\["next", "clojure.zip-api.html\\#clojure.zip/next"],
\["node", "clojure.zip-api.html\\#clojure.zip/node"],
\["path", "clojure.zip-api.html\\#clojure.zip/path"],
\["prev", "clojure.zip-api.html\\#clojure.zip/prev"],
\["remove", "clojure.zip-api.html\\#clojure.zip/remove"],
\["replace", "clojure.zip-api.html\\#clojure.zip/replace"],
\["right", "clojure.zip-api.html\\#clojure.zip/right"],
\["rightmost", "clojure.zip-api.html\\#clojure.zip/rightmost"],
\["rights", "clojure.zip-api.html\\#clojure.zip/rights"],
\["root", "clojure.zip-api.html\\#clojure.zip/root"],
\["seq-zip", "clojure.zip-api.html\\#clojure.zip/seq-zip"],
\["up", "clojure.zip-api.html\\#clojure.zip/up"],
\["vector-zip", "clojure.zip-api.html\\#clojure.zip/vector-zip"],
\["xml-zip", "clojure.zip-api.html\\#clojure.zip/xml-zip"],
\["zipper", "clojure.zip-api.html\\#clojure.zip/zipper"]]
endif

3820
sources_non_forked/slimv/ftplugin/slimv-javadoc.vim Normal file
View File

File diff suppressed because it is too large Load Diff

3805
sources_non_forked/slimv/ftplugin/slimv.vim Normal file
View File

File diff suppressed because it is too large Load Diff

1415
sources_non_forked/slimv/ftplugin/swank.py Normal file
View File

File diff suppressed because it is too large Load Diff

28
sources_non_forked/slimv/indent/clojure.vim Normal file
View File

@ -0,0 +1,28 @@
" clojure.vim:
" Clojure indent plugin for Slimv
" Version: 0.9.14
" Last Change: 22 Jan 2021
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if exists("b:did_indent") || exists("b:slimv_did_indent") || exists("g:slimv_disable_clojure") ||
\ (exists("g:slimv_indent_disable") && g:slimv_indent_disable)
finish
endif
" Prevent recursive call but allow loading other clojure plugins
let b:slimv_did_indent = 1
runtime! indent/**/clojure.vim
runtime indent/**/lisp.vim
setlocal nolisp
setlocal autoindent
setlocal expandtab
setlocal indentexpr=SlimvIndent(v:lnum)

30
sources_non_forked/slimv/indent/lisp.vim Normal file
View File

@ -0,0 +1,30 @@
" lisp.vim:
" Lisp indent plugin for Slimv
" Version: 0.9.14
" Last Change: 22 Jan 2021
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if exists("b:did_indent") || (exists("g:slimv_indent_disable") && g:slimv_indent_disable)
finish
endif
" Handle cases when lisp dialects explicitly use the lisp indent plugins
if &ft == "clojure" && exists("g:slimv_disable_clojure")
finish
endif
if &ft == "scheme" && exists("g:slimv_disable_scheme")
finish
endif
setlocal nolisp
setlocal autoindent
setlocal expandtab
setlocal indentexpr=SlimvIndent(v:lnum)

24
sources_non_forked/slimv/indent/scheme.vim Normal file
View File

@ -0,0 +1,24 @@
" scheme.vim:
" Scheme indent plugin for Slimv
" Version: 0.9.14
" Last Change: 26 Feb 2021
" Maintainer: Tamas Kovacs <kovisoft at gmail dot com>
" License: This file is placed in the public domain.
" No warranty, express or implied.
" *** *** Use At-Your-Own-Risk! *** ***
"
" =====================================================================
"
" Load Once:
if exists("b:did_indent") || exists("g:slimv_disable_scheme") ||
\ (exists("g:slimv_indent_disable") && g:slimv_indent_disable)
finish
endif
let b:did_indent = 1
setlocal nolisp
setlocal autoindent
setlocal expandtab
setlocal indentexpr=SlimvIndent(v:lnum)

1997
sources_non_forked/slimv/plugin/paredit.vim Normal file
View File

File diff suppressed because it is too large Load Diff

64
sources_non_forked/slimv/slime/README.md Normal file
View File

@ -0,0 +1,64 @@
[![Build Status](https://github.com/slime/slime/workflows/CI/badge.svg)](https://github.com/slime/slime/actions)
[![MELPA](http://melpa.org/packages/slime-badge.svg?)](http://melpa.org/#/slime) [![MELPA Stable](http://stable.melpa.org/packages/slime-badge.svg?)](http://stable.melpa.org/#/slime)
Overview
--------
SLIME is the Superior Lisp Interaction Mode for Emacs.
SLIME extends Emacs with support for interactive programming in Common
Lisp. The features are centered around slime-mode, an Emacs minor-mode that
complements the standard lisp-mode. While lisp-mode supports editing Lisp
source files, slime-mode adds support for interacting with a running Common
Lisp process for compilation, debugging, documentation lookup, and so on.
For much more information, consult [the manual][1].
Quick setup instructions
------------------------
1. [Set up the MELPA repository][2], if you haven't already, and install
SLIME using `M-x package-install RET slime RET`.
2. In your `~/.emacs` file, point the `inferior-lisp-program`
variable to your favourite Common Lisp implementation:
```el
(setq inferior-lisp-program "sbcl")
```
3. Use `M-x slime` to fire up and connect to an inferior Lisp. SLIME will
now automatically be available in your Lisp source buffers.
If you'd like to contribute to SLIME, you will want to instead follow
the manual's instructions on [how to install SLIME via Git][7].
License
-------
SLIME is free software. All files, unless explicitly stated otherwise, are
public domain.
Contact
-------
If you have problems, first have a look at the list of
[known issues and workarounds][6].
Questions and comments are best directed to the mailing list at
`slime-devel@common-lisp.net`, but you have to [subscribe][3] first.
See the [CONTRIBUTING.md][5] file for instructions on how to contribute.
[1]: http://common-lisp.net/project/slime/doc/html/
[2]: http://melpa.org/#/getting-started
[3]: http://www.common-lisp.net/project/slime/#mailinglist
[5]: https://github.com/slime/slime/blob/master/CONTRIBUTING.md
[6]: https://github.com/slime/slime/issues?labels=workaround&state=closed
[7]: http://common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git

14
sources_non_forked/slimv/slime/contrib/README.md Normal file
View File

@ -0,0 +1,14 @@
This directory contains source code which may be useful to some Slime
users. `*.el` files are Emacs Lisp source and `*.lisp` files contain
Common Lisp source code. If not otherwise stated in the file itself,
the files are placed in the Public Domain.
The components in this directory are more or less detached from the
rest of Slime. They are essentially "add-ons". But Slime can also be
used without them. The code is maintained by the respective authors.
See the top level README.md for how to use packages in this directory.
Finally, the contrib `slime-fancy` is specially noteworthy, as it
represents a meta-contrib that'll load a bunch of commonly used
contribs. Look into `slime-fancy.el` to find out which.

1619
sources_non_forked/slimv/slime/contrib/swank-arglists.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

533
sources_non_forked/slimv/slime/contrib/swank-asdf.lisp Normal file
View File

@ -0,0 +1,533 @@
;;; swank-asdf.lisp -- ASDF support
;;
;; Authors: Daniel Barlow <dan@telent.net>
;; Marco Baringer <mb@bese.it>
;; Edi Weitz <edi@agharta.de>
;; Francois-Rene Rideau <tunes@google.com>
;; and others
;; License: Public Domain
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; The best way to load ASDF is from an init file of an
;;; implementation. If ASDF is not loaded at the time swank-asdf is
;;; loaded, it will be tried first with (require "asdf"), if that
;;; doesn't help and *asdf-path* is set, it will be loaded from that
;;; file.
;;; To set *asdf-path* put the following into ~/.swank.lisp:
;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp")
(defvar *asdf-path* nil
"Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails."))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(ignore-errors (funcall 'require "asdf"))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(handler-bind ((warning #'muffle-warning))
(when *asdf-path*
(load *asdf-path* :if-does-not-exist nil)))))
;; If still not found, error out.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(error "Could not load ASDF.
Please update your implementation or
install a recent release of ASDF and in your ~~/.swank.lisp specify:
(defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")")))
;;; If ASDF is too old, punt.
;; As of January 2014, Quicklisp has been providing 2.26 for a year
;; (and previously had 2.014.6 for over a year), whereas
;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later)
;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released
;; in years and doesn't provide ASDF at all, but is fully supported by ASDF).
;; If your implementation doesn't provide ASDF, or provides an old one,
;; install an upgrade yourself and configure *asdf-path*.
;; It's just not worth the hassle supporting something
;; that doesn't even have COERCE-PATHNAME.
;;
;; NB: this version check is duplicated in swank-loader.lisp so that we don't
;; try to load this contrib when ASDF is too old since that will abort the SLIME
;; connection.
#-asdf3
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (and #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.14.6"))
(error "Your ASDF is too old. ~
The oldest version supported by swank-asdf is 2.014.6.")))
;;; Import functionality from ASDF that isn't available in all ASDF versions.
;;; Please do NOT depend on any of the below as reference:
;;; they are sometimes stripped down versions, for compatibility only.
;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF.
;;;
;;; The way I got these is usually by looking at the current definition,
;;; using git blame in one screen to locate which commit last modified it,
;;; and git log in another to determine which release that made it in.
;;; It is OK for some of the below definitions to be or become obsolete,
;;; as long as it will make do with versions older than the tagged version:
;;; if ASDF is more recent, its more recent version will win.
;;;
;;; If your software is hacking ASDF, use its internals.
;;; If you want ASDF utilities in user software, please use ASDF-UTILS.
(defun asdf-at-least (version)
(asdf:version-satisfies (asdf:asdf-version) version))
(defmacro asdefs (version &rest defs)
(flet ((defun* (version name aname rest)
`(progn
(defun ,name ,@rest)
(declaim (notinline ,name))
(when (asdf-at-least ,version)
(setf (fdefinition ',name) (fdefinition ',aname)))))
(defmethod* (version aname rest)
`(unless (asdf-at-least ,version)
(defmethod ,aname ,@rest)))
(defvar* (name aname rest)
`(progn
(define-symbol-macro ,name ,aname)
(defvar ,aname ,@rest))))
`(progn
,@(loop :for (def name . args) :in defs
:for aname = (intern (string name) :asdf)
:collect
(ecase def
((defun) (defun* version name aname args))
((defmethod) (defmethod* version aname args))
((defvar) (defvar* name aname args)))))))
(asdefs "2.15"
(defvar *wild* #-cormanlisp :wild #+cormanlisp "*")
(defun collect-asds-in-directory (directory collect)
(map () collect (directory-asd-files directory)))
(defun register-asd-directory (directory &key recurse exclude collect)
(if (not recurse)
(collect-asds-in-directory directory collect)
(collect-sub*directories-asd-files
directory :exclude exclude :collect collect))))
(asdefs "2.16"
(defun load-sysdef (name pathname)
(declare (ignore name))
(let ((package (asdf::make-temporary-package)))
(unwind-protect
(let ((*package* package)
(*default-pathname-defaults*
(asdf::pathname-directory-pathname
(translate-logical-pathname pathname))))
(asdf::asdf-message
"~&; Loading system definition from ~A into ~A~%" ;
pathname package)
(load pathname))
(delete-package package))))
(defun directory* (pathname-spec &rest keys &key &allow-other-keys)
(apply 'directory pathname-spec
(append keys
'#.(or #+allegro
'(:directories-are-files nil
:follow-symbolic-links nil)
#+clozure
'(:follow-links nil)
#+clisp
'(:circle t :if-does-not-exist :ignore)
#+(or cmu scl)
'(:follow-links nil :truenamep nil)
#+sbcl
(when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl)
'(:resolve-symlinks nil)))))))
(asdefs "2.17"
(defun collect-sub*directories-asd-files
(directory &key
(exclude asdf::*default-source-registry-exclusions*)
collect)
(asdf::collect-sub*directories
directory
(constantly t)
(lambda (x) (not (member (car (last (pathname-directory x)))
exclude :test #'equal)))
(lambda (dir) (collect-asds-in-directory dir collect))))
(defun system-source-directory (system-designator)
(asdf::pathname-directory-pathname
(asdf::system-source-file system-designator)))
(defun filter-logical-directory-results (directory entries merger)
(if (typep directory 'logical-pathname)
(loop for f in entries
when
(if (typep f 'logical-pathname)
f
(let ((u (ignore-errors (funcall merger f))))
(and u
(equal (ignore-errors (truename u))
(truename f))
u)))
collect it)
entries))
(defun directory-asd-files (directory)
(directory-files directory asdf::*wild-asd*)))
(asdefs "2.19"
(defun subdirectories (directory)
(let* ((directory (asdf::ensure-directory-pathname directory))
#-(or abcl cormanlisp xcl)
(wild (asdf::merge-pathnames*
#-(or abcl allegro cmu lispworks sbcl scl xcl)
asdf::*wild-directory*
#+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
directory))
(dirs
#-(or abcl cormanlisp xcl)
(ignore-errors
(directory* wild . #.(or #+clozure '(:directories t :files nil)
#+mcl '(:directories t))))
#+(or abcl xcl) (system:list-directory directory)
#+cormanlisp (cl::directory-subdirs directory))
#+(or abcl allegro cmu lispworks sbcl scl xcl)
(dirs (loop for x in dirs
for d = #+(or abcl xcl) (extensions:probe-directory x)
#+allegro (excl:probe-directory x)
#+(or cmu sbcl scl) (asdf::directory-pathname-p x)
#+lispworks (lw:file-directory-p x)
when d collect #+(or abcl allegro xcl) d
#+(or cmu lispworks sbcl scl) x)))
(filter-logical-directory-results
directory dirs
(let ((prefix (or (normalize-pathname-directory-component
(pathname-directory directory))
;; because allegro 8.x returns NIL for #p"FOO:"
'(:absolute))))
(lambda (d)
(let ((dir (normalize-pathname-directory-component
(pathname-directory d))))
(and (consp dir) (consp (cdr dir))
(make-pathname
:defaults directory :name nil :type nil :version nil
:directory
(append prefix
(make-pathname-component-logical
(last dir))))))))))))
(asdefs "2.21"
(defun component-loaded-p (c)
(and (gethash 'load-op (asdf::component-operation-times
(asdf::find-component c nil))) t))
(defun normalize-pathname-directory-component (directory)
(cond
#-(or cmu sbcl scl)
((stringp directory) `(:absolute ,directory) directory)
((or (null directory)
(and (consp directory)
(member (first directory) '(:absolute :relative))))
directory)
(t
(error "Unrecognized pathname directory component ~S" directory))))
(defun make-pathname-component-logical (x)
(typecase x
((eql :unspecific) nil)
#+clisp (string (string-upcase x))
#+clisp (cons (mapcar 'make-pathname-component-logical x))
(t x)))
(defun make-pathname-logical (pathname host)
(make-pathname
:host host
:directory (make-pathname-component-logical (pathname-directory pathname))
:name (make-pathname-component-logical (pathname-name pathname))
:type (make-pathname-component-logical (pathname-type pathname))
:version (make-pathname-component-logical (pathname-version pathname)))))
(asdefs "2.22"
(defun directory-files (directory &optional (pattern asdf::*wild-file*))
(let ((dir (pathname directory)))
(when (typep dir 'logical-pathname)
(when (wild-pathname-p dir)
(error "Invalid wild pattern in logical directory ~S" directory))
(unless (member (pathname-directory pattern)
'(() (:relative)) :test 'equal)
(error "Invalid file pattern ~S for logical directory ~S"
pattern directory))
(setf pattern (make-pathname-logical pattern (pathname-host dir))))
(let ((entries (ignore-errors
(directory* (asdf::merge-pathnames* pattern dir)))))
(filter-logical-directory-results
directory entries
(lambda (f)
(make-pathname :defaults dir
:name (make-pathname-component-logical
(pathname-name f))
:type (make-pathname-component-logical
(pathname-type f))
:version (make-pathname-component-logical
(pathname-version f)))))))))
(asdefs "2.26.149"
(defmethod component-relative-pathname ((system asdf:system))
(asdf::coerce-pathname
(and (slot-boundp system 'asdf::relative-pathname)
(slot-value system 'asdf::relative-pathname))
:type :directory
:defaults (system-source-directory system)))
(defun load-asd (pathname &key name &allow-other-keys)
(asdf::load-sysdef (or name (string-downcase (pathname-name pathname)))
pathname)))
;;; Taken from ASDF 1.628
(defmacro while-collecting ((&rest collectors) &body body)
`(asdf::while-collecting ,collectors ,@body))
;;; Now for SLIME-specific stuff
(defun asdf-operation (operation)
(or (asdf::find-symbol* operation :asdf)
(error "Couldn't find ASDF operation ~S" operation)))
(defun map-system-components (fn system)
(map-component-subcomponents fn (asdf:find-system system)))
(defun map-component-subcomponents (fn component)
(when component
(funcall fn component)
(when (typep component 'asdf:module)
(dolist (c (asdf:module-components component))
(map-component-subcomponents fn c)))))
;;; Maintaining a pathname to component table
(defvar *pathname-component* (make-hash-table :test 'equal))
(defun clear-pathname-component-table ()
(clrhash *pathname-component*))
(defun register-system-pathnames (system)
(map-system-components 'register-component-pathname system))
(defun recompute-pathname-component-table ()
(clear-pathname-component-table)
(asdf::map-systems 'register-system-pathnames))
(defun pathname-component (x)
(gethash (pathname x) *pathname-component*))
(defmethod asdf:component-pathname :around ((component asdf:component))
(let ((p (call-next-method)))
(when (pathnamep p)
(setf (gethash p *pathname-component*) component))
p))
(defun register-component-pathname (component)
(asdf:component-pathname component))
(recompute-pathname-component-table)
;;; This is a crude hack, see ASDF's LP #481187.
(defslimefun who-depends-on (system)
(flet ((system-dependencies (op system)
(mapcar (lambda (dep)
(asdf::coerce-name (if (consp dep) (second dep) dep)))
(cdr (assoc op (asdf:component-depends-on op system))))))
(let ((system-name (asdf::coerce-name system))
(result))
(asdf::map-systems
(lambda (system)
(when (member system-name
(system-dependencies 'asdf:load-op system)
:test #'string=)
(push (asdf:component-name system) result))))
result)))
(defmethod xref-doit ((type (eql :depends-on)) thing)
(when (typep thing '(or string symbol))
(loop for dependency in (who-depends-on thing)
for asd-file = (asdf:system-definition-pathname dependency)
when asd-file
collect (list dependency
(swank/backend:make-location
`(:file ,(namestring asd-file))
`(:position 1)
`(:snippet ,(format nil "(defsystem :~A" dependency)
:align t))))))
(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
"Compile and load SYSTEM using ASDF.
Record compiler notes signalled as `compiler-condition's."
(collect-notes
(lambda ()
(apply #'operate-on-system system-name operation keywords))))
(defun operate-on-system (system-name operation-name &rest keyword-args)
"Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
The KEYWORD-ARGS are passed on to the operation.
Example:
\(operate-on-system \"cl-ppcre\" 'compile-op :force t)"
(handler-case
(with-compilation-hooks ()
(apply #'asdf:operate (asdf-operation operation-name)
system-name keyword-args)
t)
((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error)
() nil)))
(defun unique-string-list (&rest lists)
(sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<))
(defslimefun list-all-systems-in-central-registry ()
"Returns a list of all systems in ASDF's central registry
AND in its source-registry. (legacy name)"
(unique-string-list
(mapcar
#'pathname-name
(while-collecting (c)
(loop for dir in asdf:*central-registry*
for defaults = (eval dir)
when defaults
do (collect-asds-in-directory defaults #'c))
(asdf:ensure-source-registry)
(if (or #+asdf3 t
#-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15"))
(loop :for k :being :the :hash-keys :of asdf::*source-registry*
:do (c k))
#-asdf3
(dolist (entry (asdf::flatten-source-registry))
(destructuring-bind (directory &key recurse exclude) entry
(register-asd-directory
directory
:recurse recurse :exclude exclude :collect #'c))))))))
(defslimefun list-all-systems-known-to-asdf ()
"Returns a list of all systems ASDF knows already."
(while-collecting (c)
(asdf::map-systems (lambda (system) (c (asdf:component-name system))))))
(defslimefun list-asdf-systems ()
"Returns the systems in ASDF's central registry and those which ASDF
already knows."
(unique-string-list
(list-all-systems-known-to-asdf)
(list-all-systems-in-central-registry)))
(defun asdf-component-source-files (component)
(while-collecting (c)
(labels ((f (x)
(typecase x
(asdf:source-file (c (asdf:component-pathname x)))
(asdf:module (map () #'f (asdf:module-components x))))))
(f component))))
(defun make-operation (x)
#+#.(swank/backend:with-symbol 'make-operation 'asdf)
(asdf:make-operation x)
#-#.(swank/backend:with-symbol 'make-operation 'asdf)
(make-instance x))
(defun asdf-component-output-files (component)
(while-collecting (c)
(labels ((f (x)
(typecase x
(asdf:source-file
(map () #'c
(asdf:output-files (make-operation 'asdf:compile-op) x)))
(asdf:module (map () #'f (asdf:module-components x))))))
(f component))))
(defslimefun asdf-system-files (name)
(let* ((system (asdf:find-system name))
(files (mapcar #'namestring
(cons
(asdf:system-definition-pathname system)
(asdf-component-source-files system))))
(main-file (find name files
:test #'equalp :key #'pathname-name :start 1)))
(if main-file
(cons main-file (remove main-file files
:test #'equal :count 1))
files)))
(defslimefun asdf-system-loaded-p (name)
(component-loaded-p name))
(defslimefun asdf-system-directory (name)
(namestring (translate-logical-pathname (asdf:system-source-directory name))))
(defun pathname-system (pathname)
(let ((component (pathname-component pathname)))
(when component
(asdf:component-name (asdf:component-system component)))))
(defslimefun asdf-determine-system (file buffer-package-name)
(or
(and file
(pathname-system file))
(and file
(progn
;; If not found, let's rebuild the table first
(recompute-pathname-component-table)
(pathname-system file)))
;; If we couldn't find an already defined system,
;; try finding a system that's named like BUFFER-PACKAGE-NAME.
(loop with package = (guess-buffer-package buffer-package-name)
for name in (package-names package)
for system = (asdf:find-system (asdf::coerce-name name) nil)
when (and system
(or (not file)
(pathname-system file)))
return (asdf:component-name system))))
(defslimefun delete-system-fasls (name)
(let ((removed-count
(loop for file in (asdf-component-output-files
(asdf:find-system name))
when (probe-file file)
count it
and
do (delete-file file))))
(format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count)))
(defvar *recompile-system* nil)
(defmethod asdf:operation-done-p :around
((operation asdf:compile-op)
component)
(unless (eql *recompile-system*
(asdf:component-system component))
(call-next-method)))
(defslimefun reload-system (name)
(let ((*recompile-system* (asdf:find-system name)))
(operate-on-system-for-emacs name 'asdf:load-op)))
;;; Hook for compile-file-for-emacs
(defun try-compile-file-with-asdf (pathname load-p &rest options)
(declare (ignore options))
(let ((component (pathname-component pathname)))
(when component
;;(format t "~&Compiling ASDF component ~S~%" component)
(let ((op (make-operation 'asdf:compile-op)))
(with-compilation-hooks ()
(asdf:perform op component))
(when load-p
(asdf:perform (make-operation 'asdf:load-op) component))
(values t t nil (first (asdf:output-files op component)))))))
(defun try-compile-asd-file (pathname load-p &rest options)
(declare (ignore load-p options))
(when (equalp (pathname-type pathname) "asd")
(load-asd pathname)
(values t t nil pathname)))
(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*)
;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*)
(provide :swank-asdf)

39
sources_non_forked/slimv/slime/contrib/swank-buffer-streams.lisp Normal file
View File

@ -0,0 +1,39 @@
;;; swank-buffer-streams.lisp --- Streams that output to a buffer
;;;
;;; Authors: Ed Langley <el-github@elangley.org>
;;;
;;; License: This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
(in-package :swank)
(defpackage :swank-buffer-streams
(:use :cl)
(:import-from :swank
defslimefun
add-hook
encode-message
send-event
find-thread
dcase
current-socket-io
send-to-emacs
current-thread-id
wait-for-event
*emacs-connection*
*event-hook*)
(:export make-buffer-output-stream))
(in-package :swank-buffer-streams)
(defun get-temporary-identifier ()
(intern (symbol-name (gensym "BUFFER"))
:keyword))
(defun make-buffer-output-stream (&optional (target-identifier (get-temporary-identifier)))
(swank:ed-rpc '#:slime-make-buffer-stream-target (current-thread-id) target-identifier)
(values (swank:make-output-stream-for-target *emacs-connection* target-identifier)
target-identifier))
(provide :swank-buffer-streams)

298
sources_non_forked/slimv/slime/contrib/swank-c-p-c.lisp Normal file
View File

@ -0,0 +1,298 @@
;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion
;;
;; Author: Luke Gorrie <luke@synap.se>
;; Edi Weitz <edi@agharta.de>
;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;; Tobias C. Rittweiler <tcr@freebits.de>
;; and others
;;
;; License: Public Domain
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-util))
(defslimefun completions (string default-package-name)
"Return a list of completions for a symbol designator STRING.
The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
COMPLETION-SET is the list of all matching completions, and
COMPLETED-PREFIX is the best (partial) completion of the input
string.
Simple compound matching is supported on a per-hyphen basis:
(completions \"m-v-\" \"COMMON-LISP\")
==> ((\"multiple-value-bind\" \"multiple-value-call\"
\"multiple-value-list\" \"multiple-value-prog1\"
\"multiple-value-setq\" \"multiple-values-limit\")
\"multiple-value\")
\(For more advanced compound matching, see FUZZY-COMPLETIONS.)
If STRING is package qualified the result list will also be
qualified. If string is non-qualified the result strings are
also not qualified and are considered relative to
DEFAULT-PACKAGE-NAME.
The way symbols are matched depends on the symbol designator's
format. The cases are as follows:
FOO - Symbols with matching prefix and accessible in the buffer package.
PKG:FOO - Symbols with matching prefix and external in package PKG.
PKG::FOO - Symbols with matching prefix and accessible in package PKG.
"
(multiple-value-bind (name package-name package internal-p)
(parse-completion-arguments string default-package-name)
(let* ((symbol-set (symbol-completion-set
name package-name package internal-p
(make-compound-prefix-matcher #\-)))
(package-set (package-completion-set
name package-name package internal-p
(make-compound-prefix-matcher '(#\. #\-))))
(completion-set
(format-completion-set (nconc symbol-set package-set)
internal-p package-name)))
(when completion-set
(list completion-set (longest-compound-prefix completion-set))))))
;;;;; Find completion set
(defun symbol-completion-set (name package-name package internal-p matchp)
"Return the set of completion-candidates as strings."
(mapcar (completion-output-symbol-converter name)
(and package
(mapcar #'symbol-name
(find-matching-symbols name
package
(and (not internal-p)
package-name)
matchp)))))
(defun package-completion-set (name package-name package internal-p matchp)
(declare (ignore package internal-p))
(mapcar (completion-output-package-converter name)
(and (not package-name)
(find-matching-packages name matchp))))
(defun find-matching-symbols (string package external test)
"Return a list of symbols in PACKAGE matching STRING.
TEST is called with two strings. If EXTERNAL is true, only external
symbols are returned."
(let ((completions '())
(converter (completion-output-symbol-converter string)))
(flet ((symbol-matches-p (symbol)
(and (or (not external)
(symbol-external-p symbol package))
(funcall test string
(funcall converter (symbol-name symbol))))))
(do-symbols* (symbol package)
(when (symbol-matches-p symbol)
(push symbol completions))))
completions))
(defun find-matching-symbols-in-list (string list test)
"Return a list of symbols in LIST matching STRING.
TEST is called with two strings."
(let ((completions '())
(converter (completion-output-symbol-converter string)))
(flet ((symbol-matches-p (symbol)
(funcall test string
(funcall converter (symbol-name symbol)))))
(dolist (symbol list)
(when (symbol-matches-p symbol)
(push symbol completions))))
(remove-duplicates completions)))
(defun find-matching-packages (name matcher)
"Return a list of package names matching NAME with MATCHER.
MATCHER is a two-argument predicate."
(let ((converter (completion-output-package-converter name)))
(remove-if-not (lambda (x)
(funcall matcher name (funcall converter x)))
(mapcar (lambda (pkgname)
(concatenate 'string pkgname ":"))
(loop for package in (list-all-packages)
nconcing (package-names package))))))
;; PARSE-COMPLETION-ARGUMENTS return table:
;;
;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
;; ----------------+--------+--------------+-----------------------------------
;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME">
;; | | | or *BUFFER-PACKAGE*
;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF">
;; | | |
;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF">
;; | | |
;; as:fo [tab] | "fo" | "as" | NIL
;; | | |
;; : [tab] | "" | "" | #<PACKAGE "KEYWORD">
;; | | |
;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD">
;;
(defun parse-completion-arguments (string default-package-name)
"Parse STRING as a symbol designator.
Return these values:
SYMBOL-NAME
PACKAGE-NAME, or nil if the designator does not include an explicit package.
PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
if PACKAGE is non-NIL but a package cannot be found under that name,
return NIL.)
INTERNAL-P, if the symbol is qualified with `::'."
(multiple-value-bind (name package-name internal-p)
(tokenize-symbol string)
(flet ((default-package ()
(or (guess-package default-package-name) *buffer-package*)))
(let ((package (cond
((not package-name)
(default-package))
((equal package-name "")
(guess-package (symbol-name :keyword)))
((find-locally-nicknamed-package
package-name (default-package)))
(t
(guess-package package-name)))))
(values name package-name package internal-p)))))
(defun completion-output-case-converter (input &optional with-escaping-p)
"Return a function to convert strings for the completion output.
INPUT is used to guess the preferred case."
(ecase (readtable-case *readtable*)
(:upcase (cond ((or with-escaping-p
(and (plusp (length input))
(not (some #'lower-case-p input))))
#'identity)
(t #'string-downcase)))
(:invert (lambda (output)
(multiple-value-bind (lower upper) (determine-case output)
(cond ((and lower upper) output)
(lower (string-upcase output))
(upper (string-downcase output))
(t output)))))
(:downcase (cond ((or with-escaping-p
(and (zerop (length input))
(not (some #'upper-case-p input))))
#'identity)
(t #'string-upcase)))
(:preserve #'identity)))
(defun completion-output-package-converter (input)
"Return a function to convert strings for the completion output.
INPUT is used to guess the preferred case."
(completion-output-case-converter input))
(defun completion-output-symbol-converter (input)
"Return a function to convert strings for the completion output.
INPUT is used to guess the preferred case. Escape symbols when needed."
(let ((case-converter (completion-output-case-converter input))
(case-converter-with-escaping (completion-output-case-converter input t)))
(lambda (str)
(if (or (multiple-value-bind (lowercase uppercase)
(determine-case str)
;; In these readtable cases, symbols with letters from
;; the wrong case need escaping
(case (readtable-case *readtable*)
(:upcase lowercase)
(:downcase uppercase)
(t nil)))
(some (lambda (el)
(or (member el '(#\: #\Space #\Newline #\Tab))
(multiple-value-bind (macrofun nonterminating)
(get-macro-character el)
(and macrofun
(not nonterminating)))))
str))
(concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
(funcall case-converter str)))))
(defun determine-case (string)
"Return two booleans LOWER and UPPER indicating whether STRING
contains lower or upper case characters."
(values (some #'lower-case-p string)
(some #'upper-case-p string)))
;;;;; Compound-prefix matching
(defun make-compound-prefix-matcher (delimiter &key (test #'char=))
"Returns a matching function that takes a `prefix' and a
`target' string and which returns T if `prefix' is a
compound-prefix of `target', and otherwise NIL.
Viewing each of `prefix' and `target' as a series of substrings
delimited by DELIMITER, if each substring of `prefix' is a prefix
of the corresponding substring in `target' then we call `prefix'
a compound-prefix of `target'.
DELIMITER may be a character, or a list of characters."
(let ((delimiters (etypecase delimiter
(character (list delimiter))
(cons (assert (every #'characterp delimiter))
delimiter))))
(lambda (prefix target)
(declare (type simple-string prefix target))
(loop with tpos = 0
for ch across prefix
always (and (< tpos (length target))
(let ((delimiter (car (member ch delimiters :test test))))
(if delimiter
(setf tpos (position delimiter target :start tpos))
(funcall test ch (aref target tpos)))))
do (incf tpos)))))
;;;;; Extending the input string by completion
(defun longest-compound-prefix (completions &optional (delimiter #\-))
"Return the longest compound _prefix_ for all COMPLETIONS."
(flet ((tokenizer (string) (tokenize-completion string delimiter)))
(untokenize-completion
(loop for token-list in (transpose-lists (mapcar #'tokenizer completions))
if (notevery #'string= token-list (rest token-list))
;; Note that we possibly collect the "" here as well, so that
;; UNTOKENIZE-COMPLETION will append a delimiter for us.
collect (longest-common-prefix token-list)
and do (loop-finish)
else collect (first token-list))
delimiter)))
(defun tokenize-completion (string delimiter)
"Return all substrings of STRING delimited by DELIMITER."
(loop with end
for start = 0 then (1+ end)
until (> start (length string))
do (setq end (or (position delimiter string :start start) (length string)))
collect (subseq string start end)))
(defun untokenize-completion (tokens &optional (delimiter #\-))
(format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens))
(defun transpose-lists (lists)
"Turn a list-of-lists on its side.
If the rows are of unequal length, truncate uniformly to the shortest.
For example:
\(transpose-lists '((ONE TWO THREE) (1 2)))
=> ((ONE 1) (TWO 2))"
(cond ((null lists) '())
((some #'null lists) '())
(t (cons (mapcar #'car lists)
(transpose-lists (mapcar #'cdr lists))))))
;;;; Completion for character names
(defslimefun completions-for-character (prefix)
(let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal))
(completion-set (character-completion-set prefix matcher))
(completions (sort completion-set #'string<)))
(list completions (longest-compound-prefix completions #\_))))
(provide :swank-c-p-c)

71
sources_non_forked/slimv/slime/contrib/swank-clipboard.lisp Normal file
View File

@ -0,0 +1,71 @@
;;; swank-clipboard.lisp --- Object clipboard
;;
;; Written by Helmut Eller in 2008.
;; License: Public Domain
(defpackage :swank-clipboard
(:use :cl)
(:import-from :swank :defslimefun :with-buffer-syntax :dcase)
(:export :add :delete-entry :entries :entry-to-ref :ref))
(in-package :swank-clipboard)
(defstruct clipboard entries (counter 0))
(defvar *clipboard* (make-clipboard))
(defslimefun add (datum)
(let ((value (dcase datum
((:string string package)
(with-buffer-syntax (package)
(eval (read-from-string string))))
((:inspector part)
(swank:inspector-nth-part part))
((:sldb frame var)
(swank/backend:frame-var-value frame var)))))
(clipboard-add value)
(format nil "Added: ~a"
(entry-to-string (1- (length (clipboard-entries *clipboard*)))))))
(defslimefun entries ()
(loop for (ref . value) in (clipboard-entries *clipboard*)
collect `(,ref . ,(to-line value))))
(defslimefun delete-entry (entry)
(let ((msg (format nil "Deleted: ~a" (entry-to-string entry))))
(clipboard-delete-entry entry)
msg))
(defslimefun entry-to-ref (entry)
(destructuring-bind (ref . value) (clipboard-entry entry)
(list ref (to-line value 5))))
(defun clipboard-add (value)
(setf (clipboard-entries *clipboard*)
(append (clipboard-entries *clipboard*)
(list (cons (incf (clipboard-counter *clipboard*))
value)))))
(defun clipboard-ref (ref)
(let ((tail (member ref (clipboard-entries *clipboard*) :key #'car)))
(cond (tail (cdr (car tail)))
(t (error "Invalid clipboard ref: ~s" ref)))))
(defun clipboard-entry (entry)
(elt (clipboard-entries *clipboard*) entry))
(defun clipboard-delete-entry (index)
(let* ((list (clipboard-entries *clipboard*))
(tail (nthcdr index list)))
(setf (clipboard-entries *clipboard*)
(append (ldiff list tail) (cdr tail)))))
(defun entry-to-string (entry)
(destructuring-bind (ref . value) (clipboard-entry entry)
(format nil "#@~d(~a)" ref (to-line value))))
(defun to-line (object &optional (width 75))
(with-output-to-string (*standard-output*)
(write object :right-margin width :lines 1)))
(provide :swank-clipboard)

1006
sources_non_forked/slimv/slime/contrib/swank-fancy-inspector.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

706
sources_non_forked/slimv/slime/contrib/swank-fuzzy.lisp Normal file
View File

@ -0,0 +1,706 @@
;;; swank-fuzzy.lisp --- fuzzy symbol completion
;;
;; Authors: Brian Downing <bdowning@lavos.net>
;; Tobias C. Rittweiler <tcr@freebits.de>
;; and others
;;
;; License: Public Domain
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-util)
(swank-require :swank-c-p-c))
(defvar *fuzzy-duplicate-symbol-filter* :nearest-package
"Specifies how fuzzy-matching handles \"duplicate\" symbols.
Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom
function. See Fuzzy Completion in the manual for details.")
(export '*fuzzy-duplicate-symbol-filter*)
;;; For nomenclature of the fuzzy completion section, please read
;;; through the following docstring.
(defslimefun fuzzy-completions (string default-package-name
&key limit time-limit-in-msec)
"Returns a list of two values:
An (optionally limited to LIMIT best results) list of fuzzy
completions for a symbol designator STRING. The list will be
sorted by score, most likely match first.
A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
been exhausted during computation. If that parameter's value is
NIL or 0, no time limit is assumed.
The main result is a list of completion objects, where a completion
object is:
(COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING)
where a CHUNK is a description of a matched substring:
(OFFSET SUBSTRING)
and FLAGS is short string describing properties of the symbol (see
SYMBOL-CLASSIFICATION-STRING).
E.g., completing \"mvb\" in a package that uses COMMON-LISP would
return something like:
((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
(:FBOUNDP :MACRO))
...)
If STRING is package qualified the result list will also be
qualified. If string is non-qualified the result strings are
also not qualified and are considered relative to
DEFAULT-PACKAGE-NAME.
Which symbols are candidates for matching depends on the symbol
designator's format. The cases are as follows:
FOO - Symbols accessible in the buffer package.
PKG:FOO - Symbols external in package PKG.
PKG::FOO - Symbols accessible in package PKG."
;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
;; to denote an infinite time limit. Internally, we only use NIL for
;; that purpose, to be able to distinguish between "no time limit
;; alltogether" and "current time limit already exhausted." So we've
;; got to canonicalize its value at first:
(let* ((no-time-limit-p (or (not time-limit-in-msec)
(zerop time-limit-in-msec)))
(time-limit (if no-time-limit-p nil time-limit-in-msec)))
(multiple-value-bind (completion-set interrupted-p)
(fuzzy-completion-set string default-package-name :limit limit
:time-limit-in-msec time-limit)
;; We may send this as elisp [] arrays to spare a coerce here,
;; but then the network serialization were slower by handling arrays.
;; Instead we limit the number of completions that is transferred
;; (the limit is set from Emacs.)
(list (coerce completion-set 'list) interrupted-p))))
;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
;;; object that will be sent back to Emacs, as described above.
(defstruct (fuzzy-matching (:conc-name fuzzy-matching.)
(:predicate fuzzy-matching-p)
(:constructor make-fuzzy-matching
(symbol package-name score package-chunks
symbol-chunks &key (symbol-p t))))
symbol ; The symbol that has been found to match.
symbol-p ; To deffirentiate between completeing
; package: and package:nil
package-name ; The name of the package where SYMBOL was found in.
; (This is not necessarily the same as the home-package
; of SYMBOL, because the SYMBOL can be internal to
; lots of packages; also think of package nicknames.)
score ; The higher the better SYMBOL is a match.
package-chunks ; Chunks pertaining to the package identifier of SYMBOL.
symbol-chunks) ; Chunks pertaining to SYMBOL's name.
(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string)
(multiple-value-bind (_ user-package-name __ input-internal-p)
(parse-completion-arguments user-input-string nil)
(declare (ignore _ __))
(with-struct (fuzzy-matching. score symbol package-name package-chunks
symbol-chunks symbol-p)
fuzzy-matching
(let (symbol-name real-package-name internal-p)
(cond (symbol-p ; symbol fuzzy matching?
(setf symbol-name (symbol-name symbol))
(setf internal-p input-internal-p)
(setf real-package-name (cond ((keywordp symbol) "")
((not user-package-name) nil)
(t package-name))))
(t ; package fuzzy matching?
(setf symbol-name "")
(setf real-package-name package-name)
;; If no explicit package name was given by the user
;; (e.g. input was "asdf"), we want to append only
;; one colon ":" to the package names.
(setf internal-p (if user-package-name input-internal-p nil))))
(values symbol-name
real-package-name
(if user-package-name internal-p nil)
(completion-output-symbol-converter user-input-string)
(completion-output-package-converter user-input-string))))))
(defun fuzzy-format-matching (fuzzy-matching user-input-string)
"Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING."
(multiple-value-bind (symbol-name package-name internal-p
symbol-converter package-converter)
(%fuzzy-extract-matching-info fuzzy-matching user-input-string)
(setq symbol-name (and symbol-name
(funcall symbol-converter symbol-name)))
(setq package-name (and package-name
(funcall package-converter package-name)))
(let ((result (untokenize-symbol package-name internal-p symbol-name)))
;; We return the length of the possibly added prefix as second value.
(values result (search symbol-name result)))))
(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string)
"Converts a result from the fuzzy completion core into something
that emacs is expecting. Converts symbols to strings, fixes case
issues, and adds information (as a string) describing if the symbol is
bound, fbound, a class, a macro, a generic-function, a
special-operator, or a package."
(with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks
symbol-p)
fuzzy-matching
(multiple-value-bind (name added-length)
(fuzzy-format-matching fuzzy-matching user-input-string)
(list name
(format nil "~,2f" score)
(append package-chunks
(mapcar (lambda (chunk)
;; Fix up chunk positions to account for possible
;; added package identifier.
(let ((offset (first chunk))
(string (second chunk)))
(list (+ added-length offset) string)))
symbol-chunks))
(if symbol-p
(symbol-classification-string symbol)
"-------p")))))
(defun fuzzy-completion-set (string default-package-name
&key limit time-limit-in-msec)
"Returns two values: an array of completion objects, sorted by
their score, that is how well they are a match for STRING
according to the fuzzy completion algorithm. If LIMIT is set,
only the top LIMIT results will be returned. Additionally, a flag
is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
exhausted."
(check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
(check-type time-limit-in-msec
(or null (integer 0 #.(1- most-positive-fixnum))))
(multiple-value-bind (matchings interrupted-p)
(fuzzy-generate-matchings string default-package-name time-limit-in-msec)
(when (and limit
(> limit 0)
(< limit (length matchings)))
(if (array-has-fill-pointer-p matchings)
(setf (fill-pointer matchings) limit)
(setf matchings (make-array limit :displaced-to matchings))))
(map-into matchings #'(lambda (m)
(fuzzy-convert-matching-for-emacs m string))
matchings)
(values matchings interrupted-p)))
(defun fuzzy-generate-matchings (string default-package-name
time-limit-in-msec)
"Does all the hard work for FUZZY-COMPLETION-SET. If
TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
(multiple-value-bind (parsed-symbol-name parsed-package-name
package internal-p)
(parse-completion-arguments string default-package-name)
(flet ((fix-up (matchings parent-package-matching)
;; The components of each matching in MATCHINGS have been computed
;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
(let* ((p parent-package-matching)
(p.name (fuzzy-matching.package-name p))
(p.score (fuzzy-matching.score p))
(p.chunks (fuzzy-matching.package-chunks p)))
(map-into
matchings
(lambda (m)
(let ((m.score (fuzzy-matching.score m)))
(setf (fuzzy-matching.package-name m) p.name)
(setf (fuzzy-matching.package-chunks m) p.chunks)
(setf (fuzzy-matching.score m)
(if (equal parsed-symbol-name "")
;; Make package matchings be sorted before all
;; the relative symbol matchings while preserving
;; over all orderness.
(/ p.score 100)
(+ p.score m.score)))
m))
matchings)))
(find-symbols (designator package time-limit &optional filter)
(fuzzy-find-matching-symbols designator package
:time-limit-in-msec time-limit
:external-only (not internal-p)
:filter (or filter #'identity)))
(find-packages (designator time-limit)
(fuzzy-find-matching-packages designator
:time-limit-in-msec time-limit))
(maybe-find-local-package (name)
(or (find-locally-nicknamed-package name *buffer-package*)
(find-package name))))
(let ((time-limit time-limit-in-msec) (symbols) (packages) (results)
(dedup-table (make-hash-table :test #'equal)))
(cond ((not parsed-package-name) ; E.g. STRING = "asd"
;; We don't know if user is searching for a package or a symbol
;; within his current package. So we try to find either.
(setf (values packages time-limit)
(find-packages parsed-symbol-name time-limit))
(setf (values symbols time-limit)
(find-symbols parsed-symbol-name package time-limit)))
((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
(setf (values symbols time-limit)
(find-symbols parsed-symbol-name package time-limit)))
(t ; E.g. STRING = "asd:" or "asd:foo"
;; Find fuzzy matchings of the denoted package identifier part.
;; After that, find matchings for the denoted symbol identifier
;; relative to all the packages found.
(multiple-value-bind (symbol-packages rest-time-limit)
(find-packages parsed-package-name time-limit-in-msec)
;; We want to traverse the found packages in the order of
;; their score, since those with higher score presumably
;; represent better choices. (This is important because some
;; packages may never be looked at if time limit exhausts
;; during traversal.)
(setf symbol-packages
(sort symbol-packages #'fuzzy-matching-greaterp))
(loop
for package-matching across symbol-packages
for package = (maybe-find-local-package
(fuzzy-matching.package-name
package-matching))
while (or (not time-limit) (> rest-time-limit 0)) do
(multiple-value-bind (matchings remaining-time)
;; The duplication filter removes all those symbols
;; which are present in more than one package
;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER*
(find-symbols parsed-symbol-name package rest-time-limit
(%make-duplicate-symbols-filter
package-matching symbol-packages dedup-table))
(setf matchings (fix-up matchings package-matching))
(setf symbols (concatenate 'vector symbols matchings))
(setf rest-time-limit remaining-time)
(let ((guessed-sort-duration
(%guess-sort-duration (length symbols))))
(when (and rest-time-limit
(<= rest-time-limit guessed-sort-duration))
(decf rest-time-limit guessed-sort-duration)
(loop-finish))))
finally
(setf time-limit rest-time-limit)
(when (equal parsed-symbol-name "") ; E.g. STRING = "asd:"
(setf packages symbol-packages))))))
;; Sort by score; thing with equal score, sort alphabetically.
;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all
;; possible completions are to be returned.)
(setf results (concatenate 'vector symbols packages))
(setf results (sort results #'fuzzy-matching-greaterp))
(values results (and time-limit (<= time-limit 0)))))))
(defun %guess-sort-duration (length)
;; These numbers are pretty much arbitrary, except that they're
;; vaguely correct on my machine with SBCL. Yes, this is an ugly
;; kludge, but it's better than before (where this didn't exist at
;; all, which essentially meant, that this was taken to be 0.)
(if (zerop length)
0
(let ((comparasions (* 3.8 (* length (log length 2)))))
(* 1000 (* comparasions (expt 10 -7)))))) ; msecs
(defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table)
;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*.
(case *fuzzy-duplicate-symbol-filter*
(:home-package
;; Return a filter function that takes a symbol, and which returns T
;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents
;; the home-package of the symbol passed.
(let ((packages (mapcar #'(lambda (m)
(find-package (fuzzy-matching.package-name m)))
(remove current-package-matching
(coerce fuzzy-package-matchings 'list)))))
#'(lambda (symbol)
(not (member (symbol-package symbol) packages)))))
(:nearest-package
;; Keep only the first occurence of the symbol.
#'(lambda (symbol)
(unless (gethash (symbol-name symbol) dedup-table)
(setf (gethash (symbol-name symbol) dedup-table) t))))
(:all
;; No filter
#'identity)
(t
(typecase *fuzzy-duplicate-symbol-filter*
(function
;; Custom filter
(funcall *fuzzy-duplicate-symbol-filter*
(fuzzy-matching.package-name current-package-matching)
(map 'list #'fuzzy-matching.package-name fuzzy-package-matchings)
dedup-table))
(t
;; Bad filter value
(warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s"
*fuzzy-duplicate-symbol-filter*)
#'identity)))))
(defun fuzzy-matching-greaterp (m1 m2)
"Returns T if fuzzy-matching M1 should be sorted before M2.
Basically just the scores of the two matchings are compared, and
the match with higher score wins. For the case that the score is
equal, the one which comes alphabetically first wins."
(declare (type fuzzy-matching m1 m2))
(let ((score1 (fuzzy-matching.score m1))
(score2 (fuzzy-matching.score m2)))
(cond ((> score1 score2) t)
((< score1 score2) nil) ; total order
(t
(let ((name1 (symbol-name (fuzzy-matching.symbol m1)))
(name2 (symbol-name (fuzzy-matching.symbol m2))))
(string< name1 name2))))))
(declaim (ftype (function () (integer 0)) get-real-time-msecs))
(defun get-real-time-in-msecs ()
(let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
(values (floor (get-internal-real-time) units-per-msec))))
(defun fuzzy-find-matching-symbols
(string package &key (filter #'identity) external-only time-limit-in-msec)
"Returns two values: a vector of fuzzy matchings for matching
symbols in PACKAGE, using the fuzzy completion algorithm, and the
remaining time limit.
Only those symbols are considered of which FILTER does return T.
If EXTERNAL-ONLY is true, only external symbols are considered. A
TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
negative, perform a NOP."
(let ((time-limit-p (and time-limit-in-msec t))
(time-limit (or time-limit-in-msec 0))
(rtime-at-start (get-real-time-in-msecs))
(package-name (package-name package))
(count 0))
(declare (type boolean time-limit-p))
(declare (type integer time-limit rtime-at-start))
(declare (type (integer 0 #.(1- most-positive-fixnum)) count))
(flet ((recompute-remaining-time (old-remaining-time)
(cond ((not time-limit-p)
;; propagate NIL back as infinite time limit
(values nil nil))
((> count 0) ; ease up on getting internal time like crazy
(setf count (mod (1+ count) 128))
(values nil old-remaining-time))
(t (let* ((elapsed-time (- (get-real-time-in-msecs)
rtime-at-start))
(remaining (- time-limit elapsed-time)))
(values (<= remaining 0) remaining)))))
(perform-fuzzy-match (string symbol-name)
(let* ((converter (completion-output-symbol-converter string))
(converted-symbol-name (funcall converter symbol-name)))
(compute-highest-scoring-completion string
converted-symbol-name))))
(let ((completions (make-array 256 :adjustable t :fill-pointer 0))
(rest-time-limit time-limit))
(do-symbols* (symbol package)
(multiple-value-bind (exhausted? remaining-time)
(recompute-remaining-time rest-time-limit)
(setf rest-time-limit remaining-time)
(cond (exhausted? (return))
((not (and (or (not external-only)
(symbol-external-p symbol package))
(funcall filter symbol))))
((string= "" string) ; "" matches always
(vector-push-extend
(make-fuzzy-matching symbol package-name
0.0 '() '())
completions))
(t
(multiple-value-bind (match-result score)
(perform-fuzzy-match string (symbol-name symbol))
(when match-result
(vector-push-extend
(make-fuzzy-matching symbol package-name score
'() match-result)
completions)))))))
(values completions rest-time-limit)))))
(defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
"Returns a vector of fuzzy matchings for each package that is
similiar to NAME, and the remaining time limit.
Cf. FUZZY-FIND-MATCHING-SYMBOLS."
(let ((time-limit-p (and time-limit-in-msec t))
(time-limit (or time-limit-in-msec 0))
(rtime-at-start (get-real-time-in-msecs))
(converter (completion-output-package-converter name))
(completions (make-array 32 :adjustable t :fill-pointer 0)))
(declare (type boolean time-limit-p))
(declare (type integer time-limit rtime-at-start))
(declare (type function converter))
(flet ((match-package (names)
(loop with max-pkg-name = ""
with max-result = nil
with max-score = 0
for package-name in names
for converted-name = (funcall converter package-name)
do
(multiple-value-bind (result score)
(compute-highest-scoring-completion name
converted-name)
(when (and result (> score max-score))
(setf max-pkg-name package-name)
(setf max-result result)
(setf max-score score)))
finally
(when max-result
(vector-push-extend
(make-fuzzy-matching nil max-pkg-name
max-score max-result '()
:symbol-p nil)
completions)))))
(cond ((and time-limit-p (<= time-limit 0))
(values #() time-limit))
(t
(loop for (nick) in (package-local-nicknames *buffer-package*)
do
(match-package (list nick)))
(loop for package in (list-all-packages)
do
;; Find best-matching package-nickname:
(match-package (package-names package))
finally
(return
(values completions
(and time-limit-p
(let ((elapsed-time (- (get-real-time-in-msecs)
rtime-at-start)))
(- time-limit elapsed-time)))))))))))
(defslimefun fuzzy-completion-selected (original-string completion)
"This function is called by Slime when a fuzzy completion is
selected by the user. It is for future expansion to make
testing, say, a machine learning algorithm for completion scoring
easier.
ORIGINAL-STRING is the string the user completed from, and
COMPLETION is the completion object (see docstring for
SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
user selected."
(declare (ignore original-string completion))
nil)
;;;;; Fuzzy completion core
(defparameter *fuzzy-recursion-soft-limit* 30
"This is a soft limit for recursion in
RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
completing a string such as \"ZZZZZZ\" with a symbol named
\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
find all the ways it can match.
Most natural language searches and symbols do not have this
problem -- this is only here as a safeguard.")
(declaim (fixnum *fuzzy-recursion-soft-limit*))
(defvar *all-chunks* '())
(declaim (type list *all-chunks*))
(defun compute-highest-scoring-completion (short full)
"Finds the highest scoring way to complete the abbreviation
SHORT onto the string FULL, using CHAR= as a equality function for
letters. Returns two values: The first being the completion
chunks of the highest scorer, and the second being the score."
(let* ((scored-results
(mapcar #'(lambda (result)
(cons (score-completion result short full) result))
(compute-most-completions short full)))
(winner (first (sort scored-results #'> :key #'first))))
(values (rest winner) (first winner))))
(defun compute-most-completions (short full)
"Finds most possible ways to complete FULL with the letters in SHORT.
Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
a list of (&rest CHUNKS), where each CHUNKS is a description of
how a completion matches."
(let ((*all-chunks* nil))
(recursively-compute-most-completions short full 0 0 nil nil nil t)
*all-chunks*))
(defun recursively-compute-most-completions
(short full
short-index initial-full-index
chunks current-chunk current-chunk-pos
recurse-p)
"Recursively (if RECURSE-P is true) find /most/ possible ways
to fuzzily map the letters in SHORT onto FULL, using CHAR= to
determine if two letters match.
A chunk is a list of elements that have matched consecutively.
When consecutive matches stop, it is coerced into a string,
paired with the starting position of the chunk, and pushed onto
CHUNKS.
Whenever a letter matches, if RECURSE-P is true,
RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
one index ahead, to find other possibly higher scoring
possibilities. If there are less than
*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
this call will also recurse.
Once a word has been completely matched, the chunks are pushed
onto the special variable *ALL-CHUNKS* and the function returns."
(declare (optimize speed)
(type fixnum short-index initial-full-index)
(type list current-chunk)
(simple-string short full))
(flet ((short-cur ()
"Returns the next letter from the abbreviation, or NIL
if all have been used."
(if (= short-index (length short))
nil
(aref short short-index)))
(add-to-chunk (char pos)
"Adds the CHAR at POS in FULL to the current chunk,
marking the start position if it is empty."
(unless current-chunk
(setf current-chunk-pos pos))
(push char current-chunk))
(collect-chunk ()
"Collects the current chunk to CHUNKS and prepares for
a new chunk."
(when current-chunk
(let ((current-chunk-as-string
(nreverse
(make-array (length current-chunk)
:element-type 'character
:initial-contents current-chunk))))
(push (list current-chunk-pos current-chunk-as-string) chunks)
(setf current-chunk nil
current-chunk-pos nil)))))
;; If there's an outstanding chunk coming in collect it. Since
;; we're recursively called on skipping an input character, the
;; chunk can't possibly continue on.
(when current-chunk (collect-chunk))
(do ((pos initial-full-index (1+ pos)))
((= pos (length full)))
(let ((cur-char (aref full pos)))
(if (and (short-cur)
(char= cur-char (short-cur)))
(progn
(when recurse-p
;; Try other possibilities, limiting insanely deep
;; recursion somewhat.
(recursively-compute-most-completions
short full short-index (1+ pos)
chunks current-chunk current-chunk-pos
(not (> (length *all-chunks*)
*fuzzy-recursion-soft-limit*))))
(incf short-index)
(add-to-chunk cur-char pos))
(collect-chunk))))
(collect-chunk)
;; If we've exhausted the short characters we have a match.
(if (short-cur)
nil
(let ((rev-chunks (reverse chunks)))
(push rev-chunks *all-chunks*)
rev-chunks))))
;;;;; Fuzzy completion scoring
(defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<"
"Letters that are likely to be at the beginning of a symbol.
Letters found after one of these prefixes will be scored as if
they were at the beginning of ths symbol.")
(defvar *fuzzy-completion-symbol-suffixes* "*+->"
"Letters that are likely to be at the end of a symbol.
Letters found before one of these suffixes will be scored as if
they were at the end of the symbol.")
(defvar *fuzzy-completion-word-separators* "-/."
"Letters that separate different words in symbols. Letters
after one of these symbols will be scores more highly than other
letters.")
(defun score-completion (completion short full)
"Scores the completion chunks COMPLETION as a completion from
the abbreviation SHORT to the full string FULL. COMPLETION is a
list like:
((0 \"mul\") (9 \"v\") (15 \"b\"))
Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
would indicate that it completed as such (completed letters
capitalized):
MULtiple-Value-Bind
Letters are given scores based on their position in the string.
Letters at the beginning of a string or after a prefix letter at
the beginning of a string are scored highest. Letters after a
word separator such as #\- are scored next highest. Letters at
the end of a string or before a suffix letter at the end of a
string are scored medium, and letters anywhere else are scored
low.
If a letter is directly after another matched letter, and its
intrinsic value in that position is less than a percentage of the
previous letter's value, it will use that percentage instead.
Finally, a small scaling factor is applied to favor shorter
matches, all other things being equal."
(labels ((at-beginning-p (pos)
(= pos 0))
(after-prefix-p (pos)
(and (= pos 1)
(find (aref full 0) *fuzzy-completion-symbol-prefixes*)))
(word-separator-p (pos)
(find (aref full pos) *fuzzy-completion-word-separators*))
(after-word-separator-p (pos)
(find (aref full (1- pos)) *fuzzy-completion-word-separators*))
(at-end-p (pos)
(= pos (1- (length full))))
(before-suffix-p (pos)
(and (= pos (- (length full) 2))
(find (aref full (1- (length full)))
*fuzzy-completion-symbol-suffixes*)))
(score-or-percentage-of-previous (base-score pos chunk-pos)
(if (zerop chunk-pos)
base-score
(max base-score
(+ (* (score-char (1- pos) (1- chunk-pos)) 0.85)
(expt 1.2 chunk-pos)))))
(score-char (pos chunk-pos)
(score-or-percentage-of-previous
(cond ((at-beginning-p pos) 10)
((after-prefix-p pos) 10)
((word-separator-p pos) 1)
((after-word-separator-p pos) 8)
((at-end-p pos) 6)
((before-suffix-p pos) 6)
(t 1))
pos chunk-pos))
(score-chunk (chunk)
(loop for chunk-pos below (length (second chunk))
for pos from (first chunk)
summing (score-char pos chunk-pos))))
(let* ((chunk-scores (mapcar #'score-chunk completion))
(length-score (/ 10.0 (1+ (- (length full) (length short))))))
(values
(+ (reduce #'+ chunk-scores) length-score)
(list (mapcar #'list chunk-scores completion) length-score)))))
(defun highlight-completion (completion full)
"Given a chunk definition COMPLETION and the string FULL,
HIGHLIGHT-COMPLETION will create a string that demonstrates where
the completion matched in the string. Matches will be
capitalized, while the rest of the string will be lower-case."
(let ((highlit (nstring-downcase (copy-seq full))))
(dolist (chunk completion)
(setf highlit (nstring-upcase highlit
:start (first chunk)
:end (+ (first chunk)
(length (second chunk))))))
highlit))
(defun format-fuzzy-completion-set (winners)
"Given a list of completion objects such as on returned by
FUZZY-COMPLETION-SET, format the list into user-readable output
for interactive debugging purpose."
(let ((max-len
(loop for winner in winners maximizing (length (first winner)))))
(loop for (sym score result) in winners do
(format t "~&~VA score ~8,2F ~A"
max-len (highlight-completion result sym) score result))))
(provide :swank-fuzzy)

18
sources_non_forked/slimv/slime/contrib/swank-hyperdoc.lisp Normal file
View File

@ -0,0 +1,18 @@
(in-package :swank)
(defslimefun hyperdoc (string)
(let ((hyperdoc-package (find-package :hyperdoc)))
(when hyperdoc-package
(multiple-value-bind (symbol foundp symbol-name package)
(parse-symbol string *buffer-package*)
(declare (ignore symbol))
(when foundp
(funcall (find-symbol (string :lookup) hyperdoc-package)
(package-name (if (member package (cons *buffer-package*
(package-use-list
*buffer-package*)))
*buffer-package*
package))
symbol-name))))))
(provide :swank-hyperdoc)

140
sources_non_forked/slimv/slime/contrib/swank-indentation.lisp Normal file
View File

@ -0,0 +1,140 @@
(in-package :swank)
(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 slime 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 swank version of this function
(defun symbol-indentation (symbol)
"Return a form describing the indentation of SYMBOL.
The form is to be used as the `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 :swank-indentation)

2504
sources_non_forked/slimv/slime/contrib/swank-kawa.scm Normal file
View File

File diff suppressed because it is too large Load Diff

176
sources_non_forked/slimv/slime/contrib/swank-larceny.scm Normal file
View File

@ -0,0 +1,176 @@
;; swank-larceny.scm --- Swank server for Larceny
;;
;; License: Public Domain
;; Author: Helmut Eller
;;
;; In a shell execute:
;; larceny -r6rs -program swank-larceny.scm
;; and then `M-x slime-connect' in Emacs.
(library (swank os)
(export getpid make-server-socket accept local-port close-socket)
(import (rnrs)
(primitives foreign-procedure
ffi/handle->address
ffi/string->asciiz
sizeof:pointer
sizeof:int
%set-pointer
%get-int))
(define getpid (foreign-procedure "getpid" '() 'int))
(define fork (foreign-procedure "fork" '() 'int))
(define close (foreign-procedure "close" '(int) 'int))
(define dup2 (foreign-procedure "dup2" '(int int) 'int))
(define bytevector-content-offset$ sizeof:pointer)
(define execvp% (foreign-procedure "execvp" '(string boxed) 'int))
(define (execvp file . args)
(let* ((nargs (length args))
(argv (make-bytevector (* (+ nargs 1)
sizeof:pointer))))
(do ((offset 0 (+ offset sizeof:pointer))
(as args (cdr as)))
((null? as))
(%set-pointer argv
offset
(+ (ffi/handle->address (ffi/string->asciiz (car as)))
bytevector-content-offset$)))
(%set-pointer argv (* nargs sizeof:pointer) 0)
(execvp% file argv)))
(define pipe% (foreign-procedure "pipe" '(boxed) 'int))
(define (pipe)
(let ((array (make-bytevector (* sizeof:int 2))))
(let ((r (pipe% array)))
(values r (%get-int array 0) (%get-int array sizeof:int)))))
(define (fork/exec file . args)
(let ((pid (fork)))
(cond ((= pid 0)
(apply execvp file args))
(#t pid))))
(define (start-process file . args)
(let-values (((r1 down-out down-in) (pipe))
((r2 up-out up-in) (pipe))
((r3 err-out err-in) (pipe)))
(assert (= 0 r1))
(assert (= 0 r2))
(assert (= 0 r3))
(let ((pid (fork)))
(case pid
((-1)
(error "Failed to fork a subprocess."))
((0)
(close up-out)
(close err-out)
(close down-in)
(dup2 down-out 0)
(dup2 up-in 1)
(dup2 err-in 2)
(apply execvp file args)
(exit 1))
(else
(close down-out)
(close up-in)
(close err-in)
(list pid
(make-fd-io-stream up-out down-in)
(make-fd-io-stream err-out err-out)))))))
(define (make-fd-io-stream in out)
(let ((write (lambda (bv start count) (fd-write out bv start count)))
(read (lambda (bv start count) (fd-read in bv start count)))
(closeit (lambda () (close in) (close out))))
(make-custom-binary-input/output-port
"fd-stream" read write #f #f closeit)))
(define write% (foreign-procedure "write" '(int ulong int) 'int))
(define (fd-write fd bytevector start count)
(write% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define read% (foreign-procedure "read" '(int ulong int) 'int))
(define (fd-read fd bytevector start count)
;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count)
(read% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define (make-server-socket port)
(let* ((args `("/bin/bash" "bash"
"-c"
,(string-append
"netcat -s 127.0.0.1 -q 0 -l -v "
(if port
(string-append "-p " (number->string port))
""))))
(nc (apply start-process args))
(err (transcoded-port (list-ref nc 2)
(make-transcoder (latin-1-codec))))
(line (get-line err))
(pos (last-index-of line '#\])))
(cond (pos
(let* ((tail (substring line (+ pos 1) (string-length line)))
(port (get-datum (open-string-input-port tail))))
(list (car nc) (cadr nc) err port)))
(#t (error "netcat failed: " line)))))
(define (accept socket codec)
(let* ((line (get-line (caddr socket)))
(pos (last-index-of line #\])))
(cond (pos
(close-port (caddr socket))
(let ((stream (cadr socket)))
(let ((io (transcoded-port stream (make-transcoder codec))))
(values io io))))
(else (error "accept failed: " line)))))
(define (local-port socket)
(list-ref socket 3))
(define (last-index-of str chr)
(let loop ((i (string-length str)))
(cond ((<= i 0) #f)
(#t (let ((i (- i 1)))
(cond ((char=? (string-ref str i) chr)
i)
(#t
(loop i))))))))
(define (close-socket socket)
;;(close-port (cadr socket))
#f
)
)
(library (swank sys)
(export implementation-name eval-in-interaction-environment)
(import (rnrs)
(primitives system-features
aeryn-evaluator))
(define (implementation-name) "larceny")
;; see $LARCENY/r6rsmode.sch:
;; Larceny's ERR5RS and R6RS modes.
;; Code names:
;; Aeryn ERR5RS
;; D'Argo R6RS-compatible
;; Spanky R6RS-conforming (not yet implemented)
(define (eval-in-interaction-environment form)
(aeryn-evaluator form))
)
(import (rnrs) (rnrs eval) (larceny load))
(load "swank-r6rs.scm")
(eval '(start-server #f) (environment '(swank)))

91
sources_non_forked/slimv/slime/contrib/swank-listener-hooks.lisp Normal file
View File

@ -0,0 +1,91 @@
;;; swank-listener-hooks.lisp --- listener with special hooks
;;
;; Author: Alan Ruttenberg <alanr-l@mumble.net>
;; Provides *slime-repl-eval-hooks* special variable which
;; can be used for easy interception of SLIME REPL form evaluation
;; for purposes such as integration with application event loop.
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-repl))
(defvar *slime-repl-advance-history* nil
"In the dynamic scope of a single form typed at the repl, is set to nil to
prevent the repl from advancing the history - * ** *** etc.")
(defvar *slime-repl-suppress-output* nil
"In the dynamic scope of a single form typed at the repl, is set to nil to
prevent the repl from printing the result of the evalation.")
(defvar *slime-repl-eval-hook-pass* (gensym "PASS")
"Token to indicate that a repl hook declines to evaluate the form")
(defvar *slime-repl-eval-hooks* nil
"A list of functions. When the repl is about to eval a form, first try running each of
these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
is considered a replacement for calling eval. If there are no hooks, or all
pass, then eval is used.")
(export '*slime-repl-eval-hooks*)
(defslimefun repl-eval-hook-pass ()
"call when repl hook declines to evaluate the form"
(throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
(defslimefun repl-suppress-output ()
"In the dynamic scope of a single form typed at the repl, call to
prevent the repl from printing the result of the evalation."
(setq *slime-repl-suppress-output* t))
(defslimefun repl-suppress-advance-history ()
"In the dynamic scope of a single form typed at the repl, call to
prevent the repl from advancing the history - * ** *** etc."
(setq *slime-repl-advance-history* nil))
(defun %eval-region (string)
(with-input-from-string (stream string)
(let (- values)
(loop
(let ((form (read stream nil stream)))
(when (eq form stream)
(fresh-line)
(finish-output)
(return (values values -)))
(setq - form)
(if *slime-repl-eval-hooks*
(setq values (run-repl-eval-hooks form))
(setq values (multiple-value-list (eval form))))
(finish-output))))))
(defun run-repl-eval-hooks (form)
(loop for hook in *slime-repl-eval-hooks*
for res = (catch *slime-repl-eval-hook-pass*
(multiple-value-list (funcall hook form)))
until (not (eq res *slime-repl-eval-hook-pass*))
finally (return
(if (eq res *slime-repl-eval-hook-pass*)
(multiple-value-list (eval form))
res))))
(defun %listener-eval (string)
(clear-user-input)
(with-buffer-syntax ()
(swank-repl::track-package
(lambda ()
(let ((*slime-repl-suppress-output* :unset)
(*slime-repl-advance-history* :unset))
(multiple-value-bind (values last-form) (%eval-region string)
(unless (or (and (eq values nil) (eq last-form nil))
(eq *slime-repl-advance-history* nil))
(setq *** ** ** * * (car values)
/// // // / / values))
(setq +++ ++ ++ + + last-form)
(unless (eq *slime-repl-suppress-output* t)
(funcall swank-repl::*send-repl-results-function* values)))))))
nil)
(setq swank-repl::*listener-eval-function* '%listener-eval)
(provide :swank-listener-hooks)

227
sources_non_forked/slimv/slime/contrib/swank-macrostep.lisp Normal file
View File

@ -0,0 +1,227 @@
;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el
;;
;; Authors: Luis Oliveira <luismbo@gmail.com>
;; Jon Oddie <j.j.oddie@gmail.com>
;;
;; License: Public Domain
(defpackage swank-macrostep
(:use cl swank)
(:import-from swank
#:*macroexpand-printer-bindings*
#:with-buffer-syntax
#:with-bindings
#:to-string
#:macroexpand-all
#:compiler-macroexpand-1
#:defslimefun
#:collect-macro-forms)
(:export #:macrostep-expand-1
#:macro-form-p))
(in-package #:swank-macrostep)
(defslimefun macrostep-expand-1 (string compiler-macros? context)
(with-buffer-syntax ()
(let ((form (read-from-string string)))
(multiple-value-bind (expansion error-message)
(expand-form-once form compiler-macros? context)
(if error-message
`(:error ,error-message)
(multiple-value-bind (macros compiler-macros)
(collect-macro-forms-in-context expansion context)
(let* ((all-macros (append macros compiler-macros))
(pretty-expansion (pprint-to-string expansion))
(positions (collect-form-positions expansion
pretty-expansion
all-macros))
(subform-info
(loop
for form in all-macros
for (start end) in positions
when (and start end)
collect (let ((op-name (to-string (first form)))
(op-type
(if (member form macros)
:macro
:compiler-macro)))
(list op-name
op-type
start)))))
`(:ok ,pretty-expansion ,subform-info))))))))
(defun expand-form-once (form compiler-macros? context)
(multiple-value-bind (expansion expanded?)
(macroexpand-1-in-context form context)
(if expanded?
(values expansion nil)
(if (not compiler-macros?)
(values nil "Not a macro form")
(multiple-value-bind (expansion expanded?)
(compiler-macroexpand-1 form)
(if expanded?
(values expansion nil)
(values nil "Not a macro or compiler-macro form")))))))
(defslimefun macro-form-p (string compiler-macros? context)
(with-buffer-syntax ()
(let ((form
(handler-case
(read-from-string string)
(error (condition)
(unless (debug-on-swank-error)
(return-from macro-form-p
`(:error ,(format nil "Read error: ~A" condition))))))))
`(:ok ,(macro-form-type form compiler-macros? context)))))
(defun macro-form-type (form compiler-macros? context)
(cond
((or (not (consp form))
(not (symbolp (car form))))
nil)
((multiple-value-bind (expansion expanded?)
(macroexpand-1-in-context form context)
(declare (ignore expansion))
expanded?)
:macro)
((and compiler-macros?
(multiple-value-bind (expansion expanded?)
(compiler-macroexpand-1 form)
(declare (ignore expansion))
expanded?))
:compiler-macro)
(t
nil)))
;;;; Hacks to support macro-expansion within local context
(defparameter *macrostep-tag* (gensym))
(defparameter *macrostep-placeholder* '*macrostep-placeholder*)
(define-condition expansion-in-context-failed (simple-error)
())
(defmacro throw-expansion (form &environment env)
(throw *macrostep-tag* (macroexpand-1 form env)))
(defmacro throw-collected-macro-forms (form &environment env)
(throw *macrostep-tag* (collect-macro-forms form env)))
(defun macroexpand-1-in-context (form context)
(handler-case
(macroexpand-and-catch
`(throw-expansion ,form) context)
(error ()
(macroexpand-1 form))))
(defun collect-macro-forms-in-context (form context)
(handler-case
(macroexpand-and-catch
`(throw-collected-macro-forms ,form) context)
(error ()
(collect-macro-forms form))))
(defun macroexpand-and-catch (form context)
(catch *macrostep-tag*
(macroexpand-all (enclose-form-in-context form context))
(error 'expansion-in-context-failed)))
(defun enclose-form-in-context (form context)
(with-buffer-syntax ()
(destructuring-bind (prefix suffix) context
(let* ((placeholder-form
(read-from-string
(concatenate
'string
prefix (prin1-to-string *macrostep-placeholder*) suffix)))
(substituted-form (subst form *macrostep-placeholder*
placeholder-form)))
(if (not (equal placeholder-form substituted-form))
substituted-form
(error 'expansion-in-context-failed))))))
;;;; Tracking Pretty Printer
(defun marker-char-p (char)
(<= #xe000 (char-code char) #xe8ff))
(defun make-marker-char (id)
;; using the private-use characters U+E000..U+F8FF as markers, so
;; that's our upper limit for how many we can use.
(assert (<= 0 id #x8ff))
(code-char (+ #xe000 id)))
(defun marker-char-id (char)
(assert (marker-char-p char))
(- (char-code char) #xe000))
(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32)))
(defun whitespacep (char)
(member char +whitespace+))
(defun pprint-to-string (object &optional pprint-dispatch)
(let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*)))
(with-bindings *macroexpand-printer-bindings*
(to-string object))))
#-clisp
(defun collect-form-positions (expansion printed-expansion forms)
(loop for (start end)
in (collect-marker-positions
(pprint-to-string expansion (make-tracking-pprint-dispatch forms))
(length forms))
collect (when (and start end)
(list (find-non-whitespace-position printed-expansion start)
(find-non-whitespace-position printed-expansion end)))))
;; The pprint-dispatch table constructed by
;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack
;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS
;; entry point a no-op in thi case, so that basic macro-expansion will
;; still work (without detection of inner macro forms)
#+clisp
(defun collect-form-positions (expansion printed-expansion forms)
nil)
(defun make-tracking-pprint-dispatch (forms)
(let ((original-table *print-pprint-dispatch*)
(table (copy-pprint-dispatch)))
(flet ((maybe-write-marker (position stream)
(when position
(write-char (make-marker-char position) stream))))
(set-pprint-dispatch 'cons
(lambda (stream cons)
(let ((pos (position cons forms)))
(maybe-write-marker pos stream)
;; delegate printing to the original table.
(funcall (pprint-dispatch cons original-table)
stream
cons)
(maybe-write-marker pos stream)))
most-positive-fixnum
table))
table))
(defun collect-marker-positions (string position-count)
(let ((positions (make-array position-count :initial-element nil)))
(loop with p = 0
for char across string
unless (whitespacep char)
do (if (marker-char-p char)
(push p (aref positions (marker-char-id char)))
(incf p)))
(map 'list #'reverse positions)))
(defun find-non-whitespace-position (string position)
(loop with non-whitespace-position = -1
for i from 0 and char across string
unless (whitespacep char)
do (incf non-whitespace-position)
until (eql non-whitespace-position position)
finally (return i)))
(provide :swank-macrostep)

25
sources_non_forked/slimv/slime/contrib/swank-media.lisp Normal file
View File

@ -0,0 +1,25 @@
;;; swank-media.lisp --- insert other media (images)
;;
;; Authors: Christophe Rhodes <csr21@cantab.net>
;;
;; Licence: GPLv2 or later
;;
(in-package :swank)
;; this file is empty of functionality. The slime-media contrib
;; allows swank to return messages other than :write-string as repl
;; results; this is used in the R implementation of swank to display R
;; objects with graphical representations (such as trellis objects) as
;; image presentations in the swank repl. In R, this is done by
;; having a hook function for the preparation of the repl results, in
;; addition to the already-existing hook for sending the repl results
;; (*send-repl-results-function*, used by swank-presentations.lisp).
;; The swank-media.R contrib implementation defines a generic function
;; for use as this hook, along with methods for commonly-encountered
;; graphical R objects. (This strategy is harder in CL, where methods
;; can only be defined if their specializers already exist; in R's S3
;; object system, methods are ordinary functions with a special naming
;; convention)
(provide :swank-media)

883
sources_non_forked/slimv/slime/contrib/swank-mit-scheme.scm Normal file
View File

@ -0,0 +1,883 @@
;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme
;;
;; Copyright (C) 2008 Helmut Eller
;;
;; This file is licensed under the terms of the GNU General Public
;; License as distributed with Emacs (press C-h C-c for details).
;;;; Installation:
#|
1. You need MIT Scheme 9.2
2. The Emacs side needs some fiddling. I have the following in
my .emacs:
(setq slime-lisp-implementations
'((mit-scheme ("mit-scheme") :init mit-scheme-init)))
(defun mit-scheme-init (file encoding)
(format "%S\n\n"
`(begin
(load-option 'format)
(load-option 'sos)
(eval
'(create-package-from-description
(make-package-description '(swank) (list (list))
(vector) (vector) (vector) false))
(->environment '(package)))
(load ,(expand-file-name
".../contrib/swank-mit-scheme.scm" ; <-- insert your path
slime-path)
(->environment '(swank)))
(eval '(start-swank ,file) (->environment '(swank))))))
(defun mit-scheme ()
(interactive)
(slime 'mit-scheme))
(defun find-mit-scheme-package ()
(save-excursion
(let ((case-fold-search t))
(and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t)
(match-string-no-properties 1)))))
(setq slime-find-buffer-package-function 'find-mit-scheme-package)
(add-hook 'scheme-mode-hook (lambda () (slime-mode 1)))
The `mit-scheme-init' function first loads the SOS and FORMAT
libraries, then creates a package "(swank)", and loads this file
into that package. Finally it starts the server.
`find-mit-scheme-package' tries to figure out which package the
buffer belongs to, assuming that ";;; package: (FOO)" appears
somewhere in the file. Luckily, this assumption is true for many of
MIT Scheme's own files. Alternatively, you could add Emacs style
-*- slime-buffer-package: "(FOO)" -*- file variables.
4. Start everything with `M-x mit-scheme'.
|#
;;; package: (swank)
;; Modified for Slimv:
;; - load options
;; - remove extension in compile-file-for-emacs
(load-option 'format)
(load-option 'sos)
(if (< (car (get-subsystem-version "Release"))
'9)
(error "This file requires MIT Scheme Release 9"))
(define (swank port)
(accept-connections (or port 4005) #f))
;; ### hardcoded port number for now. netcat-openbsd doesn't print
;; the listener port anymore.
(define (start-swank port-file)
(accept-connections 4055 port-file)
)
;;;; Networking
(define (accept-connections port port-file)
(let ((sock (open-tcp-server-socket port (host-address-loopback))))
(format #t "Listening on port: ~s~%" port)
(if port-file (write-port-file port port-file))
(dynamic-wind
(lambda () #f)
(lambda () (serve (tcp-server-connection-accept sock #t #f)))
(lambda () (close-tcp-server-socket sock)))))
(define (write-port-file portnumber filename)
(call-with-output-file filename (lambda (p) (write portnumber p))))
(define *top-level-restart* #f)
(define (serve socket)
(with-simple-restart
'disconnect "Close connection."
(lambda ()
(with-keyboard-interrupt-handler
(lambda () (main-loop socket))))))
(define (disconnect)
(format #t "Disconnecting ...~%")
(invoke-restart (find-restart 'disconnect)))
(define (main-loop socket)
(do () (#f)
(with-simple-restart
'abort "Return to SLIME top-level."
(lambda ()
(fluid-let ((*top-level-restart* (find-restart 'abort)))
(dispatch (read-packet socket) socket 0))))))
(define (with-keyboard-interrupt-handler fun)
(define (set-^G-handler exp)
(eval `(vector-set! keyboard-interrupt-vector (char->integer #\G) ,exp)
(->environment '(runtime interrupt-handler))))
(dynamic-wind
(lambda () #f)
(lambda ()
(set-^G-handler
`(lambda (char) (with-simple-restart
'continue "Continue from interrupt."
(lambda () (error "Keyboard Interrupt.")))))
(fun))
(lambda ()
(set-^G-handler '^G-interrupt-handler))))
;;;; Reading/Writing of SLIME packets
(define (read-packet in)
"Read an S-expression from STREAM using the SLIME protocol."
(let* ((len (read-length in))
(buffer (make-string len)))
(fill-buffer! in buffer)
(read-from-string buffer)))
(define (write-packet message out)
(let* ((string (write-to-string message)))
(log-event "WRITE: [~a]~s~%" (string-length string) string)
(write-length (string-length string) out)
(write-string string out)
(flush-output out)))
(define (fill-buffer! in buffer)
(read-string! buffer in))
(define (read-length in)
(if (eof-object? (peek-char in)) (disconnect))
(do ((len 6 (1- len))
(sum 0 (+ (* sum 16) (char->hex-digit (read-char in)))))
((zero? len) sum)))
(define (ldb size position integer)
"LoaD a Byte of SIZE bits at bit position POSITION from INTEGER."
(fix:and (fix:lsh integer (- position))
(1- (fix:lsh 1 size))))
(define (write-length len out)
(do ((pos 20 (- pos 4)))
((< pos 0))
(write-hex-digit (ldb 4 pos len) out)))
(define (write-hex-digit n out)
(write-char (hex-digit->char n) out))
(define (hex-digit->char n)
(digit->char n 16))
(define (char->hex-digit c)
(char->digit c 16))
;;;; Event dispatching
(define (dispatch request socket level)
(log-event "READ: ~s~%" request)
(case (car request)
((:emacs-rex) (apply emacs-rex socket level (cdr request)))))
(define (swank-package)
(if (name->package '(swank))
'(swank)
'(user)))
(define *buffer-package* #f)
(define (find-buffer-package name)
(if (elisp-false? name)
#f
(let ((v (ignore-errors
(lambda () (name->package (read-from-string name))))))
(and (package? v) v))))
(define swank-env (->environment (swank-package)))
(define (user-env buffer-package)
(cond ((string? buffer-package)
(let ((p (find-buffer-package buffer-package)))
(if (not p) (error "Invalid package name: " buffer-package))
(package/environment p)))
(else (nearest-repl/environment))))
;; quote keywords
(define (hack-quotes list)
(map (lambda (x)
(cond ((symbol? x) `(quote ,x))
(#t x)))
list))
(define (emacs-rex socket level sexp package thread id)
(let ((ok? #f) (result #f) (condition #f))
(dynamic-wind
(lambda () #f)
(lambda ()
(bind-condition-handler
(list condition-type:serious-condition)
(lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c))
(lambda ()
(fluid-let ((*buffer-package* package))
(set! result
(eval (cons* (car sexp) socket (hack-quotes (cdr sexp)))
swank-env))
(set! ok? #t)))))
(lambda ()
(write-packet `(:return
,(if ok? `(:ok ,result)
`(:abort
,(if condition
(format #f "~a"
(condition/type condition))
"<unknown reason>")))
,id)
socket)))))
(define (swank:connection-info _)
(let ((p (environment->package (user-env #f))))
`(:pid ,(unix/current-pid)
:package (:name ,(write-to-string (package/name p))
:prompt ,(write-to-string (package/name p)))
:lisp-implementation
(:type "MIT Scheme" :version ,(get-subsystem-version-string "release"))
:encoding (:coding-systems ("iso-8859-1"))
)))
(define (swank:quit-lisp _)
(%exit))
;;;; Evaluation
(define (swank-repl:listener-eval socket string)
;;(call-with-values (lambda () (eval-region string socket))
;; (lambda values `(:values . ,(map write-to-string values))))
`(:values ,(write-to-string (eval-region string socket))))
(define (eval-region string socket)
(let ((sexp (read-from-string string)))
(if (eof-object? exp)
(values)
(with-output-to-repl socket
(lambda () (eval sexp (user-env *buffer-package*)))))))
(define (with-output-to-repl socket fun)
(let ((p (make-port repl-port-type socket)))
(dynamic-wind
(lambda () #f)
(lambda () (with-output-to-port p fun))
(lambda () (flush-output p)))))
(define (swank:interactive-eval socket string)
;;(call-with-values (lambda () (eval-region string)) format-for-echo-area)
(format-values (eval-region string socket))
)
(define (format-values . values)
(if (null? values)
"; No value"
(with-string-output-port
(lambda (out)
(write-string "=> " out)
(do ((vs values (cdr vs))) ((null? vs))
(write (car vs) out)
(if (not (null? (cdr vs)))
(write-string ", " out)))))))
(define (swank:pprint-eval _ string)
(pprint-to-string (eval (read-from-string string)
(user-env *buffer-package*))))
(define (swank:interactive-eval-region socket string)
(format-values (eval-region string socket)))
(define (swank:set-package _ package)
(set-repl/environment! (nearest-repl)
(->environment (read-from-string package)))
(let* ((p (environment->package (user-env #f)))
(n (write-to-string (package/name p))))
(list n n)))
(define (repl-write-substring port string start end)
(cond ((< start end)
(write-packet `(:write-string ,(substring string start end))
(port/state port))))
(- end start))
(define (repl-write-char port char)
(write-packet `(:write-string ,(string char))
(port/state port)))
(define repl-port-type
(make-port-type `((write-substring ,repl-write-substring)
(write-char ,repl-write-char)) #f))
(define (swank-repl:create-repl socket . _)
(let* ((env (user-env #f))
(name (format #f "~a" (package/name (environment->package env)))))
(list name name)))
;;;; Compilation
(define (swank:compile-string-for-emacs _ string . x)
(apply
(lambda (errors seconds)
`(:compilation-result ,errors t ,seconds nil nil))
(call-compiler
(lambda ()
(let* ((sexps (snarf-string string))
(env (user-env *buffer-package*))
(scode (syntax `(begin ,@sexps) env))
(compiled-expression (compile-scode scode #t)))
(scode-eval compiled-expression env))))))
(define (snarf-string string)
(with-input-from-string string
(lambda ()
(let loop ()
(let ((e (read)))
(if (eof-object? e) '() (cons e (loop))))))))
(define (call-compiler fun)
(let ((time #f))
(with-timings fun
(lambda (run-time gc-time real-time)
(set! time real-time)))
(list 'nil (internal-time/ticks->seconds time))))
(define (swank:compiler-notes-for-emacs _) nil)
(define (swank:compile-file-for-emacs socket file load?)
(apply
(lambda (errors seconds)
(list ':compilation-result errors 't seconds load?
(->namestring (pathname-name file))))
(call-compiler
(lambda () (with-output-to-repl socket (lambda () (compile-file file)))))))
(define (swank:load-file socket file)
(with-output-to-repl socket
(lambda ()
(pprint-to-string
(load file (user-env *buffer-package*))))))
(define (swank:disassemble-form _ string)
(let ((sexp (let ((sexp (read-from-string string)))
(cond ((and (pair? sexp) (eq? (car sexp) 'quote))
(cadr sexp))
(#t sexp)))))
(with-output-to-string
(lambda ()
(compiler:disassemble
(eval sexp (user-env *buffer-package*)))))))
(define (swank:disassemble-symbol _ string)
(with-output-to-string
(lambda ()
(compiler:disassemble
(eval (read-from-string string)
(user-env *buffer-package*))))))
;;;; Macroexpansion
(define (swank:swank-macroexpand-all _ string)
(with-output-to-string
(lambda ()
(pp (syntax (read-from-string string)
(user-env *buffer-package*))))))
(define swank:swank-macroexpand-1 swank:swank-macroexpand-all)
(define swank:swank-macroexpand swank:swank-macroexpand-all)
;;; Arglist
(define (swank:operator-arglist socket name pack)
(let ((v (ignore-errors
(lambda ()
(string-trim-right
(with-output-to-string
(lambda ()
(carefully-pa
(eval (read-from-string name) (user-env pack))))))))))
(if (condition? v) 'nil v)))
(define (carefully-pa o)
(cond ((arity-dispatched-procedure? o)
;; MIT Scheme crashes for (pa /)
(display "arity-dispatched-procedure"))
((procedure? o) (pa o))
(else (error "Not a procedure"))))
;;; Some unimplemented stuff.
(define (swank:buffer-first-change . _) nil)
(define (swank:filename-to-modulename . _) nil)
(define (swank:swank-require . _) nil)
;; M-. is beyond my capabilities.
(define (swank:find-definitions-for-emacs . _) nil)
;;; Debugger
(define-structure (sldb-state (conc-name sldb-state.)) condition restarts)
(define *sldb-state* #f)
(define (invoke-sldb socket level condition)
(fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts))))
(dynamic-wind
(lambda () #f)
(lambda ()
(write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20))
socket)
(sldb-loop level socket))
(lambda ()
(write-packet `(:debug-return 0 ,level nil) socket)))))
(define (sldb-loop level socket)
(write-packet `(:debug-activate 0 ,level) socket)
(with-simple-restart
'abort (format #f "Return to SLDB level ~a." level)
(lambda () (dispatch (read-packet socket) socket level)))
(sldb-loop level socket))
(define (sldb-info state start end)
(let ((c (sldb-state.condition state))
(rs (sldb-state.restarts state)))
(list (list (condition/report-string c)
(format #f " [~a]" (%condition-type/name (condition/type c)))
nil)
(sldb-restarts rs)
(sldb-backtrace c start end)
;;'((0 "dummy frame"))
'())))
(define %condition-type/name
(eval '%condition-type/name (->environment '(runtime error-handler))))
(define (sldb-restarts restarts)
(map (lambda (r)
(list (symbol->string (restart/name r))
(with-string-output-port
(lambda (p) (write-restart-report r p)))))
restarts))
(define (swank:throw-to-toplevel . _)
(invoke-restart *top-level-restart*))
(define (swank:sldb-abort . _)
(abort (sldb-state.restarts *sldb-state*)))
(define (swank:sldb-continue . _)
(continue (sldb-state.restarts *sldb-state*)))
(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n)
(invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n)))
(define (swank:debugger-info-for-emacs _ from to)
(sldb-info *sldb-state* from to))
(define (swank:backtrace _ from to)
(sldb-backtrace (sldb-state.condition *sldb-state*) from to))
(define (sldb-backtrace condition from to)
(sldb-backtrace-aux (condition/continuation condition) from to))
(define (sldb-backtrace-aux k from to)
(let ((l (map frame>string (substream (continuation>frames k) from to))))
(let loop ((i from) (l l))
(if (null? l)
'()
(cons (list i (car l)) (loop (1+ i) (cdr l)))))))
;; Stack parser fails for this:
;; (map (lambda (x) x) "/tmp/x.x")
(define (continuation>frames k)
(let loop ((frame (continuation->stack-frame k)))
(cond ((not frame) (stream))
(else
(let ((next (ignore-errors
(lambda () (stack-frame/next-subproblem frame)))))
(cons-stream frame
(if (condition? next)
(stream next)
(loop next))))))))
(define (frame>string frame)
(if (condition? frame)
(format #f "Bogus frame: ~a ~a" frame
(condition/report-string frame))
(with-string-output-port (lambda (p) (print-frame frame p)))))
(define (print-frame frame port)
(define (invalid-subexpression? subexpression)
(or (debugging-info/undefined-expression? subexpression)
(debugging-info/unknown-expression? subexpression)))
(define (invalid-expression? expression)
(or (debugging-info/undefined-expression? expression)
(debugging-info/compiled-code? expression)))
(with-values (lambda () (stack-frame/debugging-info frame))
(lambda (expression environment subexpression)
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
(fluid-let ((*unparse-primitives-by-name?* #t))
(write
(unsyntax (if (invalid-subexpression? subexpression)
expression
subexpression))
port)))
((debugging-info/noise? expression)
(write-string ";" port)
(write-string ((debugging-info/noise expression) #f)
port))
(else
(write-string ";undefined expression" port))))))
(define (substream s from to)
(let loop ((i 0) (l '()) (s s))
(cond ((or (= i to) (stream-null? s)) (reverse l))
((< i from) (loop (1+ i) l (stream-cdr s)))
(else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s))))))
(define (swank:frame-locals-and-catch-tags _ frame)
(list (map frame-var>elisp (frame-vars (sldb-get-frame frame)))
'()))
(define (frame-vars frame)
(with-values (lambda () (stack-frame/debugging-info frame))
(lambda (expression environment subexpression)
(cond ((environment? environment)
(environment>frame-vars environment))
(else '())))))
(define (environment>frame-vars environment)
(let loop ((e environment))
(cond ((environment->package e) '())
(else (append (environment-bindings e)
(if (environment-has-parent? e)
(loop (environment-parent e))
'()))))))
(define (frame-var>elisp b)
(list ':name (write-to-string (car b))
':value (cond ((null? (cdr b)) "{unavailable}")
(else (>line (cadr b))))
':id 0))
(define (sldb-get-frame index)
(stream-ref (continuation>frames
(condition/continuation
(sldb-state.condition *sldb-state*)))
index))
(define (frame-var-value frame var)
(let ((binding (list-ref (frame-vars frame) var)))
(cond ((cdr binding) (cadr binding))
(else unspecific))))
(define (swank:inspect-frame-var _ frame var)
(reset-inspector)
(inspect-object (frame-var-value (sldb-get-frame frame) var)))
;;;; Completion
(define (swank:simple-completions _ string package)
(let ((strings (all-completions string (user-env package) string-prefix?)))
(list (sort strings string<?)
(longest-common-prefix strings))))
(define (all-completions pattern env match?)
(let ((ss (map %symbol->string (environment-names env))))
(keep-matching-items ss (lambda (s) (match? pattern s)))))
;; symbol->string is too slow
(define %symbol->string symbol-name)
(define (environment-names env)
(append (environment-bound-names env)
(if (environment-has-parent? env)
(environment-names (environment-parent env))
'())))
(define (longest-common-prefix strings)
(define (common-prefix s1 s2)
(substring s1 0 (string-match-forward s1 s2)))
(reduce common-prefix "" strings))
;;;; Apropos
(define (swank:apropos-list-for-emacs _ name #!optional
external-only case-sensitive package)
(let* ((pkg (and (string? package)
(find-package (read-from-string package))))
(parent (and (not (default-object? external-only))
(elisp-false? external-only)))
(ss (append-map (lambda (p)
(map (lambda (s) (cons p s))
(apropos-list name p (and pkg parent))))
(if pkg (list pkg) (all-packages))))
(ss (sublist ss 0 (min (length ss) 200))))
(map (lambda (e)
(let ((p (car e)) (s (cdr e)))
(list ':designator (format #f "~a ~a" s (package/name p))
':variable (>line
(ignore-errors
(lambda () (package-lookup p s)))))))
ss)))
(define (swank:list-all-package-names . _)
(map (lambda (p) (write-to-string (package/name p)))
(all-packages)))
(define (all-packages)
(define (package-and-children package)
(append (list package)
(append-map package-and-children (package/children package))))
(package-and-children system-global-package))
;;;; Inspector
(define-structure (inspector-state (conc-name istate.))
object parts next previous content)
(define istate #f)
(define (reset-inspector)
(set! istate #f))
(define (swank:init-inspector _ string)
(reset-inspector)
(inspect-object (eval (read-from-string string)
(user-env *buffer-package*))))
(define (inspect-object o)
(let ((previous istate)
(content (inspect o))
(parts (make-eqv-hash-table)))
(set! istate (make-inspector-state o parts #f previous content))
(if previous (set-istate.next! previous istate))
(istate>elisp istate)))
(define (istate>elisp istate)
(list ':title (>line (istate.object istate))
':id (assign-index (istate.object istate) (istate.parts istate))
':content (prepare-range (istate.parts istate)
(istate.content istate)
0 500)))
(define (assign-index o parts)
(let ((i (hash-table/count parts)))
(hash-table/put! parts i o)
i))
(define (prepare-range parts content from to)
(let* ((cs (substream content from to))
(ps (prepare-parts cs parts)))
(list ps
(if (< (length cs) (- to from))
(+ from (length cs))
(+ to 1000))
from to)))
(define (prepare-parts ps parts)
(define (line label value)
`(,(format #f "~a: " label)
(:value ,(>line value) ,(assign-index value parts))
"\n"))
(append-map (lambda (p)
(cond ((string? p) (list p))
((symbol? p) (list (symbol->string p)))
(#t
(case (car p)
((line) (apply line (cdr p)))
(else (error "Invalid part:" p))))))
ps))
(define (swank:inspect-nth-part _ index)
(inspect-object (hash-table/get (istate.parts istate) index 'no-such-part)))
(define (swank:quit-inspector _)
(reset-inspector))
(define (swank:inspector-pop _)
(cond ((istate.previous istate)
(set! istate (istate.previous istate))
(istate>elisp istate))
(else 'nil)))
(define (swank:inspector-next _)
(cond ((istate.next istate)
(set! istate (istate.next istate))
(istate>elisp istate))
(else 'nil)))
(define (swank:inspector-range _ from to)
(prepare-range (istate.parts istate)
(istate.content istate)
from to))
(define-syntax stream*
(syntax-rules ()
((stream* tail) tail)
((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...)))))
(define (iline label value) `(line ,label ,value))
(define-generic inspect (o))
(define-method inspect ((o <object>))
(cond ((environment? o) (inspect-environment o))
((vector? o) (inspect-vector o))
((procedure? o) (inspect-procedure o))
((compiled-code-block? o) (inspect-code-block o))
;;((system-pair? o) (inspect-system-pair o))
((probably-scode? o) (inspect-scode o))
(else (inspect-fallback o))))
(define (inspect-fallback o)
(let* ((class (object-class o))
(slots (class-slots class)))
(stream*
(iline "Class" class)
(let loop ((slots slots))
(cond ((null? slots) (stream))
(else
(let ((n (slot-name (car slots))))
(stream* (iline n (slot-value o n))
(loop (cdr slots))))))))))
(define-method inspect ((o <pair>))
(if (or (pair? (cdr o)) (null? (cdr o)))
(inspect-list o)
(inspect-cons o)))
(define (inspect-cons o)
(stream (iline "car" (car o))
(iline "cdr" (cdr o))))
(define (inspect-list o)
(let loop ((i 0) (o o))
(cond ((null? o) (stream))
((or (pair? (cdr o)) (null? (cdr o)))
(stream* (iline i (car o))
(loop (1+ i) (cdr o))))
(else
(stream (iline i (car o))
(iline "tail" (cdr o)))))))
(define (inspect-environment o)
(stream*
(iline "(package)" (environment->package o))
(let loop ((bs (environment-bindings o)))
(cond ((null? bs)
(if (environment-has-parent? o)
(stream (iline "(<parent>)" (environment-parent o)))
(stream)))
(else
(let* ((b (car bs)) (s (car b)))
(cond ((null? (cdr b))
(stream* s " {" (environment-reference-type o s) "}\n"
(loop (cdr bs))))
(else
(stream* (iline s (cadr b))
(loop (cdr bs)))))))))))
(define (inspect-vector o)
(let ((len (vector-length o)))
(let loop ((i 0))
(cond ((= i len) (stream))
(else (stream* (iline i (vector-ref o i))
(loop (1+ i))))))))
(define (inspect-procedure o)
(cond ((primitive-procedure? o)
(stream (iline "name" (primitive-procedure-name o))
(iline "arity" (primitive-procedure-arity o))
(iline "doc" (primitive-procedure-documentation o))))
((compound-procedure? o)
(stream (iline "arity" (procedure-arity o))
(iline "lambda" (procedure-lambda o))
(iline "env" (ignore-errors
(lambda () (procedure-environment o))))))
(else
(stream
(iline "block" (compiled-entry/block o))
(with-output-to-string (lambda () (compiler:disassemble o)))))))
(define (inspect-code-block o)
(stream-append
(let loop ((i (compiled-code-block/constants-start o)))
(cond ((>= i (compiled-code-block/constants-end o)) (stream))
(else
(stream*
(iline i (system-vector-ref o i))
(loop (+ i compiled-code-block/bytes-per-object))))))
(stream (iline "debuginfo" (compiled-code-block/debugging-info o))
(iline "env" (compiled-code-block/environment o))
(with-output-to-string (lambda () (compiler:disassemble o))))))
(define (inspect-scode o)
(stream (pprint-to-string o)))
(define (probably-scode? o)
(define tests (list access? assignment? combination? comment?
conditional? definition? delay? disjunction? lambda?
quotation? sequence? the-environment? variable?))
(let loop ((tests tests))
(cond ((null? tests) #f)
(((car tests) o))
(else (loop (cdr tests))))))
(define (inspect-system-pair o)
(stream (iline "car" (system-pair-car o))
(iline "cdr" (system-pair-cdr o))))
;;;; Auxilary functions
(define nil '())
(define t 't)
(define (elisp-false? o) (member o '(nil ())))
(define (elisp-true? o) (not (elisp-false? o)))
(define (>line o)
(let ((r (write-to-string o 100)))
(cond ((not (car r)) (cdr r))
(else (string-append (cdr r) " ..")))))
;; Must compile >line otherwise we can't write unassigend-reference-traps.
(set! >line (compile-procedure >line))
(define (read-from-string s) (with-input-from-string s read))
(define (pprint-to-string o)
(with-string-output-port
(lambda (p)
(fluid-let ((*unparser-list-breadth-limit* 10)
(*unparser-list-depth-limit* 4)
(*unparser-string-length-limit* 100))
(pp o p)))))
;(define (1+ n) (+ n 1))
(define (1- n) (- n 1))
(define (package-lookup package name)
(let ((p (if (package? package) package (find-package package))))
(environment-lookup (package/environment p) name)))
(define log-port (current-output-port))
(define (log-event fstring . args)
;;(apply format log-port fstring args)
#f
)
;; Modified for Slimv:
;; - restart swank server in a loop
(let loop ()
(swank 4005)
(loop))
;;; swank-mit-scheme.scm ends here

162
sources_non_forked/slimv/slime/contrib/swank-mrepl.lisp Normal file
View File

@ -0,0 +1,162 @@
;;; swank-mrepl.lisp
;;
;; Licence: public domain
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((api '(
*emacs-connection*
channel
channel-id
define-channel-method
defslimefun
dcase
log-event
process-requests
send-to-remote-channel
use-threads-p
wait-for-event
with-bindings
with-connection
with-top-level-restart
with-slime-interrupts
)))
(eval `(defpackage #:swank-api
(:use)
(:import-from #:swank . ,api)
(:export . ,api)))))
(defpackage :swank-mrepl
(:use :cl :swank-api)
(:export #:create-mrepl))
(in-package :swank-mrepl)
(defclass listener-channel (channel)
((remote :initarg :remote)
(env :initarg :env)
(mode :initform :eval)
(tag :initform nil)))
(defun package-prompt (package)
(reduce (lambda (x y) (if (<= (length x) (length y)) x y))
(cons (package-name package) (package-nicknames package))))
(defslimefun create-mrepl (remote)
(let* ((pkg *package*)
(conn *emacs-connection*)
(thread (if (use-threads-p)
(spawn-listener-thread conn)
nil))
(ch (make-instance 'listener-channel :remote remote :thread thread)))
(setf (slot-value ch 'env) (initial-listener-env ch))
(when thread
(swank/backend:send thread `(:serve-channel ,ch)))
(list (channel-id ch)
(swank/backend:thread-id (or thread (swank/backend:current-thread)))
(package-name pkg)
(package-prompt pkg))))
(defun initial-listener-env (listener)
`((*package* . ,*package*)
(*standard-output* . ,(make-listener-output-stream listener))
(*standard-input* . ,(make-listener-input-stream listener))))
(defun spawn-listener-thread (connection)
(swank/backend:spawn
(lambda ()
(with-connection (connection)
(dcase (swank/backend:receive)
((:serve-channel c)
(loop
(with-top-level-restart (connection (drop-unprocessed-events c))
(process-requests nil)))))))
:name "mrepl thread"))
(defun drop-unprocessed-events (channel)
(with-slots (mode) channel
(let ((old-mode mode))
(setf mode :drop)
(unwind-protect
(process-requests t)
(setf mode old-mode)))
(send-prompt channel)))
(define-channel-method :process ((c listener-channel) string)
(log-event ":process ~s~%" string)
(with-slots (mode remote) c
(ecase mode
(:eval (mrepl-eval c string))
(:read (mrepl-read c string))
(:drop))))
(defun mrepl-eval (channel string)
(with-slots (remote env) channel
(let ((aborted t))
(with-bindings env
(unwind-protect
(let ((result (with-slime-interrupts (read-eval-print string))))
(send-to-remote-channel remote `(:write-result ,result))
(setq aborted nil))
(setf env (loop for (sym) in env
collect (cons sym (symbol-value sym))))
(cond (aborted
(send-to-remote-channel remote `(:evaluation-aborted)))
(t
(send-prompt channel))))))))
(defun send-prompt (channel)
(with-slots (env remote) channel
(let ((pkg (or (cdr (assoc '*package* env)) *package*))
(out (cdr (assoc '*standard-output* env)))
(in (cdr (assoc '*standard-input* env))))
(when out (force-output out))
(when in (clear-input in))
(send-to-remote-channel remote `(:prompt ,(package-name pkg)
,(package-prompt pkg))))))
(defun mrepl-read (channel string)
(with-slots (tag) channel
(assert tag)
(throw tag string)))
(defun read-eval-print (string)
(with-input-from-string (in string)
(setq / ())
(loop
(let* ((form (read in nil in)))
(cond ((eq form in) (return))
(t (setq / (multiple-value-list (eval (setq + form))))))))
(force-output)
(if /
(format nil "~{~s~%~}" /)
"; No values")))
(defun make-listener-output-stream (channel)
(let ((remote (slot-value channel 'remote)))
(swank/backend:make-output-stream
(lambda (string)
(send-to-remote-channel remote `(:write-string ,string))))))
(defun make-listener-input-stream (channel)
(swank/backend:make-input-stream (lambda () (read-input channel))))
(defun set-mode (channel new-mode)
(with-slots (mode remote) channel
(unless (eq mode new-mode)
(send-to-remote-channel remote `(:set-read-mode ,new-mode)))
(setf mode new-mode)))
(defun read-input (channel)
(with-slots (mode tag remote) channel
(force-output)
(let ((old-mode mode)
(old-tag tag))
(setf tag (cons nil nil))
(set-mode channel :read)
(unwind-protect
(catch tag (process-requests nil))
(setf tag old-tag)
(set-mode channel old-mode)))))
(provide :swank-mrepl)

65
sources_non_forked/slimv/slime/contrib/swank-package-fu.lisp Normal file
View File

@ -0,0 +1,65 @@
(in-package :swank)
(defslimefun package= (string1 string2)
(let* ((pkg1 (guess-package string1))
(pkg2 (guess-package string2)))
(and pkg1 pkg2 (eq pkg1 pkg2))))
(defslimefun 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)))))
(defslimefun 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 (swank-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 (swank-mop:slot-definition-readers slot))
(copy-list (swank-mop:slot-definition-readers slot))
:key #'extract-symbol)))
(list* (class-name class)
(mapcan #'slot-accessors slots)))))
(defslimefun 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 :swank-package-fu)

334
sources_non_forked/slimv/slime/contrib/swank-presentation-streams.lisp Normal file
View File

@ -0,0 +1,334 @@
;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities
;;; to portions of output
;;;
;;; Authors: Alan Ruttenberg <alanr-l@mumble.net>
;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;;; Helmut Eller <heller@common-lisp.net>
;;;
;;; License: This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-presentations))
;; This file contains a mechanism for printing to the slime repl so
;; that the printed result remembers what object it is associated
;; with. This extends the recording of REPL results.
;;
;; There are two methods:
;;
;; 1. Depends on the ilisp bridge code being installed and ready to
;; intercept messages in the printed stream. We encode the
;; information with a message saying that we are starting to print
;; an object corresponding to a given id and another when we are
;; done. The process filter notices these and adds the necessary
;; text properties to the output.
;;
;; 2. Use separate protocol messages :presentation-start and
;; :presentation-end for sending presentations.
;;
;; We only do this if we know we are printing to a slime stream,
;; checked with the method slime-stream-p. Initially this checks for
;; the knows slime streams looking at *connections*. In cmucl, sbcl, and
;; openmcl it also checks if it is a pretty-printing stream which
;; ultimately prints to a slime stream.
;;
;; Method 1 seems to be faster, but the printed escape sequences can
;; disturb the column counting, and thus the layout in pretty-printing.
;; We use method 1 when a dedicated output stream is used.
;;
;; Method 2 is cleaner and works with pretty printing if the pretty
;; printers support "annotations". We use method 2 when no dedicated
;; output stream is used.
;; Control
(defvar *enable-presenting-readable-objects* t
"set this to enable automatically printing presentations for some
subset of readable objects, such as pathnames." )
;; doing it
(defmacro presenting-object (object stream &body body)
"What you use in your code. Wrap this around some printing and that text will
be sensitive and remember what object it is in the repl"
`(presenting-object-1 ,object ,stream #'(lambda () ,@body)))
(defmacro presenting-object-if (predicate object stream &body body)
"What you use in your code. Wrap this around some printing and that text will
be sensitive and remember what object it is in the repl if predicate is true"
(let ((continue (gensym)))
`(let ((,continue #'(lambda () ,@body)))
(if ,predicate
(presenting-object-1 ,object ,stream ,continue)
(funcall ,continue)))))
;;; Get pretty printer patches for SBCL at load (not compile) time.
#+#:disable-dangerous-patching ; #+sbcl
(eval-when (:load-toplevel)
(handler-bind ((simple-error
(lambda (c)
(declare (ignore c))
(let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
(when clobber-it (invoke-restart clobber-it))))))
(sb-ext:without-package-locks
(swank/sbcl::with-debootstrapping
(load (make-pathname
:name "sbcl-pprint-patch"
:type "lisp"
:directory (pathname-directory
swank-loader:*source-directory*)))))))
(let ((last-stream nil)
(last-answer nil))
(defun slime-stream-p (stream)
"Check if stream is one of the slime streams, since if it isn't we
don't want to present anything.
Two special return values:
:DEDICATED -- Output ends up on a dedicated output stream
:REPL-RESULT -- Output ends up on the :repl-results target.
"
(if (eq last-stream stream)
last-answer
(progn
(setq last-stream stream)
(if (eq stream t)
(setq stream *standard-output*))
(setq last-answer
(or #+openmcl
(and (typep stream 'ccl::xp-stream)
;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure)))
(slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1)))
#+cmu
(or (and (typep stream 'lisp::indenting-stream)
(slime-stream-p (lisp::indenting-stream-stream stream)))
(and (typep stream 'pretty-print::pretty-stream)
(fboundp 'pretty-print::enqueue-annotation)
(let ((slime-stream-p
(slime-stream-p (pretty-print::pretty-stream-target stream))))
(and ;; Printing through CMUCL pretty
;; streams is only cleanly
;; possible if we are using the
;; bridge-less protocol with
;; annotations, because the bridge
;; escape sequences disturb the
;; pretty printer layout.
(not (eql slime-stream-p :dedicated-output))
;; If OK, return the return value
;; we got from slime-stream-p on
;; the target stream (could be
;; :repl-result):
slime-stream-p))))
#+sbcl
(let ()
(declare (notinline sb-pretty::pretty-stream-target))
(and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))
(find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)
(not *use-dedicated-output-stream*)
(slime-stream-p (sb-pretty::pretty-stream-target stream))))
#+allegro
(and (typep stream 'excl:xp-simple-stream)
(slime-stream-p (excl::stream-output-handle stream)))
(loop for connection in *connections*
thereis (or (and (eq stream (connection.dedicated-output connection))
:dedicated)
(eq stream (connection.socket-io connection))
(eq stream (connection.user-output connection))
(eq stream (connection.user-io connection))
(and (eq stream (connection.repl-results connection))
:repl-result)))))))))
(defun can-present-readable-objects (&optional stream)
(declare (ignore stream))
*enable-presenting-readable-objects*)
;; If we are printing to an XP (pretty printing) stream, printing the
;; escape sequences directly would mess up the layout because column
;; counting is disturbed. Use "annotations" instead.
#+allegro
(defun write-annotation (stream function arg)
(if (typep stream 'excl:xp-simple-stream)
(excl::schedule-annotation stream function arg)
(funcall function arg stream nil)))
#+cmu
(defun write-annotation (stream function arg)
(if (and (typep stream 'pp:pretty-stream)
(fboundp 'pp::enqueue-annotation))
(pp::enqueue-annotation stream function arg)
(funcall function arg stream nil)))
#+sbcl
(defun write-annotation (stream function arg)
(let ((enqueue-annotation
(find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)))
(if (and enqueue-annotation
(typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)))
(funcall enqueue-annotation stream function arg)
(funcall function arg stream nil))))
#-(or allegro cmu sbcl)
(defun write-annotation (stream function arg)
(funcall function arg stream nil))
(defstruct presentation-record
(id)
(printed-p)
(target))
(defun presentation-start (record stream truncatep)
(unless truncatep
;; Don't start new presentations when nothing is going to be
;; printed due to *print-lines*.
(let ((pid (presentation-record-id record))
(target (presentation-record-target record)))
(case target
(:dedicated
;; Use bridge protocol
(write-string "<" stream)
(prin1 pid stream)
(write-string "" stream))
(t
(finish-output stream)
(send-to-emacs `(:presentation-start ,pid ,target)))))
(setf (presentation-record-printed-p record) t)))
(defun presentation-end (record stream truncatep)
(declare (ignore truncatep))
;; Always end old presentations that were started.
(when (presentation-record-printed-p record)
(let ((pid (presentation-record-id record))
(target (presentation-record-target record)))
(case target
(:dedicated
;; Use bridge protocol
(write-string ">" stream)
(prin1 pid stream)
(write-string "" stream))
(t
(finish-output stream)
(send-to-emacs `(:presentation-end ,pid ,target)))))))
(defun presenting-object-1 (object stream continue)
"Uses the bridge mechanism with two messages >id and <id. The first one
says that I am starting to print an object with this id. The second says I am finished"
;; this declare special is to let the compiler know that *record-repl-results* will eventually be
;; a global special, even if it isn't when this file is compiled/loaded.
(declare (special *record-repl-results*))
(let ((slime-stream-p
(and *record-repl-results* (slime-stream-p stream))))
(if slime-stream-p
(let* ((pid (swank::save-presented-object object))
(record (make-presentation-record :id pid :printed-p nil
:target (if (eq slime-stream-p :repl-result)
:repl-result
nil))))
(write-annotation stream #'presentation-start record)
(multiple-value-prog1
(funcall continue)
(write-annotation stream #'presentation-end record)))
(funcall continue))))
(defun present-repl-results-via-presentation-streams (values)
;; Override a function in swank.lisp, so that
;; nested presentations work in the REPL result.
(let ((repl-results (connection.repl-results *emacs-connection*)))
(flet ((send (value)
(presenting-object value repl-results
(prin1 value repl-results))
(terpri repl-results)))
(if (null values)
(progn
(princ "; No value" repl-results)
(terpri repl-results))
(mapc #'send values)))
(finish-output repl-results)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+openmcl
(in-package :ccl)
#+openmcl
(defun monkey-patch-stream-printing ()
(let ((*warn-if-redefine-kernel* nil)
(*warn-if-redefine* nil))
(defun %print-unreadable-object (object stream type id thunk)
(cond ((null stream) (setq stream *standard-output*))
((eq stream t) (setq stream *terminal-io*)))
(swank::presenting-object object stream
(write-unreadable-start object stream)
(when type
(princ (type-of object) stream)
(stream-write-char stream #\space))
(when thunk
(funcall thunk))
(if id
(%write-address object stream #\>)
(pp-end-block stream ">"))
nil))
(defmethod print-object :around ((pathname pathname) stream)
(swank::presenting-object-if
(swank::can-present-readable-objects stream)
pathname stream (call-next-method))))
(ccl::def-load-pointers clear-presentations ()
(swank::clear-presentation-tables)))
(in-package :swank)
#+cmu
(progn
(fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body)
(presenting-object object stream
(fwrappers:call-next-function)))
(fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth)
(presenting-object-if (can-present-readable-objects stream) pathname stream
(fwrappers:call-next-function)))
(defun monkey-patch-stream-printing ()
(fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper)
(fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper)))
#+sbcl
(progn
(defvar *saved-%print-unreadable-object*
(fdefinition 'sb-impl::%print-unreadable-object))
(defun monkey-patch-stream-printing ()
(sb-ext:without-package-locks
(when (eq (fdefinition 'sb-impl::%print-unreadable-object)
*saved-%print-unreadable-object*)
(setf (fdefinition 'sb-impl::%print-unreadable-object)
(lambda (object stream &rest args)
(presenting-object object stream
(apply *saved-%print-unreadable-object*
object stream args)))))
(defmethod print-object :around ((object pathname) stream)
(presenting-object object stream
(call-next-method))))))
#+allegro
(progn
(excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation)
(swank::presenting-object object stream (excl:call-next-fwrapper)))
(excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth)
(presenting-object-if (can-present-readable-objects stream) pathname stream
(excl:call-next-fwrapper)))
(defun monkey-patch-stream-printing ()
(excl:fwrap 'excl::print-unreadable-object-1
'print-unreadable-present 'presenting-unreadable-wrapper)
(excl:fwrap 'excl::pathname-printer
'print-pathname-present 'presenting-pathname-wrapper)))
#-(or allegro sbcl cmu openmcl)
(defun monkey-patch-stream-printing ()
(values))
;; Hook into SWANK.
(defslimefun init-presentation-streams ()
(monkey-patch-stream-printing)
;; FIXME: import/use swank-repl to avoid package qualifier.
(setq swank-repl:*send-repl-results-function*
'present-repl-results-via-presentation-streams))
(provide :swank-presentation-streams)

246
sources_non_forked/slimv/slime/contrib/swank-presentations.lisp Normal file
View File

@ -0,0 +1,246 @@
;;; swank-presentations.lisp --- imitate LispM's presentations
;;
;; Authors: Alan Ruttenberg <alanr-l@mumble.net>
;; Luke Gorrie <luke@synap.se>
;; Helmut Eller <heller@common-lisp.net>
;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;;
;; License: This code has been placed in the Public Domain. All warranties
;; are disclaimed.
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-repl))
;;;; Recording and accessing results of computations
(defvar *record-repl-results* t
"Non-nil means that REPL results are saved for later lookup.")
(defvar *object-to-presentation-id*
(make-weak-key-hash-table :test 'eq)
"Store the mapping of objects to numeric identifiers")
(defvar *presentation-id-to-object*
(make-weak-value-hash-table :test 'eql)
"Store the mapping of numeric identifiers to objects")
(defun clear-presentation-tables ()
(clrhash *object-to-presentation-id*)
(clrhash *presentation-id-to-object*))
(defvar *presentation-counter* 0 "identifier counter")
(defvar *nil-surrogate* (make-symbol "nil-surrogate"))
;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
;; rest of slime isn't thread safe either), do we really care?
(defun save-presented-object (object)
"Save OBJECT and return the assigned id.
If OBJECT was saved previously return the old id."
(let ((object (if (null object) *nil-surrogate* object)))
;; We store *nil-surrogate* instead of nil, to distinguish it from
;; an object that was garbage collected.
(or (gethash object *object-to-presentation-id*)
(let ((id (incf *presentation-counter*)))
(setf (gethash id *presentation-id-to-object*) object)
(setf (gethash object *object-to-presentation-id*) id)
id))))
(defslimefun lookup-presented-object (id)
"Retrieve the object corresponding to ID.
The secondary value indicates the absence of an entry."
(etypecase id
(integer
;;
(multiple-value-bind (object foundp)
(gethash id *presentation-id-to-object*)
(cond
((eql object *nil-surrogate*)
;; A stored nil object
(values nil t))
((null object)
;; Object that was replaced by nil in the weak hash table
;; when the object was garbage collected.
(values nil nil))
(t
(values object foundp)))))
(cons
(dcase id
((:frame-var thread-id frame index)
(declare (ignore thread-id)) ; later
(handler-case
(frame-var-value frame index)
(t (condition)
(declare (ignore condition))
(values nil nil))
(:no-error (value)
(values value t))))
((:inspected-part part-index)
(inspector-nth-part part-index))))))
(defslimefun lookup-presented-object-or-lose (id)
"Get the result of the previous REPL evaluation with ID."
(multiple-value-bind (object foundp) (lookup-presented-object id)
(cond (foundp object)
(t (error "Attempt to access unrecorded object (id ~D)." id)))))
(defslimefun lookup-and-save-presented-object-or-lose (id)
"Get the object associated with ID and save it in the presentation tables."
(let ((obj (lookup-presented-object-or-lose id)))
(save-presented-object obj)))
(defslimefun clear-repl-results ()
"Forget the results of all previous REPL evaluations."
(clear-presentation-tables)
t)
(defun present-repl-results (values)
;; Override a function in swank.lisp, so that
;; presentations are associated with every REPL result.
(flet ((send (value)
(let ((id (and *record-repl-results*
(save-presented-object value))))
(send-to-emacs `(:presentation-start ,id :repl-result))
(send-to-emacs `(:write-string ,(prin1-to-string value)
:repl-result))
(send-to-emacs `(:presentation-end ,id :repl-result))
(send-to-emacs `(:write-string ,(string #\Newline)
:repl-result)))))
(fresh-line)
(finish-output)
(if (null values)
(send-to-emacs `(:write-string "; No value" :repl-result))
(mapc #'send values))))
;;;; Presentation menu protocol
;;
;; To define a menu for a type of object, define a method
;; menu-choices-for-presentation on that object type. This function
;; should return a list of two element lists where the first element is
;; the name of the menu action and the second is a function that will be
;; called if the menu is chosen. The function will be called with 3
;; arguments:
;;
;; choice: The string naming the action from above
;;
;; object: The object
;;
;; id: The presentation id of the object
;;
;; You might want append (when (next-method-p) (call-next-method)) to
;; pick up the Menu actions of superclasses.
;;
(defvar *presentation-active-menu* nil)
(defun menu-choices-for-presentation-id (id)
(multiple-value-bind (ob presentp) (lookup-presented-object id)
(cond ((not presentp) 'not-present)
(t
(let ((menu-and-actions (menu-choices-for-presentation ob)))
(setq *presentation-active-menu* (cons id menu-and-actions))
(mapcar 'car menu-and-actions))))))
(defun swank-ioify (thing)
(cond ((keywordp thing) thing)
((and (symbolp thing)(not (find #\: (symbol-name thing))))
(intern (symbol-name thing) 'swank-io-package))
((consp thing) (cons (swank-ioify (car thing))
(swank-ioify (cdr thing))))
(t thing)))
(defun execute-menu-choice-for-presentation-id (id count item)
(let ((ob (lookup-presented-object id)))
(assert (equal id (car *presentation-active-menu*)) ()
"Bug: Execute menu call for id ~a but menu has id ~a"
id (car *presentation-active-menu*))
(let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
(swank-ioify (funcall action item ob id)))))
(defgeneric menu-choices-for-presentation (object)
(:method (ob) (declare (ignore ob)) nil)) ; default method
;; Pathname
(defmethod menu-choices-for-presentation ((ob pathname))
(let* ((file-exists (ignore-errors (probe-file ob)))
(lisp-type (make-pathname :type "lisp"))
(source-file (and (not (member (pathname-type ob) '("lisp" "cl")
:test 'equal))
(let ((source (merge-pathnames lisp-type ob)))
(and (ignore-errors (probe-file source))
source))))
(fasl-file (and file-exists
(equal (ignore-errors
(namestring
(truename
(compile-file-pathname
(merge-pathnames lisp-type ob)))))
(namestring (truename ob))))))
(remove nil
(list*
(and (and file-exists (not fasl-file))
(list "Edit this file"
(lambda(choice object id)
(declare (ignore choice id))
(ed-in-emacs (namestring (truename object)))
nil)))
(and file-exists
(list "Dired containing directory"
(lambda (choice object id)
(declare (ignore choice id))
(ed-in-emacs (namestring
(truename
(merge-pathnames
(make-pathname :name "" :type "")
object))))
nil)))
(and fasl-file
(list "Load this fasl file"
(lambda (choice object id)
(declare (ignore choice id object))
(load ob)
nil)))
(and fasl-file
(list "Delete this fasl file"
(lambda (choice object id)
(declare (ignore choice id object))
(let ((nt (namestring (truename ob))))
(when (y-or-n-p-in-emacs "Delete ~a? " nt)
(delete-file nt)))
nil)))
(and source-file
(list "Edit lisp source file"
(lambda (choice object id)
(declare (ignore choice id object))
(ed-in-emacs (namestring (truename source-file)))
nil)))
(and source-file
(list "Load lisp source file"
(lambda(choice object id)
(declare (ignore choice id object))
(load source-file)
nil)))
(and (next-method-p) (call-next-method))))))
(defmethod menu-choices-for-presentation ((ob function))
(list (list "Disassemble"
(lambda (choice object id)
(declare (ignore choice id))
(disassemble object)))))
(defslimefun inspect-presentation (id reset-p)
(let ((what (lookup-presented-object-or-lose id)))
(when reset-p
(reset-inspector))
(inspect-object what)))
(defslimefun init-presentations ()
;; FIXME: import/use swank-repl to avoid package qualifier.
(setq swank-repl:*send-repl-results-function* 'present-repl-results))
(provide :swank-presentations)

17
sources_non_forked/slimv/slime/contrib/swank-quicklisp.lisp Normal file
View File

@ -0,0 +1,17 @@
;;; swank-quicklisp.lisp -- Quicklisp support
;;
;; Authors: Matthew Kennedy <burnsidemk@gmail.com>
;; License: Public Domain
;;
(in-package :swank)
(defslimefun list-quicklisp-systems ()
"Returns the Quicklisp systems list."
(if (member :quicklisp *features*)
(let ((ql-dist-name (find-symbol "NAME" "QL-DIST"))
(ql-system-list (find-symbol "SYSTEM-LIST" "QL")))
(mapcar ql-dist-name (funcall ql-system-list)))
(error "Could not find Quicklisp already loaded.")))
(provide :swank-quicklisp)

416
sources_non_forked/slimv/slime/contrib/swank-r6rs.scm Normal file
View File

@ -0,0 +1,416 @@
;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny
;;
;; Licence: public domain
;; Author: Helmut Eller
;;
;; This is a Swank server barely capable enough to process simple eval
;; requests from Emacs before dying. No fancy features like
;; backtraces, module redefintion, M-. etc. are implemented. Don't
;; even think about pc-to-source mapping.
;;
;; Despite standard modules, this file uses (swank os) and (swank sys)
;; which define implementation dependend functionality. There are
;; multiple modules in this files, which is probably not standardized.
;;
;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c
(library (swank format)
(export format printf fprintf)
(import (rnrs))
(define (format f . args)
(call-with-string-output-port
(lambda (port) (apply fprintf port f args))))
(define (printf f . args)
(let ((port (current-output-port)))
(apply fprintf port f args)
(flush-output-port port)))
(define (fprintf port f . args)
(let ((len (string-length f)))
(let loop ((i 0) (args args))
(cond ((= i len) (assert (null? args)))
((and (char=? (string-ref f i) #\~)
(< (+ i 1) len))
(dispatch-format (string-ref f (+ i 1)) port (car args))
(loop (+ i 2) (cdr args)))
(else
(put-char port (string-ref f i))
(loop (+ i 1) args))))))
(define (dispatch-format char port arg)
(let ((probe (assoc char format-dispatch-table)))
(cond (probe ((cdr probe) arg port))
(else (error "invalid format char: " char)))))
(define format-dispatch-table
`((#\a . ,display)
(#\s . ,write)
(#\d . ,(lambda (arg port) (put-string port (number->string arg 10))))
(#\x . ,(lambda (arg port) (put-string port (number->string arg 16))))
(#\c . ,(lambda (arg port) (put-char port arg))))))
;; CL-style restarts to let us continue after errors.
(library (swank restarts)
(export with-simple-restart compute-restarts invoke-restart restart-name
write-restart-report)
(import (rnrs))
(define *restarts* '())
(define-record-type restart
(fields name reporter continuation))
(define (with-simple-restart name reporter thunk)
(call/cc
(lambda (k)
(let ((old-restarts *restarts*)
(restart (make-restart name (coerce-to-reporter reporter) k)))
(dynamic-wind
(lambda () (set! *restarts* (cons restart old-restarts)))
thunk
(lambda () (set! *restarts* old-restarts)))))))
(define (compute-restarts) *restarts*)
(define (invoke-restart restart . args)
(apply (restart-continuation restart) args))
(define (write-restart-report restart port)
((restart-reporter restart) port))
(define (coerce-to-reporter obj)
(cond ((string? obj) (lambda (port) (put-string port obj)))
(#t (assert (procedure? obj)) obj)))
)
;; This module encodes & decodes messages from the wire and queues them.
(library (swank event-queue)
(export make-event-queue wait-for-event enqueue-event
read-event write-event)
(import (rnrs)
(rnrs mutable-pairs)
(swank format))
(define-record-type event-queue
(fields (mutable q) wait-fun)
(protocol (lambda (init)
(lambda (wait-fun)
(init '() wait-fun)))))
(define (wait-for-event q pattern)
(or (poll q pattern)
(begin
((event-queue-wait-fun q) q)
(wait-for-event q pattern))))
(define (poll q pattern)
(let loop ((lag #f)
(l (event-queue-q q)))
(cond ((null? l) #f)
((event-match? (car l) pattern)
(cond (lag
(set-cdr! lag (cdr l))
(car l))
(else
(event-queue-q-set! q (cdr l))
(car l))))
(else (loop l (cdr l))))))
(define (event-match? event pattern)
(cond ((or (number? pattern)
(member pattern '(t nil)))
(equal? event pattern))
((symbol? pattern) #t)
((pair? pattern)
(case (car pattern)
((quote) (equal? event (cadr pattern)))
((or) (exists (lambda (p) (event-match? event p)) (cdr pattern)))
(else (and (pair? event)
(event-match? (car event) (car pattern))
(event-match? (cdr event) (cdr pattern))))))
(else (error "Invalid pattern: " pattern))))
(define (enqueue-event q event)
(event-queue-q-set! q
(append (event-queue-q q)
(list event))))
(define (write-event event port)
(let ((payload (call-with-string-output-port
(lambda (port) (write event port)))))
(write-length (string-length payload) port)
(put-string port payload)
(flush-output-port port)))
(define (write-length len port)
(do ((i 24 (- i 4)))
((= i 0))
(put-string port
(number->string (bitwise-bit-field len (- i 4) i)
16))))
(define (read-event port)
(let* ((header (string-append (get-string-n port 2)
(get-string-n port 2)
(get-string-n port 2)))
(_ (printf "header: ~s\n" header))
(len (string->number header 16))
(_ (printf "len: ~s\n" len))
(payload (get-string-n port len)))
(printf "payload: ~s\n" payload)
(read (open-string-input-port payload))))
)
;; Entry points for SLIME commands.
(library (swank rpc)
(export connection-info interactive-eval
;;compile-string-for-emacs
throw-to-toplevel sldb-abort
operator-arglist buffer-first-change
create-repl listener-eval)
(import (rnrs)
(rnrs eval)
(only (rnrs r5rs) scheme-report-environment)
(swank os)
(swank format)
(swank restarts)
(swank sys)
)
(define (connection-info . _)
`(,@'()
:pid ,(getpid)
:package (:name ">" :prompt ">")
:lisp-implementation (,@'()
:name ,(implementation-name)
:type "R6RS-Scheme")))
(define (interactive-eval string)
(call-with-values
(lambda ()
(eval-in-interaction-environment (read-from-string string)))
(case-lambda
(() "; no value")
((value) (format "~s" value))
(values (format "values: ~s" values)))))
(define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel))
(define (sldb-abort) (invoke-restart-by-name-or-nil 'abort))
(define (invoke-restart-by-name-or-nil name)
(let ((r (find (lambda (r) (eq? (restart-name r) name))
(compute-restarts))))
(if r (invoke-restart r) 'nil)))
(define (create-repl target)
(list "" ""))
(define (listener-eval string)
(call-with-values (lambda () (eval-region string))
(lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values)))))
(define (eval-region string)
(let ((sexp (read-from-string string)))
(if (eof-object? exp)
(values)
(eval-in-interaction-environment sexp))))
(define (read-from-string string)
(call-with-port (open-string-input-port string) read))
(define (operator-arglist . _) 'nil)
(define (buffer-first-change . _) 'nil)
)
;; The server proper. Does the TCP stuff and exception handling.
(library (swank)
(export start-server)
(import (rnrs)
(rnrs eval)
(swank os)
(swank format)
(swank event-queue)
(swank restarts))
(define-record-type connection
(fields in-port out-port event-queue))
(define (start-server port)
(accept-connections (or port 4005) #f))
(define (start-server/port-file port-file)
(accept-connections #f port-file))
(define (accept-connections port port-file)
(let ((sock (make-server-socket port)))
(printf "Listening on port: ~s\n" (local-port sock))
(when port-file
(write-port-file (local-port sock) port-file))
(let-values (((in out) (accept sock (latin-1-codec))))
(dynamic-wind
(lambda () #f)
(lambda ()
(close-socket sock)
(serve in out))
(lambda ()
(close-port in)
(close-port out))))))
(define (write-port-file port port-file)
(call-with-output-file
(lambda (file)
(write port file))))
(define (serve in out)
(let ((err (current-error-port))
(q (make-event-queue
(lambda (q)
(let ((e (read-event in)))
(printf "read: ~s\n" e)
(enqueue-event q e))))))
(dispatch-loop (make-connection in out q))))
(define-record-type sldb-state
(fields level condition continuation next))
(define (dispatch-loop conn)
(let ((event (wait-for-event (connection-event-queue conn) 'x)))
(case (car event)
((:emacs-rex)
(with-simple-restart
'toplevel "Return to SLIME's toplevel"
(lambda ()
(apply emacs-rex conn #f (cdr event)))))
(else (error "Unhandled event: ~s" event))))
(dispatch-loop conn))
(define (recover thunk on-error-thunk)
(let ((ok #f))
(dynamic-wind
(lambda () #f)
(lambda ()
(call-with-values thunk
(lambda vals
(set! ok #t)
(apply values vals))))
(lambda ()
(unless ok
(on-error-thunk))))))
;; Couldn't resist to exploit the prefix feature.
(define rpc-entries (environment '(prefix (swank rpc) swank:)))
(define (emacs-rex conn sldb-state form package thread tag)
(let ((out (connection-out-port conn)))
(recover
(lambda ()
(with-exception-handler
(lambda (condition)
(call/cc
(lambda (k)
(sldb-exception-handler conn condition k sldb-state))))
(lambda ()
(let ((value (apply (eval (car form) rpc-entries) (cdr form))))
(write-event `(:return (:ok ,value) ,tag) out)))))
(lambda ()
(write-event `(:return (:abort) ,tag) out)))))
(define (sldb-exception-handler connection condition k sldb-state)
(when (serious-condition? condition)
(let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1))
(out (connection-out-port connection)))
(write-event `(:debug 0 ,level ,@(debugger-info condition connection))
out)
(dynamic-wind
(lambda () #f)
(lambda ()
(sldb-loop connection
(make-sldb-state level condition k sldb-state)))
(lambda () (write-event `(:debug-return 0 ,level nil) out))))))
(define (sldb-loop connection state)
(apply emacs-rex connection state
(cdr (wait-for-event (connection-event-queue connection)
'(':emacs-rex . _))))
(sldb-loop connection state))
(define (debugger-info condition connection)
(list `(,(call-with-string-output-port
(lambda (port) (print-condition condition port)))
,(format " [type ~s]" (if (record? condition)
(record-type-name (record-rtd condition))
))
())
(map (lambda (r)
(list (format "~a" (restart-name r))
(call-with-string-output-port
(lambda (port)
(write-restart-report r port)))))
(compute-restarts))
'()
'()))
(define (print-condition obj port)
(cond ((condition? obj)
(let ((list (simple-conditions obj)))
(case (length list)
((0)
(display "Compuond condition with zero components" port))
((1)
(assert (eq? obj (car list)))
(print-simple-condition (car list) port))
(else
(display "Compound condition:\n" port)
(for-each (lambda (c)
(display " " port)
(print-simple-condition c port)
(newline port))
list)))))
(#t
(fprintf port "Non-condition object: ~s" obj))))
(define (print-simple-condition condition port)
(fprintf port "~a" (record-type-name (record-rtd condition)))
(case (count-record-fields condition)
((0) #f)
((1)
(fprintf port ": ")
(do-record-fields condition (lambda (name value) (write value port))))
(else
(fprintf port ":")
(do-record-fields condition (lambda (name value)
(fprintf port "\n~a: ~s" name value))))))
;; Call FUN with RECORD's rtd and parent rtds.
(define (do-record-rtds record fun)
(do ((rtd (record-rtd record) (record-type-parent rtd)))
((not rtd))
(fun rtd)))
;; Call FUN with RECORD's field names and values.
(define (do-record-fields record fun)
(do-record-rtds
record
(lambda (rtd)
(let* ((names (record-type-field-names rtd))
(len (vector-length names)))
(do ((i 0 (+ 1 i)))
((= i len))
(fun (vector-ref names i) ((record-accessor rtd i) record)))))))
;; Return the number of fields in RECORD
(define (count-record-fields record)
(let ((i 0))
(do-record-rtds
record (lambda (rtd)
(set! i (+ i (vector-length (record-type-field-names rtd))))))
i))
)

441
sources_non_forked/slimv/slime/contrib/swank-repl.lisp Normal file
View File

@ -0,0 +1,441 @@
;;; swank-repl.lisp --- Server side part of the Lisp listener.
;;
;; License: public domain
(in-package swank)
(defpackage swank-repl
(:use cl swank/backend)
(:export *send-repl-results-function*)
(:import-from
swank
*default-worker-thread-bindings*
*loopback-interface*
add-hook
*connection-closed-hook*
eval-region
with-buffer-syntax
connection
connection.socket-io
connection.repl-results
connection.user-input
connection.user-output
connection.user-io
connection.trace-output
connection.dedicated-output
connection.env
multithreaded-connection
mconn.active-threads
mconn.repl-thread
mconn.auto-flush-thread
use-threads-p
*emacs-connection*
default-connection
with-connection
send-to-emacs
*communication-style*
handle-requests
wait-for-event
make-tag
thread-for-evaluation
socket-quest
authenticate-client
encode-message
auto-flush-loop
clear-user-input
current-thread-id
cat
with-struct*
with-retry-restart
with-bindings
package-string-for-prompt
find-external-format-or-lose
defslimefun
;; FIXME: those should be exported from swank-repl only, but how to
;; do that whithout breaking init files?
*use-dedicated-output-stream*
*dedicated-output-stream-port*
*globally-redirect-io*))
(in-package swank-repl)
(defvar *use-dedicated-output-stream* nil
"When T swank will attempt to create a second connection to Emacs
which is used just to send output.")
(defvar *dedicated-output-stream-port* 0
"Which port we should use for the dedicated output stream.")
(defvar *dedicated-output-stream-buffering*
(if (eq *communication-style* :spawn) t nil)
"The buffering scheme that should be used for the output stream.
Valid values are nil, t, :line")
(defvar *globally-redirect-io* :started-from-emacs
"When T globally redirect all standard streams to Emacs.
When :STARTED-FROM-EMACS redirect when launched by M-x slime")
(defun globally-redirect-io-p ()
(case *globally-redirect-io*
((t) t)
(:started-from-emacs swank-loader:*started-from-emacs*)))
(defun open-streams (connection properties)
"Return the 5 streams for IO redirection:
DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
(let* ((input-fn
(lambda ()
(with-connection (connection)
(with-simple-restart (abort-read
"Abort reading input from Emacs.")
(read-user-input-from-emacs)))))
(dedicated-output (if *use-dedicated-output-stream*
(open-dedicated-output-stream
connection
(getf properties :coding-system))))
(in (make-input-stream input-fn))
(out (or dedicated-output
(make-output-stream (make-output-function connection))))
(io (make-two-way-stream in out))
(repl-results (swank:make-output-stream-for-target connection
:repl-result)))
(typecase connection
(multithreaded-connection
(setf (mconn.auto-flush-thread connection)
(make-auto-flush-thread out))))
(values dedicated-output in out io repl-results)))
(defun make-output-function (connection)
"Create function to send user output to Emacs."
(lambda (string)
(with-connection (connection)
(send-to-emacs `(:write-string ,string)))))
(defun open-dedicated-output-stream (connection coding-system)
"Open a dedicated output connection to the Emacs on SOCKET-IO.
Return an output stream suitable for writing program output.
This is an optimized way for Lisp to deliver output to Emacs."
(let ((socket (socket-quest *dedicated-output-stream-port* nil))
(ef (find-external-format-or-lose coding-system)))
(unwind-protect
(let ((port (local-port socket)))
(encode-message `(:open-dedicated-output-stream ,port
,coding-system)
(connection.socket-io connection))
(let ((dedicated (accept-connection
socket
:external-format ef
:buffering *dedicated-output-stream-buffering*
:timeout 30)))
(authenticate-client dedicated)
(close-socket socket)
(setf socket nil)
dedicated))
(when socket
(close-socket socket)))))
(defmethod thread-for-evaluation ((connection multithreaded-connection)
(id (eql :find-existing)))
(or (car (mconn.active-threads connection))
(find-repl-thread connection)))
(defmethod thread-for-evaluation ((connection multithreaded-connection)
(id (eql :repl-thread)))
(find-repl-thread connection))
(defun find-repl-thread (connection)
(cond ((not (use-threads-p))
(current-thread))
(t
(let ((thread (mconn.repl-thread connection)))
(cond ((not thread) nil)
((thread-alive-p thread) thread)
(t
(setf (mconn.repl-thread connection)
(spawn-repl-thread connection "new-repl-thread"))))))))
(defun spawn-repl-thread (connection name)
(spawn (lambda ()
(with-bindings *default-worker-thread-bindings*
(repl-loop connection)))
:name name))
(defun repl-loop (connection)
(handle-requests connection))
;;;;; Redirection during requests
;;;
;;; We always redirect the standard streams to Emacs while evaluating
;;; an RPC. This is done with simple dynamic bindings.
(defslimefun create-repl (target &key coding-system)
(assert (eq target nil))
(let ((conn *emacs-connection*))
(initialize-streams-for-connection conn `(:coding-system ,coding-system))
(with-struct* (connection. @ conn)
(setf (@ env)
`((*standard-input* . ,(@ user-input))
,@(unless (globally-redirect-io-p)
`((*standard-output* . ,(@ user-output))
(*trace-output* . ,(or (@ trace-output) (@ user-output)))
(*error-output* . ,(@ user-output))
(*debug-io* . ,(@ user-io))
(*query-io* . ,(@ user-io))
(*terminal-io* . ,(@ user-io))))))
(maybe-redirect-global-io conn)
(add-hook *connection-closed-hook* 'update-redirection-after-close)
(typecase conn
(multithreaded-connection
(setf (mconn.repl-thread conn)
(spawn-repl-thread conn "repl-thread"))))
(list (package-name *package*)
(package-string-for-prompt *package*)))))
(defun initialize-streams-for-connection (connection properties)
(multiple-value-bind (dedicated in out io repl-results)
(open-streams connection properties)
(setf (connection.dedicated-output connection) dedicated
(connection.user-io connection) io
(connection.user-output connection) out
(connection.user-input connection) in
(connection.repl-results connection) repl-results)
connection))
(defun read-user-input-from-emacs ()
(let ((tag (make-tag)))
(force-output)
(send-to-emacs `(:read-string ,(current-thread-id) ,tag))
(let ((ok nil))
(unwind-protect
(prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
(setq ok t))
(unless ok
(send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
;;;;; Listener eval
(defvar *listener-eval-function* 'repl-eval)
(defvar *listener-saved-value* nil)
(defslimefun listener-save-value (slimefun &rest args)
"Apply SLIMEFUN to ARGS and save the value.
The saved value should be visible to all threads and retrieved via
LISTENER-GET-VALUE."
(setq *listener-saved-value* (apply slimefun args))
t)
(defslimefun listener-get-value ()
"Get the last value saved by LISTENER-SAVE-VALUE.
The value should be produced as if it were requested through
LISTENER-EVAL directly, so that spacial variables *, etc are set."
(listener-eval (let ((*package* (find-package :keyword)))
(write-to-string '*listener-saved-value*))))
(defslimefun listener-eval (string &key (window-width nil window-width-p))
(if window-width-p
(let ((*print-right-margin* window-width))
(funcall *listener-eval-function* string))
(funcall *listener-eval-function* string)))
(defslimefun clear-repl-variables ()
(let ((variables '(*** ** * /// // / +++ ++ +)))
(loop for variable in variables
do (setf (symbol-value variable) nil))))
(defvar *send-repl-results-function* 'send-repl-results-to-emacs)
(defun repl-eval (string)
(clear-user-input)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLIME REPL evaluation request.")
(track-package
(lambda ()
(multiple-value-bind (values last-form) (eval-region string)
(setq *** ** ** * * (car values)
/// // // / / values
+++ ++ ++ + + last-form)
(funcall *send-repl-results-function* values))))))
nil)
(defun track-package (fun)
(let ((p *package*))
(unwind-protect (funcall fun)
(unless (eq *package* p)
(send-to-emacs (list :new-package (package-name *package*)
(package-string-for-prompt *package*)))))))
(defun send-repl-results-to-emacs (values)
(finish-output)
(if (null values)
(send-to-emacs `(:write-string "; No value" :repl-result))
(dolist (v values)
(send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
:repl-result)))))
(defslimefun redirect-trace-output (target)
(setf (connection.trace-output *emacs-connection*)
(swank:make-output-stream-for-target *emacs-connection* target))
nil)
;;;; IO to Emacs
;;;
;;; This code handles redirection of the standard I/O streams
;;; (`*standard-output*', etc) into Emacs. The `connection' structure
;;; contains the appropriate streams, so all we have to do is make the
;;; right bindings.
;;;;; Global I/O redirection framework
;;;
;;; Optionally, the top-level global bindings of the standard streams
;;; can be assigned to be redirected to Emacs. When Emacs connects we
;;; redirect the streams into the connection, and they keep going into
;;; that connection even if more are established. If the connection
;;; handling the streams closes then another is chosen, or if there
;;; are no connections then 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.
;;;;; Global redirection setup
(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.")
(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)
(set-default-initial-binding stream-var `(quote ,stream)))))
(defun prefixed-var (prefix variable-symbol)
"(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
(let ((basename (subseq (symbol-name variable-symbol) 1)))
(intern (format nil "*~A-~A" (string prefix) basename) :swank)))
(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.")
(defun init-global-stream-redirection ()
(when (globally-redirect-io-p)
(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-io-to-connection (connection)
"Set the standard I/O streams to redirect to CONNECTION.
Assigns *CURRENT-<STREAM>* for all standard streams."
(dolist (o *standard-output-streams*)
(set (prefixed-var '#:current o)
(connection.user-output connection)))
;; 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)
(connection.user-io connection))))
(defun revert-global-io-redirection ()
"Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
(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))))
;;;;; Global redirection hooks
(defvar *global-stdio-connection* nil
"The connection to which standard I/O streams are globally redirected.
NIL if streams are not globally redirected.")
(defun maybe-redirect-global-io (connection)
"Consider globally redirecting to CONNECTION."
(when (and (globally-redirect-io-p) (null *global-stdio-connection*)
(connection.user-io connection))
(unless *saved-global-streams*
(init-global-stream-redirection))
(setq *global-stdio-connection* connection)
(globally-redirect-io-to-connection connection)))
(defun update-redirection-after-close (closed-connection)
"Update redirection after a connection closes."
(check-type closed-connection connection)
(when (eq *global-stdio-connection* closed-connection)
(if (and (default-connection) (globally-redirect-io-p))
;; Redirect to another connection.
(globally-redirect-io-to-connection (default-connection))
;; No more connections, revert to the real streams.
(progn (revert-global-io-redirection)
(setq *global-stdio-connection* nil)))))
(provide :swank-repl)

67
sources_non_forked/slimv/slime/contrib/swank-sbcl-exts.lisp Normal file
View File

@ -0,0 +1,67 @@
;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL
;;
;; Authors: Tobias C. Rittweiler <tcr@freebits.de>
;;
;; License: Public Domain
;;
(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-arglists))
;; We need to do this so users can place `slime-sbcl-exts' into their
;; ~/.emacs, and still use any implementation they want.
#+sbcl
(progn
;;; Display arglist of instructions.
;;;
(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst))
argument-forms)
(flet ((decode-instruction-arglist (instr-name instr-arglist)
(let ((decoded-arglist (decode-arglist instr-arglist)))
;; The arglist of INST is (instruction ...INSTR-ARGLIST...).
(push 'sb-assem::instruction (arglist.required-args decoded-arglist))
(values decoded-arglist
(list instr-name)
t))))
(if (null argument-forms)
(call-next-method)
(destructuring-bind (instruction &rest args) argument-forms
(declare (ignore args))
(let* ((instr-name
(typecase instruction
(arglist-dummy
(string-upcase (arglist-dummy.string-representation instruction)))
(symbol
(string-downcase instruction))))
(instr-fn
#+#.(swank/backend:with-symbol 'op-encoder-name 'sb-assem)
(or (sb-assem::op-encoder-name instr-name)
(sb-assem::op-encoder-name (string-upcase instr-name)))
#+#.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem)
(sb-assem::inst-emitter-symbol instr-name)
#+(and
(not #.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem))
#.(swank/backend:with-symbol '*assem-instructions* 'sb-assem))
(gethash instr-name sb-assem:*assem-instructions*)))
(cond ((functionp instr-fn)
(with-available-arglist (arglist) (arglist instr-fn)
(decode-instruction-arglist instr-name arglist)))
((fboundp instr-fn)
(with-available-arglist (arglist) (arglist instr-fn)
;; SB-ASSEM:INST invokes a symbolic INSTR-FN with
;; current segment and current vop implicitly.
(decode-instruction-arglist instr-name
(if (or (get instr-fn :macro)
(macro-function instr-fn))
arglist
(cddr arglist)))))
(t
(call-next-method))))))))
) ; PROGN
(provide :swank-sbcl-exts)

67
sources_non_forked/slimv/slime/contrib/swank-snapshot.lisp Normal file
View File

@ -0,0 +1,67 @@
(defpackage swank-snapshot
(:use cl)
(:export restore-snapshot save-snapshot background-save-snapshot)
(:import-from swank defslimefun))
(in-package swank-snapshot)
(defslimefun save-snapshot (image-file)
(swank/backend:save-image image-file
(let ((c swank::*emacs-connection*))
(lambda () (resurrect c))))
(format nil "Dumped lisp to ~A" image-file))
(defslimefun restore-snapshot (image-file)
(let* ((conn swank::*emacs-connection*)
(stream (swank::connection.socket-io conn))
(clone (swank/backend:dup (swank/backend:socket-fd stream)))
(style (swank::connection.communication-style conn))
(repl (if (swank::connection.user-io conn) t))
(args (list "--swank-fd" (format nil "~d" clone)
"--swank-style" (format nil "~s" style)
"--swank-repl" (format nil "~s" repl))))
(swank::close-connection conn nil nil)
(swank/backend:exec-image image-file args)))
(defslimefun background-save-snapshot (image-file)
(let ((connection swank::*emacs-connection*))
(flet ((complete (success)
(let ((swank::*emacs-connection* connection))
(swank::background-message
"Dumping lisp image ~A ~:[failed!~;succeeded.~]"
image-file success)))
(awaken ()
(resurrect connection)))
(swank/backend:background-save-image image-file
:restart-function #'awaken
:completion-function #'complete)
(format nil "Started dumping lisp to ~A..." image-file))))
(in-package :swank)
(defun swank-snapshot::resurrect (old-connection)
(setq *log-output* nil)
(init-log-output)
(clear-event-history)
(setq *connections* (delete old-connection *connections*))
(format *error-output* "args: ~s~%" (command-line-args))
(let* ((fd (read-command-line-arg "--swank-fd"))
(style (read-command-line-arg "--swank-style"))
(repl (read-command-line-arg "--swank-repl"))
(* (format *error-output* "fd=~s style=~s~%" fd style))
(stream (make-fd-stream fd nil))
(connection (make-connection nil stream style)))
(let ((*emacs-connection* connection))
(when repl (swank-repl:create-repl nil))
(background-message "~A" "Lisp image restored"))
(serve-requests connection)
(simple-repl)))
(defun read-command-line-arg (name)
(let* ((args (command-line-args))
(pos (position name args :test #'equal)))
(read-from-string (elt args (1+ pos)))))
(in-package :swank-snapshot)
(provide :swank-snapshot)

154
sources_non_forked/slimv/slime/contrib/swank-sprof.lisp Normal file
View File

@ -0,0 +1,154 @@
;;; swank-sprof.lisp
;;
;; Authors: Juho Snellman
;;
;; License: MIT
;;
(in-package :swank)
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sb-sprof))
#+sbcl(progn
(defvar *call-graph* nil)
(defvar *node-numbers* nil)
(defvar *number-nodes* nil)
(defun frame-name (name)
(if (consp name)
(case (first name)
((sb-c::xep sb-c::tl-xep
sb-c::&more-processor
sb-c::top-level-form
sb-c::&optional-processor)
(second name))
(sb-pcl::fast-method
(cdr name))
((flet labels lambda)
(let* ((in (member :in name)))
(if (stringp (cadr in))
(append (ldiff name in) (cddr in))
name)))
(t
name))
name))
(defun pretty-name (name)
(let ((*package* (find-package :common-lisp-user))
(*print-right-margin* most-positive-fixnum))
(format nil "~S" (frame-name name))))
(defun samples-percent (count)
(sb-sprof::samples-percent *call-graph* count))
(defun node-values (node)
(values (pretty-name (sb-sprof::node-name node))
(samples-percent (sb-sprof::node-count node))
(samples-percent (sb-sprof::node-accrued-count node))))
(defun filter-swank-nodes (nodes)
(let ((swank-packages (load-time-value
(mapcar #'find-package
'(swank swank/rpc swank/mop
swank/match swank/backend)))))
(remove-if (lambda (node)
(let ((name (sb-sprof::node-name node)))
(and (symbolp name)
(member (symbol-package name) swank-packages
:test #'eq))))
nodes)))
(defun serialize-call-graph (&key exclude-swank)
(let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*)))
(when exclude-swank
(setf nodes (filter-swank-nodes nodes)))
(setf nodes (sort (copy-list nodes) #'>
;; :key #'sb-sprof::node-count)))
:key #'sb-sprof::node-accrued-count))
(setf *number-nodes* (make-hash-table))
(setf *node-numbers* (make-hash-table))
(loop for node in nodes
for i from 1
with total = 0
collect (multiple-value-bind (name self cumulative)
(node-values node)
(setf (gethash node *node-numbers*) i
(gethash i *number-nodes*) node)
(incf total self)
(list i name self cumulative total)) into list
finally (return
(let ((rest (- 100 total)))
(return (append list
`((nil "Elsewhere" ,rest nil nil)))))))))
(defslimefun swank-sprof-get-call-graph (&key exclude-swank)
(when (setf *call-graph* (sb-sprof:report :type nil))
(serialize-call-graph :exclude-swank exclude-swank)))
(defslimefun swank-sprof-expand-node (index)
(let* ((node (gethash index *number-nodes*)))
(labels ((caller-count (v)
(loop for e in (sb-sprof::vertex-edges v) do
(when (eq (sb-sprof::edge-vertex e) node)
(return-from caller-count (sb-sprof::call-count e))))
0)
(serialize-node (node count)
(etypecase node
(sb-sprof::cycle
(list (sb-sprof::cycle-index node)
(sb-sprof::cycle-name node)
(samples-percent count)))
(sb-sprof::node
(let ((name (node-values node)))
(list (gethash node *node-numbers*)
name
(samples-percent count)))))))
(list :callers (loop for node in
(sort (copy-list (sb-sprof::node-callers node)) #'>
:key #'caller-count)
collect (serialize-node node
(caller-count node)))
:calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node))
#'>
:key #'sb-sprof::call-count)))
(loop for edge in edges
collect
(serialize-node (sb-sprof::edge-vertex edge)
(sb-sprof::call-count edge))))))))
(defslimefun swank-sprof-disassemble (index)
(let* ((node (gethash index *number-nodes*))
(debug-info (sb-sprof::node-debug-info node)))
(with-output-to-string (s)
(typecase debug-info
(sb-impl::code-component
(sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info)
(sb-vm::%code-code-size debug-info)
:stream s))
(sb-di::compiled-debug-fun
(let ((component (sb-di::compiled-debug-fun-component debug-info)))
(sb-disassem::disassemble-code-component component :stream s)))
(t `(:error "No disassembly available"))))))
(defslimefun swank-sprof-source-location (index)
(let* ((node (gethash index *number-nodes*))
(debug-info (sb-sprof::node-debug-info node)))
(or (when (typep debug-info 'sb-di::compiled-debug-fun)
(let* ((component (sb-di::compiled-debug-fun-component debug-info))
(function (sb-kernel::%code-entry-points component)))
(when function
(find-source-location function))))
`(:error "No source location available"))))
(defslimefun swank-sprof-start (&key (mode :cpu))
(sb-sprof:start-profiling :mode mode))
(defslimefun swank-sprof-stop ()
(sb-sprof:stop-profiling))
)
(provide :swank-sprof)

264
sources_non_forked/slimv/slime/contrib/swank-trace-dialog.lisp Normal file
View File

@ -0,0 +1,264 @@
(defpackage :swank-trace-dialog
(:use :cl)
(:import-from :swank :defslimefun :from-string :to-string)
(: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-trace-detail
#:report-specs
#:trace-format
#:still-inside
#:exited-non-locally
#:*record-backtrace*
#:*traces-per-report*
#:*dialog-trace-follows-trace*
#:find-trace-part
#:find-trace))
(in-package :swank-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.")
;;;; `trace-entry' model
;;;;
(defvar *traces* (make-array 1000 :fill-pointer 0
:adjustable t))
(defvar *trace-lock* (swank/backend:make-lock :name "swank-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"))
(args :initarg :args :accessor args-of
:initform (error "must provide 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)))
(defmethod initialize-instance :after ((entry trace-entry) &rest initargs)
(declare (ignore initargs))
(if (parent-of entry)
(nconc (children-of (parent-of entry)) (list entry)))
(swank/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 find-trace (id)
(when (<= 0 id (1- (length *traces*)))
(aref *traces* id)))
(defun find-trace-part (id part-id type)
(let* ((trace (find-trace id))
(l (and trace
(ecase type
(:arg (args-of trace))
(:retval (swank::ensure-list (retlist-of trace)))))))
(values (nth part-id l)
(< part-id (length l)))))
(defun useful-backtrace ()
(swank/backend:call-with-debugging-environment
#'(lambda ()
(loop for i from 0
for frame in (swank/backend:compute-backtrace 0 20)
collect (list i (swank::frame-to-string frame))))))
(defun current-trace ()
(gethash (swank/backend:current-thread) *current-trace-by-thread*))
(defun (setf current-trace) (trace)
(setf (gethash (swank/backend:current-thread) *current-trace-by-thread*)
trace))
;;;; Control of traced specs
;;;
(defvar *traced-specs* '())
(defslimefun dialog-trace (spec)
(flet ((before-hook (args)
(setf (current-trace) (make-instance 'trace-entry
:spec spec
:args args
:parent (current-trace))))
(after-hook (retlist)
(let ((trace (current-trace)))
(when 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-of trace) retlist
(current-trace) (parent-of trace))))))
(when (dialog-traced-p spec)
(warn "~a is apparently already traced! Untracing and retracing." spec)
(dialog-untrace spec))
(swank/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)))
(defslimefun dialog-untrace (spec)
(swank/backend:unwrap spec 'trace-dialog)
(setq *traced-specs* (remove spec *traced-specs* :test #'equal))
(format nil "~a is now untraced for trace dialog" spec))
(defslimefun dialog-toggle-trace (spec)
(if (dialog-traced-p spec)
(dialog-untrace spec)
(dialog-trace spec)))
(defslimefun dialog-traced-p (spec)
(find spec *traced-specs* :test #'equal))
(defslimefun dialog-untrace-all ()
(untrace)
(mapcar #'dialog-untrace *traced-specs*))
(defparameter *dialog-trace-follows-trace* nil)
(setq swank:*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")))))
;;;; A special kind of trace call
;;;
(defun 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)))
;;;; Reporting to emacs
;;;
(defparameter *visitor-idx* 0)
(defparameter *visitor-key* nil)
(defvar *unfinished-traces* '())
(defun describe-trace-for-emacs (trace)
`(,(id-of trace)
,(and (parent-of trace) (id-of (parent-of trace)))
,(spec-of trace)
,(loop for arg in (args-of trace)
for i from 0
collect (list i (swank::to-line arg)))
,(loop for retval in (swank::ensure-list (retlist-of trace))
for i from 0
collect (list i (swank::to-line retval)))))
(defslimefun 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)))
(defslimefun report-trace-detail (trace-id)
(swank::call-with-bindings
swank::*inspector-printer-bindings*
#'(lambda ()
(let ((trace (find-trace trace-id)))
(when trace
(append
(describe-trace-for-emacs trace)
(list (backtrace-of trace)
(swank::to-line trace))))))))
(defslimefun report-specs ()
(sort (copy-list *traced-specs*)
#'string<
:key #'princ-to-string))
(defslimefun report-total ()
(length *traces*))
(defslimefun clear-trace-tree ()
(setf *current-trace-by-thread* (clrhash *current-trace-by-thread*)
*visitor-key* nil
*unfinished-traces* nil)
(swank/backend:call-with-lock-held
*trace-lock*
#'(lambda () (setf (fill-pointer *traces*) 0)))
nil)
;; HACK: `swank::*inspector-history*' is unbound by default and needs
;; a reset in that case so that it won't error `swank::inspect-object'
;; before any other object is inspected in the slime session.
;;
(unless (boundp 'swank::*inspector-history*)
(swank::reset-inspector))
(defslimefun inspect-trace-part (trace-id part-id type)
(multiple-value-bind (obj found)
(find-trace-part trace-id part-id type)
(if found
(swank::inspect-object obj)
(error "No object found with ~a, ~a and ~a" trace-id part-id type))))
(provide :swank-trace-dialog)

63
sources_non_forked/slimv/slime/contrib/swank-util.lisp Normal file
View File

@ -0,0 +1,63 @@
;;; swank-util.lisp --- stuff of questionable utility
;;
;; License: public domain
(in-package :swank)
(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))))))
(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)))
(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)))
(provide :swank-util)

1235
sources_non_forked/slimv/slime/metering.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

523
sources_non_forked/slimv/slime/nregex.lisp Normal file
View File

@ -0,0 +1,523 @@
;;;
;;; This code was written by:
;;;
;;; Lawrence E. Freil <lef@freil.com>
;;; National Science Center Foundation
;;; Augusta, Georgia 30909
;;;
;;; This program was released into the public domain on 2005-08-31.
;;; (See the slime-devel mailing list archive for details.)
;;;
;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression
;;; parser.
;;;
;;; This regular expression parser operates by taking a
;;; regular expression and breaking it down into a list
;;; consisting of lisp expressions and flags. The list
;;; of lisp expressions is then taken in turned into a
;;; lambda expression that can be later applied to a
;;; string argument for parsing.
;;;;
;;;; Modifications made 6 March 2001 By Chris Double (chris@double.co.nz)
;;;; to get working with Corman Lisp 1.42, add package statement and export
;;;; relevant functions.
;;;;
(in-package :cl-user)
;; Renamed to slime-nregex avoid name clashes with other versions of
;; this file. -- he
;;;; CND - 6/3/2001
(defpackage slime-nregex
(:use #:common-lisp)
(:export
#:regex
#:regex-compile
))
;;;; CND - 6/3/2001
(in-package :slime-nregex)
;;;
;;; First we create a copy of macros to help debug the beast
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *regex-debug* nil) ; Set to nil for no debugging code
)
(defmacro info (message &rest args)
(if *regex-debug*
`(format *standard-output* ,message ,@args)))
;;;
;;; Declare the global variables for storing the paren index list.
;;;
(defvar *regex-groups* (make-array 10))
(defvar *regex-groupings* 0)
;;;
;;; Declare a simple interface for testing. You probably wouldn't want
;;; to use this interface unless you were just calling this once.
;;;
(defun regex (expression string)
"Usage: (regex <expression> <string)
This function will call regex-compile on the expression and then apply
the string to the returned lambda list."
(let ((findit (cond ((stringp expression)
(regex-compile expression))
((listp expression)
expression)))
(result nil))
(if (not (funcall (if (functionp findit)
findit
(eval `(function ,findit))) string))
(return-from regex nil))
(if (= *regex-groupings* 0)
(return-from regex t))
(dotimes (i *regex-groupings*)
(push (funcall 'subseq
string
(car (aref *regex-groups* i))
(cadr (aref *regex-groups* i)))
result))
(reverse result)))
;;;
;;; Declare some simple macros to make the code more readable.
;;;
(defvar *regex-special-chars* "?*+.()[]\\${}")
(defmacro add-exp (list)
"Add an item to the end of expression"
`(setf expression (append expression ,list)))
;;;
;;; Define a function that will take a quoted character and return
;;; what the real character should be plus how much of the source
;;; string was used. If the result is a set of characters, return an
;;; array of bits indicating which characters should be set. If the
;;; expression is one of the sub-group matches return a
;;; list-expression that will provide the match.
;;;
(defun regex-quoted (char-string &optional (invert nil))
"Usage: (regex-quoted <char-string> &optional invert)
Returns either the quoted character or a simple bit vector of bits set for
the matching values"
(let ((first (char char-string 0))
(result (char char-string 0))
(used-length 1))
(cond ((eql first #\n)
(setf result #\NewLine))
((eql first #\c)
(setf result #\Return))
((eql first #\t)
(setf result #\Tab))
((eql first #\d)
(setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
((eql first #\D)
(setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
((eql first #\w)
(setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
((eql first #\W)
(setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
((eql first #\b)
(setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
((eql first #\B)
(setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
((eql first #\s)
(setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
((eql first #\S)
(setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
((and (>= (char-code first) (char-code #\0))
(<= (char-code first) (char-code #\9)))
(if (and (> (length char-string) 2)
(and (>= (char-code (char char-string 1)) (char-code #\0))
(<= (char-code (char char-string 1)) (char-code #\9))
(>= (char-code (char char-string 2)) (char-code #\0))
(<= (char-code (char char-string 2)) (char-code #\9))))
;;
;; It is a single character specified in octal
;;
(progn
(setf result (do ((x 0 (1+ x))
(return 0))
((= x 2) return)
(setf return (+ (* return 8)
(- (char-code (char char-string x))
(char-code #\0))))))
(setf used-length 3))
;;
;; We have a group number replacement.
;;
(let ((group (- (char-code first) (char-code #\0))))
(setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group))
(cadr (aref *regex-groups* ,group)))))
(if (< length (+ index (length nstring)))
(return-from compare nil))
(if (not (string= string nstring
:start1 index
:end1 (+ index (length nstring))))
(return-from compare nil)
(incf index (length nstring)))))))))
(t
(setf result first)))
(if (and (vectorp result) invert)
(bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t))
(values result used-length)))
;;;
;;; Now for the main regex compiler routine.
;;;
(defun regex-compile (source &key (anchored nil))
"Usage: (regex-compile <expression> [ :anchored (t/nil) ])
This function take a regular expression (supplied as source) and
compiles this into a lambda list that a string argument can then
be applied to. It is also possible to compile this lambda list
for better performance or to save it as a named function for later
use"
(info "Now entering regex-compile with \"~A\"~%" source)
;;
;; This routine works in two parts.
;; The first pass take the regular expression and produces a list of
;; operators and lisp expressions for the entire regular expression.
;; The second pass takes this list and produces the lambda expression.
(let ((expression '()) ; holder for expressions
(group 1) ; Current group index
(group-stack nil) ; Stack of current group endings
(result nil) ; holder for built expression.
(fast-first nil)) ; holder for quick unanchored scan
;;
;; If the expression was an empty string then it alway
;; matches (so lets leave early)
;;
(if (= (length source) 0)
(return-from regex-compile
'(lambda (&rest args)
(declare (ignore args))
t)))
;;
;; If the first character is a caret then set the anchored
;; flags and remove if from the expression string.
;;
(cond ((eql (char source 0) #\^)
(setf source (subseq source 1))
(setf anchored t)))
;;
;; If the first sequence is .* then also set the anchored flags.
;; (This is purely for optimization, it will work without this).
;;
(if (>= (length source) 2)
(if (string= source ".*" :start1 0 :end1 2)
(setf anchored t)))
;;
;; Also, If this is not an anchored search and the first character is
;; a literal, then do a quick scan to see if it is even in the string.
;; If not then we can issue a quick nil,
;; otherwise we can start the search at the matching character to skip
;; the checks of the non-matching characters anyway.
;;
;; If I really wanted to speed up this section of code it would be
;; easy to recognize the case of a fairly long multi-character literal
;; and generate a Boyer-Moore search for the entire literal.
;;
;; I generate the code to do a loop because on CMU Lisp this is about
;; twice as fast a calling position.
;;
(if (and (not anchored)
(not (position (char source 0) *regex-special-chars*))
(not (and (> (length source) 1)
(position (char source 1) *regex-special-chars*))))
(setf fast-first `((if (not (dotimes (i length nil)
(if (eql (char string i)
,(char source 0))
(return (setf start i)))))
(return-from final-return nil)))))
;;
;; Generate the very first expression to save the starting index
;; so that group 0 will be the entire string matched always
;;
(add-exp '((setf (aref *regex-groups* 0)
(list index nil))))
;;
;; Loop over each character in the regular expression building the
;; expression list as we go.
;;
(do ((eindex 0 (1+ eindex)))
((= eindex (length source)))
(let ((current (char source eindex)))
(info "Now processing character ~A index = ~A~%" current eindex)
(case current
((#\.)
;;
;; Generate code for a single wild character
;;
(add-exp '((if (>= index length)
(return-from compare nil)
(incf index)))))
((#\$)
;;
;; If this is the last character of the expression then
;; anchor the end of the expression, otherwise let it slide
;; as a standard character (even though it should be quoted).
;;
(if (= eindex (1- (length source)))
(add-exp '((if (not (= index length))
(return-from compare nil))))
(add-exp '((if (not (and (< index length)
(eql (char string index) #\$)))
(return-from compare nil)
(incf index))))))
((#\*)
(add-exp '(ASTRISK)))
((#\+)
(add-exp '(PLUS)))
((#\?)
(add-exp '(QUESTION)))
((#\()
;;
;; Start a grouping.
;;
(incf group)
(push group group-stack)
(add-exp `((setf (aref *regex-groups* ,(1- group))
(list index nil))))
(add-exp `(,group)))
((#\))
;;
;; End a grouping
;;
(let ((group (pop group-stack)))
(add-exp `((setf (cadr (aref *regex-groups* ,(1- group)))
index)))
(add-exp `(,(- group)))))
((#\[)
;;
;; Start of a range operation.
;; Generate a bit-vector that has one bit per possible character
;; and then on each character or range, set the possible bits.
;;
;; If the first character is carat then invert the set.
(let* ((invert (eql (char source (1+ eindex)) #\^))
(bitstring (make-array 256 :element-type 'bit
:initial-element
(if invert 1 0)))
(set-char (if invert 0 1)))
(if invert (incf eindex))
(do ((x (1+ eindex) (1+ x)))
((eql (char source x) #\]) (setf eindex x))
(info "Building range with character ~A~%" (char source x))
(cond ((and (eql (char source (1+ x)) #\-)
(not (eql (char source (+ x 2)) #\])))
(if (>= (char-code (char source x))
(char-code (char source (+ 2 x))))
(error "Invalid range \"~A-~A\". Ranges must be in acending order"
(char source x) (char source (+ 2 x))))
(do ((j (char-code (char source x)) (1+ j)))
((> j (char-code (char source (+ 2 x))))
(incf x 2))
(info "Setting bit for char ~A code ~A~%" (code-char j) j)
(setf (sbit bitstring j) set-char)))
(t
(cond ((not (eql (char source x) #\]))
(let ((char (char source x)))
;;
;; If the character is quoted then find out what
;; it should have been
;;
(if (eql (char source x) #\\ )
(let ((length))
(multiple-value-setq (char length)
(regex-quoted (subseq source x) invert))
(incf x length)))
(info "Setting bit for char ~A code ~A~%" char (char-code char))
(if (not (vectorp char))
(setf (sbit bitstring (char-code (char source x))) set-char)
(bit-ior bitstring char t))))))))
(add-exp `((let ((range ,bitstring))
(if (>= index length)
(return-from compare nil))
(if (= 1 (sbit range (char-code (char string index))))
(incf index)
(return-from compare nil)))))))
((#\\ )
;;
;; Intreprete the next character as a special, range, octal, group or
;; just the character itself.
;;
(let ((length)
(value))
(multiple-value-setq (value length)
(regex-quoted (subseq source (1+ eindex)) nil))
(cond ((listp value)
(add-exp value))
((characterp value)
(add-exp `((if (not (and (< index length)
(eql (char string index)
,value)))
(return-from compare nil)
(incf index)))))
((vectorp value)
(add-exp `((let ((range ,value))
(if (>= index length)
(return-from compare nil))
(if (= 1 (sbit range (char-code (char string index))))
(incf index)
(return-from compare nil)))))))
(incf eindex length)))
(t
;;
;; We have a literal character.
;; Scan to see how many we have and if it is more than one
;; generate a string= verses as single eql.
;;
(let* ((lit "")
(term (dotimes (litindex (- (length source) eindex) nil)
(let ((litchar (char source (+ eindex litindex))))
(if (position litchar *regex-special-chars*)
(return litchar)
(progn
(info "Now adding ~A index ~A to lit~%" litchar
litindex)
(setf lit (concatenate 'string lit
(string litchar)))))))))
(if (= (length lit) 1)
(add-exp `((if (not (and (< index length)
(eql (char string index) ,current)))
(return-from compare nil)
(incf index))))
;;
;; If we have a multi-character literal then we must
;; check to see if the next character (if there is one)
;; is an astrisk or a plus or a question mark. If so then we must not use this
;; character in the big literal.
(progn
(if (or (eql term #\*)
(eql term #\+)
(eql term #\?))
(setf lit (subseq lit 0 (1- (length lit)))))
(add-exp `((if (< length (+ index ,(length lit)))
(return-from compare nil))
(if (not (string= string ,lit :start1 index
:end1 (+ index ,(length lit))))
(return-from compare nil)
(incf index ,(length lit)))))))
(incf eindex (1- (length lit))))))))
;;
;; Plug end of list to return t. If we made it this far then
;; We have matched!
(add-exp '((setf (cadr (aref *regex-groups* 0))
index)))
(add-exp '((return-from final-return t)))
;;
;;; (print expression)
;;
;; Now take the expression list and turn it into a lambda expression
;; replacing the special flags with lisp code.
;; For example: A BEGIN needs to be replace by an expression that
;; saves the current index, then evaluates everything till it gets to
;; the END then save the new index if it didn't fail.
;; On an ASTRISK I need to take the previous expression and wrap
;; it in a do that will evaluate the expression till an error
;; occurs and then another do that encompases the remainder of the
;; regular expression and iterates decrementing the index by one
;; of the matched expression sizes and then returns nil. After
;; the last expression insert a form that does a return t so that
;; if the entire nested sub-expression succeeds then the loop
;; is broken manually.
;;
(setf result (copy-tree nil))
;;
;; Reversing the current expression makes building up the
;; lambda list easier due to the nexting of expressions when
;; and astrisk has been encountered.
(setf expression (reverse expression))
(do ((elt 0 (1+ elt)))
((>= elt (length expression)))
(let ((piece (nth elt expression)))
;;
;; Now check for PLUS, if so then ditto the expression and then let the
;; ASTRISK below handle the rest.
;;
(cond ((eql piece 'PLUS)
(cond ((listp (nth (1+ elt) expression))
(setf result (append (list (nth (1+ elt) expression))
result)))
;;
;; duplicate the entire group
;; NOTE: This hasn't been implemented yet!!
(t
(error "GROUP repeat hasn't been implemented yet~%")))))
(cond ((listp piece) ;Just append the list
(setf result (append (list piece) result)))
((eql piece 'QUESTION) ; Wrap it in a block that won't fail
(cond ((listp (nth (1+ elt) expression))
(setf result
(append `((progn (block compare
,(nth (1+ elt)
expression))
t))
result))
(incf elt))
;;
;; This is a QUESTION on an entire group which
;; hasn't been implemented yet!!!
;;
(t
(error "Optional groups not implemented yet~%"))))
((or (eql piece 'ASTRISK) ; Do the wild thing!
(eql piece 'PLUS))
(cond ((listp (nth (1+ elt) expression))
;;
;; This is a single character wild card so
;; do the simple form.
;;
(setf result
`((let ((oindex index))
(block compare
(do ()
(nil)
,(nth (1+ elt) expression)))
(do ((start index (1- start)))
((< start oindex) nil)
(let ((index start))
(block compare
,@result))))))
(incf elt))
(t
;;
;; This is a subgroup repeated so I must build
;; the loop using several values.
;;
))
)
(t t)))) ; Just ignore everything else.
;;
;; Now wrap the result in a lambda list that can then be
;; invoked or compiled, however the user wishes.
;;
(if anchored
(setf result
`(lambda (string &key (start 0) (end (length string)))
(setf *regex-groupings* ,group)
(block final-return
(block compare
(let ((index start)
(length end))
,@result)))))
(setf result
`(lambda (string &key (start 0) (end (length string)))
(setf *regex-groupings* ,group)
(block final-return
(let ((length end))
,@fast-first
(do ((marker start (1+ marker)))
((> marker end) nil)
(let ((index marker))
(if (block compare
,@result)
(return t)))))))))))
;; (provide 'nregex)

202
sources_non_forked/slimv/slime/packages.lisp Normal file
View File

@ -0,0 +1,202 @@
(defpackage swank/backend
(:use cl)
(:nicknames swank-backend)
(:export *debug-swank-backend*
*log-output*
sldb-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-slime-interrupts*
check-slime-interrupts
*interrupt-queued-handler*
;; inspector related symbols
emacs-inspect
label-value-line
label-value-line*
boolean-to-feature-expression
with-symbol
choose-symbol
;; package helper for backend
import-to-swank-mop
import-swank-mop-symbols
;;
default-directory
set-default-directory
frame-source-location
restart-frame
gdb-initial-commands
sldb-break-on-return
buffer-first-change
profiled-functions
unprofile-all
profile-report
profile-reset
profile-package
with-collected-macro-forms
auto-flush-loop
*auto-flush-interval*))
(defpackage swank/rpc
(:use :cl)
(:export
read-message
read-packet
swank-reader-error
swank-reader-error.packet
swank-reader-error.cause
write-message))
(defpackage swank/match
(:use cl)
(:export match))
;; FIXME: rename to sawnk/mop
(defpackage swank-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))
(defpackage swank
(:use cl swank/backend swank/match swank/rpc)
(:export #:startup-multiprocessing
#:start-server
#:create-server
#:stop-server
#:restart-server
#:ed-in-emacs
#:inspect-in-emacs
#:print-indentation-lossage
#:invoke-slime-debugger
#:swank-debugger-hook
#:emacs-inspect
;;#:inspect-slot-for-emacs
;; These are user-configurable variables:
#:*communication-style*
#:*dont-close*
#:*fasl-pathname-function*
#:*log-events*
#:*use-dedicated-output-stream*
#:*dedicated-output-stream-port*
#:*configure-emacs-indentation*
#:*readtable-alist*
#:*globally-redirect-io*
#:*global-debugger*
#:*sldb-quit-restart*
#:*backtrace-printer-bindings*
#:*default-worker-thread-bindings*
#:*macroexpand-printer-bindings*
#:*swank-pprint-bindings*
#:*record-repl-results*
#:*inspector-verbose*
;; This is SETFable.
#:debug-on-swank-error
;; These are re-exported directly from the backend:
#:buffer-first-change
#:frame-source-location
#:gdb-initial-commands
#:restart-frame
#:sldb-step
#:sldb-break
#:sldb-break-on-return
#:profiled-functions
#:profile-report
#:profile-reset
#:unprofile-all
#:profile-package
#:default-directory
#:set-default-directory
#:quit-lisp
#:eval-for-emacs
#:eval-in-emacs
#:ed-rpc
#:ed-rpc-no-wait
#:y-or-n-p-in-emacs
#:*find-definitions-right-trim*
#:*find-definitions-left-trim*
#:*after-toggle-trace-hook*
#:unreadable-result
#:unreadable-result-p
#:unreadable-result-string
#:parse-string
#:from-string
#:to-string
#:*swank-debugger-condition*
#:run-hook-with-args-until-success
#:make-output-function-for-target
#:make-output-stream-for-target))

332
sources_non_forked/slimv/slime/sbcl-pprint-patch.lisp Normal file
View File

@ -0,0 +1,332 @@
;; Pretty printer patch for SBCL, which adds the "annotations" feature
;; required for sending presentations through pretty-printing streams.
;;
;; The section marked "Changed functions" and the DEFSTRUCT
;; PRETTY-STREAM are based on SBCL's pprint.lisp.
;;
;; Public domain.
(in-package "SB!PRETTY")
(defstruct (annotation (:include queued-op))
(handler (constantly nil) :type function)
(record))
(defstruct (pretty-stream (:include sb!kernel:ansi-stream
(out #'pretty-out)
(sout #'pretty-sout)
(misc #'pretty-misc))
(:constructor make-pretty-stream (target))
(:copier nil))
;; Where the output is going to finally go.
(target (missing-arg) :type stream)
;; Line length we should format to. Cached here so we don't have to keep
;; extracting it from the target stream.
(line-length (or *print-right-margin*
(sb!impl::line-length target)
default-line-length)
:type column)
;; A simple string holding all the text that has been output but not yet
;; printed.
(buffer (make-string initial-buffer-size) :type (simple-array character (*)))
;; The index into BUFFER where more text should be put.
(buffer-fill-pointer 0 :type index)
;; Whenever we output stuff from the buffer, we shift the remaining noise
;; over. This makes it difficult to keep references to locations in
;; the buffer. Therefore, we have to keep track of the total amount of
;; stuff that has been shifted out of the buffer.
(buffer-offset 0 :type posn)
;; The column the first character in the buffer will appear in. Normally
;; zero, but if we end up with a very long line with no breaks in it we
;; might have to output part of it. Then this will no longer be zero.
(buffer-start-column (or (sb!impl::charpos target) 0) :type column)
;; The line number we are currently on. Used for *PRINT-LINES*
;; abbreviations and to tell when sections have been split across
;; multiple lines.
(line-number 0 :type index)
;; the value of *PRINT-LINES* captured at object creation time. We
;; use this, instead of the dynamic *PRINT-LINES*, to avoid
;; weirdness like
;; (let ((*print-lines* 50))
;; (pprint-logical-block ..
;; (dotimes (i 10)
;; (let ((*print-lines* 8))
;; (print (aref possiblybigthings i) prettystream)))))
;; terminating the output of the entire logical blockafter 8 lines.
(print-lines *print-lines* :type (or index null) :read-only t)
;; Stack of logical blocks in effect at the buffer start.
(blocks (list (make-logical-block)) :type list)
;; Buffer holding the per-line prefix active at the buffer start.
;; Indentation is included in this. The length of this is stored
;; in the logical block stack.
(prefix (make-string initial-buffer-size) :type (simple-array character (*)))
;; Buffer holding the total remaining suffix active at the buffer start.
;; The characters are right-justified in the buffer to make it easier
;; to output the buffer. The length is stored in the logical block
;; stack.
(suffix (make-string initial-buffer-size) :type (simple-array character (*)))
;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
;; cons. Adding things to the queue is basically (setf (cdr head) (list
;; new)) and removing them is basically (pop tail) [except that care must
;; be taken to handle the empty queue case correctly.]
(queue-tail nil :type list)
(queue-head nil :type list)
;; Block-start queue entries in effect at the queue head.
(pending-blocks nil :type list)
;; Queue of annotations to the buffer
(annotations-tail nil :type list)
(annotations-head nil :type list))
(defmacro enqueue (stream type &rest args)
(let ((constructor (intern (concatenate 'string
"MAKE-"
(symbol-name type))
"SB-PRETTY")))
(once-only ((stream stream)
(entry `(,constructor :posn
(index-posn
(pretty-stream-buffer-fill-pointer
,stream)
,stream)
,@args))
(op `(list ,entry))
(head `(pretty-stream-queue-head ,stream)))
`(progn
(if ,head
(setf (cdr ,head) ,op)
(setf (pretty-stream-queue-tail ,stream) ,op))
(setf (pretty-stream-queue-head ,stream) ,op)
,entry))))
;;;
;;; New helper functions
;;;
(defun enqueue-annotation (stream handler record)
(enqueue stream annotation :handler handler
:record record))
(defun re-enqueue-annotation (stream annotation)
(let* ((annotation-cons (list annotation))
(head (pretty-stream-annotations-head stream)))
(if head
(setf (cdr head) annotation-cons)
(setf (pretty-stream-annotations-tail stream) annotation-cons))
(setf (pretty-stream-annotations-head stream) annotation-cons)
nil))
(defun re-enqueue-annotations (stream end)
(loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
while (and tail (not (eql (car tail) end)))
when (annotation-p (car tail))
do (re-enqueue-annotation stream (car tail))))
(defun dequeue-annotation (stream &key end-posn)
(let ((next-annotation (car (pretty-stream-annotations-tail stream))))
(when next-annotation
(when (or (not end-posn)
(<= (annotation-posn next-annotation) end-posn))
(pop (pretty-stream-annotations-tail stream))
(unless (pretty-stream-annotations-tail stream)
(setf (pretty-stream-annotations-head stream) nil))
next-annotation))))
(defun invoke-annotation (stream annotation truncatep)
(let ((target (pretty-stream-target stream)))
(funcall (annotation-handler annotation)
(annotation-record annotation)
target
truncatep)))
(defun output-buffer-with-annotations (stream end)
(let ((target (pretty-stream-target stream))
(buffer (pretty-stream-buffer stream))
(end-posn (index-posn end stream))
(start 0))
(loop
for annotation = (dequeue-annotation stream :end-posn end-posn)
while annotation
do
(let ((annotation-index (posn-index (annotation-posn annotation)
stream)))
(when (> annotation-index start)
(write-string buffer target :start start
:end annotation-index)
(setf start annotation-index))
(invoke-annotation stream annotation nil)))
(when (> end start)
(write-string buffer target :start start :end end))))
(defun flush-annotations (stream end truncatep)
(let ((end-posn (index-posn end stream)))
(loop
for annotation = (dequeue-annotation stream :end-posn end-posn)
while annotation
do (invoke-annotation stream annotation truncatep))))
;;;
;;; Changed functions
;;;
(defun maybe-output (stream force-newlines-p)
(declare (type pretty-stream stream))
(let ((tail (pretty-stream-queue-tail stream))
(output-anything nil))
(loop
(unless tail
(setf (pretty-stream-queue-head stream) nil)
(return))
(let ((next (pop tail)))
(etypecase next
(newline
(when (ecase (newline-kind next)
((:literal :mandatory :linear) t)
(:miser (misering-p stream))
(:fill
(or (misering-p stream)
(> (pretty-stream-line-number stream)
(logical-block-section-start-line
(first (pretty-stream-blocks stream))))
(ecase (fits-on-line-p stream
(newline-section-end next)
force-newlines-p)
((t) nil)
((nil) t)
(:dont-know
(return))))))
(setf output-anything t)
(output-line stream next)))
(indentation
(unless (misering-p stream)
(set-indentation stream
(+ (ecase (indentation-kind next)
(:block
(logical-block-start-column
(car (pretty-stream-blocks stream))))
(:current
(posn-column
(indentation-posn next)
stream)))
(indentation-amount next)))))
(block-start
(ecase (fits-on-line-p stream (block-start-section-end next)
force-newlines-p)
((t)
;; Just nuke the whole logical block and make it look like one
;; nice long literal. (But don't nuke annotations.)
(let ((end (block-start-block-end next)))
(expand-tabs stream end)
(re-enqueue-annotations stream end)
(setf tail (cdr (member end tail)))))
((nil)
(really-start-logical-block
stream
(posn-column (block-start-posn next) stream)
(block-start-prefix next)
(block-start-suffix next)))
(:dont-know
(return))))
(block-end
(really-end-logical-block stream))
(tab
(expand-tabs stream next))
(annotation
(re-enqueue-annotation stream next))))
(setf (pretty-stream-queue-tail stream) tail))
output-anything))
(defun output-line (stream until)
(declare (type pretty-stream stream)
(type newline until))
(let* ((target (pretty-stream-target stream))
(buffer (pretty-stream-buffer stream))
(kind (newline-kind until))
(literal-p (eq kind :literal))
(amount-to-consume (posn-index (newline-posn until) stream))
(amount-to-print
(if literal-p
amount-to-consume
(let ((last-non-blank
(position #\space buffer :end amount-to-consume
:from-end t :test #'char/=)))
(if last-non-blank
(1+ last-non-blank)
0)))))
(output-buffer-with-annotations stream amount-to-print)
(flush-annotations stream amount-to-consume nil)
(let ((line-number (pretty-stream-line-number stream)))
(incf line-number)
(when (and (not *print-readably*)
(pretty-stream-print-lines stream)
(>= line-number (pretty-stream-print-lines stream)))
(write-string " .." target)
(flush-annotations stream
(pretty-stream-buffer-fill-pointer stream)
t)
(let ((suffix-length (logical-block-suffix-length
(car (pretty-stream-blocks stream)))))
(unless (zerop suffix-length)
(let* ((suffix (pretty-stream-suffix stream))
(len (length suffix)))
(write-string suffix target
:start (- len suffix-length)
:end len))))
(throw 'line-limit-abbreviation-happened t))
(setf (pretty-stream-line-number stream) line-number)
(write-char #\newline target)
(setf (pretty-stream-buffer-start-column stream) 0)
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
(block (first (pretty-stream-blocks stream)))
(prefix-len
(if literal-p
(logical-block-per-line-prefix-end block)
(logical-block-prefix-length block)))
(shift (- amount-to-consume prefix-len))
(new-fill-ptr (- fill-ptr shift))
(new-buffer buffer)
(buffer-length (length buffer)))
(when (> new-fill-ptr buffer-length)
(setf new-buffer
(make-string (max (* buffer-length 2)
(+ buffer-length
(floor (* (- new-fill-ptr buffer-length)
5)
4)))))
(setf (pretty-stream-buffer stream) new-buffer))
(replace new-buffer buffer
:start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
(replace new-buffer (pretty-stream-prefix stream)
:end1 prefix-len)
(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
(incf (pretty-stream-buffer-offset stream) shift)
(unless literal-p
(setf (logical-block-section-column block) prefix-len)
(setf (logical-block-section-start-line block) line-number))))))
(defun output-partial-line (stream)
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
(tail (pretty-stream-queue-tail stream))
(count
(if tail
(posn-index (queued-op-posn (car tail)) stream)
fill-ptr))
(new-fill-ptr (- fill-ptr count))
(buffer (pretty-stream-buffer stream)))
(when (zerop count)
(error "Output-partial-line called when nothing can be output."))
(output-buffer-with-annotations stream count)
(incf (pretty-stream-buffer-start-column stream) count)
(replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
(incf (pretty-stream-buffer-offset stream) count)))
(defun force-pretty-output (stream)
(maybe-output stream nil)
(expand-tabs stream nil)
(re-enqueue-annotations stream nil)
(output-buffer-with-annotations stream
(pretty-stream-buffer-fill-pointer stream)))

7657
sources_non_forked/slimv/slime/slime.el Normal file
View File

File diff suppressed because it is too large Load Diff

40
sources_non_forked/slimv/slime/start-swank.lisp Normal file
View File

@ -0,0 +1,40 @@
;;; This file is intended to be loaded by an implementation to
;;; get a running swank server
;;; e.g. sbcl --load start-swank.lisp
;;;
;;; Default port is 4005
;;; For additional swank-side configurations see
;;; 6.2 section of the Slime user manual.
;;;
;;; Modified for Slimv:
;;; - don't close connection
;;; - pass swank port in environment variable
(load (merge-pathnames "swank-loader.lisp" *load-truename*))
(swank-loader:init
:delete nil ; delete any existing SWANK packages
:reload nil ; reload SWANK, even if the SWANK package already exists
:load-contribs nil ; load all contribs
:from-emacs nil) ; not started from emacs
(defun my-getenv (name &optional default)
#+CMU
(let ((x (assoc name ext:*environment-list*
:test #'string=)))
(if x (cdr x) default))
#-CMU
(or
#+Allegro (sys:getenv name)
#+CLISP (ext:getenv name)
#+ECL (si:getenv name)
#+SBCL (sb-unix::posix-getenv name)
#+LISPWORKS (lispworks:environment-variable name)
#+CCL (ccl::getenv name)
default))
(swank:create-server :port (parse-integer (my-getenv "SWANK_PORT" "4005"))
;; if non-nil the connection won't be closed
;; after connecting
:dont-close t)

376
sources_non_forked/slimv/slime/swank-loader.lisp Normal file
View File

@ -0,0 +1,376 @@
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-loader.lisp --- Compile and load the Slime 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
;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
;; before loading this files.
;; E.g.:
;;
;; (load ".../swank-loader.lisp")
;; (setq swank-loader::*fasl-directory* "/tmp/fasl/")
;; (swank-loader:init)
(cl:defpackage :swank-loader
(:use :cl)
(:export :init
:dump-image
:list-fasls
:*source-directory*
:*fasl-directory*
:*started-from-emacs*))
(cl:in-package :swank-loader)
(defvar *started-from-emacs* nil)
(defvar *source-directory*
(make-pathname :name nil :type nil
:defaults (or *load-pathname* *default-pathname-defaults*))
"The directory where to look for the source.")
(defparameter *sysdep-files*
#+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl)
(swank gray))
#+scl '((swank source-path-parser) (swank source-file-cache) (swank scl)
(swank gray))
#+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl)
(swank gray))
#+clozure '(metering (swank ccl) (swank gray))
#+lispworks '((swank lispworks) (swank gray))
#+allegro '((swank allegro) (swank gray))
#+clisp '(xref metering (swank clisp) (swank gray))
#+armedbear '((swank abcl))
#+cormanlisp '((swank corman) (swank gray))
#+ecl '((swank ecl) (swank gray))
#+clasp '(metering (swank clasp) (swank gray))
#+mkcl '((swank mkcl) (swank gray))
#+mezzano '((swank mezzano) (swank gray))
)
(defparameter *implementation-features*
'(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
:armedbear :gcl :ecl :scl :mkcl :clasp :mezzano))
(defparameter *os-features*
'(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
:unix :mezzano))
(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)
#+clasp (clasp-version-string)
#+mezzano (let ((s (lisp-implementation-version)))
(subseq s 0 (position #\space s))))
(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 string-starts-with (string prefix)
(string-equal string prefix :end1 (min (length string) (length prefix))))
(defun slime-version-string ()
"Return a string identifying the SLIME version.
Return nil if nothing appropriate is available."
(with-open-file (s (merge-pathnames "slime.el" *source-directory*)
:if-does-not-exist nil)
(when s
(loop with prefix = ";; Version: "
for line = (read-line s nil :eof)
until (eq line :eof)
when (string-starts-with line prefix)
return (subseq line (length prefix))))))
(defun default-fasl-dir ()
(merge-pathnames
(make-pathname
:directory `(:relative ".slime" "fasl"
,@(if (slime-version-string) (list (slime-version-string)))
,(unique-dir-name)))
(user-homedir-pathname)))
(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-swank-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-swank-load-error c "compiling" src))
(:load (handle-swank-load-error c "loading" dest))
(:unknown (handle-swank-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 load-user-init-file ()
"Load the user init file, return NIL if it does not exist."
(load (merge-pathnames (user-homedir-pathname)
(make-pathname :name ".swank" :type "lisp"))
:if-does-not-exist nil))
(defun load-site-init-file (dir)
(load (make-pathname :name "site-init" :type "lisp"
:defaults dir)
:if-does-not-exist nil))
(defun src-files (names src-dir)
(mapcar (lambda (name)
(multiple-value-bind (dirs name)
(etypecase name
(symbol (values '() name))
(cons (values (butlast name) (car (last name)))))
(make-pathname
:directory (append (or (pathname-directory src-dir)
'(:relative))
(mapcar #'string-downcase dirs))
:name (string-downcase name)
:type "lisp"
:defaults src-dir)))
names))
(defvar *swank-files*
`(packages
(swank backend) ,@*sysdep-files* (swank match) (swank rpc)
swank))
(defvar *contribs*
'(swank-util swank-repl
swank-c-p-c swank-arglists swank-fuzzy
swank-fancy-inspector
swank-presentations swank-presentation-streams
#+(or asdf2 asdf3 sbcl ecl) swank-asdf
swank-package-fu
swank-hyperdoc
#+sbcl swank-sbcl-exts
swank-mrepl
swank-trace-dialog
swank-macrostep
swank-quicklisp)
"List of names for contrib modules.")
(defun append-dir (absolute name)
(merge-pathnames
(make-pathname :directory `(:relative ,name) :defaults absolute)
absolute))
(defun contrib-dir (base-dir)
(append-dir base-dir "contrib"))
(defun load-swank (&key (src-dir *source-directory*)
(fasl-dir *fasl-directory*)
quiet)
(with-compilation-unit ()
(compile-files (src-files *swank-files* src-dir) fasl-dir t quiet))
(funcall (q "swank::before-init")
(slime-version-string)
(list (contrib-dir fasl-dir)
(contrib-dir src-dir))))
(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir)
(let ((newest (reduce #'max (mapcar #'file-write-date swank-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 compile-contribs (&key (src-dir (contrib-dir *source-directory*))
(fasl-dir (contrib-dir *fasl-directory*))
(swank-src-dir *source-directory*)
load quiet)
(let* ((swank-src-files (src-files *swank-files* swank-src-dir))
(contrib-src-files (src-files *contribs* src-dir)))
(delete-stale-contrib-fasl-files swank-src-files contrib-src-files
fasl-dir)
(compile-files contrib-src-files fasl-dir load quiet)))
(defun loadup ()
(load-swank)
(compile-contribs :load t))
(defun setup ()
(load-site-init-file *source-directory*)
(load-user-init-file)
(when (#-clisp probe-file
#+clisp ext:probe-directory
(contrib-dir *source-directory*))
(eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
(funcall (q "swank::init")))
(defun list-swank-packages ()
(remove-if-not (lambda (package)
(let ((name (package-name package)))
(and (string-not-equal name "swank-loader")
(string-starts-with name "swank"))))
(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 load-contribs (setup t)
(quiet (not *load-verbose*))
from-emacs)
"Load SWANK and initialize some global variables.
If DELETE is true, delete any existing SWANK packages.
If RELOAD is true, reload SWANK, even if the SWANK package already exists.
If LOAD-CONTRIBS is true, load all contribs
If SETUP is true, load user init files and initialize some
global variabes in SWANK."
(when from-emacs
(setf *started-from-emacs* t))
(when (and delete (find-package :swank))
(delete-packages (list-swank-packages)))
(cond ((or (not (find-package :swank)) reload)
(load-swank :quiet quiet))
(t
(warn "Not reloading SWANK. Package already exists.")))
(when load-contribs
(compile-contribs :load t :quiet quiet))
(when setup
(setup)))
(defun dump-image (filename)
(init :setup nil)
(funcall (q "swank/backend:save-image") filename))
(defun list-fasls (&key (include-contribs t) (compile t)
(quiet (not *compile-verbose*)))
"List up SWANK's fasls along with their dependencies."
(flet ((collect-fasls (files fasl-dir)
(when compile
(compile-files files fasl-dir nil quiet))
(loop for src in files
when (probe-file (binary-pathname src fasl-dir))
collect it)))
(append (collect-fasls (src-files *swank-files* *source-directory*)
*fasl-directory*)
(when include-contribs
(collect-fasls (src-files *contribs*
(contrib-dir *source-directory*))
(contrib-dir *fasl-directory*))))))

36
sources_non_forked/slimv/slime/swank.asd Normal file
View File

@ -0,0 +1,36 @@
;;; -*- lisp -*-
;; ASDF system definition for loading the Swank server independently
;; of Emacs.
;;
;; This is only useful if you want to start a Swank server in a Lisp
;; processes that doesn't run under Emacs. Lisp processes created by
;; `M-x slime' automatically start the server.
;; Usage:
;;
;; (require :swank)
;; (swank:create-swank-server PORT) => ACTUAL-PORT
;;
;; (PORT can be zero to mean "any available port".)
;; Then the Swank server is running on localhost:ACTUAL-PORT. You can
;; use `M-x slime-connect' to connect Emacs to it.
;;
;; This code has been placed in the Public Domain. All warranties
;; are disclaimed.
(defclass swank-loader-file (asdf:cl-source-file) ())
;;;; after loading run init
(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file))
;; swank-loader computes its own source/fasl relation based on the
;; TRUENAME of the loader file, so we need a "manual" CL:LOAD
;; invocation here.
(load (asdf::component-pathname f))
;; After loading, run the swank-loader init routines.
(funcall (read-from-string "swank-loader::init") :reload t))
(asdf:defsystem :swank
:default-component-class swank-loader-file
:components ((:file "swank-loader")))

3800
sources_non_forked/slimv/slime/swank.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

1536
sources_non_forked/slimv/slime/swank/abcl.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

1086
sources_non_forked/slimv/slime/swank/allegro.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

1581
sources_non_forked/slimv/slime/swank/backend.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

868
sources_non_forked/slimv/slime/swank/ccl.lisp Normal file
View File

@ -0,0 +1,868 @@
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-ccl.lisp --- SLIME 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 swank/ccl
(:use cl swank/backend))
(in-package swank/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))))
;;; swank-mop
(import-to-swank-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))
;;; 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 swank/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 swank-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 swank-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 swank-clisp)
(defimplementation profile (fname)
(eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
swank-monitor:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(swank-monitor:unmonitor))
(defimplementation profile-report ()
(swank-monitor:report-monitoring))
(defimplementation profile-reset ()
(swank-monitor:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(swank-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 (swank::default-connection)))
(and (swank::multithreaded-connection-p conn)
(swank::mconn.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-call (frame-number)
(with-frame (p context) frame-number
(with-output-to-string (stream)
(print-frame (list :frame p context) stream))))
(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)))))
;;; 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 (Swank)")
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-slime-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*)

712
sources_non_forked/slimv/slime/swank/clasp.lisp Normal file
View File

@ -0,0 +1,712 @@
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-clasp.lisp --- SLIME backend for CLASP.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;;; Administrivia
(defpackage swank/clasp
(:use cl swank/backend))
(in-package swank/clasp)
#+(or)
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq swank::*log-output* (open "/tmp/slime.log" :direction :output))
(setq swank:*log-events* t))
(defmacro slime-dbg (fmt &rest args)
`(swank::log-event "slime-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*)))
(declaim (optimize (debug 3)))
;;; Swank-mop
(eval-when (:compile-toplevel :load-toplevel :execute)
(import-swank-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)
(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
;; SWANK: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 Slime'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 ()
(core: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-slime-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-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))))))
;;;; 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)
(if (null origin)
(make-error-location "No error location available")
;; 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
(core:file-scope-pathname
(core:file-scope origin))
(core:source-pos-info-filepos 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)))
(defimplementation swank-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 (si:mkstemp "TMP:clasp-swank-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 swank-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 (si:mkstemp "TMP:clasp-swank-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)
(core: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 (core: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 swank backend, that's
;;; a bad idea.
;; (defun in-swank-package-p (x)
;; (and
;; (symbolp x)
;; (member (symbol-package x)
;; (list #.(find-package :swank)
;; #.(find-package :swank/backend)
;; #.(ignore-errors (find-package :swank-mop))
;; #.(ignore-errors (find-package :swank-loader))))
;; t))
;; (defun is-swank-source-p (name)
;; (setf name (pathname name))
;; (pathname-match-p
;; name
;; (make-pathname :defaults swank-loader::*source-directory*
;; :name (pathname-name name)
;; :type (pathname-type name)
;; :version (pathname-version name))))
;; (defun is-ignorable-fun-p (x)
;; (or
;; (in-swank-package-p (frame-name x))
;; (multiple-value-bind (file position)
;; (ignore-errors (si::bc-file (car x)))
;; (declare (ignore position))
;; (if file (is-swank-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 (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 (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 `(swank-monitor:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
swank-monitor:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(swank-monitor:unmonitor))
(defimplementation profile-report ()
(swank-monitor:report-monitoring))
(defimplementation profile-reset ()
(swank-monitor:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(swank-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 "SLIMELCK"))
(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)))
(swank::log-event "clasp.lisp: send message ~a mutex: ~a~%" message mutex)
(swank::log-event "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
(swank::log-event "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
(mp:with-lock (mutex)
(swank::log-event "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
(swank::log-event "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(swank::log-event "clasp.lisp: send about to broadcast~%")
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
(defimplementation receive-if (test &optional timeout)
(slime-dbg "Entered receive-if")
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox)))
(slime-dbg "receive-if assert")
(assert (or (not timeout) (eq timeout t)))
(loop
(slime-dbg "receive-if check-slime-interrupts")
(check-slime-interrupts)
(slime-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))))
(slime-dbg "receive-if when (eq")
(when (eq timeout t) (return (values nil t)))
(slime-dbg "receive-if condition-variable-timedwait")
(mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2
(slime-dbg "came out of condition-variable-timedwait")
(core:check-pending-interrupts)))))
) ; #+threads (progn ...
(defmethod emacs-inspect ((object core:cxx-object))
(let ((encoded (core:encode object)))
(loop for (key . value) in encoded
append (list (string key) ": " (list :value value) (list :newline)))))
(defmethod emacs-inspect ((object core:va-list))
(emacs-inspect (core:list-from-va-list object)))

930
sources_non_forked/slimv/slime/swank/clisp.lisp Normal file
View File

@ -0,0 +1,930 @@
;;;; -*- indent-tabs-mode: nil -*-
;;;; SWANK 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 swank-*.lisp, in particular from
;;; swank-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 SLIME.
;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
(defpackage swank/clisp
(:use cl swank/backend))
(in-package swank/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" swank-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 swank/clisp::*have-mop* '(cl:and) '(cl:or))
(progn
(import-swank-mop-symbols :clos '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
(clos::slot-definition-documentation slot)))
#-#.(cl:if swank/clisp::*have-mop* '(and) '(or))
(defclass swank-mop:standard-slot-definition ()
()
(:documentation
"Dummy class created so that swank.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-slime-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-slime-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))))
;;;; Swank 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 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 () ,form))))
(values macro-forms nil)))
(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 *sldb-backtrace*)
(defun sldb-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)
(*sldb-backtrace*
(let* ((f (sys::the-frame))
(bt (sldb-backtrace))
(rest (member f bt)))
(if rest (nthcdr 8 rest) bt))))
(funcall debugger-loop-fn)))
(defun nth-frame (index)
(nth index *sldb-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 *sldb-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-sldb-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 `(swank-monitor:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
swank-monitor:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(swank-monitor:unmonitor))
(defimplementation profile-report ()
(swank-monitor:report-monitoring))
(defimplementation profile-reset ()
(swank-monitor:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(swank-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 swank-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 swank-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 :swank-loader)
(setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
(lambda ()
(let ((home (user-homedir-pathname)))
(and (ext:probe-directory home)
(probe-file (format nil "~A/.swank.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-slime-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)))

2470
sources_non_forked/slimv/slime/swank/cmucl.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

583
sources_non_forked/slimv/slime/swank/corman.lisp Normal file
View File

@ -0,0 +1,583 @@
;;;
;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
;;;
;;; 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 SLIME
;;; will blow up in your face. You should also follow the
;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
;;;
;;; The only communication style currently supported is NIL.
;;;
;;; Starting CCL inside emacs (with M-x slime) 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
;;; slime-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 :swank/backend)
;;; Pull in various needed bits
(require :composite-streams)
(require :sockets)
(require :winbase)
(require :lp)
(use-package :gs)
;; MOP stuff
(defclass swank-mop:standard-slot-definition ()
()
(:documentation
"Dummy class created so that swank.lisp will compile and load."))
(defun named-by-gensym-p (c)
(null (symbol-package (class-name c))))
(deftype swank-mop:eql-specializer ()
'(satisfies named-by-gensym-p))
(defun swank-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 swank-mop:class-finalized-p (class)
(declare (ignore class))
t)
(defun swank-mop:class-prototype (class)
(make-instance class))
(defun swank-mop:specializer-direct-methods (obj)
(declare (ignore obj))
nil)
(defun swank-mop:generic-function-argument-precedence-order (gf)
(generic-function-lambda-list gf))
(defun swank-mop:generic-function-method-combination (gf)
(declare (ignore gf))
:standard)
(defun swank-mop:generic-function-declarations (gf)
(declare (ignore gf))
nil)
(defun swank-mop:slot-definition-documentation (slot)
(declare (ignore slot))
(getf slot :documentation nil))
(defun swank-mop:slot-definition-type (slot)
(declare (ignore slot))
t)
(import-swank-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))
;;;; swank 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 swank-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 swank-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 swank.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 (swank-mop:class-direct-superclasses class))
(:newline)
"Direct Slots: "
,@(comma-separated
(swank-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot
,(princ-to-string
(swank-mop:slot-definition-name slot)))))
(:newline)
"Effective Slots: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated
(swank-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(princ-to-string
(swank-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 (swank-mop:class-direct-subclasses class)
(lambda (sub)
`(:value ,sub ,(princ-to-string (class-name sub)))))
(:newline)
"Precedence List: "
,@(if (swank-mop:class-finalized-p class)
(comma-separated
(swank-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 ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
`("Documentation:"
(:newline)
(:value
,(swank-mop:slot-definition-documentation slot))
(:newline)))
"Init args: " (:value
,(swank-mop:slot-definition-initargs slot))
(:newline)
"Init form: "
,(if (swank-mop:slot-definition-initfunction slot)
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: "
(:value ,(swank-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))))

1098
sources_non_forked/slimv/slime/swank/ecl.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

207
sources_non_forked/slimv/slime/swank/gray.lisp Normal file
View File

@ -0,0 +1,207 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; swank-gray.lisp --- Gray stream based IO redirection.
;;;
;;; Created 2003
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(in-package swank/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 swank/gray
(:use cl swank/backend)
(:import-from #.(gray-package-name) . #.*gray-stream-symbols*)
(:export . #.*gray-stream-symbols*))
(in-package swank/gray)
(defclass slime-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-slime-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 slime-output-stream) char)
(with-slime-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 slime-output-stream) string
&optional start end)
(with-slime-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 slime-output-stream))
(with-slime-output-stream stream column))
(defmethod stream-finish-output ((stream slime-output-stream))
(with-slime-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 slime-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 slime-output-stream))
(stream-finish-output stream))
(defmethod stream-fresh-line ((stream slime-output-stream))
(with-slime-output-stream stream
(cond ((zerop column) nil)
(t (terpri stream) t))))
(defclass slime-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 slime-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 slime-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(< index (length buffer))))))
(defmethod stream-unread-char ((s slime-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 slime-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 slime-input-stream))
nil)
(defmethod stream-read-char-no-hang ((s slime-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 'slime-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 'slime-output-stream :output-fn write-string))
(defimplementation make-input-stream (read-string)
(make-instance 'slime-input-stream :input-fn read-string))

1020
sources_non_forked/slimv/slime/swank/lispworks.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

242
sources_non_forked/slimv/slime/swank/match.lisp Normal file
View File

@ -0,0 +1,242 @@
;;
;; 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.
;;
(in-package swank/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)))))

700
sources_non_forked/slimv/slime/swank/mezzano.lisp Normal file
View File

@ -0,0 +1,700 @@
;;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-mezzano.lisp --- SLIME backend for Mezzano
;;;
;;; This code has been placed in the Public Domain. All warranties are
;;; disclaimed.
;;;
;;; Administrivia
(defpackage swank/mezzano
(:use cl swank/backend))
(in-package swank/mezzano)
;;; swank-mop
(import-swank-mop-symbols :mezzano.clos '(:class-default-initargs
:class-direct-default-initargs
:specializer-direct-methods
:generic-function-declarations))
(defun swank-mop:specializer-direct-methods (obj)
(declare (ignore obj))
'())
(defun swank-mop:generic-function-declarations (gf)
(declare (ignore gf))
'())
(defimplementation gray-package-name ()
"MEZZANO.GRAY")
;;;; TCP server
(defclass listen-socket ()
((%listener :initarg :listener)))
(defimplementation create-socket (host port &key backlog)
(make-instance 'listen-socket
:listener (mezzano.network.tcp:tcp-listen
host
port
:backlog (or backlog 10))))
(defimplementation local-port (socket)
(mezzano.network.tcp:tcp-listener-local-port (slot-value socket '%listener)))
(defimplementation close-socket (socket)
(mezzano.network.tcp:close-tcp-listener (slot-value socket '%listener)))
(defimplementation accept-connection (socket &key external-format
buffering timeout)
(declare (ignore external-format buffering timeout))
(loop
(let ((value (mezzano.network.tcp:tcp-accept (slot-value socket '%listener)
:wait-p nil)))
(if value
(return value)
;; Poke standard-input every now and then to keep the console alive.
(progn (listen)
(sleep 0.05))))))
(defimplementation preferred-communication-style ()
:spawn)
;;;; Unix signals
;;;; ????
(defimplementation getpid ()
0)
;;;; Compilation
(defun signal-compiler-condition (condition severity)
(signal 'compiler-condition
:original-condition condition
:severity severity
:message (format nil "~A" condition)
:location nil))
(defimplementation call-with-compilation-hooks (func)
(handler-bind
((error
(lambda (c)
(signal-compiler-condition c :error)))
(warning
(lambda (c)
(signal-compiler-condition c :warning)))
(style-warning
(lambda (c)
(signal-compiler-condition c :style-warning))))
(funcall func)))
(defimplementation swank-compile-string (string &key buffer position filename
line column policy)
(declare (ignore buffer line column policy))
(let* ((*load-pathname* (ignore-errors (pathname filename)))
(*load-truename* (when *load-pathname*
(ignore-errors (truename *load-pathname*))))
(sys.int::*top-level-form-number* `(:position ,position)))
(with-compilation-hooks ()
(eval (read-from-string (concatenate 'string "(progn " string " )")))))
t)
(defimplementation swank-compile-file (input-file output-file load-p
external-format
&key policy)
(with-compilation-hooks ()
(multiple-value-prog1
(compile-file input-file
:output-file output-file
:external-format external-format)
(when load-p
(load output-file)))))
(defimplementation find-external-format (coding-system)
(if (or (equal coding-system "utf-8")
(equal coding-system "utf-8-unix"))
:default
nil))
;;;; Debugging
;; Definitely don't allow this.
(defimplementation install-debugger-globally (function)
(declare (ignore function))
nil)
(defvar *current-backtrace*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let ((*current-backtrace* '()))
(let ((prev-fp nil))
(sys.int::map-backtrace
(lambda (i fp)
(push (list (1- i) fp prev-fp) *current-backtrace*)
(setf prev-fp fp))))
(setf *current-backtrace* (reverse *current-backtrace*))
;; Drop the topmost frame, which is finished call to MAP-BACKTRACE.
(pop *current-backtrace*)
;; And the next one for good measure.
(pop *current-backtrace*)
(funcall debugger-loop-fn)))
(defimplementation compute-backtrace (start end)
(subseq *current-backtrace* start end))
(defimplementation print-frame (frame stream)
(format stream "~S" (sys.int::function-from-frame frame)))
(defimplementation frame-source-location (frame-number)
(let* ((frame (nth frame-number *current-backtrace*))
(fn (sys.int::function-from-frame frame)))
(function-location fn)))
(defimplementation frame-locals (frame-number)
(loop
with frame = (nth frame-number *current-backtrace*)
for (name id location repr) in (sys.int::frame-locals frame)
collect (list :name name
:id id
:value (sys.int::read-frame-slot frame location repr))))
(defimplementation frame-var-value (frame-number var-id)
(let* ((frame (nth frame-number *current-backtrace*))
(locals (sys.int::frame-locals frame))
(info (nth var-id locals)))
(if info
(destructuring-bind (name id location repr)
info
(declare (ignore id))
(values (sys.int::read-frame-slot frame location repr) name))
(error "Invalid variable id ~D for frame number ~D."
var-id frame-number))))
;;;; Definition finding
(defun top-level-form-position (pathname tlf)
(ignore-errors
(with-open-file (s pathname)
(loop
repeat tlf
do (with-standard-io-syntax
(let ((*read-suppress* t)
(*read-eval* nil))
(read s nil))))
(let ((default (make-pathname :host (pathname-host s))))
(make-location `(:file ,(enough-namestring s default))
`(:position ,(1+ (file-position s))))))))
(defun function-location (function)
"Return a location object for FUNCTION."
(let* ((info (sys.int::function-debug-info function))
(pathname (sys.int::debug-info-source-pathname info))
(tlf (sys.int::debug-info-source-top-level-form-number info)))
(cond ((and (consp tlf)
(eql (first tlf) :position))
(let ((default (make-pathname :host (pathname-host pathname))))
(make-location `(:file ,(enough-namestring pathname default))
`(:position ,(second tlf)))))
(t
(top-level-form-position pathname tlf)))))
(defun method-definition-name (name method)
`(defmethod ,name
,@(mezzano.clos:method-qualifiers method)
,(mapcar (lambda (x)
(typecase x
(mezzano.clos:class
(mezzano.clos:class-name x))
(mezzano.clos:eql-specializer
`(eql ,(mezzano.clos:eql-specializer-object x)))
(t x)))
(mezzano.clos:method-specializers method))))
(defimplementation find-definitions (name)
(let ((result '()))
(labels
((frob-fn (dspec fn)
(let ((loc (function-location fn)))
(when loc
(push (list dspec loc) result))))
(try-fn (name)
(when (valid-function-name-p name)
(when (and (fboundp name)
(not (and (symbolp name)
(or (special-operator-p name)
(macro-function name)))))
(let ((fn (fdefinition name)))
(cond ((typep fn 'mezzano.clos:standard-generic-function)
(dolist (m (mezzano.clos:generic-function-methods fn))
(frob-fn (method-definition-name name m)
(mezzano.clos:method-function m))))
(t
(frob-fn `(defun ,name) fn)))))
(when (compiler-macro-function name)
(frob-fn `(define-compiler-macro ,name)
(compiler-macro-function name))))))
(try-fn name)
(try-fn `(setf name))
(try-fn `(sys.int::cas name))
(when (and (symbolp name)
(get name 'sys.int::setf-expander))
(frob-fn `(define-setf-expander ,name)
(get name 'sys.int::setf-expander)))
(when (and (symbolp name)
(macro-function name))
(frob-fn `(defmacro ,name)
(macro-function name))))
result))
;;;; XREF
;;; Simpler variants.
(defun find-all-frefs ()
(let ((frefs (make-array 500 :adjustable t :fill-pointer 0))
(keep-going t))
(loop
(when (not keep-going)
(return))
(adjust-array frefs (* (array-dimension frefs 0) 2))
(setf keep-going nil
(fill-pointer frefs) 0)
;; Walk the wired area looking for FREFs.
(sys.int::walk-area
:wired
(lambda (object address size)
(when (sys.int::function-reference-p object)
(when (not (vector-push object frefs))
(setf keep-going t))))))
(remove-duplicates (coerce frefs 'list))))
(defimplementation list-callers (function-name)
(let ((fref-for-fn (sys.int::function-reference function-name))
(callers '()))
(loop
for fref in (find-all-frefs)
for fn = (sys.int::function-reference-function fref)
for name = (sys.int::function-reference-name fref)
when fn
do
(cond ((typep fn 'standard-generic-function)
(dolist (m (mezzano.clos:generic-function-methods fn))
(let* ((mf (mezzano.clos:method-function m))
(mf-frefs (get-all-frefs-in-function mf)))
(when (member fref-for-fn mf-frefs)
(push `((defmethod ,name
,@(mezzano.clos:method-qualifiers m)
,(mapcar #'specializer-name
(mezzano.clos:method-specializers m)))
,(function-location mf))
callers)))))
((member fref-for-fn
(get-all-frefs-in-function fn))
(push `((defun ,name) ,(function-location fn)) callers))))
callers))
(defun specializer-name (specializer)
(if (typep specializer 'standard-class)
(mezzano.clos:class-name specializer)
specializer))
(defun get-all-frefs-in-function (function)
(when (sys.int::funcallable-std-instance-p function)
(setf function (sys.int::funcallable-std-instance-function function)))
(when (sys.int::closure-p function)
(setf function (sys.int::%closure-function function)))
(loop
for i below (sys.int::function-pool-size function)
for entry = (sys.int::function-pool-object function i)
when (sys.int::function-reference-p entry)
collect entry
when (compiled-function-p entry) ; closures
append (get-all-frefs-in-function entry)))
(defimplementation list-callees (function-name)
(let* ((fn (fdefinition function-name))
;; Grovel around in the function's constant pool looking for
;; function-references. These may be for #', but they're
;; probably going to be for normal calls.
;; TODO: This doesn't work well on interpreted functions or
;; funcallable instances.
(callees (remove-duplicates (get-all-frefs-in-function fn))))
(loop
for fref in callees
for name = (sys.int::function-reference-name fref)
for fn = (sys.int::function-reference-function fref)
when fn
collect `((defun ,name) ,(function-location fn)))))
;;;; Documentation
(defimplementation arglist (name)
(let ((macro (when (symbolp name)
(macro-function name)))
(fn (if (functionp name)
name
(ignore-errors (fdefinition name)))))
(cond
(macro
(get name 'sys.int::macro-lambda-list))
(fn
(cond
((typep fn 'mezzano.clos:standard-generic-function)
(mezzano.clos:generic-function-lambda-list fn))
(t
(function-lambda-list fn))))
(t :not-available))))
(defun function-lambda-list (function)
(sys.int::debug-info-lambda-list
(sys.int::function-debug-info function)))
(defimplementation type-specifier-p (symbol)
(cond
((or (get symbol 'sys.int::type-expander)
(get symbol 'sys.int::compound-type)
(get symbol 'sys.int::type-symbol))
t)
(t :not-available)))
(defimplementation function-name (function)
(sys.int::function-name function))
(defimplementation 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)
(or (eq (first form) 'setf)
(eq (first form) 'sys.int::cas))
(symbolp (second form))))))
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(when (boundp symbol)
(setf (getf result :variable) nil))
(when (and (fboundp symbol)
(not (macro-function symbol)))
(setf (getf result :function)
(function-docstring symbol)))
(when (fboundp `(setf ,symbol))
(setf (getf result :setf)
(function-docstring `(setf ,symbol))))
(when (get symbol 'sys.int::setf-expander)
(setf (getf result :setf) nil))
(when (special-operator-p symbol)
(setf (getf result :special-operator) nil))
(when (macro-function symbol)
(setf (getf result :macro) nil))
(when (compiler-macro-function symbol)
(setf (getf result :compiler-macro) nil))
(when (type-specifier-p symbol)
(setf (getf result :type) nil))
(when (find-class symbol nil)
(setf (getf result :class) nil))
result))
(defun function-docstring (function-name)
(let* ((definition (fdefinition function-name))
(debug-info (sys.int::function-debug-info definition)))
(sys.int::debug-info-docstring debug-info)))
;;;; Multithreading
;; FIXME: This should be a weak table.
(defvar *thread-ids-for-emacs* (make-hash-table))
(defvar *next-thread-id-for-emacs* 0)
(defvar *thread-id-for-emacs-lock* (mezzano.supervisor:make-mutex
"SWANK thread ID table"))
(defimplementation spawn (fn &key name)
(mezzano.supervisor:make-thread fn :name name))
(defimplementation thread-id (thread)
(mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
(let ((id (gethash thread *thread-ids-for-emacs*)))
(when (null id)
(setf id (incf *next-thread-id-for-emacs*)
(gethash thread *thread-ids-for-emacs*) id
(gethash id *thread-ids-for-emacs*) thread))
id)))
(defimplementation find-thread (id)
(mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
(gethash id *thread-ids-for-emacs*)))
(defimplementation thread-name (thread)
(mezzano.supervisor:thread-name thread))
(defimplementation thread-status (thread)
(format nil "~:(~A~)" (mezzano.supervisor:thread-state thread)))
(defimplementation current-thread ()
(mezzano.supervisor:current-thread))
(defimplementation all-threads ()
(mezzano.supervisor:all-threads))
(defimplementation thread-alive-p (thread)
(not (eql (mezzano.supervisor:thread-state thread) :dead)))
(defimplementation interrupt-thread (thread fn)
(mezzano.supervisor:establish-thread-foothold thread fn))
(defimplementation kill-thread (thread)
;; Documentation says not to execute unwind-protected sections, but there's
;; no way to do that.
;; And killing threads at arbitrary points without unwinding them is a good
;; way to hose the system.
(mezzano.supervisor:terminate-thread thread))
(defvar *mailbox-lock* (mezzano.supervisor:make-mutex "mailbox lock"))
(defvar *mailboxes* (list))
(defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (mezzano.supervisor:make-mutex))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
;; Use weak pointers to avoid holding on to dead threads forever.
(mezzano.supervisor:with-mutex (*mailbox-lock*)
;; Flush forgotten threads.
(setf *mailboxes*
(remove-if-not #'sys.int::weak-pointer-value *mailboxes*))
(loop
for entry in *mailboxes*
do
(multiple-value-bind (key value livep)
(sys.int::weak-pointer-pair entry)
(when (eql key thread)
(return value)))
finally
(let ((mb (make-mailbox :thread thread)))
(push (sys.int::make-weak-pointer thread mb) *mailboxes*)
(return mb)))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(mezzano.supervisor:with-mutex (mutex)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
(defvar *receive-if-sleep-time* 0.02)
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
(mezzano.supervisor: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))))
(sleep *receive-if-sleep-time*))))
(defvar *registered-threads* (make-hash-table))
(defvar *registered-threads-lock*
(mezzano.supervisor:make-mutex "registered threads lock"))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(mezzano.supervisor:with-mutex (*registered-threads-lock*)
(etypecase thread
(null
(remhash name *registered-threads*))
(mezzano.supervisor:thread
(setf (gethash name *registered-threads*) thread))))
nil)
(defimplementation find-registered (name)
(mezzano.supervisor:with-mutex (*registered-threads-lock*)
(values (gethash name *registered-threads*))))
(defimplementation wait-for-input (streams &optional timeout)
(loop
(let ((ready '()))
(dolist (s streams)
(when (or (listen s)
(and (typep s 'mezzano.network.tcp::tcp-stream)
(mezzano.network.tcp::tcp-connection-closed-p s)))
(push s ready)))
(when ready
(return ready))
(when (check-slime-interrupts)
(return :interrupt))
(when timeout
(return '()))
(sleep 1)
(when (numberp timeout)
(decf timeout 1)
(when (not (plusp timeout))
(return '()))))))
;;;; Locks
(defstruct recursive-lock
mutex
(depth 0))
(defimplementation make-lock (&key name)
(make-recursive-lock
:mutex (mezzano.supervisor:make-mutex name)))
(defimplementation call-with-lock-held (lock function)
(cond ((mezzano.supervisor:mutex-held-p
(recursive-lock-mutex lock))
(unwind-protect
(progn (incf (recursive-lock-depth lock))
(funcall function))
(decf (recursive-lock-depth lock))))
(t
(mezzano.supervisor:with-mutex ((recursive-lock-mutex lock))
(multiple-value-prog1
(funcall function)
(assert (eql (recursive-lock-depth lock) 0)))))))
;;;; Character names
(defimplementation character-completion-set (prefix matchp)
;; TODO: Unicode characters too.
(loop
for names in sys.int::*char-name-alist*
append
(loop
for name in (rest names)
when (funcall matchp prefix name)
collect name)))
;;;; Inspector
(defmethod emacs-inspect ((o function))
(case (sys.int::%object-tag o)
(#.sys.int::+object-tag-function+
(label-value-line*
(:name (sys.int::function-name o))
(:arglist (arglist o))
(:debug-info (sys.int::function-debug-info o))))
(#.sys.int::+object-tag-closure+
(append
(label-value-line :function (sys.int::%closure-function o))
`("Closed over values:" (:newline))
(loop
for i below (sys.int::%closure-length o)
append (label-value-line i (sys.int::%closure-value o i)))))
(t
(call-next-method))))
(defmethod emacs-inspect ((o sys.int::weak-pointer))
(label-value-line*
(:key (sys.int::weak-pointer-key o))
(:value (sys.int::weak-pointer-value o))))
(defmethod emacs-inspect ((o sys.int::function-reference))
(label-value-line*
(:name (sys.int::function-reference-name o))
(:function (sys.int::function-reference-function o))))
(defmethod emacs-inspect ((object structure-object))
(let ((class (class-of object)))
`("Class: " (:value ,class) (:newline)
,@(swank::all-slots-for-inspector object))))
(in-package :swank)
(defmethod all-slots-for-inspector ((object structure-object))
(let* ((class (class-of object))
(direct-slots (swank-mop:class-direct-slots class))
(effective-slots (swank-mop:class-slots class))
(longest-slot-name-length
(loop for slot :in effective-slots
maximize (length (symbol-name
(swank-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 #'swank-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)
(swank-mop:slot-makunbound-using-class
class object (nth idx effective-slots))))
:refreshp t)
(:newline))))

933
sources_non_forked/slimv/slime/swank/mkcl.lisp Normal file
View File

@ -0,0 +1,933 @@
;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-mkcl.lisp --- SLIME backend for MKCL.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;;; Administrivia
(defpackage swank/mkcl
(:use cl swank/backend))
(in-package swank/mkcl)
;;(declaim (optimize (debug 3)))
(defvar *tmp*)
(defimplementation gray-package-name ()
'#:gray)
(eval-when (:compile-toplevel :load-toplevel)
(swank/backend::import-swank-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
;; SWANK: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 ()
(progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO 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 swank-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 "~%swank saw a compiler note: ~A~%" n) (finish-output) nil))
(compiler::compiler-warning
#'(lambda (w)
(format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil))
(compiler::compiler-error
#'(lambda (e)
(format t "~%swank 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 swank-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-SWANK-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-swank-package-p (x)
(and
(symbolp x)
(member (symbol-package x)
(list #.(find-package :swank)
#.(find-package :swank/backend)
#.(ignore-errors (find-package :swank-mop))
#.(ignore-errors (find-package :swank-loader))))
t))
(defun is-swank-source-p (name)
(setf name (pathname name))
#+(or)
(pathname-match-p
name
(make-pathname :defaults swank-loader::*source-directory*
:name (pathname-name name)
:type (pathname-type name)
:version (pathname-version name)))
nil)
(defun is-ignorable-fun-p (x)
(or
(in-swank-package-p (frame-name x))
(multiple-value-bind (file position)
(ignore-errors (si::compiled-function-file (car x)))
(declare (ignore position))
(if file (is-swank-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 (swank-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 (swank-mkcl) receive-if: semaphore-wait timed out!~%"))
)
)
(condition (condition)
(format t "~&Error in (swank-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)
)

162
sources_non_forked/slimv/slime/swank/rpc.lisp Normal file
View File

@ -0,0 +1,162 @@
;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
;;;
;;; swank-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.
;;;
(in-package swank/rpc)
;;;;; Input
(define-condition swank-reader-error (reader-error)
((packet :type string :initarg :packet
:reader swank-reader-error.packet)
(cause :type reader-error :initarg :cause
:reader swank-reader-error.cause)))
(defun read-message (stream package)
(let ((packet (read-packet stream)))
(handler-case (values (read-form packet package))
(reader-error (c)
(error 'swank-reader-error
:packet packet :cause c)))))
(defun read-packet (stream)
(let* ((length (parse-header stream))
(octets (read-chunk stream length)))
(handler-case (swank/backend:utf8-to-string octets)
(error (c)
(error 'swank-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 *validate-input* nil
"Set to true to require input that more strictly conforms to the protocol")
(defun read-form (string package)
(with-standard-io-syntax
(let ((*package* package))
(if *validate-input*
(validating-read string)
(read-from-string string)))))
(defun validating-read (string)
(with-input-from-string (*standard-input* string)
(simple-read)))
(defun simple-read ()
"Read a form that conforms to the protocol, otherwise signal an error."
(let ((c (read-char)))
(case c
(#\( (loop collect (simple-read)
while (ecase (read-char)
(#\) nil)
(#\space t))))
(#\' `(quote ,(simple-read)))
(t
(cond
((digit-char-p c)
(parse-integer
(map 'simple-string #'identity
(loop for ch = c then (read-char nil nil)
while (and ch (digit-char-p ch))
collect ch
finally (unread-char ch)))))
((or (member c '(#\: #\")) (alpha-char-p c))
(unread-char c)
(read-preserving-whitespace))
(t (error "Invalid character ~:c" c)))))))
;;;;; Output
(defun write-message (message package stream)
(let* ((string (prin1-to-string-for-emacs message package))
(octets (handler-case (swank/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)
(swank/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*)))
|#

2036
sources_non_forked/slimv/slime/swank/sbcl.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

1726
sources_non_forked/slimv/slime/swank/scl.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

136
sources_non_forked/slimv/slime/swank/source-file-cache.lisp Normal file
View File

@ -0,0 +1,136 @@
;;;; 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 swank/source-file-cache
(:use cl)
(:import-from swank/backend
defimplementation buffer-first-change
guess-external-format
find-external-format)
(: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 swank/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)))

242
sources_non_forked/slimv/slime/swank/source-path-parser.lisp Normal file
View File

@ -0,0 +1,242 @@
;;;; 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 swank-cmucl.lisp, by Helmut Eller
(defpackage swank/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 swank/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 swank
;; package.
(funcall (read-from-string "swank::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 swank.lisp so that all backends
;; use the same heuristic and to avoid the need to access
;; swank::guess-buffer-readtable from here.
(defun guess-reader-state (stream)
(let* ((point (file-position stream))
(pkg *package*))
(file-position stream 0)
(loop for line = (read-line stream nil nil) 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)))))

2906
sources_non_forked/slimv/slime/xref.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

227
sources_non_forked/slimv/swank-clojure/COPYING Normal file
View File

@ -0,0 +1,227 @@
Eclipse Public License - v 1.0
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF
THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
1. DEFINITIONS
"Contribution" means:
a) in the case of the initial Contributor, the initial code and
documentation distributed under this Agreement, and
b) in the case of each subsequent Contributor:
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program originate from and
are distributed by that particular Contributor. A Contribution
'originates' from a Contributor if it was added to the Program by such
Contributor itself or anyone acting on such Contributor's
behalf. Contributions do not include additions to the Program which:
(i) are separate modules of software distributed in conjunction with
the Program under their own license agreement, and (ii) are not
derivative works of the Program.
"Contributor" means any person or entity that distributes the Program.
"Licensed Patents" mean patent claims licensable by a Contributor
which are necessarily infringed by the use or sale of its Contribution
alone or when combined with the Program.
"Program" means the Contributions distributed in accordance with this
Agreement.
"Recipient" means anyone who receives the Program under this
Agreement, including all Contributors.
2. GRANT OF RIGHTS
a) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free copyright
license to reproduce, prepare derivative works of, publicly display,
publicly perform, distribute and sublicense the Contribution of such
Contributor, if any, and such derivative works, in source code and
object code form.
b) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free patent
license under Licensed Patents to make, use, sell, offer to sell,
import and otherwise transfer the Contribution of such Contributor, if
any, in source code and object code form. This patent license shall
apply to the combination of the Contribution and the Program if, at
the time the Contribution is added by the Contributor, such addition
of the Contribution causes such combination to be covered by the
Licensed Patents. The patent license shall not apply to any other
combinations which include the Contribution. No hardware per se is
licensed hereunder.
c) Recipient understands that although each Contributor grants the
licenses to its Contributions set forth herein, no assurances are
provided by any Contributor that the Program does not infringe the
patent or other intellectual property rights of any other entity. Each
Contributor disclaims any liability to Recipient for claims brought by
any other entity based on infringement of intellectual property rights
or otherwise. As a condition to exercising the rights and licenses
granted hereunder, each Recipient hereby assumes sole responsibility
to secure any other intellectual property rights needed, if any. For
example, if a third party patent license is required to allow
Recipient to distribute the Program, it is Recipient's responsibility
to acquire that license before distributing the Program.
d) Each Contributor represents that to its knowledge it has sufficient
copyright rights in its Contribution, if any, to grant the copyright
license set forth in this Agreement.
3. REQUIREMENTS
A Contributor may choose to distribute the Program in object code form
under its own license agreement, provided that:
a) it complies with the terms and conditions of this Agreement; and
b) its license agreement:
i) effectively disclaims on behalf of all Contributors all warranties
and conditions, express and implied, including warranties or
conditions of title and non-infringement, and implied warranties or
conditions of merchantability and fitness for a particular purpose;
ii) effectively excludes on behalf of all Contributors all liability
for damages, including direct, indirect, special, incidental and
consequential damages, such as lost profits;
iii) states that any provisions which differ from this Agreement are
offered by that Contributor alone and not by any other party; and
iv) states that source code for the Program is available from such
Contributor, and informs licensees how to obtain it in a reasonable
manner on or through a medium customarily used for software exchange.
When the Program is made available in source code form:
a) it must be made available under this Agreement; and
b) a copy of this Agreement must be included with each copy of the Program.
Contributors may not remove or alter any copyright notices contained
within the Program.
Each Contributor must identify itself as the originator of its
Contribution, if any, in a manner that reasonably allows subsequent
Recipients to identify the originator of the Contribution.
4. COMMERCIAL DISTRIBUTION
Commercial distributors of software may accept certain
responsibilities with respect to end users, business partners and the
like. While this license is intended to facilitate the commercial use
of the Program, the Contributor who includes the Program in a
commercial product offering should do so in a manner which does not
create potential liability for other Contributors. Therefore, if a
Contributor includes the Program in a commercial product offering,
such Contributor ("Commercial Contributor") hereby agrees to defend
and indemnify every other Contributor ("Indemnified Contributor")
against any losses, damages and costs (collectively "Losses") arising
from claims, lawsuits and other legal actions brought by a third party
against the Indemnified Contributor to the extent caused by the acts
or omissions of such Commercial Contributor in connection with its
distribution of the Program in a commercial product offering. The
obligations in this section do not apply to any claims or Losses
relating to any actual or alleged intellectual property
infringement. In order to qualify, an Indemnified Contributor must: a)
promptly notify the Commercial Contributor in writing of such claim,
and b) allow the Commercial Contributor tocontrol, and cooperate with
the Commercial Contributor in, the defense and any related settlement
negotiations. The Indemnified Contributor may participate in any such
claim at its own expense.
For example, a Contributor might include the Program in a commercial
product offering, Product X. That Contributor is then a Commercial
Contributor. If that Commercial Contributor then makes performance
claims, or offers warranties related to Product X, those performance
claims and warranties are such Commercial Contributor's responsibility
alone. Under this section, the Commercial Contributor would have to
defend claims against the other Contributors related to those
performance claims and warranties, and if a court requires any other
Contributor to pay any damages as a result, the Commercial Contributor
must pay those damages.
5. NO WARRANTY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS
PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY
WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY
OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely
responsible for determining the appropriateness of using and
distributing the Program and assumes all risks associated with its
exercise of rights under this Agreement , including but not limited to
the risks and costs of program errors, compliance with applicable
laws, damage to or loss of data, programs or equipment, and
unavailability or interruption of operations.
6. DISCLAIMER OF LIABILITY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR
ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
7. GENERAL
If any provision of this Agreement is invalid or unenforceable under
applicable law, it shall not affect the validity or enforceability of
the remainder of the terms of this Agreement, and without further
action by the parties hereto, such provision shall be reformed to the
minimum extent necessary to make such provision valid and enforceable.
If Recipient institutes patent litigation against any entity
(including a cross-claim or counterclaim in a lawsuit) alleging that
the Program itself (excluding combinations of the Program with other
software or hardware) infringes such Recipient's patent(s), then such
Recipient's rights granted under Section 2(b) shall terminate as of
the date such litigation is filed.
All Recipient's rights under this Agreement shall terminate if it
fails to comply with any of the material terms or conditions of this
Agreement and does not cure such failure in a reasonable period of
time after becoming aware of such noncompliance. If all Recipient's
rights under this Agreement terminate, Recipient agrees to cease use
and distribution of the Program as soon as reasonably
practicable. However, Recipient's obligations under this Agreement and
any licenses granted by Recipient relating to the Program shall
continue and survive.
Everyone is permitted to copy and distribute copies of this Agreement,
but in order to avoid inconsistency the Agreement is copyrighted and
may only be modified in the following manner. The Agreement Steward
reserves the right to publish new versions (including revisions) of
this Agreement from time to time. No one other than the Agreement
Steward has the right to modify this Agreement. The Eclipse Foundation
is the initial Agreement Steward. The Eclipse Foundation may assign
the responsibility to serve as the Agreement Steward to a suitable
separate entity. Each new version of the Agreement will be given a
distinguishing version number. The Program (including Contributions)
may always be distributed subject to the version of the Agreement
under which it was received. In addition, after a new version of the
Agreement is published, Contributor may elect to distribute the
Program (including its Contributions) under the new version. Except as
expressly stated in Sections 2(a) and 2(b) above, Recipient receives
no rights or licenses to the intellectual property of any Contributor
under this Agreement, whether expressly, by implication, estoppel or
otherwise. All rights in the Program not expressly granted under this
Agreement are reserved.
This Agreement is governed by the laws of the State of Washington and
the intellectual property laws of the United States of America. No
party to this Agreement will bring a legal action under this Agreement
more than one year after the cause of action arose. Each party waives
its rights to a jury trial in any resulting litigation.

152
sources_non_forked/slimv/swank-clojure/README.md Normal file
View File

@ -0,0 +1,152 @@
# Swank Clojure
[Swank Clojure](http://github.com/technomancy/swank-clojure) is a
server that allows [SLIME](http://common-lisp.net/project/slime/) (the
Superior Lisp Interaction Mode for Emacs) to connect to Clojure
projects. To use it you must launch a swank server, then connect to it
from within Emacs.
## Usage
If you just want a standalone swank server with no third-party
libraries, you can just install swank-clojure using Leiningen.
$ lein plugin install swank-clojure 1.3.0-SNAPSHOT
$ ~/.lein/bin/swank-clojure
M-x slime-connect
If you put ~/.lein/bin on your $PATH it's even more convenient.
You can also start a swank server from inside your project:
$ lein swank # you can specify PORT and HOST optionally
Note that the lein-swank plugin now comes with Swank Clojure; it does
not need to be specified as a separate dependency any more.
If you're using Maven, add this to your pom.xml under the
\<dependencies\> section:
<dependency>
<groupId>swank-clojure</groupId>
<artifactId>swank-clojure</artifactId>
<version>1.2.1</version>
</dependency>
Then you can launch a swank server like so:
$ mvn -o clojure:swank
Note that due to a bug in clojure-maven-plugin, you currently cannot
include it as a test-scoped dependency; it must be compile-scoped. You
also cannot change the port from Maven; it's hard-coded to 4005.
Put this in your Emacs configuration to get syntax highlighting in the
slime repl:
(add-hook 'slime-repl-mode-hook 'clojure-mode-font-lock-setup)
## Connecting with SLIME
Install the "slime-repl" package using package.el. If you are using
Emacs 23, it's best to get [the latest version of package.el from
Emacs
trunk](http://bit.ly/pkg-el). Then
add Marmalade as an archive source:
(add-to-list 'package-archives
'("marmalade" . "http://marmalade-repo.org/packages/") t)
Then you can do <kbd>M-x package-list-packages</kbd>. Go down to
slime-repl and mark it with <kbd>i</kbd>. Execute the installation by
pressing <kbd>x</kbd>.
When you perform the installation, you will see warnings related to
the byte-compilation of the packages. This is **normal**; the packages
will work just fine even if there are problems byte-compiling it upon
installation.
Then you should be able to connect to the swank server you launched:
M-x slime-connect
It will prompt you for your host (usually localhost) and port. It may
also warn you that your SLIME version doesn't match your Swank
version; this should be OK.
Having old versions of SLIME either manually installed or installed
using a system-wide package manager like apt-get may cause issues.
## SLIME Commands
Commonly-used SLIME commands:
* **C-c TAB**: Autocomplete symbol at point
* **C-x C-e**: Eval the form under the point
* **C-c C-k**: Compile the current buffer
* **C-c C-l**: Load current buffer and force dependent namespaces to reload
* **M-.**: Jump to the definition of a var
* **C-c S-i**: Inspect a value
* **C-c C-m**: Macroexpand the call under the point
* **C-c C-d C-d**: Look up documentation for a var
* **C-c C-z**: Switch from a Clojure buffer to the repl buffer
* **C-c M-p**: Switch the repl namespace to match the current buffer
* **C-c C-w c**: List all callers of a given function
Pressing "v" on a stack trace a debug buffer will jump to the file and
line referenced by that frame if possible.
Note that SLIME was designed to work with Common Lisp, which has a
distinction between interpreted code and compiled code. Clojure has no
such distinction, so the load-file functionality is overloaded to add
<code>:reload-all</code> behaviour.
## Embedding
You can embed Swank Clojure in your project, start the server from
within your own code, and connect via Emacs to that instance:
(ns my-app
(:require [swank.swank]))
(swank.swank/start-repl) ;; optionally takes a port argument
Then use M-x slime-connect to connect from within Emacs.
You can also start the server directly from the "java" command-line
launcher if you AOT-compile it and specify "swank.swank" as your main
class.
## Debug Repl
For now, see [Hugo Duncan's
blog](http://hugoduncan.org/post/2010/swank_clojure_gets_a_break_with_the_local_environment.xhtml)
for an explanation of this excellent feature. Further documentation to come.
## swank-clojure.el
Previous versions of Swank Clojure bundled an Elisp library called
swank-clojure.el that provided ways to launch your swank server from
within your Emacs process. It's much more reliable to launch the
server from your build tool, so this has been removed.
## Community
The [mailing list](http://groups.google.com/group/swank-clojure) and
clojure channel on Freenode are the best places to bring up
questions/issues.
Contributions are preferred as either Github pull requests or using
"git format-patch". Please use standard indentation with no tabs,
trailing whitespace, or lines longer than 80 columns. See [this post
on submitting good patches](http://technomancy.us/135) for some
tips. If you've got some time on your hands, reading this [style
guide](http://mumble.net/~campbell/scheme/style.txt) wouldn't hurt
either.
## License
Copyright (C) 2008-2011 Jeffrey Chu, Phil Hagelberg, Hugo Duncan, and
contributors
Licensed under the EPL. (See the file COPYING.)

30
sources_non_forked/slimv/swank-clojure/leiningen/swank.clj Normal file
View File

@ -0,0 +1,30 @@
(ns leiningen.swank
"Launch swank server for Emacs to connect."
(:use [leiningen.compile :only [eval-in-project]])
(:import [java.io File]))
(defn swank-form [project port host opts]
;; bootclasspath workaround: http://dev.clojure.org/jira/browse/CLJ-673
(when (:eval-in-leiningen project)
(require '[clojure walk template stacktrace]))
`(do
(let [is# ~(:repl-init-script project)]
(when (.exists (File. (str is#)))
(load-file is#)))
(require '~'swank.swank)
(require '~'swank.commands.basic)
(@(ns-resolve '~'swank.swank '~'start-repl)
(Integer. ~port) ~@(concat (map read-string opts)
[:host host]))
;; This exits immediately when using :eval-in-leiningen; must block
(when ~(:eval-in-leiningen project)
(doseq [t# ((ns-resolve '~'swank.commands.basic
'~'get-thread-list))]
(.join t#)))))
(defn swank
"Launch swank server for Emacs to connect. Optionally takes PORT and HOST."
([project port host & opts]
(eval-in-project project (swank-form project port host opts)))
([project port] (swank project port "localhost"))
([project] (swank project 4005)))

9
sources_non_forked/slimv/swank-clojure/project.clj Normal file
View File

@ -0,0 +1,9 @@
(defproject swank-clojure "1.3.0"
:description "Swank server connecting Clojure to Emacs SLIME"
:url "http://github.com/technomancy/swank-clojure"
:dependencies [[org.clojure/clojure "1.2.0"]]
:dev-dependencies [[lein-multi "1.0.0"]]
:multi-deps {"1.1" [[org.clojure/clojure "1.1.0"]
[org.clojure/clojure-contrib "1.1.0"]]
"1.3" [[org.clojure/clojure "1.3.0-master-SNAPSHOT"]]}
:shell-wrapper {:main swank.swank})

17
sources_non_forked/slimv/swank-clojure/swank/clj_contrib/macroexpand.clj Normal file
View File

@ -0,0 +1,17 @@
(ns swank.clj-contrib.macroexpand)
(def
#^{:private true}
walk-enabled?
(.getResource (clojure.lang.RT/baseLoader) "clojure/contrib/macro_utils.clj"))
(when walk-enabled?
(require 'clojure.contrib.macro-utils))
(defmacro macroexpand-all* [form]
(if walk-enabled?
`(clojure.contrib.macro-utils/mexpand-all ~form)
`(macroexpand ~form)))
(defn macroexpand-all [form]
(macroexpand-all* form))

34
sources_non_forked/slimv/swank-clojure/swank/clj_contrib/pprint.clj Normal file
View File

@ -0,0 +1,34 @@
(ns swank.clj-contrib.pprint)
(def #^{:private true} pprint-enabled?
(try ;; 1.2+
(.getResource (clojure.lang.RT/baseLoader) "clojure/pprint")
(require '[clojure.pprint :as pp])
(defmacro #^{:private true} pretty-pr-code*
([code]
(if pprint-enabled?
`(binding [pp/*print-suppress-namespaces* true]
(pp/with-pprint-dispatch pp/code-dispatch
(pp/write ~code :pretty true :stream nil)))
`(pr-str ~code))))
true
(catch Exception e
(try ;; 1.0, 1.1
(.loadClass (clojure.lang.RT/baseLoader)
"clojure.contrib.pprint.PrettyWriter")
(require '[clojure.contrib.pprint :as pp])
(defmacro #^{:private true} pretty-pr-code*
([code]
(if pprint-enabled?
`(binding [pp/*print-suppress-namespaces* true]
(pp/with-pprint-dispatch pp/*code-dispatch*
(pp/write ~code :pretty true :stream nil)))
`(pr-str ~code))))
true
;; if you just don't have contrib, be silent.
(catch ClassNotFoundException _)
(catch Exception e
(println e))))))
(defn pretty-pr-code [code]
(pretty-pr-code* code))

14
sources_non_forked/slimv/swank-clojure/swank/commands.clj Normal file
View File

@ -0,0 +1,14 @@
(ns swank.commands)
(defonce slime-fn-map {})
(defmacro defslimefn
([fname & body]
`(alter-var-root #'slime-fn-map
assoc
(symbol "swank" ~(name fname))
(defn ~fname ~@body)))
{:indent 'defun})
(defn slime-fn [sym]
(slime-fn-map (symbol "swank" (name sym))))

608
sources_non_forked/slimv/swank-clojure/swank/commands/basic.clj Normal file
View File

@ -0,0 +1,608 @@
(ns swank.commands.basic
(:refer-clojure :exclude [load-file print-doc])
(:use (swank util commands core)
(swank.util.concurrent thread)
(swank.util string clojure)
(swank.clj-contrib pprint macroexpand))
(:require (swank.util [sys :as sys])
(swank.commands [xref :as xref]))
(:import (java.io StringReader File)
(java.util.zip ZipFile)
(clojure.lang LineNumberingPushbackReader)))
;;;; Connection
(defslimefn connection-info []
`(:pid ~(sys/get-pid)
:style :spawn
:lisp-implementation (:type "Clojure"
:name "clojure"
:version ~(clojure-version))
:package (:name ~(name (ns-name *ns*))
:prompt ~(name (ns-name *ns*)))
:version ~(deref protocol-version)))
(defslimefn quit-lisp []
(System/exit 0))
(defslimefn toggle-debug-on-swank-error []
(alter-var-root #'swank.core/debug-swank-clojure not))
;;;; Evaluation
(defn- eval-region
"Evaluate string, return the results of the last form as a list and
a secondary value the last form."
([string]
(eval-region string "NO_SOURCE_FILE" 1))
([string file line]
(with-open [rdr (proxy [LineNumberingPushbackReader]
((StringReader. string))
(getLineNumber [] line))]
(binding [*file* file]
(loop [form (read rdr false rdr), value nil, last-form nil]
(if (= form rdr)
[value last-form]
(recur (read rdr false rdr)
(eval (with-env-locals form))
form)))))))
(defn- compile-region
"Compile region."
([string file line]
(with-open [rdr1 (proxy [LineNumberingPushbackReader]
((StringReader. string)))
rdr (proxy [LineNumberingPushbackReader] (rdr1)
(getLineNumber [] (+ line (.getLineNumber rdr1) -1)))]
(clojure.lang.Compiler/load rdr file (.getName (File. file))))))
(defslimefn interactive-eval-region [string]
(with-emacs-package
(pr-str (first (eval-region string)))))
(defslimefn interactive-eval [string]
(with-emacs-package
(pr-str (first (eval-region string)))))
(defslimefn listener-eval [form]
(with-emacs-package
(with-package-tracking
(let [[value last-form] (eval-region form)]
(when (and last-form (not (one-of? last-form '*1 '*2 '*3 '*e)))
(set! *3 *2)
(set! *2 *1)
(set! *1 value))
(send-repl-results-to-emacs value)))))
(defslimefn eval-and-grab-output [string]
(with-emacs-package
(let [retval (promise)]
(list (with-out-str
(deliver retval (pr-str (first (eval-region string)))))
@retval))))
(defslimefn pprint-eval [string]
(with-emacs-package
(pretty-pr-code (first (eval-region string)))))
;;;; Macro expansion
(defn- apply-macro-expander [expander string]
(pretty-pr-code (expander (read-string string))))
(defslimefn swank-macroexpand-1 [string]
(apply-macro-expander macroexpand-1 string))
(defslimefn swank-macroexpand [string]
(apply-macro-expander macroexpand string))
;; not implemented yet, needs walker
(defslimefn swank-macroexpand-all [string]
(apply-macro-expander macroexpand-all string))
;;;; Compiler / Execution
(def compiler-exception-location-re #"Exception:.*\(([^:]+):([0-9]+)(:[0-9]+)?\)")
(defn- guess-compiler-exception-location [#^Throwable t]
(when (instance? clojure.lang.Compiler$CompilerException t)
(let [[match file line] (re-find compiler-exception-location-re (str t))]
(when (and file line)
`(:location (:file ~file) (:line ~(Integer/parseInt line)) nil)))))
;; TODO: Make more and better guesses
(defn- exception-location [#^Throwable t]
(or (guess-compiler-exception-location t)
'(:error "No error location available")))
;; plist of message, severity, location, references, short-message
(defn- exception-to-message [#^Throwable t]
`(:message ~(.toString t)
:severity :error
:location ~(exception-location t)
:references nil
:short-message ~(.toString t)))
(defn- compile-file-for-emacs*
"Compiles a file for emacs. Because clojure doesn't compile, this is
simple an alias for load file w/ timing and messages. This function
is to reply with the following:
(:swank-compilation-unit notes results durations)"
([file-name]
(let [start (System/nanoTime)]
(try
(let [ret (clojure.core/load-file file-name)
delta (- (System/nanoTime) start)]
`(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0)))
(catch Throwable t
(let [delta (- (System/nanoTime) start)
causes (exception-causes t)
num (count causes)]
(.printStackTrace t) ;; prints to *inferior-lisp*
`(:compilation-result
~(map exception-to-message causes) ;; notes
nil ;; results
~(/ delta 1000000000.0) ;; durations
)))))))
(defslimefn compile-file-for-emacs
([file-name load? & compile-options]
(when load?
(compile-file-for-emacs* file-name))))
(defslimefn load-file [file-name]
(let [libs-ref @(resolve 'clojure.core/*loaded-libs*)
libs @libs-ref]
(try
(dosync (ref-set libs-ref #{}))
(pr-str (clojure.core/load-file file-name))
(finally
(dosync (alter libs-ref into libs))))))
(defn- line-at-position [file position]
(try
(with-open [f (java.io.LineNumberReader. (java.io.FileReader. file))]
(.skip f position)
(.getLineNumber f))
(catch Exception e 1)))
(defmacro compiler-exception [directory line ex]
`(eval (if (>= (:minor *clojure-version*) 5)
'(clojure.lang.Compiler$CompilerException.
~directory ~line 0 ~ex)
'(clojure.lang.Compiler$CompilerException.
~directory ~line ~ex))))
(defslimefn compile-string-for-emacs [string buffer position directory debug]
(let [start (System/nanoTime)
line (line-at-position directory position)
ret (with-emacs-package
(when-not (= (name (ns-name *ns*)) *current-package*)
(throw (compiler-exception
directory line
(Exception. (str "No such namespace: "
*current-package*)))))
(compile-region string directory line))
delta (- (System/nanoTime) start)]
`(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0))))
;;;; Describe
(defn- maybe-resolve-sym [symbol-name]
(try
(ns-resolve (maybe-ns *current-package*) (symbol symbol-name))
(catch ClassNotFoundException e nil)))
(defn- maybe-resolve-ns [sym-name]
(let [sym (symbol sym-name)]
(or ((ns-aliases (maybe-ns *current-package*)) sym)
(find-ns sym))))
(defn- print-doc* [m]
(println "-------------------------")
(println (str (when-let [ns (:ns m)] (str (ns-name ns) "/")) (:name m)))
(cond
(:forms m) (doseq [f (:forms m)]
(print " ")
(prn f))
(:arglists m) (prn (:arglists m)))
(if (:special-form m)
(do
(println "Special Form")
(println " " (:doc m))
(if (contains? m :url)
(when (:url m)
(println (str "\n Please see http://clojure.org/" (:url m))))
(println (str "\n Please see http://clojure.org/special_forms#"
(:name m)))))
(do
(when (:macro m)
(println "Macro"))
(println " " (:doc m)))))
(def print-doc (let [print-doc (resolve 'clojure.core/print-doc)]
(if (or (nil? print-doc) (-> print-doc meta :private))
(comp print-doc* meta)
print-doc)))
(defn- describe-to-string [var]
(with-out-str
(print-doc var)))
(defn- describe-symbol* [symbol-name]
(with-emacs-package
(if-let [v (maybe-resolve-sym symbol-name)]
(if-not (class? v)
(describe-to-string v)))))
(defslimefn describe-symbol [symbol-name]
(describe-symbol* symbol-name))
(defslimefn describe-function [symbol-name]
(describe-symbol* symbol-name))
;; Only one namespace... so no kinds
(defslimefn describe-definition-for-emacs [name kind]
(describe-symbol* name))
;; Only one namespace... so only describe symbol
(defslimefn documentation-symbol
([symbol-name default] (documentation-symbol symbol-name))
([symbol-name] (describe-symbol* symbol-name)))
;;;; Documentation
(defn- briefly-describe-symbol-for-emacs [var]
(let [lines (fn [s] (.split #^String s (System/getProperty "line.separator")))
[_ symbol-name arglists d1 d2 & __] (lines (describe-to-string var))
macro? (= d1 "Macro")]
(list :designator symbol-name
(cond
macro? :macro
(:arglists (meta var)) :function
:else :variable)
(apply str (concat arglists (if macro? d2 d1))))))
(defn- make-apropos-matcher [pattern case-sensitive?]
(let [pattern (java.util.regex.Pattern/quote pattern)
pat (re-pattern (if case-sensitive?
pattern
(format "(?i:%s)" pattern)))]
(fn [var] (re-find pat (pr-str var)))))
(defn- apropos-symbols [string external-only? case-sensitive? package]
(let [packages (or (when package [package]) (all-ns))
matcher (make-apropos-matcher string case-sensitive?)
lister (if external-only? ns-publics ns-interns)]
(filter matcher
(apply concat (map (comp (partial map second) lister)
packages)))))
(defn- present-symbol-before
"Comparator such that x belongs before y in a printed summary of symbols.
Sorted alphabetically by namespace name and then symbol name, except
that symbols accessible in the current namespace go first."
[x y]
(let [accessible?
(fn [var] (= (maybe-resolve-sym (:name (meta var)))
var))
ax (accessible? x) ay (accessible? y)]
(cond
(and ax ay) (compare (:name (meta x)) (:name (meta y)))
ax -1
ay 1
:else (let [nx (str (:ns (meta x))) ny (str (:ns (meta y)))]
(if (= nx ny)
(compare (:name (meta x)) (:name (meta y)))
(compare nx ny))))))
(defslimefn apropos-list-for-emacs
([name]
(apropos-list-for-emacs name nil))
([name external-only?]
(apropos-list-for-emacs name external-only? nil))
([name external-only? case-sensitive?]
(apropos-list-for-emacs name external-only? case-sensitive? nil))
([name external-only? case-sensitive? package]
(let [package (when package
(maybe-ns package))]
(map briefly-describe-symbol-for-emacs
(sort present-symbol-before
(apropos-symbols name external-only? case-sensitive?
package))))))
;;;; Operator messages
(defslimefn operator-arglist [name package]
(try
(let [f (read-string name)]
(cond
(keyword? f) "([map])"
(symbol? f) (let [var (ns-resolve (maybe-ns package) f)]
(if-let [args (and var (:arglists (meta var)))]
(pr-str args)
nil))
:else nil))
(catch Throwable t nil)))
;;;; Package Commands
(defslimefn list-all-package-names
([] (map (comp str ns-name) (all-ns)))
([nicknames?] (list-all-package-names)))
(defslimefn set-package [name]
(let [ns (maybe-ns name)]
(in-ns (ns-name ns))
(list (str (ns-name ns))
(str (ns-name ns)))))
;;;; Tracing
(defonce traced-fn-map {})
(def #^{:dynamic true} *trace-level* 0)
(defn- indent [num]
(dotimes [x (+ 1 num)]
(print " ")))
(defn- trace-fn-call [sym f args]
(let [fname (symbol (str (.name (.ns sym)) "/" (.sym sym)))]
(indent *trace-level*)
(println (str *trace-level* ":")
(apply str (take 240 (pr-str (when fname (cons fname args)) ))))
(let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))]
(indent *trace-level*)
(println (str *trace-level* ": " fname " returned " (apply str (take 240 (pr-str result)))))
result)))
(defslimefn swank-toggle-trace [fname]
(when-let [sym (maybe-resolve-sym fname)]
(if-let [f# (get traced-fn-map sym)]
(do
(alter-var-root #'traced-fn-map dissoc sym)
(alter-var-root sym (constantly f#))
(str " untraced."))
(let [f# @sym]
(alter-var-root #'traced-fn-map assoc sym f#)
(alter-var-root sym
(constantly
(fn [& args]
(trace-fn-call sym f# args))))
(str " traced.")))))
(defslimefn untrace-all []
(doseq [sym (keys traced-fn-map)]
(swank-toggle-trace (.sym sym))))
;;;; Source Locations
(comment
"Sets the default directory (java's user.dir). Note, however, that
this will not change the search path of load-file. ")
(defslimefn set-default-directory
([directory & ignore]
(System/setProperty "user.dir" directory)
directory))
;;;; meta dot find
(defn- clean-windows-path [#^String path]
;; Decode file URI encoding and remove an opening slash from
;; /c:/program%20files/... in jar file URLs and file resources.
(or (and (.startsWith (System/getProperty "os.name") "Windows")
(second (re-matches #"^/([a-zA-Z]:/.*)$" path)))
path))
(defn- slime-zip-resource [#^java.net.URL resource]
(let [jar-connection #^java.net.JarURLConnection (.openConnection resource)
jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))]
(list :zip (clean-windows-path jar-file) (.getEntryName jar-connection))))
(defn- slime-file-resource [#^java.net.URL resource]
(list :file (clean-windows-path (.getFile resource))))
(defn- slime-find-resource [#^String file]
(if-let [resource (.getResource (clojure.lang.RT/baseLoader) file)]
(if (= (.getProtocol resource) "jar")
(slime-zip-resource resource)
(slime-file-resource resource))))
(defn- slime-find-file [#^String file]
(if (.isAbsolute (File. file))
(list :file file)
(slime-find-resource file)))
(defn- namespace-to-path [ns]
(let [#^String ns-str (name (ns-name ns))
last-dot-index (.lastIndexOf ns-str ".")]
(if (pos? last-dot-index)
(-> (.substring ns-str 0 last-dot-index)
(.replace \- \_)
(.replace \. \/)))))
(defn- classname-to-path [class-name]
(namespace-to-path
(symbol (.replace class-name \_ \-))))
(defn- location-in-file [path line]
`(:location ~path (:line ~line) nil))
(defn- location-label [name type]
(if type
(str "(" type " " name ")")
(str name)))
(defn- location [name type path line]
`((~(location-label name type)
~(if path
(location-in-file path line)
(list :error (format "%s - definition not found." name))))))
(defn- location-not-found [name type]
(location name type nil nil))
(defn source-location-for-frame [#^StackTraceElement frame]
(let [line (.getLineNumber frame)
filename (if (.. frame getFileName (endsWith ".java"))
(.. frame getClassName (replace \. \/)
(substring 0 (.lastIndexOf (.getClassName frame) "."))
(concat (str File/separator (.getFileName frame))))
(let [ns-path (classname-to-path
((re-find #"(.*?)\$"
(.getClassName frame)) 1))]
(if ns-path
(str ns-path File/separator (.getFileName frame))
(.getFileName frame))))
path (slime-find-file filename)]
(location-in-file path line)))
(defn- namespace-to-filename [ns]
(str (-> (str ns)
(.replaceAll "\\." File/separator)
(.replace \- \_ ))
".clj"))
(defn- source-location-for-meta [meta xref-type-name]
(location (:name meta)
xref-type-name
(slime-find-file (:file meta))
(:line meta)))
(defn- find-ns-definition [sym-name]
(if-let [ns (maybe-resolve-ns sym-name)]
(when-let [path (slime-find-file (namespace-to-filename ns))]
(location ns nil path 1))))
(defn- find-var-definition [sym-name]
(if-let [meta (meta (maybe-resolve-sym sym-name))]
(source-location-for-meta meta "defn")))
(defslimefn find-definitions-for-emacs [name]
(let [sym-name (read-string name)]
(or (find-var-definition sym-name)
(find-ns-definition sym-name)
(location name nil nil nil))))
(defn who-specializes [class]
(letfn [(xref-lisp [sym] ; see find-definitions-for-emacs
(if-let [meta (meta sym)]
(source-location-for-meta meta "method")
(location-not-found (.getName sym) "method")))]
(let [methods (try (. class getMethods)
(catch java.lang.IllegalArgumentException e nil)
(catch java.lang.NullPointerException e nil))]
(map xref-lisp methods))))
(defn who-calls [name]
(letfn [(xref-lisp [sym-var] ; see find-definitions-for-emacs
(when-let [meta (meta sym-var)]
(source-location-for-meta meta nil)))]
(let [callers (xref/all-vars-who-call name) ]
(map first (map xref-lisp callers)))))
(defslimefn xref [type name]
(let [sexp (maybe-resolve-sym name)]
(condp = type
:specializes (who-specializes sexp)
:calls (who-calls (symbol name))
:callers nil
:not-implemented)))
(defslimefn throw-to-toplevel []
(throw debug-quit-exception))
(defn invoke-restart [restart]
((nth restart 2)))
(defslimefn invoke-nth-restart-for-emacs [level n]
((invoke-restart (*sldb-restarts* (nth (keys *sldb-restarts*) n)))))
(defslimefn throw-to-toplevel []
(if-let [restart (*sldb-restarts* :quit)]
(invoke-restart restart)))
(defslimefn sldb-continue []
(if-let [restart (*sldb-restarts* :continue)]
(invoke-restart restart)))
(defslimefn sldb-abort []
(if-let [restart (*sldb-restarts* :abort)]
(invoke-restart restart)))
(defslimefn backtrace [start end]
(build-backtrace start end))
(defslimefn buffer-first-change [file-name] nil)
(defn locals-for-emacs [m]
(sort-by second
(map #(list :name (name (first %)) :id 0
:value (pr-str (second %))) m)))
(defslimefn frame-catch-tags-for-emacs [n] nil)
(defslimefn frame-locals-for-emacs [n]
(if (and (zero? n) (seq *current-env*))
(locals-for-emacs *current-env*)))
(defslimefn frame-locals-and-catch-tags [n]
(list (frame-locals-for-emacs n)
(frame-catch-tags-for-emacs n)))
(defslimefn debugger-info-for-emacs [start end]
(build-debugger-info-for-emacs start end))
(defslimefn eval-string-in-frame [expr n]
(if (and (zero? n) *current-env*)
(with-bindings *current-env*
(eval expr))))
(defslimefn frame-source-location [n]
(source-location-for-frame
(nth (.getStackTrace *current-exception*) n)))
;; Older versions of slime use this instead of the above.
(defslimefn frame-source-location-for-emacs [n]
(source-location-for-frame
(nth (.getStackTrace *current-exception*) n)))
(defslimefn create-repl [target] '("user" "user"))
;;; Threads
(def #^{:private true} thread-list (atom []))
(defn- get-root-group [#^java.lang.ThreadGroup tg]
(if-let [parent (.getParent tg)]
(recur parent)
tg))
(defn- get-thread-list []
(let [rg (get-root-group (.getThreadGroup (Thread/currentThread)))
arr (make-array Thread (.activeCount rg))]
(.enumerate rg arr true)
(seq arr)))
(defn- extract-info [#^Thread t]
(map str [(.getId t) (.getName t) (.getPriority t) (.getState t)]))
(defslimefn 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."
[]
(reset! thread-list (get-thread-list))
(let [labels '(id name priority state)]
(cons labels (map extract-info @thread-list))))
;;; TODO: Find a better way, as Thread.stop is deprecated
(defslimefn kill-nth-thread [index]
(when index
(when-let [thread (nth @thread-list index nil)]
(println "Thread: " thread)
(.stop thread))))
(defslimefn quit-thread-browser []
(reset! thread-list []))

103
sources_non_forked/slimv/swank-clojure/swank/commands/completion.clj Normal file
View File

@ -0,0 +1,103 @@
(ns swank.commands.completion
(:use (swank util core commands)
(swank.util string clojure java class-browse)))
(defn potential-ns
"Returns a list of potential namespace completions for a given
namespace"
([] (potential-ns *ns*))
([ns]
(for [ns-sym (concat (keys (ns-aliases (ns-name ns)))
(map ns-name (all-ns)))]
(name ns-sym))))
(defn potential-var-public
"Returns a list of potential public var name completions for a
given namespace"
([] (potential-var-public *ns*))
([ns]
(for [var-sym (keys (ns-publics ns))]
(name var-sym))))
(defn potential-var
"Returns a list of all potential var name completions for a given
namespace"
([] (potential-var *ns*))
([ns]
(for [[key v] (ns-map ns)
:when (var? v)]
(name key))))
(defn potential-classes
"Returns a list of potential class name completions for a given
namespace"
([] (potential-classes *ns*))
([ns]
(for [class-sym (keys (ns-imports ns))]
(name class-sym))))
(defn potential-dot
"Returns a list of potential dot method name completions for a given
namespace"
([] (potential-dot *ns*))
([ns]
(map #(str "." %) (set (map member-name (mapcat instance-methods (vals (ns-imports ns))))))))
(defn potential-static
"Returns a list of potential static members for a given namespace"
([#^Class class]
(concat (map member-name (static-methods class))
(map member-name (static-fields class)))))
(defn potential-classes-on-path
"Returns a list of Java class and Clojure package names found on the current
classpath. To minimize noise, list is nil unless a '.' is present in the search
string, and nested classes are only shown if a '$' is present."
([symbol-string]
(when (.contains symbol-string ".")
(if (.contains symbol-string "$")
@nested-classes
@top-level-classes))))
(defn resolve-class
"Attempts to resolve a symbol into a java Class. Returns nil on
failure."
([sym]
(try
(let [res (resolve sym)]
(when (class? res)
res))
(catch Throwable t
nil))))
(defn- maybe-alias [sym ns]
(or (resolve-ns sym (maybe-ns ns))
(maybe-ns ns)))
(defn potential-completions [symbol-ns ns]
(if symbol-ns
(map #(str symbol-ns "/" %)
(if-let [class (resolve-class symbol-ns)]
(potential-static class)
(potential-var-public (maybe-alias symbol-ns ns))))
(concat (potential-var ns)
(when-not symbol-ns
(potential-ns))
(potential-classes ns)
(potential-dot ns))))
(defslimefn simple-completions [symbol-string package]
(try
(let [[sym-ns sym-name] (symbol-name-parts symbol-string)
potential (concat (potential-completions (when sym-ns (symbol sym-ns)) (ns-name (maybe-ns package)))
(potential-classes-on-path symbol-string))
matches (seq (sort (filter #(.startsWith #^String % symbol-string) potential)))]
(list matches
(if matches
(reduce largest-common-prefix matches)
symbol-string)))
(catch java.lang.Throwable t
(list nil symbol-string))))

9
sources_non_forked/slimv/swank-clojure/swank/commands/contrib.clj Normal file
View File

@ -0,0 +1,9 @@
(ns swank.commands.contrib
(:use (swank util core commands)))
(defslimefn swank-require [keys]
(binding [*ns* (find-ns 'swank.commands.contrib)]
(doseq [k (if (seq? keys) keys (list keys))]
(try
(require (symbol (str "swank.commands.contrib." (name k))))
(catch java.io.FileNotFoundException fne nil)))))

123
sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_arglists.clj Normal file
View File

@ -0,0 +1,123 @@
(ns swank.commands.contrib.swank-arglists
(:use (swank util core commands)))
((slime-fn 'swank-require) :swank-c-p-c)
;;; pos starts at 1 bc 0 is function name
(defn position-in-arglist? [arglist pos]
(or (some #(= '& %) arglist)
(<= pos (count arglist))))
;; (position-in-arglist? '[x y] 2)
;; => true
(defn highlight-position [arglist pos]
(if (zero? pos)
arglist
;; i.e. not rest args
(let [num-normal-args (count (take-while #(not= % '&) arglist))]
(if (<= pos num-normal-args)
(into [] (concat (take (dec pos) arglist)
'(===>)
(list (nth arglist (dec pos)))
'(<===)
(drop pos arglist)))
(let [rest-arg? (some #(= % '&) arglist)]
(if rest-arg?
(into [] (concat (take-while #(not= % '&) arglist)
'(===>)
'(&)
(list (last arglist))
'(<===)))))))))
;; (highlight-position '[x y] 0)
;; => [===> x <=== y]
(defn highlight-arglists [arglists pos]
(let [arglists (read-string arglists)]
(loop [checked []
current (first arglists)
remaining (rest arglists)]
(if (position-in-arglist? current pos)
(apply list (concat checked
[(highlight-position current pos)]
remaining))
(when (seq remaining)
(recur (conj checked current)
(first remaining)
(rest remaining)))))))
;; (highlight-arglists "([x] [x & more])" 1)
;; => ([===> x <===] [x & more])
;;(defmacro dbg[x] `(let [x# ~x] (println '~x "->" x#) x#))
(defn defnk-arglists? [arglists]
(and (not (nil? arglists ))
(not (vector? (first (read-string arglists))))))
(defn fix-defnk-arglists [arglists]
(str (list (into [] (read-string arglists)))))
(defn arglists-for-fname-lookup [fname]
((slime-fn 'operator-arglist) fname *current-package*))
(defn arglists-for-fname [fname]
(let [arglists (arglists-for-fname-lookup fname)]
;; defnk's arglists format is (a b) instead of ([a b])
(if (defnk-arglists? arglists)
(fix-defnk-arglists arglists)
arglists)))
(defn message-format [cmd arglists pos]
(str (when cmd (str cmd ": "))
(when arglists
(if pos
(highlight-arglists arglists pos)
arglists))))
(defn handle-apply [raw-specs pos]
(let [fname (second (first raw-specs))]
(message-format fname (arglists-for-fname fname) (dec pos))))
(defslimefn arglist-for-echo-area [raw-specs & options]
(let [{:keys [arg-indices
print-right-margin
print-lines]} (apply hash-map options)]
(if-not (and raw-specs
(seq? raw-specs)
(seq? (first raw-specs)))
nil ;; problem?
(let [pos (first (second options))
top-level? (= 1 (count raw-specs))
parent-pos (when-not top-level?
(second (second options)))
fname (ffirst raw-specs)
parent-fname (when-not top-level?
(first (second raw-specs)))
arglists (arglists-for-fname fname)
inside-binding? (and (not top-level?)
(#{"let" "binding" "doseq" "for" "loop"}
parent-fname)
(= 1 parent-pos))]
;; (dbg raw-specs)
;; (dbg options)
(cond
;; display arglists for function being applied unless on top of apply
(and (= fname "apply") (not= pos 0)) (handle-apply raw-specs pos)
;; highlight binding inside binding forms unless >1 level deep
inside-binding? (message-format parent-fname
(arglists-for-fname parent-fname)
1)
:else (message-format fname arglists pos))))))
(defslimefn variable-desc-for-echo-area [variable-name]
(with-emacs-package
(or
(try
(when-let [sym (read-string variable-name)]
(when-let [var (resolve sym)]
(when (.isBound #^clojure.lang.Var var)
(str variable-name " => " (var-get var)))))
(catch Exception e nil))
"")))

21
sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c.clj Normal file
View File

@ -0,0 +1,21 @@
(ns swank.commands.contrib.swank-c-p-c
(:use (swank util core commands)
(swank.commands completion)
(swank.util string clojure)
(swank.commands.contrib.swank-c-p-c internal)))
(defslimefn completions [symbol-string package]
(try
(let [[sym-ns sym-name] (symbol-name-parts symbol-string)
potential (concat
(potential-completions
(when sym-ns (symbol sym-ns))
(ns-name (maybe-ns package)))
(potential-classes-on-path symbol-string))
matches (seq (sort (filter #(split-compound-prefix-match? symbol-string %) potential)))]
(list matches
(if matches
(reduce largest-common-prefix matches)
symbol-string)))
(catch java.lang.Throwable t
(list nil symbol-string))))

Some files were not shown because too many files have changed in this diff Show More