/local-lisp/slime/contrib/swank-kawa.scm

Large files files are truncated, but you can click here to view the full file

;;;; 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 ((zip ".../slime/contrib/swank-kawa.zip")) ; <-- insert the right path
    (format "%S\n"
            `(begin (load ,(expand-file-name zip)) (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)

(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 body ...))
    ((df name (args ...) body ...)
     (define (name args ...) 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 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 (@ car tmp))
                (mif (ps (@ 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 (@ car tmp))
                  (mif (ps (@ 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 (::)
    ((typecase var (type body ...) ...)
     (cond ((instance? var type) 
            (let ((var :: type var))
              body ...))
           ...
           (else (error "typecase failed" var 
                        (! getClass (as <object> var))))))))

(define-syntax ignore-errors
  (syntax-rules ()
    ((ignore-errors body ...)
     (try-catch (begin body ...)
                (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 <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)

;; 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 `(debug-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))))
      (enable-uncaught-exception-events vm))
    (rpc c `(get-vm))
    (listener-loop c env out)))

(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 <listener-abort>
             (let ((flag (java.lang.Thread:interrupted)))
               (log "listener-abort: ~s ~a\n" ex flag))
             (restart)))))))

(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)))
    (format "~:[=> ~{~s~^, ~}~;; No values~]" (null? values) 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.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.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))))

(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 (! reflectedType (as <com.sun.jdi.ClassObjectReference>
                                    (vm-mirror *the-vm* c))))
         (locs (! all-line-locations type)))
    (cond ((not (! isEmpty locs)) (1st locs))
          (#t (<swank-location> (1st (! source-paths type #!null))
                                #f)))))

(df src-loc>elisp ((l <location>))
  (df src-loc>list ((l <location>))
    (list (ignore-errors (! source-name l))
          (ignore-errors (! source-path l))
          (ignore-errors (! line-number l))))
  (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)
  (primitive-throw (<java.lang.Error> (to-str (apply format fstring args)))))

;;;;;; class-path hacking

(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 (module-method>meth-ref f))))))))

(df disassemble ((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-macroexpand-1 (env s) (%swank-macroexpand s))
(defslimefun swank-macroexpand (env s) (%swank-macroexpand s))
(defslimefun swank-macroexpand-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 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

(df vm-monitor ((c <chan>))
  (! set-name (current-thread) "swank-vm-monitor")
  (let ((vm (vm-attach)))
    (log-vm-props vm)
    ;;(enable-uncaught-exception-events 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 . ('debug-thread ref))
           (set state (debug-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 (debug-thread t state c))))
          ((,c . ('quit-thread-browser id))
           (reply c 't id)
           (set state (del state 'all-threads)))
          ((,ev . ('vm-event es))
           ;;(log "vm-events: len=~a\n" (len es))
           (for (((e <event>) (as <list> es)))
             (set state (process-vm-event e c state))))
          ((_ . ('get-exception from tid))
           (mlet ((_ _ es) (get state tid #f))
             (send from (let ((e (car es)))
                          (typecase e 
                            (<exception-event> (! exception e))
                            (<event> e))))))
          ((_ . ('get-local rc tid frame var))
           (send rc (frame-local-var tid frame var state)))
          )))))

(df reply ((c <chan>) value id)
  (send c `(forward (:return (:ok ,value) ,id))))

(df reply-abort ((c <chan>) id)
  (send c `(forward (:return (:abort) ,id))))

(df process-vm-event ((e <event>) (c <chan>) state)
  (log "vm-event: ~s\n" e)
  (typecase e
    (<exception-event>
     (log "exception-location: ~s\n" (src-loc>str (! location e)))
     (log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e)))
     (let ((l (! catch-location e)))
       (cond ((or (nul? l)
                  ;; (member (! source-path l) '("gnu/expr/ModuleExp.java"))
                  )
              (process-exception e c state))
             (#t
              (let* ((t (! thread e))
                     (r (! request e))
                     (ex (! exception e)))
                (unless (eq? *last-exception* ex)
                  (set *last-exception* ex)
                  (set *last-stacktrace*  (copy-stack t)))
                (! resume t))
              state))))
    (<step-event>
     (let* ((r (! request e))
            (k (! get-property r 'continuation)))
       (! disable r)
       (log "k: ~s\n" k)
       (k e))
     state)))

(df process-exception ((e <exception-event>) (c <chan>) state)
    (let* ((tref (! thread e))
           (tid (! uniqueID tref))
           (s (get state tid #f)))
      (mcase s
        ('#f
         ;; XXX redundant in debug-thread
         (let* ((level 1)
                (state (put state tid (list tref level (list e)))))
           (send c `(forward (:debug ,tid ,level 
                                     ,@(debug-info tid 0 15 state))))
           (send c `(forward (:debug-activate ,tid ,level)))
           state))
        ((_ level exs)
         (send c `(forward (:debug-activate ,(! uniqueID tref) ,level)))
         (put state tid (list tref (1+ level) (cons e exs)))))))

(define-simple-class <faked-frame> ()
  (loc :: <location>)
  (args)
  (names)
  (values :: <java.util.Map>)
  (self)
  ((*init* (loc <location>) args names (values <java.util.Map>) self)
   (set (@ loc (this)) loc)
   (set (@ args (this)) args)
   (set (@ names (this)) names)
   (set (@ values (this)) values)
   (set (@ self (this)) self))
  ((toString) :: <str>
   (format "#<ff ~a>" (src-loc>str loc))))

(df copy-stack ((t <thread-ref>))
  (packing (pack)
    (iter (! frames t)
          (fun ((f <frame>))
            (let ((vars (ignore-errors (! visibleVariables f))))
              (pack (<faked-frame> 
                     (or (ignore-errors (! location f)) #!null)
                     (ignore-errors (! getArgumentValues f))
                     (or vars #!null)
                     (or (and vars (ignore-errors (! get-values f vars)))
                         #!null)
                     (ignore-errors (! thisObject f)))))))))

(define-simple-class <listener-abort> (<java.lang.Throwable>)
  ((abort) :: void
   (primitive-throw (this))
   #!void))

(define-simple-class <break-event> (<com.sun.jdi.event.Event>)
  (thread :: <thread-ref>)
  ((*init* (thread :: <thread-ref>)) (set (@ thread (this)) thread))
  ((request) :: <com.sun.jdi.request.EventRequest> #!null)
  ((virtualMachine) :: <vm> (! virtualMachine thread)))

(df log-vm-props ((vm <vm>))
  (letrec-syntax ((p (syntax-rules ()
                       ((p name) (log "~s: ~s\n" 'name (! name vm)))))
                  (p* (syntax-rules ()
                        ((p* n ...) (seq (p n) ...)))))
    (p* canBeModified
        canRedefineClasses
        canAddMethod
        canUnrestrictedlyRedefineClasses
        canGetBytecodes
        canGetConstantPool
        canGetSyntheticAttribute
        canGetSourceDebugExtension
        canPopFrames
        canForceEarlyReturn
        canGetMethodReturnValues
        canGetInstanceInfo
        )))

;;;;; Debugger

(df debug-thread ((tref <thread-ref>) state (c <chan>))
  (! suspend tref)
  (let* ((ev (<break-event> tref))
         (id (! uniqueID tref))
         (level 1)
         (state (put state id (list tref level (list ev)))))
    (send c `(forward (:debug ,id ,level ,@(debug-info id 0 10 state))))
    (send c `(forward (:debug-activate ,id ,level)))
    state))

(df debug-info ((tid <int>) (from <int>) to state)
  (mlet ((thread-ref level evs) (get state tid #f))
    (let* ((tref (as <thread-ref> thread-ref))
           (vm (! virtualMachine tref))
           (ev (as <event> (car evs)))
           (ex (typecase ev
                 (<exception-event> (! exception ev))
                 (<break-event> (<java.lang.Exception> "Interrupt"))))
           (desc (typecase ex
                   (<obj-ref> 
                    ;;(log "ex: ~a ~a\n" ex (vm-demirror vm ex))
                    (! toString (vm-demirror vm ex)))
                   (<java.lang.Exception> (! toString ex))))
           (type (format "  [type ~a]" 
                         (typecase ex
                           (<obj-ref> (! name (! referenceType ex)))
                           (<object> (!! getName getClass ex)))))
           (bt (thread-frames tid from to state)))
      `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ()))))

(df thread-frames ((tid <int>) (from <int>) to state)
  (mlet ((thread level evs) (get state tid #f))
    (let* ((thread (as <thread-ref> thread))
           (fcount (! frameCount thread))
           (stacktrace (event-stacktrace (car evs)))
 …