dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/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 (version 2.x) and a JVM with debugger support.
;;
;; 2. Compile this file and create swank-kawa.jar with:
;;      java -cp kawa.jar:$JAVA_HOME/lib/tools.jar \
;;           -Xss2M kawa.repl --r7rs -d classes -C swank-kawa.scm &&
;;      jar cf swank-kawa.jar -C classes .
;;
;; 3. Add something like this to your .emacs:
#|
;; Kawa, Swank, 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"
          ;; needed jar files
          "-cp" "kawa-2.0.1.jar:swank-kawa.jar:/opt/jdk1.8.0/lib/tools.jar"
          ;; channel for debugger
          "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n"
          ;; depending on JVM, compiler may need more stack
          "-Xss2M"
          ;; kawa without GUI
          "kawa.repl" "-s")
         :init kawa-slime-init)))

(defun kawa-slime-init (file _)
  (setq slime-protocol-version 'ignore)
  (format "%S\n"
          `(begin (import (swank-kawa))
                  (start-swank ,file)
                  ;; Optionally add source paths of your code so
                  ;; that M-. works better:
                  ;;(set! swank-java-source-path
                  ;;  (append
                  ;;   '(,(expand-file-name "~/lisp/slime/contrib/")
                  ;;     "/scratch/kawa")
                  ;;   swank-java-source-path))
                  )))

;; Optionally define a command to start it.
(defun kawa ()
  (interactive)
  (slime 'kawa))

|#
;; 4. Start everything with  M-- M-x slime kawa
;;
;;


;;; Code:

(define-library (swank macros)
    (export df fun seq set fin esc
            ! !! !s @ @s
            when unless while dotimes dolist for packing with pushf == assert
            mif mcase mlet mlet* typecase ignore-errors
            ferror
            )
    (import (scheme base)
            (only (kawa base)
                  syntax
                  quasisyntax
                  syntax-case
                  define-syntax-case
                  identifier?

                  invoke
                  invoke-static
                  field
                  static-field
                  instance?
                  try-finally
                  try-catch
                  primitive-throw

                  format
                  reverse!
                  as
                  ))
  (begin "
("

(define (ferror fstring #!rest args)
  (let ((err (<java.lang.Error>
              (as <java.lang.String> (apply format fstring args)))))
    (primitive-throw err)))

(define (rewrite-lambda-list args)
  (syntax-case args ()
    (() #`())
    ((rest x ...) (eq? #'rest #!rest) args)
    ((optional x ...) (eq? #'optional #!optional) args)
    ((var args ...) (identifier? #'var)
     #`(var #,@(rewrite-lambda-list #'(args ...))))
    (((var type) args ...) (identifier? #'var)
     #`((var :: type) #,@(rewrite-lambda-list #'(args ...))))))

(define-syntax df
  (lambda (stx)
    (syntax-case stx (=>)
      ((df name (args ... => return-type) body ...)
       #`(define (name #,@(rewrite-lambda-list #'(args ...))) :: return-type
                 (seq body ...)))
      ((df name (args ...) body ...)
       #`(define (name #,@(rewrite-lambda-list #'(args ...)))
           (seq body ...))))))

(define-syntax fun
  (lambda (stx)
    (syntax-case stx (=>)
      ((fun (args ... => return-type) body ...)
       #`(lambda #,(rewrite-lambda-list #'(args ...)) :: return-type
                 (seq body ...)))
      ((fun (args ...) body ...)
       #`(lambda #,(rewrite-lambda-list #'(args ...))
           (seq 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 !s
  (syntax-rules ()
    ((! class name args ...)
     (invoke-static class 'name args ...))))

(define-syntax @
    (syntax-rules ()
      ((@ name obj)
       (field obj 'name))))

(define-syntax @s
  (syntax-rules (quote)
    ((@s class name)
     (static-field class (quote 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 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 satisfies)
    ((typecase% var (#t body ...) more ...)
     (seq body ...))
    ((typecase% var ((eql value) body ...) more ...)
     (cond ((eqv? var 'value) body ...)
           (else (typecase% var more ...))))
    ((typecase% var ((satisfies predicate) body ...) more ...)
     (cond ((predicate var) 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 (as type var)))
              body ...))
           (else (typecase% var more ...))))
    ((typecase% var)
     (error "typecase% failed" var
            (! getClass (as <object> var))))))

(define-syntax typecase
  (lambda (stx)
    (syntax-case stx ()
      ((_ 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 (seq body ...)
                (v <java.lang.Error> #f)
                (v <java.lang.Exception> #f)))))

))

(define-library (swank-kawa)
    (export start-swank
            create-swank-server
            swank-java-source-path
            break)
    (import (scheme base)
            (scheme file)
            (scheme repl)
            (scheme read)
            (scheme write)
            (scheme eval)
            (scheme process-context)
            (swank macros)
            (only (kawa base)

                  define-alias
                  define-variable

                  define-simple-class
                  this

                  invoke-special
                  instance?
                  as

                  primitive-throw
                  try-finally
                  try-catch
                  synchronized

                  call-with-input-string
                  call-with-output-string
                  force-output
                  format

                  make-process
                  command-parse

                  runnable

                  scheme-implementation-version
                  reverse!
                  )
            (rnrs hashtables)
            (only (gnu kawa slib syntaxutils) expand)
            (only (kawa regex) regex-match))
  (begin "
("


;;(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 <in-port> gnu.kawa.io.InPort)
(define-alias <out-port> gnu.kawa.io.OutPort)
(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-type> com.sun.jdi.ClassType)
(define-alias <ref-type> com.sun.jdi.ReferenceType)
(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 <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 (!s 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)
               #f))
          ((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 (!s 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 (!s 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 <in-port>) (table <gnu.kawa.lispexpr.ReadTable>))
  (let ((old (!s gnu.kawa.lispexpr.ReadTable getCurrent)))
    (try-finally
     (seq (!s gnu.kawa.lispexpr.ReadTable setCurrent table)
          (read port))
     (!s 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|
  (or (get tab name #f)
      (ferror "~a not implemented" name)))

(df %defslimefun ((name <symbol>) (fun <procedure>))
  (let ((string (symbol->string name)))
    (cond ((regex-match #/:/ string)
           (put *slime-funs* name fun))
          (#t
           (let ((qname (string->symbol (string-append "swank:" string))))
             (put *slime-funs* qname fun))))))

(define-syntax defslimefun
  (syntax-rules ()
    ((defslimefun name (args ...) body ...)
     (seq
       (df name (args ...) body ...)
       (%defslimefun 'name name)))))

(defslimefun connection-info ((env <env>))
  (let ((prop (fun (name) (!s java.lang.System getProperty name))))
  `(: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))
    :encoding (:coding-systems ("iso-8859-1"))
    )))


;;;; Listener

(df listener ((c <chan>) (env <env>))
  (! set-name (current-thread) "swank-listener")
  (log "listener: ~s ~s ~s ~s\n"
       (current-thread) (! hashCode (current-thread)) 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)
      ;;stack snaphost are too expensive
      ;;(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))))

(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-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 (!s 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 |swank-repl: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 |swank-repl: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))))

(defslimefun eval-and-grab-output (env string)
  (let ((form (read (open-input-string string))))
    (let-values ((values (eval form env)))
      (list ""
            (format #f "~{~S~^~%~}" values)))))

(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>))
       (!s 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)
         #f))
    (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) #f))
      (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 <in-port>))
                     (! set-path p
                        (format "~s"
                                `(buffer ,buffer offset ,offset str ,string)))
                     (!s 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 ('quote ((:position o) _)) 'str s)
                (read-from-string (@ filename e)))
           (let ((off (line>offset (1- (@ line e)) s))
                 (col (1- (@ column e))))
             `(:location (:buffer ,b) (:position ,(+ o off col)) 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) '())
(defslimefun frame-package-name (#!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)))))
         (1st-method-by-name (fun (name)
                               (let ((i (! methods-by-name module name)))
                                 (cond ((! is-empty i) #f)
                                       (#t (1st i)))))))
    (as <meth-ref> (or (1st-method-by-name (! get-name f))
                       (let ((mangled (mangled-name f)))
                         (or (1st-method-by-name mangled)
                             (1st-method-by-name (cat mangled "$V"))
                             (1st-method-by-name (cat mangled "$X"))))))))

(df mangled-name ((f <gnu.expr.ModuleMethod>))
  (let* ((name0 (! get-name f))
         (name (cond ((nul? name0) (format "lambda~d" (@ selector f)))
                     (#t (!s gnu.expr.Compilation mangleName name0)))))
    name))

(df class>src-loc ((c <java.lang.Class>) => <location>)
  (let* ((type (class>ref-type c))
         (locs (! all-line-locations type)))
    (cond ((not (! isEmpty locs)) (1st locs))
          (#t (<swank-location> (1st (! source-paths type "Java"))
                                #f)))))

(df class>ref-type ((class <java.lang.Class>) => <ref-type>)
  (! reflectedType (as <com.sun.jdi.ClassObjectReference>
                       (vm-mirror *the-vm* class))))

(df class>class-type ((class <java.lang.Class>) => <class-type>)
  (as <class-type> (class>ref-type class)))

(df bytemethod>src-loc ((m <gnu.bytecode.Method>) => <location>)
  (let* ((cls (class>class-type (! 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))))))

;;;;;; 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 :: <str> (! 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 :: <str> (!s <java.lang.System> getProperty "java.home"))
         (parent :: <str> (! get-parent (<file> jre-home))))
    (list (! get-path (<file> parent "src.zip")))))

(df source-path ()
  (mlet ((base) (search-path-prop "user.dir"))
    (append
     (list base)
     (map (fun ((s <str>))
            (let ((f (<file> s))
                  (base :: <str> (as <str> base)))
               (cond ((! isAbsolute f) s)
                     (#t (! getPath (<file> base s))))))
          (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 (!s java.lang.System getProperty name)
                    (@s <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 env))
(defslimefun swank-expand (env s) (%swank-macroexpand s env))
(defslimefun swank-expand-all (env s) (%swank-macroexpand s env))

(df %swank-macroexpand (string env)
  (pprint-to-string (%macroexpand (read-from-string string) env)))

(df %macroexpand (sexp env) (expand sexp #:env env))


;;;; 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))))
    (typecase obj
      (<array-ref> (inspect-array-ref vm obj))
      (<obj-ref> (inspect-obj-ref vm obj)))))

(df inspect-array-ref ((vm <vm>) (obj <array-ref>))
  (packing (pack)
    (let ((i 0))
      (for (((v :: <value>) (! getValues obj)))
        (pack (format "~d: " i))
        (pack `(:value ,(vm-demirror vm v)))
        (pack "\n")
        (set i (1+ i))))))

(df inspect-obj-ref ((vm <vm>) (obj <obj-ref>))
  (let* ((type (! referenceType obj))
         (fields (! allFields type))
         (values (! getValues obj fields))
         (ifields '()) (sfields '()) (imeths '()) (smeths '())
         (frob (lambda (lists) (apply append (reverse lists)))))
    (for (((f :: <field>) fields))
      (let* ((val (as <value> (! get values f)))
             (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n")))
        (if (! is-static f)
            (pushf l sfields)
            (pushf l ifields))))
    (for (((m :: <meth-ref>) (! allMethods type)))
      (let ((l `(,(! name m) ,(! signature m) "\n")))
        (if (! is-static m)
            (pushf l smeths)
            (pushf l imeths))))
    `(,@(frob ifields)
      "--- static fields ---\n" ,@(frob sfields)
      "--- methods ---\n" ,@(frob imeths)
      "--- static methods ---\n" ,@(frob smeths))))

(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))))
                    (! setLength builder 0))))
         (closed #f))
    (while (not closed)
      (mcase (! poll q (as long 200) (@s <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))
    (<out-port> 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))))
          ((,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 nil) ,id))))

(df process-vm-event ((e <event>) (c <chan>) state)
  ;;(log "vm-event: ~s\n" e)
  (typecase e
    (<exception-event>
     ;;(log "exception: ~s\n" (! exception e))
     ;;(log "exception-message: ~s\n"
     ;;     (exception-message (vm-demirror *the-vm* (! exception e))))
     ;;(log "exception-location: ~s\n" (src-loc>str (! location e)))
     ;;(log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e)))
     (cond ((! notifyUncaught (as <com.sun.jdi.request.ExceptionRequest>
                                  (! request e)))
            (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)
    (<breakpoint-event>
     (log "breakpoint event: ~a\n" e)
     (debug-thread (! thread e) e state c))
    ))

(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 <interrupt-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 break (#!optional condition)
  ((breakpoint condition)))

;; We set a breakpoint on this function.  It returns a function which
;; specifies what the debuggee should do next (the actual return value
;; is set via JDI).  Lets hope that the compiler doesn't optimize this
;; away.
(df breakpoint (condition => <function>)
  (fun () #!null))

;; Enable breakpoints event on the breakpoint function.
(df request-breakpoint ((vm <vm>))
  (let* ((swank-classes (! classesByName vm "swank-kawa"))
         (swank-classes-legacy (! classesByName vm "swank$Mnkawa"))
         (class :: <class-type> (1st (if (= (length swank-classes) 0)
                                         swank-classes-legacy
                                         swank-classes)))
         (meth :: <meth-ref> (1st (! methodsByName class "breakpoint")))
         (erm (! eventRequestManager vm))
         (req (! createBreakpointRequest erm (! location meth))))
    (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
    (! put-property req 'swank #t)
    (! put-property req 'argname "condition")
    (! enable req)))

(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>) (ev <event>) state (c <chan>))
  (unless (! is-suspended tref)
    (! suspend tref))
  (let* ((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 interrupt-thread ((tref <thread-ref>) state (c <chan>))
  (debug-thread tref (<interrupt-event> tref) state c))

(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
                 (<breakpoint-event> (breakpoint-condition ev))
                 (<exception-event> (! exception ev))
                 (<interrupt-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.Throwable> (! 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 breakpoint-condition ((e <breakpoint-event>) => <obj-ref>)
  (let ((frame (! frame (! thread e) 0)))
    (1st (! get-argument-values frame))))

(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)))
           (missing (cond ((zero? (len stacktrace)) 0)
                          (#t (- (len stacktrace) fcount))))
           (fstart (max (- from missing) 0))
           (flen (max (- to from missing) 0))
           (frames (! frames thread fstart (min flen (- fcount fstart)))))
      (packing (pack)
        (let ((i from))
          (dotimes (_ (max (- missing from) 0))
            (pack (list i (format "~a" (stacktrace i))))
            (set i (1+ i)))
          (iter frames (fun ((f <frame>))
                         (let ((s (frame-to-string f)))
                           (pack (list i s))
                           (set i (1+ i))))))))))

(df event-stacktrace ((ev <event>))
  (let ((nothing (fun () (<java.lang.StackTraceElement[]>)))
        (vm (! virtualMachine ev)))
    (typecase ev
      (<breakpoint-event>
       (let ((condition (vm-demirror vm (breakpoint-condition ev))))
         (cond ((instance? condition <throwable>)
                (throwable-stacktrace vm condition))
               (#t (nothing)))))
      (<exception-event>
       (throwable-stacktrace vm (vm-demirror vm (! exception ev))))
      (<event> (nothing)))))

(df throwable-stacktrace ((vm <vm>) (ex <throwable>))
  (cond ((== ex (ignore-errors (vm-demirror vm *last-exception*)))
         *last-stacktrace*)
        (#t
         (! getStackTrace ex))))

(df frame-to-string ((f <frame>))
  (let ((loc (! location f))
        (vm (! virtualMachine f)))
    (format "~a (~a)" (!! name method loc)
            (call-with-abort
             (fun () (format "~{~a~^ ~}"
                             (mapi (! getArgumentValues f)
                                   (fun (arg)
                                     (pprint-to-string
                                      (vm-demirror vm arg))))))))))

(df frame-src-loc ((tid <int>) (n <int>) state)
  (try-catch
   (mlet* (((frame vm) (nth-frame tid n state))
           (vm (as <vm> vm)))
     (src-loc>elisp
      (typecase frame
        (<frame> (! location frame))
        (<faked-frame> (@ loc frame))
        (<java.lang.StackTraceElement>
         (let* ((classname (! getClassName frame))
                (classes (! classesByName vm classname))
                (t (as <ref-type> (1st classes))))
           (1st (! locationsOfLine t (! getLineNumber frame))))))))
   (ex <throwable>
       (let ((msg (! getMessage ex)))
         `(:error ,(if (== msg #!null)
                       (! toString ex)
                       msg))))))

(df nth-frame ((tid <int>) (n <int>) state)
  (mlet ((tref level evs) (get state tid #f))
    (let* ((thread (as <thread-ref> tref))
           (fcount (! frameCount thread))
           (stacktrace (event-stacktrace (car evs)))
           (missing (cond ((zero? (len stacktrace)) 0)
                          (#t (- (len stacktrace) fcount))))
           (vm (! virtualMachine thread))
           (frame (cond ((< n missing)
                         (stacktrace n))
                        (#t (! frame thread (- n missing))))))
      (list frame vm))))

;;;;; Locals

(df frame-locals ((tid <int>) (n <int>) state)
  (mlet ((thread _ _) (get state tid #f))
    (let* ((thread (as <thread-ref> thread))
           (vm (! virtualMachine thread))
           (p (fun (x) (pprint-to-string
                        (call-with-abort (fun () (vm-demirror vm x)))))))
      (map (fun (x)
             (mlet ((name value) x)
               (list ':name name ':value (p value) ':id 0)))
           (%frame-locals tid n state)))))

(df frame-local-var ((tid <int>) (frame <int>) (var <int>) state => <mirror>)
  (cadr (nth (%frame-locals tid frame state) var)))

(df %frame-locals ((tid <int>) (n <int>) state)
  (mlet ((frame _) (nth-frame tid n state))
    (typecase frame
      (<frame>
       (let* ((visible (try-catch (! visibleVariables frame)
                                  (ex <com.sun.jdi.AbsentInformationException>
                                      '())))
              (map (! getValues frame visible))
              (p (fun (x) x)))
         (packing (pack)
           (let ((self (ignore-errors (! thisObject frame))))
             (when self
               (pack (list "this" (p self)))))
           (iter (! entrySet map)
                 (fun ((e <java.util.Map$Entry>))
                   (let ((var (as <local-var> (! getKey e)))
                         (val (as <value> (! getValue e))))
                     (pack (list (! name var) (p val)))))))))
      (<faked-frame>
       (packing (pack)
         (when (@ self frame)
           (pack (list "this" (@ self frame))))
         (iter (! entrySet (@ values frame))
               (fun ((e <java.util.Map$Entry>))
                 (let ((var (as <local-var> (! getKey e)))
                       (val (as <value> (! getValue e))))
                   (pack (list (! name var) val)))))))
      (<java.lang.StackTraceElement> '()))))

(df disassemble-frame ((tid <int>) (frame <int>) state)
  (mlet ((frame _) (nth-frame tid frame state))
    (typecase frame
      (<java.lang.StackTraceElement> "<??>")
      (<frame>
       (let* ((l (! location frame))
              (m (! method l))
              (c (! declaringType l)))
          (disassemble-to-string m))))))

;;;;; Restarts

;; FIXME: factorize
(df throw-to-toplevel ((tid <int>) (id <int>) (c <chan>) state)
  (mlet ((tref level exc) (get state tid #f))
    (let* ((t (as <thread-ref> tref))
           (ev (car exc)))
      (typecase ev
        (<exception-event> ; actually uncaughtException
         (! resume t)
         (reply-abort c id)
         ;;(send-debug-return c tid state)
         (do ((level level (1- level))
              (exc exc (cdr exc)))
             ((null? exc))
           (send c `(forward (:debug-return ,tid ,level nil))))
         (del state tid))
        (<breakpoint-event>
         ;; XXX race condition?
         (log "resume from from break (suspendCount: ~d)\n" (! suspendCount t))
         (let ((vm (! virtualMachine t))
               (k (fun () (primitive-throw (<listener-abort>)))))
           (reply-abort c id)
           (! force-early-return t (vm-mirror vm k))
           (! resume t)
           (do ((level level (1- level))
                (exc exc (cdr exc)))
               ((null? exc))
             (send c `(forward (:debug-return ,tid ,level nil))))
           (del state tid)))
        (<interrupt-event>
         (log "resume from from interrupt\n")
         (let ((vm (! virtualMachine t)))
           (! stop t (vm-mirror vm (<listener-abort>)))
           (! resume t)
           (reply-abort c id)
           (do ((level level (1- level))
                (exc exc (cdr exc)))
               ((null? exc))
             (send c `(forward (:debug-return ,tid ,level nil))))
           (del state tid))
         )))))

(df thread-continue ((tid <int>) (id <int>) (c <chan>) state)
  (mlet ((tref level exc) (get state tid #f))
    (log "thread-continue: ~a ~a ~a \n" tref level exc)
    (let* ((t (as <thread-ref> tref)))
       (! resume t))
    (reply-abort c id)
    (do ((level level (1- level))
         (exc exc (cdr exc)))
        ((null? exc))
      (send c `(forward (:debug-return ,tid ,level nil))))
    (del state tid)))

(df thread-step ((t <thread-ref>) k)
  (let* ((vm (! virtual-machine t))
         (erm (! eventRequestManager vm))
         (<sr> <com.sun.jdi.request.StepRequest>)
         (req (! createStepRequest erm t
                 (@s <sr> STEP_MIN)
                 (@s <sr> STEP_OVER))))
    (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
    (! addCountFilter req 1)
    (! put-property req 'continuation k)
    (! enable req)))

(df eval-in-thread ((t <thread-ref>) sexp
                    #!optional (env :: <env> (!s <env> current)))
  (let* ((vm (! virtualMachine t))
         (sc :: <class-type>
             (1st (! classes-by-name vm "kawa.standard.Scheme")))
         (ev :: <meth-ref>
             (1st (! methods-by-name sc "eval"
                     (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)"
                          "Ljava/lang/Object;")))))
    (! invokeMethod sc t ev (list sexp env)
       (@s <class-type> INVOKE_SINGLE_THREADED))))

;;;;; Threads

(df list-threads (vm :: <vm> state)
  (let* ((threads (! allThreads vm)))
    (put state 'all-threads threads)
    (packing (pack)
      (pack '(\:id \:name \:status \:priority))
      (iter threads (fun ((t <thread-ref>))
                      (pack (list (! uniqueID t)
                                  (! name t)
                                  (let ((s (thread-status t)))
                                    (if (! is-suspended t)
                                        (cat "SUSPENDED/" s)
                                        s))
                                  0)))))))

(df thread-status (t :: <thread-ref>)
  (let ((s (! status t)))
    (cond ((= s (@s <thread-ref> THREAD_STATUS_UNKNOWN)) "UNKNOWN")
          ((= s (@s <thread-ref> THREAD_STATUS_ZOMBIE)) "ZOMBIE")
          ((= s (@s <thread-ref> THREAD_STATUS_RUNNING)) "RUNNING")
          ((= s (@s <thread-ref> THREAD_STATUS_SLEEPING)) "SLEEPING")
          ((= s (@s <thread-ref> THREAD_STATUS_MONITOR)) "MONITOR")
          ((= s (@s <thread-ref> THREAD_STATUS_WAIT)) "WAIT")
          ((= s (@s <thread-ref> THREAD_STATUS_NOT_STARTED)) "NOT_STARTED")
          (#t "<bug>"))))

;;;;; Bootstrap

(df vm-attach (=> <vm>)
  (attach (getpid) 20))

(df attach (pid timeout)
  (log "attaching: ~a ~a\n" pid timeout)
  (let* ((<ac> <com.sun.jdi.connect.AttachingConnector>)
         (<arg> <com.sun.jdi.connect.Connector$Argument>)
         (vmm (!s com.sun.jdi.Bootstrap virtualMachineManager))
         (pa (as <ac>
                 (or
                  (find-if (! attaching-connectors vmm)
                           (fun (x :: <ac>)
                             (! equals (! name x) "com.sun.jdi.ProcessAttach"))
                           #f)
                  (error "ProcessAttach connector not found"))))
         (args (! default-arguments pa)))
    (! set-value (as <arg> (! get args (to-str "pid"))) pid)
    (when timeout
      (! set-value (as <arg> (! get args (to-str "timeout"))) timeout))
    (log "attaching2: ~a ~a\n" pa args)
    (! attach pa args)))

(df getpid ()
  (let ((p (make-process (command-parse "echo $PPID") #!null)))
    (! waitFor p)
    (! read-line (<java.io.BufferedReader> (<in> (! get-input-stream p))))))

(df request-uncaught-exception-events ((vm <vm>))
  (let* ((erm (! eventRequestManager vm))
         (req (! createExceptionRequest erm #!null #f #t)))
    (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
    (! addThreadFilter req (vm-mirror vm (current-thread)))
    (! enable req)))


(df request-caught-exception-events ((vm <vm>))
  (let* ((erm (! eventRequestManager vm))
         (req (! createExceptionRequest erm #!null #t #f)))
    (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
    (! addThreadFilter req (vm-mirror vm (current-thread)))
    (! addClassExclusionFilter req "java.lang.ClassLoader")
    (! addClassExclusionFilter req "java.net.URLClassLoader")
    (! addClassExclusionFilter req "java.net.URLClassLoader$1")
    (! enable req)))

(df set-stacktrace-recording ((vm <vm>) (flag <boolean>))
  (for (((e :: <com.sun.jdi.request.ExceptionRequest>)
         (!! exceptionRequests eventRequestManager vm)))
    (when (! notify-caught e)
      (! setEnabled e flag))))

;; (set-stacktrace-recording *the-vm* #f)

(df vm-to-string ((vm <vm>))
  (let* ((obj (as <ref-type> (1st (! classesByName vm "java.lang.Object"))))
         (met (as <meth-ref> (1st (! methodsByName obj "toString")))))
    (fun ((o <obj-ref>) (t <thread-ref>))
      (! value
         (as <str-ref>
             (! invokeMethod o t met '()
                (@s <obj-ref> INVOKE_SINGLE_THREADED)))))))

(define-simple-class <swank-global-variable> ()
  (var #:allocation 'static))

(define-variable *global-get-mirror* #!null)
(define-variable *global-set-mirror* #!null)
(define-variable *global-get-raw* #!null)
(define-variable *global-set-raw* #!null)

(df init-global-field ((vm <vm>))
  (when (nul? *global-get-mirror*)
    (set (@s <swank-global-variable> var) #!null) ; prepare class
    (let* ((swank-global-variable-classes
            (! classes-by-name vm "swank-global-variable"))
           (swank-global-variable-classes-legacy
            (! classes-by-name vm "swank$Mnglobal$Mnvariable"))
           (c (as <com.sun.jdi.ClassType>
                  (1st (if (= (length swank-global-variable-classes) 0)
                           swank-global-variable-classes-legacy
                           swank-global-variable-classes))))
           (f (! fieldByName c "var")))
      (set *global-get-mirror* (fun () (! getValue c f)))
      (set *global-set-mirror* (fun ((v <obj-ref>)) (! setValue c f v))))
    (set *global-get-raw* (fun () '() (@s <swank-global-variable> var)))
    (set *global-set-raw* (fun (x)
                            (set (@s <swank-global-variable> var) x)))))

(df vm-mirror ((vm <vm>) obj)
  (synchronized vm
    (init-global-field vm)
    (*global-set-raw* obj)
    (*global-get-mirror*)))

(df vm-demirror ((vm <vm>) (v <value>))
  (synchronized vm
    (if (== v #!null)
      #!null
      (typecase v
        (<obj-ref> (init-global-field vm)
                   (*global-set-mirror* v)
                   (*global-get-raw*))
        (<com.sun.jdi.IntegerValue> (! value v))
        (<com.sun.jdi.LongValue> (! value v))
        (<com.sun.jdi.CharValue> (! value v))
        (<com.sun.jdi.ByteValue> (! value v))
        (<com.sun.jdi.BooleanValue> (! value v))
        (<com.sun.jdi.ShortValue> (! value v))
        (<com.sun.jdi.FloatValue> (! value v))
        (<com.sun.jdi.DoubleValue> (! value v))))))

(df vm-set-slot ((vm <vm>) (o <object>) (name <str>) value)
  (let* ((o (as <obj-ref> (vm-mirror vm o)))
         (t (! reference-type o))
         (f (! field-by-name t name)))
    (! set-value o f (vm-mirror vm value))))

(define-simple-class <ucex-handler>
    (<java.lang.Thread$UncaughtExceptionHandler>)
  (f :: <gnu.mapping.Procedure>)
  ((*init* (f :: <gnu.mapping.Procedure>)) (set (@ f (this)) f))
  ((uncaughtException (t :: <thread>) (e :: <throwable>))
   :: <void>
   (! println (@s java.lang.System err) (to-str "uhexc:::"))
   (! apply2 f t e)
   #!void))

;;;; Channels

(df spawn (f)
  (let ((thread (<thread> (%%runnable f))))
    (! start thread)
    thread))


;; gnu.mapping.RunnableClosure uses the try{...}catch(Throwable){...}
;; idiom which defeats all attempts to use a break-on-error-style
;; debugger.  Previously I had my own version of RunnableClosure
;; without that deficiency but something in upstream changed and it no
;; longer worked. Now we use the normal RunnableClosure and at the
;; cost of taking stack snapshots on every throw.
(df %%runnable (f => <java.lang.Runnable>)
  ;;(<runnable> f)
  ;;(<gnu.mapping.RunnableClosure> f)
  ;;(runnable f)
  (%runnable f)
  )

(df %runnable (f => <java.lang.Runnable>)
  (runnable
   (fun ()
     (try-catch (f)
                (ex <throwable>
                    (log "exception in thread ~s: ~s" (current-thread)
                          ex)
                    (! printStackTrace ex))))))

(df chan ()
  (let ((lock (<object>))
        (im (<chan>))
        (ex (<chan>)))
    (set (@ lock im) lock)
    (set (@ lock ex) lock)
    (set (@ peer im) ex)
    (set (@ peer ex) im)
    (cons im ex)))

(df immutable? (obj)
  (or (== obj #!null)
      (symbol? obj)
      (number? obj)
      (char? obj)
      (instance? obj <str>)
      (null? obj)))

(df send ((c <chan>) value => <void>)
  (df pass (obj)
    (cond ((immutable? obj) obj)
          ((string? obj) (! to-string obj))
          ((pair? obj)
           (let loop ((r (list (pass (car obj))))
                      (o (cdr obj)))
             (cond ((null? o) (reverse! r))
                   ((pair? o) (loop (cons (pass (car o)) r) (cdr o)))
                   (#t (append (reverse! r) (pass o))))))
          ((instance? obj <chan>)
           (let ((o :: <chan> obj))
             (assert (== (@ owner o) (current-thread)))
             (synchronized (@ lock c)
               (set (@ owner o) (@ owner (@ peer c))))
             o))
          ((or (instance? obj <env>)
               (instance? obj <mirror>))
           ;; those can be shared, for pragmatic reasons
           obj
           )
          (#t (error "can't send" obj (class-name-sans-package obj)))))
  ;;(log "send: ~s ~s -> ~s\n" value (@ owner c) (@ owner (@ peer c)))
  (assert (== (@ owner c) (current-thread)))
  ;;(log "lock: ~s send\n" (@ owner (@ peer c)))
  (synchronized (@ owner (@ peer c))
    (! put (@ queue (@ peer c)) (pass value))
    (! notify (@ owner (@ peer c))))
  ;;(log "unlock: ~s send\n" (@ owner (@ peer c)))
  )

(df recv ((c <chan>))
  (cdr (recv/timeout (list c) 0)))

(df recv* ((cs <iterable>))
  (recv/timeout cs 0))

(df recv/timeout ((cs <iterable>) (timeout <long>))
  (let ((self (current-thread))
        (end (if (zero? timeout)
                 0
                 (+ (current-time) timeout))))
    ;;(log "lock: ~s recv\n" self)
    (synchronized self
      (let loop ()
        ;;(log "receive-loop: ~s\n" self)
        (let ((ready (find-if cs
                              (fun ((c <chan>))
                                (not (! is-empty (@ queue c))))
                              #f)))
          (cond (ready
                 ;;(log "unlock: ~s recv\n" self)
                 (cons ready (! take (@ queue (as <chan> ready)))))
                ((zero? timeout)
                 ;;(log "wait: ~s recv\n" self)
                 (! wait self) (loop))
                (#t
                 (let ((now (current-time)))
                   (cond ((<= end now)
                          'timeout)
                         (#t
                          ;;(log "wait: ~s recv\n" self)
                          (! wait self (- end now))
                          (loop)))))))))))

(df rpc ((c <chan>) msg)
  (mlet* (((im . ex) (chan))
          ((op . args) msg))
    (send c `(,op ,ex . ,args))
    (recv im)))

(df spawn/chan (f)
  (mlet ((im . ex) (chan))
    (let ((thread (<thread> (%%runnable (fun () (f ex))))))
      (set (@ owner ex) thread)
      (! start thread)
      (cons im thread))))

(df spawn/chan/catch (f)
  (spawn/chan
   (fun (c)
     (try-catch
      (f c)
      (ex <throwable>
          (send c `(error ,(! toString ex)
                          ,(class-name-sans-package ex)
                          ,(map (fun (e) (! to-string e))
                                (array-to-list (! get-stack-trace ex))))))))))

;;;; Logging

(define swank-log-port (current-error-port))
(df log (fstr #!rest args)
  (synchronized swank-log-port
    (apply format swank-log-port fstr args)
    (force-output swank-log-port))
  #!void)

;;;; Random helpers

(df 1+ (x) (+ x 1))
(df 1- (x) (- x 1))

(df len (x => <int>)
  (typecase x
    (<list> (length x))
    (<str> (! length x))
    (<string> (string-length x))
    (<vector> (vector-length x))
    (<java.util.List> (! size x))
    (<object[]> (@ length x))))

;;(df put (tab key value) (hash-table-set! tab key value) tab)
;;(df get (tab key default) (hash-table-ref/default tab key default))
;;(df del (tab key) (hash-table-delete! tab key) tab)
;;(df tab () (make-hash-table))

(df put (tab key value) (hashtable-set! tab key value) tab)
(df get (tab key default) (hashtable-ref tab key default))
(df del (tab key) (hashtable-delete! tab key) tab)
(df tab () (make-eqv-hashtable))

(df equal (x y => <boolean>) (equal? x y))

(df current-thread (=> <thread>) (!s java.lang.Thread currentThread))
(df current-time (=> <long>) (!s java.lang.System currentTimeMillis))

(df nul? (x) (== x #!null))

(df read-from-string (str)
  (call-with-input-string str read))

;;(df print-to-string (obj) (call-with-output-string (fun (p) (write obj p))))

(df pprint-to-string (obj)
  (let* ((w (<java.io.StringWriter>))
         (p (<out-port> w #t #f)))
    (try-catch (print-object obj p)
               (ex <throwable>
                   (format p "#<error while printing ~a ~a>"
                           ex (class-name-sans-package ex))))
    (! flush p)
    (to-string (! getBuffer w))))

(df print-object (obj stream)
  (typecase obj
    #;
    ((or (eql #!null) (eql #!eof)
         <list> <number> <character> <string> <vector> <procedure> <boolean>)
     (write obj stream))
    (#t
     #;(print-unreadable-object obj stream)
     (write obj stream)
     )))

(df print-unreadable-object ((o <object>) stream)
  (let* ((string (! to-string o))
         (class (! get-class o))
         (name (! get-name class))
         (simplename (! get-simple-name class)))
    (cond ((! starts-with string "#<")
           (format stream "~a" string))
          ((or (! starts-with string name)
               (! starts-with string simplename))
           (format stream "#<~a>" string))
          (#t
           (format stream "#<~a ~a>" name string)))))

(define cat string-append)

(df values-to-list (values)
  (typecase values
    (<gnu.mapping.Values> (array-to-list (! getValues values)))
    (<object> (list values))))

;; (to-list (as-list (values 1 2 2)))

(df array-to-list ((array <object[]>) => <list>)
  (packing (pack)
    (dotimes (i (@ length array))
      (pack (array i)))))

(df lisp-bool (obj)
  (cond ((== obj 'nil) #f)
        ((== obj 't) #t)
        (#t (error "Can't map lisp boolean" obj))))

(df path-sans-extension ((p path) => <string>)
  (let ((ex (! get-extension p))
        (str (! to-string p)))
    (to-string (cond ((not ex) str)
                     (#t (! substring str 0 (- (len str) (len ex) 1)))))))

(df class-name-sans-package ((obj <object>))
  (cond ((nul? obj) "<#!null>")
        (#t
         (try-catch
          (let* ((c (! get-class obj))
                 (n (! get-simple-name c)))
            (cond ((equal n "") (! get-name c))
                  (#t n)))
          (e <java.lang.Throwable>
             (format "#<~a: ~a>" e (! get-message e)))))))

(df list-env (#!optional (env :: <env> (!s <env> current)))
  (let ((enum (! enumerateAllLocations env)))
    (packing (pack)
      (while (! hasMoreElements enum)
        (pack (! nextLocation enum))))))

(df list-file (filename)
  (with (port (call-with-input-file filename))
    (let* ((lang (!s gnu.expr.Language getDefaultLanguage))
           (messages (<gnu.text.SourceMessages>))
           (comp (! parse lang (as <in-port> port) messages 0)))
      (! get-module comp))))

(df list-decls (file)
  (let* ((module (as <gnu.expr.ModuleExp> (list-file file))))
    (do ((decl :: <gnu.expr.Declaration>
               (! firstDecl module) (! nextDecl decl)))
        ((nul? decl))
      (format #t "~a ~a:~d:~d\n" decl
              (! getFileName decl)
              (! getLineNumber decl)
              (! getColumnNumber decl)
              ))))

(df %time (f)
  (define-alias <mf> <java.lang.management.ManagementFactory>)
  (define-alias <gc> <java.lang.management.GarbageCollectorMXBean>)
  (let* ((gcs (!s <mf> getGarbageCollectorMXBeans))
         (mem (!s <mf> getMemoryMXBean))
         (jit (!s <mf> getCompilationMXBean))
         (oldjit (! getTotalCompilationTime jit))
         (oldgc (packing (pack)
                  (iter gcs (fun ((gc <gc>))
                              (pack (cons gc
                                          (list (! getCollectionCount gc)
                                                (! getCollectionTime gc))))))))
         (heap (!! getUsed getHeapMemoryUsage mem))
         (nonheap (!! getUsed getNonHeapMemoryUsage mem))
         (start (!s java.lang.System nanoTime))
         (values (f))
         (end (!s java.lang.System nanoTime))
         (newheap (!! getUsed getHeapMemoryUsage mem))
         (newnonheap (!! getUsed getNonHeapMemoryUsage mem)))
    (format #t "~&")
    (let ((njit (! getTotalCompilationTime jit)))
      (format #t "; JIT compilation: ~:d ms (~:d)\n" (- njit oldjit) njit))
    (iter gcs (fun ((gc <gc>))
                (mlet ((_ count time) (assoc gc oldgc))
                  (format #t "; GC ~a: ~:d ms (~d)\n"
                          (! getName gc)
                          (- (! getCollectionTime gc) time)
                          (- (! getCollectionCount gc) count)))))
    (format #t "; Heap: ~@:d (~:d)\n" (- newheap heap) newheap)
    (format #t "; Non-Heap: ~@:d (~:d)\n" (- newnonheap nonheap) newnonheap)
    (format #t "; Elapsed time: ~:d us\n" (/ (- end start) 1000))
    values))

(define-syntax time
  (syntax-rules ()
    ((time form)
     (%time (lambda () form)))))

(df gc ()
  (let* ((mem (!s java.lang.management.ManagementFactory getMemoryMXBean))
         (oheap (!! getUsed getHeapMemoryUsage mem))
         (onheap (!! getUsed getNonHeapMemoryUsage mem))
         (_ (! gc mem))
         (heap (!! getUsed  getHeapMemoryUsage mem))
         (nheap (!! getUsed getNonHeapMemoryUsage mem)))
    (format #t "; heap: ~@:d (~:d) non-heap: ~@:d (~:d)\n"
             (- heap oheap) heap (- onheap nheap) nheap)))

(df room ()
  (let* ((pools (!s java.lang.management.ManagementFactory
                    getMemoryPoolMXBeans))
         (mem (!s java.lang.management.ManagementFactory getMemoryMXBean))
         (heap (!! getUsed  getHeapMemoryUsage mem))
         (nheap (!! getUsed getNonHeapMemoryUsage mem)))
    (iter pools (fun ((p <java.lang.management.MemoryPoolMXBean>))
                  (format #t "~&; ~a~1,16t: ~10:d\n"
                          (! getName p)
                          (!! getUsed getUsage p))))
    (format #t "; Heap~1,16t: ~10:d\n" heap)
    (format #t "; Non-Heap~1,16t: ~10:d\n" nheap)))

;; (df javap (class #!key method signature)
;;   (let* ((<is> <java.io.ByteArrayInputStream>)
;;          (bytes
;;           (typecase class
;;             (<string> (read-bytes (<java.io.FileInputStream> (to-str class))))
;;             (<byte[]> class)
;;             (<symbol> (read-class-file class))))
;;          (cdata (<sun.tools.javap.ClassData> (<is> bytes)))
;;          (p (<sun.tools.javap.JavapPrinter>
;;           (<is> bytes)
;;              (current-output-port)
;;              (<sun.tools.javap.JavapEnvironment>))))
;;     (cond (method
;;            (dolist ((m <sun.tools.javap.MethodData>)
;;                     (array-to-list (! getMethods cdata)))
;;              (when (and (equal (to-str method) (! getName m))
;;                         (or (not signature)
;;                             (equal signature (! getInternalSig m))))
;;                (! printMethodSignature p m (! getAccess m))
;;                (! printExceptions p m)
;;                (newline)
;;                (! printVerboseHeader p m)
;;                (! printcodeSequence p m))))
;;           (#t (p:print)))
;;     (values)))

(df read-bytes ((is <java.io.InputStream>) => <byte[]>)
  (let ((os (<java.io.ByteArrayOutputStream>)))
    (let loop ()
      (let ((c (! read is)))
        (cond ((= c -1))
              (#t (! write os c) (loop)))))
    (! to-byte-array os)))

(df read-class-file ((name <symbol>) => <byte[]>)
  (let ((f (cat (! replace (to-str name) (as <char> #\.) (as <char> #\/))
                ".class")))
    (mcase (find-file-in-path f (class-path))
      ('#f (ferror "Can't find classfile for ~s" name))
      ((:zip zipfile entry)
       (let* ((z (<java.util.zip.ZipFile> (as <str> zipfile)))
              (e (! getEntry z (as <str> entry))))
         (read-bytes (! getInputStream z e))))
      ((:file s) (read-bytes (<java.io.FileInputStream> (as <str> s)))))))

(df all-instances ((vm <vm>) (classname <str>))
  (mappend (fun ((c <class-type>)) (to-list (! instances c (as long 9999))))
           (%all-subclasses vm classname)))

(df %all-subclasses ((vm <vm>) (classname <str>))
  (mappend (fun ((c <class-type>)) (cons c (to-list (! subclasses c))))
           (to-list (! classes-by-name vm classname))))

(df with-output-to-string (thunk => <str>)
  (call-with-output-string
   (fun (s) (parameterize ((current-output-port s)) (thunk)))))

(df find-if ((i <iterable>) test default)
  (let ((iter (! iterator i))
        (found #f))
    (while (and (not found) (! has-next iter))
      (let ((e (! next iter)))
        (when (test e)
          (set found #t)
          (set default e))))
    default))

(df filter ((i <iterable>) test => <list>)
  (packing (pack)
    (for ((e i))
      (when (test e)
        (pack e)))))

(df iter ((i <iterable>) f)
  (for ((e i)) (f e)))

(df mapi ((i <iterable>) f => <list>)
  (packing (pack) (for ((e i)) (pack (f e)))))

(df nth ((i <iterable>) (n <int>))
  (let ((iter (! iterator i)))
    (dotimes (i n)
      (! next iter))
    (! next iter)))

(df 1st ((i <iterable>)) (!! next iterator i))

(df to-list ((i <iterable>) => <list>)
  (packing (pack) (for ((e i)) (pack e))))

(df as-list ((o <java.lang.Object[]>) => <java.util.List>)
  (!s java.util.Arrays asList o))

(df mappend (f list)
  (apply append (map f list)))

(df subseq (s from to)
  (typecase s
    (<list> (apply list (! sub-list s from to)))
    (<vector> (apply vector (! sub-list s from to)))
    (<str> (! substring s from to))
    (<byte[]> (let* ((len (as <int> (- to from)))
                     (t (<byte[]> #:length len)))
                (!s java.lang.System arraycopy s from t 0 len)
                t))))

(df to-string (obj => <string>)
  (typecase obj
    (<str> (<gnu.lists.FString> obj))
    ((satisfies string?) obj)
    ((satisfies symbol?) (symbol->string obj))
    (<java.lang.StringBuffer> (<gnu.lists.FString> obj))
    (<java.lang.StringBuilder> (<gnu.lists.FString> obj))
    (#t (error "Not a string designator" obj
               (class-name-sans-package obj)))))

(df to-str (obj => <str>)
  (cond ((instance? obj <str>) obj)
        ((string? obj) (! toString obj))
        ((symbol? obj) (! getName (as <gnu.mapping.Symbol> obj)))
        (#t (error "Not a string designator" obj
                   (class-name-sans-package obj)))))

))

;; Local Variables:
;; mode: goo
;; compile-command: "\
;;  rm -rf classes && \
;;  JAVA_OPTS=-Xss2M kawa --r7rs -d classes -C swank-kawa.scm && \
;;  jar cf swank-kawa.jar -C classes ."
;; End: