/local-lisp/slime/contrib/swank-kawa.scm
Scheme | 2174 lines | 1738 code | 251 blank | 185 comment | 2 complexity | d55a8867a508e1d528cdf1f8c1e0d728 MD5 | raw file
Possible License(s): GPL-3.0, CC-BY-SA-4.0, GPL-2.0, Unlicense
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)))
- …
Large files files are truncated, but you can click here to view the full file