Commits

Tamas Kovacs  committed 7a6b5dd

Version 0.8.2

Added Paredit and g:lisp_rainbow support for Scheme files, added SWANK support for MIT Scheme on Linux, added frame call information to SLDB (thanks to Philipp Marek), check for unbalanced form before evaluation, reconnect SWANK server in Connect-Server if already connected (thanks to Philipp Marek), select current form instead of top level form in Macroexpand, bugfixes: Paredit handling of escaped matched characters (e.g. \"), cursor positioning problems when debugger activated, print prompt after Describe.

  • Participants
  • Parent commits 3f46006

Comments (0)

Files changed (13)

 This is a mirror of http://www.vim.org/scripts/script.php?script_id=2531
 
-Slimv is a SWANK client for Vim, similarly to SLIME for Emacs. SWANK is a TCP server for Emacs, which runs a Common Lisp or Clojure 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 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 or clojure 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 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, profiler, cross reference, 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.
 

File doc/paredit.txt

-*paredit.txt*                    Slimv               Last Change: 25 Mar 2011
+*paredit.txt*                    Slimv               Last Change: 01 May 2011
 
 Paredit mode for Slimv                                *paredit* *slimv-paredit*
-                               Version 0.8.0
+                               Version 0.8.2
 
 The paredit.vim plugin performs structured editing of s-expressions used in
 the Lisp or Clojure programming language.
 
 
 ===============================================================================
-vim:tw=80:noet:wrap:ts=8:ft=help:norl:
+vim:tw=80:et:wrap:ft=help:norl:

File doc/slimv.txt

-*slimv.txt*                    Slimv                 Last Change: 20 Apr 2011
+*slimv.txt*                    Slimv                 Last Change: 01 May 2011
 
 Slimv                                                                  *slimv*
-                               Version 0.8.1
+                               Version 0.8.2
 
 The Superior Lisp Interaction Mode for Vim.
 This plugin is aimed to help Lisp development by interfacing between Vim and
 |slimv-usage|                Usage
 |slimv-repl|                 Lisp REPL inside Vim
 |slimv-clojure|              Clojure support
+|slimv-scheme|               Scheme support
 |slimv-package|              Package and Namespace handling
 |slimv-profiling|            Profiling
 |slimv-hyperspec|            Hyperspec Lookup and Completion
   details in |swank-installation|.
 
   Required components:
-  - Lisp (any console Common Lisp implementation should be OK) or
-    Clojure installed.
+  - Lisp (any console Common Lisp implementation should be OK) or Clojure or
+    MIT Scheme (Linux only) installed.
   - Python 2.4 or later installed. When using the SWANK client the same Python
     version is needed that Vim is compiled against.
     When not using the SWANK client then due to a Popen bug in the Cygwin
        ftplugin/swank.py
        ftplugin/clojure/slimv-clojure.vim
        ftplugin/lisp/slimv-lisp.vim
+       ftplugin/scheme/slimv-scheme.vim
        indent/clojure.vim
        plugin/paredit.vim
        slime/*
        swank-clojure/*
        syntax/clojure/slimv-syntax-clojure.vim
+       syntax/scheme/slimv-syntax-scheme.vim
 
     You might already have an ftdetect/clojure.vim file if you already use
     another Clojure filetype plugin. In this case just keep the original file.
 
 
 ===============================================================================
+SCHEME SUPPORT                                                   *slimv-scheme*
+
+Slimv has a limited support for Scheme: currently only MIT Scheme is supported
+via the SWANK client, using a modified version of swank-mit-scheme.scm in the
+slime/contrib directory.
+The Scheme SWANK server also requires the 'netcat' program to create sockets.
+Please read information about the implementation details in the file header of
+swank-mit-scheme.scm.
+There is no Hyperspec information for Scheme at the moment.
+
+
+===============================================================================
 PACKAGE AND NAMESPACE HANDLING                                  *slimv-package*
 
 Slimv has a basic support for handling Lisp packages and Clojure namespaces.
 ===============================================================================
 CHANGE LOG                                                    *slimv-changelog*
 
+0.8.2  - Added Paredit and g:lisp_rainbow support for Scheme files.
+       - Added SWANK support for MIT Scheme on Linux.
+       - Added frame call information to SLDB (thanks to Philipp Marek).
+       - Check for unbalanced form before evaluation.
+       - Reconnect SWANK server in Connect-Server if already connected
+         (thanks to Philipp Marek).
+       - Select current form instead of top level form in Macroexpand.
+       - Bugfix: Paredit handling of escaped matched characters, like \" or \(.
+       - Bugfix: cursor positioning problems when debugger activated.
+       - Bugfix: print prompt after Describe.
+
 0.8.1  - Added action handling to Inspector, fixed Inspector output.
        - Bugfix: read-string mode was stuck.
        - Bugfix: buffer corruption with two source windows
 Common Lisp Hyperspec lookup packages for SLIME, and thanks to
 Taylor R. Campbell for the Emacs paredit.el script.
 
-Thanks to Jeffrey Chu, Phil Hagelberg, Hugo Duncan for making Swank Clojure.
+Thanks to Jeffrey Chu, Phil Hagelberg, Hugo Duncan for making Swank Clojure,
+and to Helmut Eller for making Scheme Swank server.
 
 Thanks to the Vim community for testing, commenting and patching the script,
 especially to Philipp Marek for his great number of contributions, patches,
 hey, this is a female name in Hungary :) for her support and patience.
 
 ===============================================================================
-vim:tw=80:noet:wrap:ts=8:ft=help:norl:
+vim:tw=80:et:wrap:ft=help:norl:

File doc/swank.txt

-*swank.txt*                    Slimv                 Last Change: 18 Apr 2011
+*swank.txt*                    Slimv                 Last Change: 01 May 2011
 
 SWANK client for Slimv                                    *swank* *slimv-swank*
-                               Version 0.8.1
+                               Version 0.8.2
 
 The Superior Lisp Interaction Mode for Vim.
 Slimv contains a SWANK client that can communicate with a running SWANK server
     This can also be verified by the :ver command, look for the
     -DDYNAMIC_PYTHON_DLL=\"pythonXX\" string, where XX is the required
     Python version.
-  - Lisp or Clojure installed.
+  - Lisp or Clojure or MIT Scheme (Linux only) installed.
     Any Lisp implementation is OK that has SLIME support.
 
   The bundle version of Slimv also contains SLIME (in fact the SWANK server
 
                                                             *g:slimv_swank_cmd*
                                                         *g:slimv_swank_clojure*
+                                                         *g:slimv_swank_scheme*
   Slimv tries to autodetect your Python/Lisp/SWANK installation (please find
   more details about the Python and Lisp autodetection and configuration in
   |slimv-options|).
   If the location for the SWANK server is not identified by the script, or you
   want to use a different command for starting the SWANK server, then you may
   want to customize the g:slimv_swank_cmd (general) and g:slimv_swank_clojure
-  (Clojure specific) options in your .vimrc file.
+  (Clojure specific) and g:slimv_swank_scheme (Scheme specific) options in
+  your .vimrc file.
   Enter a Vim command here that spawns a detached process that runs the SWANK
   server of your choice. It is important to use a Vim command here that returns
   immediately and does not wait for the termination of the detached process,
 (swank:create-server :port 4005
                      :coding-system "iso-latin-1-unix"
                      :dont-close t)
- 
+
 
                                                                  *g:swank_port*
   The SWANK server is connected to port 4005 by default. This can be changed
   5: (SWANK::EVAL-REGION "(/ 1 0)")
 
 
-  If you press Enter in normal mode on a frame line then the local variable
-  bindings for that frame are displayed at the bottom of the SLDB printout.
+  If you press Enter in normal mode on a frame line then frame information
+  with the local variable bindings for that frame are displayed at the bottom
+  of the SLDB printout.
 
 
 -------------------------------------------------------------------------------
   swank:describe-function
   swank:disassemble-form
   swank:frame-locals-and-catch-tags
+  swank:frame-source-location
   swank:init-inspector
   swank:inspect-nth-part
   swank:inspector-call-nth-action
   swank:unprofile-all
   swank:untrace-all
   swank:xref
+  swank-backend:frame-call
 
 ===============================================================================
-vim:tw=80:noet:wrap:ts=8:ft=help:norl:
+vim:tw=80:et:wrap:ft=help:norl:

File ftplugin/scheme/slimv-scheme.vim

+" slimv-scheme.vim:
+"               Scheme filetype plugin for Slimv
+" Version:      0.8.2
+" Last Change:  27 Apr 2011
+" 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_scheme_loaded' )
+    finish
+endif
+
+let g:slimv_scheme_loaded = 1
+
+" Try to autodetect Scheme executable
+" Returns list [Scheme executable, Scheme implementation]
+function! b:SlimvAutodetect()
+    " 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! b:SlimvImplementation()
+    if exists( 'g:slimv_impl' ) && g:slimv_impl != ''
+        " Return Lisp implementation if defined
+        return tolower( g:slimv_impl )
+    endif
+
+    return 'mit'
+endfunction
+
+" Filename for the REPL buffer file
+function! b:SlimvREPLFile()
+    return 'Slimv.REPL.scm'
+endfunction
+
+" Lookup symbol in the Hyperspec
+function! b: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
+

File ftplugin/slimv.vim

 " slimv.vim:    The Superior Lisp Interaction Mode for VIM
-" Version:      0.8.1
-" Last Change:  20 Apr 2011
+" Version:      0.8.2
+" Last Change:  30 Apr 2011
 " Maintainer:   Tamas Kovacs <kovisoft at gmail dot com>
 " License:      This file is placed in the public domain.
 "               No warranty, express or implied.
     if exists( 'g:slimv_swank_clojure' ) && SlimvGetFiletype() == 'clojure'
         return g:slimv_swank_clojure
     endif
+    if exists( 'g:slimv_swank_scheme' ) && SlimvGetFiletype() == 'scheme'
+        return g:slimv_swank_scheme
+    endif
     if exists( 'g:slimv_swank_cmd' )
         return g:slimv_swank_cmd
     endif
             let sclj = substitute( swanks[0], '\', '/', "g" )
             let cmd = g:slimv_lisp . ' -e "(load-file \"' . sclj . '\") (swank.swank/start-repl)" -r'
         endif
+    elseif SlimvGetFiletype() == 'scheme'
+        let swanks = split( globpath( &runtimepath, 'slime/contrib/swank-mit-scheme.scm'), '\n' )
+        if len( swanks ) == 0
+            return ''
+        endif
+        if b:SlimvImplementation() == 'mit'
+            let cmd = '"' . g:slimv_lisp . '" --load "' . swanks[0] . '"'
+        endif
     else
         " First check if SWANK is bundled with Slimv
         let swanks = split( globpath( &runtimepath, 'slime/start-swank.lisp'), '\n' )
         let c = c - 1
     endwhile
     silent normal! "sy
+    let sel = SlimvGetSelection()
+    if sel == ''
+        call SlimvError( "Form is empty." )
+        return 0
+    elseif sel == '(' || sel == '['
+        call SlimvError( "Form is unbalanced." )
+        return 0
+    else
+        return 1
+    endif
 endfunction
 
 " Find starting '(' of a top level form
 " Select top level form the cursor is inside and copy it to register 's'
 function! SlimvSelectDefun()
     call SlimvFindDefunStart()
-    call SlimvSelectForm()
+    return SlimvSelectForm()
 endfunction
 
 " Return the contents of register 's'
 " Find and add language specific package/namespace definition before the
 " cursor position and if exists then add it in front of the current selection
 function! SlimvFindPackage()
-    if !g:slimv_package || s:debug_activated
+    if !g:slimv_package || s:debug_activated || SlimvGetFiletype() == 'scheme'
         return
     endif
     if SlimvGetFiletype() == 'clojure'
         if g:slimv_repl_open && ( repl_buf == -1 || ( g:slimv_repl_split && repl_win == -1 ) )
             call SlimvOpenReplBuffer()
         endif 
+        if s:swank_connected
+            python swank_disconnect()
+            let s:swank_connected = 0
+        endif 
         call SlimvConnectSwank()
     endif
     if !g:slimv_swank
 " Evaluate top level form at the cursor pos
 function! SlimvEvalDefun()
     let oldpos = getpos( '.' ) 
-    call SlimvSelectDefun()
+    if !SlimvSelectDefun()
+        return
+    endif
     call SlimvFindPackage()
-    call SlimvEvalSelection()
     call setpos( '.', oldpos ) 
+    call SlimvEvalSelection()
 endfunction
 
 " Evaluate the whole buffer
 " Evaluate current s-expression at the cursor pos
 function! SlimvEvalExp()
     let oldpos = getpos( '.' ) 
-    call SlimvSelectForm()
+    if !SlimvSelectForm()
+        return
+    endif
     call SlimvFindPackage()
-    call SlimvEvalSelection()
     call setpos( '.', oldpos ) 
+    call SlimvEvalSelection()
 endfunction
 
 " Evaluate and pretty print current s-expression
 function! SlimvPprintEvalExp()
     let oldpos = getpos( '.' ) 
-    call SlimvSelectForm()
+    if !SlimvSelectForm()
+        return
+    endif
     call SlimvFindPackage()
-    call SlimvEvalForm1( g:slimv_template_pprint, SlimvGetSelection() )
     call setpos( '.', oldpos ) 
+    call SlimvEvalForm1( g:slimv_template_pprint, SlimvGetSelection() )
 endfunction
 
 " Evaluate expression entered interactively
     let line = getline( "." )
     if match( line, '(\s*defmacro\s' ) < 0
         " The form does not contain 'defmacro', put it in a macroexpand block
-        call SlimvSelectForm()
+        if !SlimvSelectForm()
+            return
+        endif
         let m = "(" . a:command . " '" . SlimvGetSelection() . ")"
     else
         " The form is a 'defmacro', so do a macroexpand from the macro name and parameters
 function! SlimvMacroexpand()
     if g:slimv_swank
         if s:swank_connected
-            call SlimvSelectDefun()
+            if !SlimvSelectForm()
+                return
+            endif
             let s:swank_form = SlimvGetSelection()
             call SlimvCommandUsePackage( 'python swank_macroexpand("s:swank_form")' )
         endif
 function! SlimvMacroexpandAll()
     if g:slimv_swank
         if s:swank_connected
-            call SlimvSelectDefun()
+            if !SlimvSelectForm()
+                return
+            endif
             let s:swank_form = SlimvGetSelection()
             call SlimvCommandUsePackage( 'python swank_macroexpand_all("s:swank_form")' )
         else
 " Compile the current top-level form
 function! SlimvCompileDefun()
     let oldpos = getpos( '.' ) 
-    call SlimvSelectDefun()
-    call SlimvFindPackage()
+    if !SlimvSelectDefun()
+        call setpos( '.', oldpos ) 
+        return
+    endif
     if g:slimv_swank
         if s:swank_connected
             let s:swank_form = SlimvGetSelection()
             call SlimvError( "Not connected to SWANK server." )
         endif
     else
+        call SlimvFindPackage()
         let form = SlimvGetSelection()
         let form = substitute( form, '"', '\\\\"', 'g' )
         call SlimvEvalForm1( g:slimv_template_compile_string, form )
+        call setpos( '.', oldpos ) 
     endif
-    call setpos( '.', oldpos ) 
 endfunction
 
 " Compile and load whole file
     let oldpos = getpos( '.' ) 
     let lines = SlimvGetRegion()
     let region = join( lines, "\n" )
-    call SlimvFindPackage()
     if g:slimv_swank
         if s:swank_connected
             let s:swank_form = region
             call SlimvError( "Not connected to SWANK server." )
         endif
     else
+        call SlimvFindPackage()
         let region = substitute( region, '"', '\\\\"', 'g' )
         call SlimvEvalForm1( g:slimv_template_compile_string, region )
+        call setpos( '.', oldpos ) 
     endif
-    call setpos( '.', oldpos ) 
 endfunction
 
 " ---------------------------------------------------------------------

File ftplugin/swank.py

 #
 # SWANK client for Slimv
 # swank.py:     SWANK client code for slimv.vim plugin
-# Version:      0.8.1
-# Last Change:  18 Apr 2011
+# Version:      0.8.2
+# Last Change:  30 Apr 2011
 # Maintainer:   Tamas Kovacs <kovisoft at gmail dot com>
 # License:      This file is placed in the public domain.
 #               No warranty, express or implied.
             if severity[0] == ':':
                 severity = severity[1:]
             location = parse_plist(w, ':location')
-            fname   = unquote(location[1][1])
-            pos     = location[2][1]
-            if location[3] != 'nil':
-                snippet = unquote(location[3][1]).replace('\r', '')
-                buf = buf + snippet + '\n'
-            buf = buf + fname + ':' + pos + '\n'
-            buf = buf + '  ' + severity + ': ' + msg + '\n\n'
+            if location[0] == ':error':
+                # "no error location available"
+                buf = buf + '  ' + unquote(location[1]) + '\n'
+                buf = buf + '  ' + severity + ': ' + msg + '\n\n'
+            else:
+                fname   = unquote(location[1][1])
+                pos     = location[2][1]
+                if location[3] != 'nil':
+                    snippet = unquote(location[3][1]).replace('\r', '')
+                    buf = buf + snippet + '\n'
+                buf = buf + fname + ':' + pos + '\n'
+                buf = buf + '  ' + severity + ': ' + msg + '\n\n' 
     else:
         buf = '\nCompilation finished. (No warnings)  [' + time + ' secs]\n\n'
     return buf
 
+def swank_parse_frame_call(struct):
+    """
+    Parse frame call output
+    """
+    if type(struct) == list:
+        buf = struct[1][1] + '\n'
+        #buf = '{{{' + struct[1][1] + '}}}\n'
+    else:
+        buf = 'No frame call information\n'
+    return buf
+
+def swank_parse_frame_source(struct):
+    """
+    Parse frame source output
+    http://comments.gmane.org/gmane.lisp.slime.devel/9961 ;-(
+    'Well, let's say a missing feature: source locations are currently not available for code loaded as source.'
+    """
+    if type(struct) == list and len(struct) == 4:
+        buf = ' in ' + struct[1][1] + ' line ' + struct[2][1] + '\n'
+    else:
+        buf = ' No source line information\n'
+    return buf
+
 def swank_parse_locals(struct):
     """
     Parse frame locals output
                                 if action:
                                     action.result = retval
                             # List of actions needing a prompt
-                            to_prompt = [':undefine-function', ':swank-macroexpand-1', ':swank-macroexpand-all', ':load-file', ':toggle-profile-fdefinition', ':profile-by-substring', ':disassemble-form']
+                            to_prompt = [':describe-symbol', ':undefine-function', ':swank-macroexpand-1', ':swank-macroexpand-all', ':load-file', ':toggle-profile-fdefinition', ':profile-by-substring', ':disassemble-form']
                             if element == 'nil' or (action and action.name in to_prompt):
                                 # No more output from REPL, write new prompt
                                 if len(retval) > 0 and retval[-1] != '\n':
                                     retval = retval + '\n'
                                 retval = retval + prompt + '> '
-                        
+
                         elif type(params) == list:
                             if type(params[0]) == list: 
                                 params = params[0]
                                 # No more output from REPL, write new prompt
                                 retval = retval + unquote(params[1][0][0]) + '\n' + prompt + '> '
                             elif element == ':values':
-                                retval = retval + params[1][0] + '\n'
+                                if type(params[1]) == list: 
+                                    retval = retval + unquote(params[1][0]) + '\n'
+                                else:
+                                    retval = retval + unquote(params[1]) + '\n' + prompt + '> '
                             elif element == ':suppress-output':
                                 pass
                             elif element == ':pid':
                                 conn_info = make_keys(params)
                                 pid = conn_info[':pid']
-                                ver = conn_info[':version']
+                                ver = conn_info.get(':version', 'nil')
                                 imp = make_keys( conn_info[':lisp-implementation'] )
                                 pkg = make_keys( conn_info[':package'] )
                                 package = pkg[':name']
                                     package = unquote(params[0])
                                     prompt = unquote(params[1])
                                     retval = retval + prompt + '> '
+                                elif action.name == ':frame-call':
+                                    retval = retval + swank_parse_frame_call(params)
+                                    retval = retval + prompt + '> '
+                                elif action.name == ':frame-source-location':
+                                    retval = retval + swank_parse_frame_source(params)
+                                    #retval = retval + prompt + '> '
                                 elif action.name == ':frame-locals-and-catch-tags':
                                     retval = retval + swank_parse_locals(params)
                                     retval = retval + prompt + '> '
 def swank_invoke_continue():
     swank_rex(':sldb-continue', '(swank:sldb-continue)', 'nil', current_thread)
 
+def swank_frame_call(frame):
+    cmd = '(swank-backend:frame-call ' + frame + ')'
+    swank_rex(':frame-call', cmd, 'nil', current_thread)
+
+def swank_frame_source_loc(frame):
+    cmd = '(swank:frame-source-location ' + frame + ')'
+    swank_rex(':frame-source-location', cmd, 'nil', current_thread)
+
 def swank_frame_locals(frame):
     cmd = '(swank:frame-locals-and-catch-tags ' + frame + ')'
     swank_rex(':frame-locals-and-catch-tags', cmd, 'nil', current_thread)
     elif debug_activated and form[0] != '(' and form[0] != ' ':
         # We are in debug mode and an SLDB command follows (that is not an s-expr)
         if form[0] == '#':
+            swank_frame_call(form[1:])
+            swank_frame_source_loc(form[1:])
             swank_frame_locals(form[1:])
         elif form[0].lower() == 'q':
             swank_throw_toplevel()

File plugin/paredit.vim

 " paredit.vim:
 "               Paredit mode for Slimv
-" Version:      0.8.0
-" Last Change:  02 Apr 2011
+" Version:      0.8.2
+" Last Change:  27 Apr 2011
 " Maintainer:   Tamas Kovacs <kovisoft at gmail dot com>
 " License:      This file is placed in the public domain.
 "               No warranty, express or implied.
     let g:paredit_mode = 1
 endif
 
-"TODO: automatic indentation
-" Automatic indentation after some editing commands
-"if !exists( 'g:paredit_autoindent' )
-"    let g:paredit_autoindent = 1
-"endif
-
 " Match delimiter this number of lines before and after cursor position
 if !exists( 'g:paredit_matchlines' )
     let g:paredit_matchlines = 100
 
 " Skip matches inside string or comment
 let s:skip_c  = 'synIDattr(synID(line("."), col("."), 0), "name") =~ "[Cc]omment"'
-let s:skip_sc = 'synIDattr(synID(line("."), col("."), 0), "name") =~ "[Ss]tring\\|[Cc]omment"'
+let s:skip_sc = 'synIDattr(synID(line("."), col("."), 0), "name") =~ "[Ss]tring\\|[Cc]omment\\|[Ss]pecial"'
 
 " Regular expressions to identify special characters combinations used by paredit
 "TODO: add curly brace
     return s:SynIDMatch( '[Ss]tring', a:0 ? a:1 : '.', 0 )
 endfunction
 
-" Autoindent current top level form
-function! PareditIndentTopLevelForm( level )
-    if a:level < g:paredit_autoindent
-        return
-    endif
-    let l = line( '.' )
-    let c =  col( '.' )
-    normal! ms
-    let matchb = max( [l-g:paredit_matchlines, 1] )
-    let [l0, c0] = searchpairpos( '(', '', ')', 'brmW', s:skip_sc, matchb )
-    "let save_exp = &expandtab
-    "set expandtab
-    normal! v%=`s
-    "let &expandtab = save_exp
-endfunction
-
 " Is this a Slimv REPL buffer?
 function! s:IsReplBuffer()
     if exists( 'g:slimv_repl_dir' ) && exists( 'g:slimv_repl_file' )
             if a:lines[i] == "\n"
                 let inside_comment = 0
             endif
+        elseif i > 0 && a:lines[i-1] == '\' && (i < 2 || a:lines[i-2] != '\')
+            " This is an escaped character, ignore it
         else
             " We are outside of strings and comments, now we shall count parens
             if a:lines[i] == '"'
     endif
     let line = getline( '.' )
     let pos = col( '.' ) - 1
-    if line[pos] !~ s:any_wsclose_char && pos < len( line )
+    if pos > 0 && line[pos-1] == '\' && (pos < 2 || line[pos-2] != '\')
+        " About to enter a \( or \[
+        return a:open
+    elseif line[pos] !~ s:any_wsclose_char && pos < len( line )
         " Add a space after if needed
         let retval = a:open . a:close . " \<Left>\<Left>"
     else
     endif
     let line = getline( '.' )
     let pos = col( '.' ) - 1
-    if line[pos] == a:close
+    if pos > 0 && line[pos-1] == '\' && (pos < 2 || line[pos-2] != '\')
+        " About to enter a \) or \]
+        return a:close
+    elseif line[pos] == a:close
         return "\<Right>"
     else
         let open  = escape( a:open , '[]' )
     if !g:paredit_mode || s:InsideComment()
         return '"'
     endif
-    if s:InsideString()
-        let line = getline( '.' )
-        let pos = col( '.' ) - 1
+    let line = getline( '.' )
+    let pos = col( '.' ) - 1
+    if pos > 0 && line[pos-1] == '\' && (pos < 2 || line[pos-2] != '\')
+        " About to enter a \"
+        return '"'
+    elseif s:InsideString()
         "TODO: skip comments in search(...)
-        if pos > 0 && line[pos-1] == '\' && (pos < 2 || line[pos-2] != '\')
-            " About to enter a \" inside a string
-            return '"'
-        elseif line[pos] == '"'
+        if line[pos] == '"'
             " Standing on a ", just move to the right
             return "\<Right>"
         elseif search('[^\\]"\|^"', 'nW') == 0
     elseif s:InsideString() && line[pos-1] =~ s:any_openclose_char
         " Deleting a paren inside a string
         return "\<BS>"
-    elseif s:InsideString() && pos > 1 && line[pos-2:pos-1] == '\"'
-        " Deleting an escaped double quote inside a string
+    elseif pos > 1 && line[pos-1] =~ s:any_matched_char && line[pos-2] == '\' && (pos < 3 || line[pos-3] != '\')
+        " Deleting an escaped matched character
         return "\<BS>\<BS>"
     elseif line[pos-1] !~ s:any_matched_char
         " Deleting a non-special character
     if pos == len(line)
         " We are at the end of the line
         return "\<Del>"
+    elseif line[pos] == '\' && line[pos+1] =~ s:any_matched_char && (pos < 1 || line[pos-1] != '\')
+        " Deleting an escaped matched character
+        return "\<Del>\<Del>"
     elseif line[pos] !~ s:any_matched_char
         " Erasing a non-special character
         return "\<Del>"
     let reg = @"
     let c = a:count
     while c > 0
-        if s:InsideString() && line[pos : pos+1] == '\"'
-            " Erasing a \" inside string
+        if line[pos] == '\' && line[pos+1] =~ s:any_matched_char && (pos < 1 || line[pos-1] != '\')
+            " Erasing an escaped matched character
             let reg = reg . line[pos : pos+1]
             let line = strpart( line, 0, pos ) . strpart( line, pos+2 )
         elseif s:InsideComment() && line[pos] == ';' && a:startcol >= 0
     let reg = @"
     let c = a:count
     while c > 0 && pos > 0
-        if s:InsideString() && pos > 1 && line[pos-2:pos-1] == '\"'
+        if pos > 1 && line[pos-2] == '\' && line[pos-1] =~ s:any_matched_char && (pos < 3 || line[pos-3] != '\')
+            " Erasing an escaped matched character
             let reg = reg . line[pos-2 : pos-1]
             let line = strpart( line, 0, pos-2 ) . strpart( line, pos )
             normal! h
 
 au BufNewFile,BufRead *.lisp call PareditInitBuffer()
 au BufNewFile,BufRead *.clj  call PareditInitBuffer()
+au BufNewFile,BufRead *.scm  call PareditInitBuffer()
 

File slime/contrib/swank-kawa.scm

+;;;; swank-kawa.scm --- Swank server for Kawa
+;;;
+;;; Copyright (C) 2007  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 Kawa (SVN version) 
+;;    and a Sun JVM with debugger support.
+;; 2. Compile this file with:
+;;      kawa -e '(compile-file "swank-kawa.scm" "swank-kawa")'
+;; 3. Add something like this to your .emacs:
+#|
+;; Kawa and the debugger classes (tools.jar) must be in the classpath.
+;; You also need to start the debug agent.
+(setq slime-lisp-implementations
+      '((kawa ("java"
+	       "-cp" "/opt/kawa/kawa-svn:/opt/java/jdk1.6.0/lib/tools.jar"
+	       "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n"
+	       "kawa.repl" "-s")
+              :init kawa-slime-init)))
+
+(defun kawa-slime-init (file _)
+  (setq slime-protocol-version 'ignore)
+  (let ((swank ".../slime/contrib/swank-kawa.scm")) ; <-- insert the right path
+    (format "%S\n"
+            `(begin (require ,(expand-file-name swank)) (start-swank ,file)))))
+|#
+;; 4. Start everything with  M-- M-x slime kawa
+;;
+;;
+
+;;;; Module declaration
+
+(module-export start-swank create-swank-server swank-java-source-path break)
+
+(module-static #t)
+
+(module-compile-options
+ warn-invoke-unknown-method: #t
+ warn-undefined-variable: #t
+ )
+
+(require 'hash-table)
+
+
+;;;; Macros ()
+
+(define-syntax df
+  (syntax-rules (=>)
+    ((df name (args ... => return-type) body ...)
+     (define (name args ...) :: return-type (seq body ...)))
+    ((df name (args ...) body ...)
+     (define (name args ...) (seq body ...)))))
+
+(define-syntax fun
+  (syntax-rules ()
+    ((fun (args ...) body ...)
+     (lambda (args ...) body ...))))
+
+(define-syntax fin
+  (syntax-rules ()
+    ((fin body handler ...)
+     (try-finally body (seq handler ...)))))
+
+(define-syntax seq
+  (syntax-rules ()
+    ((seq) 
+     (begin #!void))
+    ((seq body ...) 
+     (begin body ...))))
+
+(define-syntax esc
+  (syntax-rules ()
+    ((esc abort body ...)
+     (let* ((key (<symbol>))
+            (abort (lambda (val) (throw key val))))
+       (catch key 
+              (lambda () body ...)
+              (lambda (key val) val))))))
+
+(define-syntax !
+  (syntax-rules ()
+    ((! name obj args ...)
+     (invoke obj 'name args ...))))
+
+(define-syntax !!
+  (syntax-rules ()
+    ((!! name1 name2 obj args ...)
+     (! name1 (! name2 obj args ...)))))
+
+(define-syntax @
+  (syntax-rules ()
+    ((@ name obj)
+     (field obj 'name))))
+
+(define-syntax while
+  (syntax-rules ()
+    ((while exp body ...)
+     (do () ((not exp)) body ...))))
+
+(define-syntax dotimes 
+  (syntax-rules ()
+    ((dotimes (i n result) body ...)
+     (let ((max :: <int> n))
+       (do ((i :: <int> 0 (as <int> (+ i 1))))
+           ((= i max) result)
+           body ...)))
+    ((dotimes (i n) body ...)
+     (dotimes (i n #f) body ...))))
+
+(define-syntax dolist 
+  (syntax-rules ()
+    ((dolist (e list) body ... )
+     (for ((e list)) body ...))))
+
+(define-syntax for
+  (syntax-rules ()
+    ((for ((var iterable)) body ...)
+     (let ((iter (! iterator iterable)))
+       (while (! has-next iter)
+         ((lambda (var) body ...)
+          (! next iter)))))))
+
+(define-syntax packing
+  (syntax-rules ()
+    ((packing (var) body ...)
+     (let ((var :: <list> '()))
+       (let ((var (lambda (v) (set! var (cons v var)))))
+         body ...)
+       (reverse! var)))))
+
+;;(define-syntax loop
+;;  (syntax-rules (for = then collect until)
+;;    ((loop for var = init then step until test collect exp)
+;;     (packing (pack) 
+;;       (do ((var init step))
+;;           (test)
+;;         (pack exp))))
+;;    ((loop while test collect exp)
+;;     (packing (pack) (while test (pack exp))))))
+
+(define-syntax with
+  (syntax-rules ()
+    ((with (vars ... (f args ...)) body ...)
+     (f args ... (lambda (vars ...) body ...)))))
+
+(define-syntax pushf 
+  (syntax-rules ()
+    ((pushf value var)
+     (set! var (cons value var)))))
+
+(define-syntax ==
+  (syntax-rules ()
+    ((== x y)
+     (eq? x y))))
+
+(define-syntax set
+  (syntax-rules ()
+    ((set x y)
+     (let ((tmp y))
+       (set! x tmp)
+       tmp))
+    ((set x y more ...)
+     (begin (set! x y) (set more ...)))))
+
+(define-syntax assert
+  (syntax-rules ()
+    ((assert test)
+     (seq
+       (when (not test)
+         (error "Assertion failed" 'test))
+       'ok))
+    ((assert test fstring args ...)
+     (seq
+       (when (not test)
+         (error "Assertion failed" 'test (format #f fstring args ...)))
+       'ok))))
+
+(define-syntax mif
+  (syntax-rules (quote unquote _)
+    ((mif ('x value) then else)
+     (if (equal? 'x value) then else))
+    ((mif (,x value) then else)
+     (if (eq? x value) then else))
+    ((mif (() value) then else)
+     (if (eq? value '()) then else))
+    #|  This variant produces no lambdas but breaks the compiler
+    ((mif ((p . ps) value) then else)
+     (let ((tmp value)
+           (fail? :: <int> 0)
+           (result #!null))
+       (if (instance? tmp <pair>)
+           (let ((tmp :: <pair> tmp))
+             (mif (p (! get-car tmp))
+                (mif (ps (! get-cdr tmp))
+                     (set! result then)
+                     (set! fail? -1))
+                (set! fail? -1)))
+           (set! fail? -1))
+       (if (= fail? 0) result else)))
+    |#
+    ((mif ((p . ps) value) then else)
+     (let ((fail (lambda () else))
+           (tmp value))
+       (if (instance? tmp <pair>)
+           (let ((tmp :: <pair> tmp))
+             (mif (p (! get-car tmp))
+                  (mif (ps (! get-cdr tmp))
+                       then
+                       (fail))
+                  (fail)))
+           (fail))))
+    ((mif (_ value) then else)
+     then)
+    ((mif (var value) then else)
+     (let ((var value)) then))
+    ((mif (pattern value) then)
+     (mif (pattern value) then (values)))))
+
+(define-syntax mcase
+  (syntax-rules ()
+    ((mcase exp (pattern body ...) more ...)
+     (let ((tmp exp))
+       (mif (pattern tmp)
+            (begin body ...)
+            (mcase tmp more ...))))
+    ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp (pprint-to-string exp)))))
+
+(define-syntax mlet
+  (syntax-rules ()
+    ((mlet (pattern value) body ...)
+     (let ((tmp value))
+       (mif (pattern tmp)
+            (begin body ...)
+            (error "mlet failed" tmp))))))
+
+(define-syntax mlet* 
+  (syntax-rules ()
+    ((mlet* () body ...) (begin body ...))
+    ((mlet* ((pattern value) ms ...) body ...)
+     (mlet (pattern value) (mlet* (ms ...) body ...)))))
+
+(define-syntax typecase%
+  (syntax-rules (eql or)
+    ((typecase% var (#t body ...) more ...)
+     (seq body ...))
+    ((typecase% var ((eql value) body ...) more ...)
+     (cond ((eqv? var 'value) body ...)
+           (else (typecase% var more ...))))
+    ((typecase% var ((or type) body ...) more ...)
+     (typecase% var (type body ...) more ...))
+    ((typecase% var ((or type ...) body ...) more ...)
+     (let ((f (lambda (var) body ...)))
+       (typecase% var
+                  (type (f var)) ...
+                  (#t (typecase% var more ...)))))
+    ((typecase% var (type body ...) more ...) 
+     (cond ((instance? var type) 
+            (let ((var :: type var))
+              body ...))
+           (else (typecase% var more ...))))
+    ((typecase% var)
+     (error "typecase% failed" var 
+            (! getClass (as <object> var))))))
+
+(define-syntax-case typecase
+    ()
+  ((_ exp more ...) (identifier? (syntax exp))
+   #`(typecase% exp more ...))
+  ((_ exp more ...)
+   #`(let ((tmp exp))
+       (typecase% tmp more ...))))
+
+(define-syntax ignore-errors
+  (syntax-rules ()
+    ((ignore-errors body ...)
+     (try-catch (begin body ...)
+                (v <java.lang.Error> #f)
+                (v <java.lang.Exception> #f)))))
+
+;;(define-syntax dc
+;;  (syntax-rules ()
+;;    ((dc name () %% (props ...) prop more ...)
+;;     (dc name () %% (props ... (prop <object>)) more ...))
+;;    ;;((dc name () %% (props ...) (prop type) more ...)
+;;    ;; (dc name () %% (props ... (prop type)) more ...))
+;;    ((dc name () %% ((prop type) ...))
+;;     (define-simple-class name () 
+;;                          ((*init* (prop :: type) ...)
+;;                           (set (field (this) 'prop) prop) ...)
+;;                          (prop :type type) ...))
+;;    ((dc name () props ...)
+;;     (dc name () %% () props ...))))
+
+
+;;;; Aliases
+
+(define-alias <server-socket> <java.net.ServerSocket>)
+(define-alias <socket> <java.net.Socket>)
+(define-alias <in> <java.io.InputStreamReader>)
+(define-alias <out> <java.io.OutputStreamWriter>)
+(define-alias <file> <java.io.File>)
+(define-alias <str> <java.lang.String>)
+(define-alias <builder> <java.lang.StringBuilder>)
+(define-alias <throwable> <java.lang.Throwable>)
+(define-alias <source-error> <gnu.text.SourceError>)
+(define-alias <module-info> <gnu.expr.ModuleInfo>)
+(define-alias <iterable> <java.lang.Iterable>)
+(define-alias <thread> <java.lang.Thread>)
+(define-alias <queue> <java.util.concurrent.LinkedBlockingQueue>)
+(define-alias <exchanger> <java.util.concurrent.Exchanger>)
+(define-alias <timeunit> <java.util.concurrent.TimeUnit>)
+(define-alias <vm> <com.sun.jdi.VirtualMachine>)
+(define-alias <mirror> <com.sun.jdi.Mirror>)
+(define-alias <value> <com.sun.jdi.Value>)
+(define-alias <thread-ref> <com.sun.jdi.ThreadReference>)
+(define-alias <obj-ref> <com.sun.jdi.ObjectReference>)
+(define-alias <array-ref> <com.sun.jdi.ArrayReference>)
+(define-alias <str-ref> <com.sun.jdi.StringReference>)
+(define-alias <meth-ref> <com.sun.jdi.Method>)
+(define-alias <class-ref> <com.sun.jdi.ClassType>)
+(define-alias <frame> <com.sun.jdi.StackFrame>)
+(define-alias <field> <com.sun.jdi.Field>)
+(define-alias <local-var> <com.sun.jdi.LocalVariable>)
+(define-alias <location> <com.sun.jdi.Location>)
+(define-alias <absent-exc> <com.sun.jdi.AbsentInformationException>)
+(define-alias <ref-type> <com.sun.jdi.ReferenceType>)
+(define-alias <event> <com.sun.jdi.event.Event>)
+(define-alias <exception-event> <com.sun.jdi.event.ExceptionEvent>)
+(define-alias <step-event> <com.sun.jdi.event.StepEvent>)
+(define-alias <breakpoint-event> <com.sun.jdi.event.BreakpointEvent>)
+(define-alias <env> <gnu.mapping.Environment>)
+
+(define-simple-class <chan> ()
+  (owner :: <thread> init: (java.lang.Thread:currentThread))
+  (peer :: <chan>)
+  (queue :: <queue> init: (<queue>))
+  (lock init: (<object>)))
+
+
+;;;; Entry Points
+
+(df create-swank-server (port-number) 
+  (setup-server port-number announce-port))
+
+(df start-swank (port-file)
+  (let ((announce (fun ((socket <server-socket>))
+                    (with (f (call-with-output-file port-file))
+                      (format f "~d\n" (! get-local-port socket))))))
+    (spawn (fun ()
+             (setup-server 0 announce)))))
+
+(df setup-server ((port-number <int>) announce)
+  (! set-name (current-thread) "swank")
+  (let ((s (<server-socket> port-number)))
+    (announce s)
+    (let ((c (! accept s)))
+      (! close s)
+      (log "connection: ~s\n"  c)
+      (fin (dispatch-events c)
+        (log "closing socket: ~a\n" s)
+        (! close c)))))
+
+(df announce-port ((socket <server-socket>))
+  (log "Listening on port: ~d\n" (! get-local-port socket)))
+
+
+;;;; Event dispatcher
+
+(define-variable *the-vm* #f)
+(define-variable *last-exception* #f)
+(define-variable *last-stacktrace* #f)
+(df %vm (=> <vm>) *the-vm*)
+
+;; FIXME: this needs factorization.  But I guess the whole idea of
+;; using bidirectional channels just sucks.  Mailboxes owned by a
+;; single thread to which everybody can send are much easier to use.
+
+(df dispatch-events ((s <socket>))
+  (mlet* ((charset "iso-8859-1")
+          (ins (<in> (! getInputStream s) charset))
+          (outs (<out> (! getOutputStream s) charset))
+          ((in . _) (spawn/chan/catch (fun (c) (reader ins c))))
+          ((out . _) (spawn/chan/catch (fun (c) (writer outs c))))
+          ((dbg . _) (spawn/chan/catch vm-monitor))
+          (user-env  (interaction-environment))
+          (x (seq 
+               (! set-flag user-env #t #|<env>:THREAD_SAFE|# 8)
+               (! set-flag user-env #f #|<env>:DIRECT_INHERITED_ON_SET|# 16)))
+          ((listener . _)
+           (spawn/chan (fun (c) (listener c user-env))))
+          (inspector #f)
+          (threads '())
+          (repl-thread #f)
+          (extra '())
+          (vm (let ((vm #f)) (fun () (or vm (rpc dbg `(get-vm)))))))
+    (while #t
+      (mlet ((c . event) (recv* (append (list in out dbg listener)
+                                        (if inspector (list inspector) '())
+                                        (map car threads)
+                                        extra)))
+        ;;(log "event: ~s\n" event)
+        (mcase (list c event)
+          ((_ (':emacs-rex ('|swank:debugger-info-for-emacs| from to)
+                           pkg thread id))
+           (send dbg `(debug-info ,thread ,from ,to ,id)))
+          ((_ (':emacs-rex ('|swank:throw-to-toplevel|) pkg thread id))
+           (send dbg `(throw-to-toplevel ,thread ,id)))
+          ((_ (':emacs-rex ('|swank:sldb-continue|) pkg thread id))
+           (send dbg `(thread-continue ,thread ,id)))
+          ((_ (':emacs-rex ('|swank:frame-source-location| frame)
+			   pkg thread id))
+           (send dbg `(frame-src-loc ,thread ,frame ,id)))
+          ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame)
+                           pkg thread id))
+           (send dbg `(frame-details ,thread ,frame ,id)))
+          ((_ (':emacs-rex ('|swank:sldb-disassemble| frame)
+                           pkg thread id))
+           (send dbg `(disassemble-frame ,thread ,frame ,id)))
+          ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id))
+           (send dbg `(thread-frames ,thread ,from ,to ,id)))
+          ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id))
+           (send dbg `(list-threads ,id)))
+          ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _  _ _))
+           (send dbg `(debug-nth-thread ,n)))
+          ((_ (':emacs-rex ('|swank:quit-thread-browser|) _  _ id))
+           (send dbg `(quit-thread-browser ,id)))
+          ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id))
+           (set inspector (make-inspector user-env (vm)))
+           (send inspector `(init ,str ,id)))
+          ((_ (':emacs-rex ('|swank:inspect-frame-var| frame var) 
+                           pkg thread id))
+           (mlet ((im . ex) (chan))
+             (set inspector (make-inspector user-env (vm)))
+             (send dbg `(get-local ,ex ,thread ,frame ,var))
+             (send inspector `(init-mirror ,im ,id))))
+          ((_ (':emacs-rex ('|swank:inspect-current-condition|) pkg thread id))
+           (mlet ((im . ex) (chan))
+             (set inspector (make-inspector user-env (vm)))
+             (send dbg `(get-exception ,ex ,thread))
+             (send inspector `(init-mirror ,im ,id))))
+          ((_ (':emacs-rex ('|swank:inspect-nth-part| n) pkg _ id))
+           (send inspector `(inspect-part ,n ,id)))
+          ((_ (':emacs-rex ('|swank:inspector-pop|) pkg _ id))
+           (send inspector `(pop ,id)))
+          ((_ (':emacs-rex ('|swank:quit-inspector|) pkg _ id))
+           (send inspector `(quit ,id)))
+          ((_ (':emacs-interrupt id))
+           (let* ((vm (vm))
+                  (t (find-thread id (map cdr threads) repl-thread vm)))
+             (send dbg `(interrupt-thread ,t))))
+          ((_ (':emacs-rex form _ _ id))
+           (send listener `(,form ,id)))
+          ((_ ('get-vm c))
+           (send dbg `(get-vm ,c)))
+          ((_ ('get-channel c))
+           (mlet ((im . ex) (chan))
+             (pushf im extra)
+             (send c ex)))
+          ((_ ('forward x))
+           (send out x))
+          ((_ ('set-listener x))
+           (set repl-thread x))
+          ((_ ('publish-vm vm))
+           (set *the-vm* vm))
+          )))))
+
+(df find-thread (id threads listener (vm <vm>))
+  (cond ((== id ':repl-thread) listener)
+        ((== id 't) listener
+         ;;(if (null? threads) 
+         ;;    listener 
+         ;;    (vm-mirror vm (car threads)))
+         )
+        (#t 
+         (let ((f (find-if threads 
+                      (fun (t :: <thread>)
+                        (= id (! uniqueID 
+                                 (as <thread-ref> (vm-mirror vm t)))))
+                      #f)))
+           (cond (f (vm-mirror vm f))
+                 (#t listener))))))
+
+
+;;;; Reader thread
+
+(df reader ((in <in>) (c <chan>))
+  (! set-name (current-thread) "swank-net-reader")
+  (let ((rt (gnu.kawa.lispexpr.ReadTable:createInitial))) ; ':' not special
+    (while #t
+      (send c (decode-message in rt)))))
+
+(df decode-message ((in <in>) (rt  <gnu.kawa.lispexpr.ReadTable>) => <list>)
+  (let* ((header (read-chunk in 6))
+         (len (java.lang.Integer:parseInt header 16)))
+    (call-with-input-string (read-chunk in len) 
+                            (fun ((port <input-port>))
+                              (%read port rt)))))
+
+(df read-chunk ((in <in>) (len <int>) => <str>)
+  (let ((chars (<char[]> length: len)))
+    (let loop ((offset :: <int> 0))
+      (cond ((= offset len) (<str> chars))
+            (#t (let ((count (! read in chars offset (- len offset))))
+                  (assert (not (= count -1)) "partial packet")
+                  (loop (+ offset count))))))))
+
+;;; FIXME: not thread safe
+(df %read ((port <gnu.mapping.InPort>) (table <gnu.kawa.lispexpr.ReadTable>))
+  (let ((old (gnu.kawa.lispexpr.ReadTable:getCurrent)))
+    (try-finally
+     (seq (gnu.kawa.lispexpr.ReadTable:setCurrent table)
+          (read port))
+     (gnu.kawa.lispexpr.ReadTable:setCurrent old))))
+
+
+;;;; Writer thread
+
+(df writer ((out <out>) (c <chan>))
+  (! set-name (current-thread) "swank-net-writer")
+  (while #t
+    (encode-message out (recv c))))
+
+(df encode-message ((out <out>) (message <list>))
+  (let ((builder (<builder> (as <int> 512))))
+    (print-for-emacs message builder)
+    (! write out (! toString (format "~6,'0x" (! length builder))))
+    (! write out builder)
+    (! flush out)))
+
+(df print-for-emacs (obj (out <builder>))
+  (let ((pr (fun (o) (! append out (! toString (format "~s" o)))))
+        (++ (fun ((s <string>)) (! append out (! toString s)))))
+    (cond ((null? obj) (++ "nil"))
+          ((string? obj) (pr obj))
+          ((number? obj) (pr obj))
+          ;;((keyword? obj) (++ ":") (! append out (to-str obj)))
+          ((symbol? obj) (pr obj))
+          ((pair? obj)
+           (++ "(")
+           (let loop ((obj obj))
+             (print-for-emacs (car obj) out)
+             (let ((cdr (cdr obj)))
+               (cond ((null? cdr) (++ ")"))
+                     ((pair? cdr) (++ " ") (loop cdr))
+                     (#t (++ " . ") (print-for-emacs cdr out) (++ ")"))))))
+          (#t (error "Unprintable object" obj)))))
+
+;;;; SLIME-EVAL
+
+(df eval-for-emacs ((form <list>) env (id <int>) (c <chan>))
+  ;;(! set-uncaught-exception-handler (current-thread)
+  ;;   (<ucex-handler> (fun (t e) (reply-abort c id))))
+  (reply c (%eval form env) id))
+
+(define-variable *slime-funs*)
+(set *slime-funs* (tab))
+
+(df %eval (form env)
+  (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form)))
+
+(df lookup-slimefun ((name <symbol>) tab)
+  ;; name looks like '|swank:connection-info|
+  (let* ((str (symbol->string name))
+         (sub (substring str 6 (string-length str))))
+    (or (get tab (string->symbol sub) #f)
+        (ferror "~a not implemented" sub))))
+                         
+(define-syntax defslimefun 
+  (syntax-rules ()
+    ((defslimefun name (args ...) body ...)
+     (seq
+       (df name (args ...) body ...)
+       (put *slime-funs* 'name name)))))
+
+(defslimefun connection-info ((env <env>))
+  (let ((prop java.lang.System:getProperty))
+  `(:pid 
+    0 
+    :style :spawn
+    :lisp-implementation (:type "Kawa" :name "kawa" 
+                                :version ,(scheme-implementation-version))
+    :machine (:instance ,(prop "java.vm.name") :type ,(prop "os.name")
+                        :version ,(prop "java.runtime.version"))
+    :features ()
+    :package (:name "??" :prompt ,(! getName env)))))
+
+
 
+;;;; Listener
+
+(df listener ((c <chan>) (env <env>))
+  (! set-name (current-thread) "swank-listener")
+  (log "listener: ~s ~s ~s ~s\n"
+       (current-thread) ((current-thread):hashCode) c env)
+  (let ((out (make-swank-outport (rpc c `(get-channel)))))
+    ;;(set (current-output-port) out)
+    (let ((vm (as <vm> (rpc c `(get-vm)))))
+      (send c `(set-listener ,(vm-mirror vm (current-thread))))
+      (request-uncaught-exception-events vm)
+      (request-caught-exception-events vm)
+      )
+    (rpc c `(get-vm))
+    (listener-loop c env out)))
+
+(define-simple-class <listener-abort> (<throwable>)
+  ((*init*)
+   (invoke-special <throwable> (this) '*init* ))
+  ((abort) :: void
+   (primitive-throw (this))
+   #!void))
+
+(df listener-loop ((c <chan>) (env <env>) port)
+  (while (not (nul? c))
+    ;;(log "listener-loop: ~s ~s\n" (current-thread) c)
+    (mlet ((form id) (recv c))
+      (let ((restart (fun ()
+                       (close-output-port port)
+                       (reply-abort c id)
+                       (send (car (spawn/chan
+                                   (fun (cc) 
+                                     (listener (recv cc) env)))) 
+                             c)
+                       (set c #!null))))
+        (! set-uncaught-exception-handler (current-thread)
+           (<ucex-handler> (fun (t e) (restart))))
+        (try-catch
+         (let* ((val (%eval form env)))
+           (force-output)
+           (reply c val id))
+         (ex <java.lang.Exception> (invoke-debugger ex) (restart))
+         (ex <java.lang.Error> (invoke-debugger ex) (restart))
+         (ex <listener-abort>
+             (let ((flag (java.lang.Thread:interrupted)))
+               (log "listener-abort: ~s ~a\n" ex flag))
+             (restart))
+         )))))
+
+(df invoke-debugger (condition)
+  ;;(log "should now invoke debugger: ~a" condition)
+  (try-catch
+   (break condition)
+   (ex <listener-abort> (seq))))
+
+(defslimefun create-repl (env #!rest _)
+  (list "user" "user"))
+
+(defslimefun interactive-eval (env str)
+  (values-for-echo-area (eval (read-from-string str) env)))
+
+(defslimefun interactive-eval-region (env (s <string>))
+  (with (port (call-with-input-string s))
+    (values-for-echo-area
+     (let next ((result (values)))
+       (let ((form (read port)))
+         (cond ((== form #!eof) result)
+               (#t (next (eval form env)))))))))
+
+(defslimefun listener-eval (env string)
+  (let* ((form (read-from-string string))
+         (list (values-to-list (eval form env))))
+  `(:values ,@(map pprint-to-string list))))
+
+(defslimefun pprint-eval (env string)
+  (let* ((form (read-from-string string))
+         (l (values-to-list (eval form env))))
+    (apply cat (map pprint-to-string l))))
+
+(df call-with-abort (f)
+  (try-catch (f) (ex <throwable> (exception-message ex))))
+
+(df exception-message ((ex <throwable>))
+  (typecase ex
+    (<kawa.lang.NamedException> (! to-string ex))
+    (<throwable> (format "~a: ~a"
+                         (class-name-sans-package ex)
+                         (! getMessage ex)))))
+
+(df values-for-echo-area (values)
+  (let ((values (values-to-list values)))
+    (cond ((null? values) "; No value")
+          (#t (format "~{~a~^, ~}" (map pprint-to-string values))))))
+
+;;;; Compilation
+
+(defslimefun compile-file-for-emacs (env (filename <str>) load? 
+                                         #!optional options)
+  (let ((jar (cat (path-sans-extension (filepath filename)) ".jar")))
+    (wrap-compilation 
+     (fun ((m <gnu.text.SourceMessages>))
+       (kawa.lang.CompileFile:read filename m))
+     jar (if (lisp-bool load?) env #f) #f)))
+
+(df wrap-compilation (f jar env delete?)
+  (let ((start-time (current-time))
+        (messages (<gnu.text.SourceMessages>)))
+    (try-catch
+     (let ((c (as <gnu.expr.Compilation> (f messages))))
+       (set (@ explicit c) #t)
+       (! compile-to-archive c (! get-module c) jar))
+     (ex <throwable>
+         (log "error during compilation: ~a\n~a" ex (! getStackTrace ex))
+         (! error messages (as <char> #\f)
+            (to-str (exception-message ex)) #!null)))
+    (log "compilation done.\n")
+    (let ((success? (zero? (! get-error-count messages))))
+      (when (and env success?)
+        (log "loading ...\n")
+        (eval `(load ,jar) env)
+        (log "loading ... done.\n"))
+      (when delete?
+        (ignore-errors (delete-file jar)))
+      (let ((end-time (current-time)))
+        (list ':compilation-result 
+              (compiler-notes-for-emacs messages)
+              (if success? 't 'nil)
+              (/ (- end-time start-time) 1000.0))))))
+
+(defslimefun compile-string-for-emacs (env string buffer offset dir)
+  (wrap-compilation
+   (fun ((m <gnu.text.SourceMessages>))
+     (let ((c (as <gnu.expr.Compilation>
+                  (call-with-input-string 
+                   string
+                   (fun ((p <gnu.mapping.InPort>))
+                     (! set-path p 
+                        (format "~s" 
+                                `(buffer ,buffer offset ,offset str ,string)))
+                     (kawa.lang.CompileFile:read p m))))))
+       (let ((o (@ currentOptions c)))
+         (! set o "warn-invoke-unknown-method" #t)
+         (! set o "warn-undefined-variable" #t))
+       (let ((m (! getModule c)))
+         (! set-name m (format "<emacs>:~a/~a" buffer (current-time))))
+       c))
+   "/tmp/kawa-tmp.zip" env #t))
+
+(df compiler-notes-for-emacs ((messages <gnu.text.SourceMessages>))
+  (packing (pack)
+    (do ((e (! get-errors messages) (@ next e)))
+        ((nul? e))
+      (pack (source-error>elisp e)))))
+
+(df source-error>elisp ((e <source-error>) => <list>)
+  (list ':message (to-string (@ message e))
+        ':severity (case (integer->char (@ severity e))
+                    ((#\e #\f) ':error)
+                    ((#\w) ':warning)
+                    (else ':note))
+        ':location (error-loc>elisp e)))
+
+(df error-loc>elisp ((e <source-error>))
+  (cond ((nul? (@ filename e)) `(:error "No source location"))
+        ((! starts-with (@ filename e) "(buffer ")
+         (mlet (('buffer b 'offset o 'str s) (read-from-string (@ filename e)))
+           `(:location (:buffer ,b)
+                       (:position ,(+ o (line>offset (1- (@ line e)) s)
+                                      (1- (@ column e))))
+                       nil)))
+        (#t
+         `(:location (:file ,(to-string (@ filename e)))
+                     (:line ,(@ line e) ,(1- (@ column e)))
+                     nil))))
+
+(df line>offset ((line <int>) (s <str>) => <int>)
+  (let ((offset :: <int> 0))
+    (dotimes (i line)
+      (set offset (! index-of s (as <char> #\newline) offset))
+      (assert (>= offset 0))
+      (set offset (as <int> (+ offset 1))))
+    (log "line=~a offset=~a\n" line offset)
+    offset))
+
+(defslimefun load-file (env filename)
+  (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env)))
+
+;;;; Completion
+
+(defslimefun simple-completions (env (pattern <str>) _)
+  (let* ((env (as <gnu.mapping.InheritingEnvironment> env))
+         (matches (packing (pack)
+                    (let ((iter (! enumerate-all-locations env)))
+                      (while (! has-next iter)
+                        (let ((l (! next-location iter)))
+                          (typecase l
+                            (<gnu.mapping.NamedLocation>
+                             (let ((name (!! get-name get-key-symbol l)))
+                               (when (! starts-with name pattern)
+                                 (pack name)))))))))))
+    `(,matches ,(cond ((null? matches) pattern)
+                      (#t (fold+ common-prefix matches))))))
+
+(df common-prefix ((s1 <str>) (s2 <str>) => <str>)
+  (let ((limit (min (! length s1) (! length s2))))
+    (let loop ((i 0))
+      (cond ((or (= i limit)
+                 (not (== (! char-at s1 i)
+                          (! char-at s2 i))))
+             (! substring s1 0 i))
+            (#t (loop (1+ i)))))))
+
+(df fold+ (f list)
+  (let loop ((s (car list))
+             (l (cdr list)))
+    (cond ((null? l) s)
+          (#t (loop (f s (car l)) (cdr l))))))
+
+;;; Quit
+
+(defslimefun quit-lisp (env)
+  (exit))
+
+;;(defslimefun set-default-directory (env newdir))
+
+
+;;;; Dummy defs
+
+
+(defslimefun buffer-first-change (#!rest y) '())
+(defslimefun swank-require (#!rest y) '())
+
+;;;; arglist
+
+(defslimefun operator-arglist (env name #!rest _)
+  (mcase (try-catch `(ok ,(eval (read-from-string name) env))
+                    (ex <throwable> 'nil))
+    (('ok obj)
+     (mcase (arglist obj)
+       ('#f 'nil)
+       ((args rtype)
+        (format "(~a~{~^ ~a~})~a" name 
+                (map (fun (e) 
+                       (if (equal (cadr e) "java.lang.Object") (car e) e))
+                     args)
+                (if (equal rtype "java.lang.Object")
+                    ""
+                    (format " => ~a" rtype))))))
+    (_ 'nil)))
+
+(df arglist (obj)
+  (typecase obj
+    (<gnu.expr.ModuleMethod> 
+     (let* ((mref (module-method>meth-ref obj)))
+       (list (mapi (! arguments mref)
+                   (fun ((v <local-var>))
+                     (list (! name v) (! typeName v))))
+             (! returnTypeName mref))))
+    (<object> #f)))
+
+;;;; M-.
+
+(defslimefun find-definitions-for-emacs (env name)
+  (mcase (try-catch `(ok ,(eval (read-from-string name) env))
+                    (ex <throwable> `(error ,(exception-message ex))))
+    (('ok obj) (mapi (all-definitions obj)
+                     (fun (d)
+                       `(,(format "~a" d) ,(src-loc>elisp (src-loc d))))))
+    (('error msg) `((,name (:error ,msg))))))
+
+(define-simple-class <swank-location> (<location>)
+  (file init: #f)
+  (line init: #f)
+  ((*init* file name) 
+   (set (@ file (this)) file)
+   (set (@ line (this)) line))
+  ((lineNumber) :: <int> (or line (absent)))
+  ((lineNumber (s <str>)) :: int (! lineNumber (this)))
+  ((method) :: <meth-ref> (absent))
+  ((sourcePath) :: <str> (or file (absent)))
+  ((sourcePath (s <str>)) :: <str> (! sourcePath (this)))
+  ((sourceName) :: <str> (absent))
+  ((sourceName (s <str>)) :: <str> (! sourceName (this)))
+  ((declaringType) :: <ref-type> (absent))
+  ((codeIndex) :: <long> -1)
+  ((virtualMachine) :: <vm> *the-vm*)
+  ((compareTo o) :: <int>
+   (typecase o
+     (<location> (- (! codeIndex (this)) (! codeIndex o))))))
+
+(df absent () (primitive-throw (<absent-exc>)))
+
+(df all-definitions (o)
+  (typecase o
+    (<gnu.expr.ModuleMethod> (list o))
+    (<gnu.expr.PrimProcedure> (list o))
+    (<gnu.expr.GenericProc> (append (mappend all-definitions (gf-methods o))
+                                    (let ((s (! get-setter o)))
+                                      (if s (all-definitions s) '()))))
+    (<java.lang.Class> (list o))
+    (<gnu.mapping.Procedure> (all-definitions (! get-class o)))
+    (<kawa.lang.Macro> (list o))
+    (<gnu.bytecode.ObjectType> (all-definitions (! getReflectClass o)))
+    (<java.lang.Object> '())
+    ))
+
+(df gf-methods ((f <gnu.expr.GenericProc>))
+  (let* ((o :: <obj-ref> (vm-mirror *the-vm* f))
+         (f (! field-by-name (! reference-type o) "methods"))
+         (ms (vm-demirror *the-vm* (! get-value o f))))
+    (filter (array-to-list ms) (fun (x) (not (nul? x))))))
+
+(df src-loc (o => <location>)
+  (typecase o
+    (<gnu.expr.PrimProcedure> (src-loc (@ method o)))
+    (<gnu.expr.ModuleMethod> (module-method>src-loc o))
+    (<gnu.expr.GenericProc> (<swank-location> #f #f))
+    (<java.lang.Class> (class>src-loc o))
+    (<kawa.lang.Macro> (<swank-location> #f #f))
+    (<gnu.bytecode.Method> (bytemethod>src-loc o))))
+
+(df module-method>src-loc ((f <gnu.expr.ModuleMethod>))
+  (! location (module-method>meth-ref f)))
+
+(df module-method>meth-ref ((f <gnu.expr.ModuleMethod>) => <meth-ref>)
+  (let ((module (! reference-type
+                   (as <obj-ref> (vm-mirror *the-vm* (@ module f)))))
+	(name (mangled-name f)))
+    (as <meth-ref> (1st (! methods-by-name module name)))))
+
+(df mangled-name ((f <gnu.expr.ModuleMethod>))
+  (let ((name (gnu.expr.Compilation:mangleName (! get-name f))))
+    (if (= (! maxArgs f) -1)
+        (cat name "$V")
+        name)))
+
+(df class>src-loc ((c <java.lang.Class>) => <location>)
+  (let* ((type (class>class-ref c))
+         (locs (! all-line-locations type)))
+    (cond ((not (! isEmpty locs)) (1st locs))
+          (#t (<swank-location> (1st (! source-paths type "Java"))
+                                #f)))))
+
+(df class>class-ref ((class <java.lang.Class>) => <class-ref>)
+  (! reflectedType (as <com.sun.jdi.ClassObjectReference>
+                       (vm-mirror *the-vm* class))))
+
+(df bytemethod>src-loc ((m <gnu.bytecode.Method>) => <location>)
+  (let* ((cls (class>class-ref (! get-reflect-class (! get-declaring-class m))))
+         (name (! get-name m))
+         (sig (! get-signature m))
+         (meth (! concrete-method-by-name cls name sig)))
+    (! location meth)))
+
+(df src-loc>elisp ((l <location>))
+  (df src-loc>list ((l <location>))
+    (list (ignore-errors (! source-name l "Java"))
+          (ignore-errors (! source-path l "Java"))
+          (ignore-errors (! line-number l "Java"))))
+  (mcase (src-loc>list l)
+    ((name path line)
+     (cond ((not path) 
+            `(:error ,(call-with-abort (fun () (! source-path l)))))
+           ((! starts-with (as <str> path) "(buffer ")
+            (mlet (('buffer b 'offset o 'str s) (read-from-string path))
+              `(:location (:buffer ,b)
+                          (:position ,(+ o (line>offset line s)))
+                          nil)))
+           (#t
+            `(:location ,(or (find-file-in-path name (source-path))
+                             (find-file-in-path path (source-path))
+                             (ferror "Can't find source-path: ~s ~s ~a" 
+                                     path name (source-path)))
+                        (:line ,(or line -1)) ()))))))
+
+(df src-loc>str ((l <location>))
+  (cond ((nul? l) "<null-location>")
+        (#t (format "~a ~a ~a" 
+                    (or (ignore-errors (! source-path l))
+                        (ignore-errors (! source-name l))
+                        (ignore-errors (!! name declaring-type l)))
+                    (ignore-errors (!! name method l))
+                    (ignore-errors (! lineNumber l))))))
+
+(df ferror (fstring #!rest args)
+  (let ((err (<java.lang.Error> (to-str (apply format fstring args)))))
+    (primitive-throw err)))
+
+;;;;;; class-path hacking
+
+;; (find-file-in-path "kawa/lib/kawa/hashtable.scm" (source-path))
+
+(df find-file-in-path ((filename <str>) (path <list>))
+  (let ((f (<file> filename)))
+    (cond ((! isAbsolute f) `(:file ,filename))
+          (#t (let ((result #f))
+                (find-if path (fun (dir) 
+                                (let ((x (find-file-in-dir f dir)))
+                                  (set result x)))
+                         #f)
+                result)))))
+
+(df find-file-in-dir ((file <file>) (dir <str>))
+  (let ((filename (! getPath file)))
+    (or (let ((child (<file> (<file> dir) filename)))
+          (and (! exists child)
+               `(:file ,(! getPath child))))
+        (try-catch 
+         (and (not (nul? (! getEntry (<java.util.zip.ZipFile> dir) filename)))
+              `(:zip ,dir ,filename))
+         (ex <throwable> #f)))))
+
+(define swank-java-source-path
+  (let ((jre-home (<java.lang.System>:getProperty "java.home")))
+    (list (! get-path (<file> (! get-parent (<file> jre-home)) "src.zip"))
+          )))
+
+(df source-path ()
+  (mlet ((base) (search-path-prop "user.dir"))
+    (append 
+     (list base)
+     (map (fun ((s <str>))
+             (let ((f (<file> s)))
+               (cond ((! isAbsolute f) s)
+                     (#t (<file> (as <str> base) s):path))))
+          (class-path))
+     swank-java-source-path)))
+
+(df class-path ()
+  (append (search-path-prop "java.class.path")
+          (search-path-prop "sun.boot.class.path")))
+
+(df search-path-prop ((name <str>))
+  (array-to-list (! split (java.lang.System:getProperty name)
+                    <file>:pathSeparator)))
+
+;;;; Disassemble 
+
+(defslimefun disassemble-form (env form)
+  (mcase (read-from-string form)
+    (('quote name)
+     (let ((f (eval name env)))
+       (typecase f
+         (<gnu.expr.ModuleMethod> 
+          (disassemble-to-string (module-method>meth-ref f))))))))
+
+(df disassemble-to-string ((mr <meth-ref>) => <str>)
+  (with-sink #f (fun (out) (disassemble-meth-ref mr out))))
+
+(df disassemble-meth-ref ((mr <meth-ref>) (out <java.io.PrintWriter>))
+  (let* ((t (! declaring-type mr)))
+    (disas-header mr out)
+    (disas-code (! constant-pool t)
+                (! constant-pool-count t)
+                (! bytecodes mr)
+                out)))
+
+(df disas-header ((mr <meth-ref>) (out <java.io.PrintWriter>))
+  (let* ((++ (fun ((str <str>)) (! write out str)))
+         (? (fun (flag str) (if flag (++ str)))))
+    (? (! is-static mr) "static ") 
+    (? (! is-final mr) "final ")
+    (? (! is-private mr) "private ") 
+    (? (! is-protected mr) "protected ")
+    (? (! is-public mr) "public ")
+    (++ (! name mr)) (++ (! signature mr)) (++ "\n")))
+
+(df disas-code ((cpool <byte[]>) (cpoolcount <int>) (bytecode <byte[]>) 
+                (out <java.io.PrintWriter>))
+  (let* ((ct (<gnu.bytecode.ClassType> "foo"))
+	 (met (! addMethod ct "bar" 0))
+	 (ca (<gnu.bytecode.CodeAttr> met))
+         (constants (let* ((bs (<java.io.ByteArrayOutputStream>))
+                           (s (<java.io.DataOutputStream> bs)))
+                      (! write-short s cpoolcount)
+                      (! write s cpool)
+                      (! flush s)
+                      (! toByteArray bs))))
+    (vm-set-slot *the-vm* ct "constants"
+                 (<gnu.bytecode.ConstantPool>
+                  (<java.io.DataInputStream>
+                   (<java.io.ByteArrayInputStream>
+                    constants))))
+    (! setCode ca bytecode)
+    (let ((w (<gnu.bytecode.ClassTypeWriter> ct out 0)))
+      (! print ca w)
+      (! flush w))))
+
+(df with-sink (sink (f <function>))
+  (cond ((instance? sink <java.io.PrintWriter>) (f sink))
+        ((== sink #t) (f (as <java.io.PrintWriter> (current-output-port))))
+        ((== sink #f)
+         (let* ((buffer (<java.io.StringWriter>))
+                (out (<java.io.PrintWriter> buffer)))
+           (f out)
+           (! flush out)
+           (! toString buffer)))
+        (#t (ferror "Invalid sink designator: ~s" sink))))
+
+(df test-disas ((c <str>) (m <str>))
+  (let* ((vm (as <vm> *the-vm*))
+         (c (as <ref-type> (1st (! classes-by-name vm c))))
+         (m (as <meth-ref> (1st (! methods-by-name c m)))))
+    (with-sink #f (fun (out) (disassemble-meth-ref m out)))))
+
+;; (test-disas "java.lang.Class" "toString")
+
+
+;;;; Macroexpansion
+
+(defslimefun swank-expand-1 (env s) (%swank-macroexpand s))
+(defslimefun swank-expand (env s) (%swank-macroexpand s))
+(defslimefun swank-expand-all (env s) (%swank-macroexpand s))
+
+(df %swank-macroexpand (string)
+  (pprint-to-string (%macroexpand (read-from-string string))))
+
+(df %macroexpand (sexp)
+  (let ((tr :: kawa.lang.Translator (gnu.expr.Compilation:getCurrent)))
+    (! rewrite tr `(begin ,sexp))))
+
+
+;;;; Inspector
+
+(define-simple-class <inspector-state> () 
+  (object init: #!null) 
+  (parts :: <java.util.ArrayList> init: (<java.util.ArrayList>) )
+  (stack :: <list> init: '())
+  (content :: <list> init: '()))
+
+(df make-inspector (env (vm <vm>) => <chan>)
+  (car (spawn/chan (fun (c) (inspector c env vm)))))
+
+(df inspector ((c <chan>) env (vm <vm>))
+  (! set-name (current-thread) "inspector")
+  (let ((state :: <inspector-state> (<inspector-state>))
+        (open #t))
+    (while open
+      (mcase (recv c)
+        (('init str id)
+         (set state (<inspector-state>))
+         (let ((obj (try-catch (eval (read-from-string str) env)
+                               (ex <throwable> ex))))
+           (reply c (inspect-object obj state vm) id)))
+        (('init-mirror cc id)
+         (set state (<inspector-state>))
+         (let* ((mirror (recv cc))
+                (obj (vm-demirror vm mirror)))
+           (reply c (inspect-object obj state vm) id)))
+        (('inspect-part n id)
+         (let ((part (! get (@ parts state) n)))
+           (reply c (inspect-object part state vm) id)))
+        (('pop id)
+         (reply c (inspector-pop state vm) id))
+        (('quit id)
+         (reply c 'nil id)
+         (set open #f))))))
+
+(df inspect-object (obj (state <inspector-state>) (vm <vm>))
+  (set (@ object state) obj)
+  (set (@ parts state) (<java.util.ArrayList>))
+  (pushf obj (@ stack state))
+  (set (@ content state) (inspector-content 
+                          `("class: " (:value ,(! getClass obj)) "\n" 
+                            ,@(inspect obj vm))
+                          state))
+  (cond ((nul? obj) (list ':title "#!null" ':id 0 ':content `()))
+        (#t
+         (list ':title (pprint-to-string obj) 
+               ':id (assign-index obj state)
+               ':content (let ((c (@ content state)))
+                           (content-range  c 0 (len c)))))))
+
+(df inspect (obj vm)
+  (let* ((obj (as <obj-ref> (vm-mirror vm obj))))
+    (packing (pack)
+      (typecase obj
+        (<array-ref>
+         (let ((i 0))
+           (iter (! getValues obj)
+                 (fun ((v <value>))
+                   (pack (format "~d: " i))
+                   (set i (1+ i))
+                   (pack `(:value ,(vm-demirror vm v)))
+                   (pack "\n")))))
+        (<obj-ref>
+         (let* ((type (! referenceType obj))
+                (fields (! allFields type))
+                (values (! getValues obj fields)))
+           (iter fields 
+                 (fun ((f <field>))
+                   (let ((val (as <value> (! get values f))))
+                     (when (! is-static f)
+                       (pack "static "))
+                     (pack (! name f)) (pack ": ") 
+                     (pack `(:value ,(vm-demirror vm val)))
+                     (pack "\n"))))))))))
+
+(df inspector-content (content (state <inspector-state>))
+  (map (fun (part)
+         (mcase part
+           ((':value val)
+            `(:value ,(pprint-to-string val) ,(assign-index val state)))
+           (x (to-string x))))
+       content))
+
+(df assign-index (obj (state <inspector-state>) => <int>)
+  (! add (@ parts state) obj)
+  (1- (! size  (@ parts state))))
+
+(df content-range (l start end)
+  (let* ((len (length l)) (end (min len end)))
+    (list (subseq l start end) len start end)))
+
+(df inspector-pop ((state <inspector-state>) vm)
+  (cond ((<= 2 (len (@ stack state)))
+         (let ((obj (cadr (@ stack state))))
+           (set (@ stack state) (cddr (@ stack state)))
+           (inspect-object obj state vm)))
+        (#t 'nil)))
+
+;;;; IO redirection
+
+(define-simple-class <swank-writer> (<java.io.Writer>)
+  (q :: <queue> init: (<queue> (as <int> 100)))
+  ((*init*) (invoke-special <java.io.Writer> (this) '*init*))
+  ((write (buffer <char[]>) (from <int>) (to <int>)) :: <void>
+   (synchronized (this)
+     (assert (not (== q #!null)))
+     (! put q `(write ,(<str> buffer from to)))))
+  ((close) :: <void>
+   (synchronized (this)
+     (! put q 'close)
+     (set! q #!null)))
+  ((flush) :: <void>
+   (synchronized (this)
+     (assert (not (== q #!null)))
+     (let ((ex (<exchanger>)))
+       (! put q `(flush ,ex))
+       (! exchange ex #!null)))))
+
+(df swank-writer ((in <chan>) (q <queue>))
+  (! set-name (current-thread) "swank-redirect-thread")
+  (let* ((out (as <chan> (recv in)))
+         (builder (<builder>))
+         (flush (fun ()
+                  (unless (zero? (! length builder))
+                    (send out `(forward (:write-string ,(<str> builder))))
+                    (set! builder:length 0)))) ; pure magic
+         (closed #f))
+    (while (not closed)
+      (mcase (! poll q (as long 200) <timeunit>:MILLISECONDS)
+        ('#!null (flush))
+        (('write s)
+         (! append builder (as <str> s))
+         (when (> (! length builder) 4000)
+           (flush)))
+        (('flush ex)
+         (flush)
+         (! exchange (as <exchanger> ex) #!null))
+        ('close        
+         (set closed #t)
+         (flush))))))
+
+(df make-swank-outport ((out <chan>))
+  (let ((w (<swank-writer>)))
+    (mlet ((in . _) (spawn/chan (fun (c) (swank-writer c (@ q w)))))
+      (send in out))
+    (<gnu.mapping.OutPort> w  #t #t)))
+
+
+;;;; Monitor
+
+;;(define-simple-class <monitorstate> ()
+;;  (threadmap type: (tab)))
+
+(df vm-monitor ((c <chan>))
+  (! set-name (current-thread) "swank-vm-monitor")
+  (let ((vm (vm-attach)))
+    (log-vm-props vm)
+    (request-breakpoint vm)
+    (mlet* (((ev . _) (spawn/chan/catch 
+                       (fun (c) 
+                         (let ((q (! eventQueue vm)))
+                           (while #t
+                             (send c `(vm-event ,(to-list (! remove q)))))))))
+            (to-string (vm-to-string vm))
+            (state (tab)))
+      (send c `(publish-vm ,vm))
+      (while #t
+        (mcase (recv* (list c ev))
+          ((_ . ('get-vm cc))
+           (send cc vm))
+          ((,c . ('debug-info thread from to id))
+           (reply c (debug-info thread from to state) id))
+          ((,c . ('throw-to-toplevel thread id))
+           (set state (throw-to-toplevel thread id c state)))
+          ((,c . ('thread-continue thread id))
+           (set state (thread-continue thread id c state)))
+          ((,c . ('frame-src-loc thread frame id))
+           (reply c (frame-src-loc thread frame state) id))
+          ((,c . ('frame-details thread frame id))
+           (reply c (list (frame-locals thread frame state) '()) id))
+          ((,c . ('disassemble-frame thread frame id))
+           (reply c (disassemble-frame thread frame state) id))
+          ((,c . ('thread-frames thread from to id))
+           (reply c (thread-frames thread from to state) id))
+          ((,c . ('list-threads id))
+           (reply c (list-threads vm state) id))
+          ((,c . ('interrupt-thread ref))
+           (set state (interrupt-thread ref state c)))
+          ((,c . ('debug-nth-thread n))
+           (let ((t (nth (get state 'all-threads #f) n)))
+             ;;(log "thread ~d : ~a\n" n t)
+             (set state (interrupt-thread t state c))))