[slime-cvs] CVS slime/contrib
CVS User heller
heller at common-lisp.net
Sun Oct 17 10:17:31 UTC 2010
Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv29636/contrib
Modified Files:
ChangeLog swank-kawa.scm
Log Message:
Some updates to the Kawa backend.
* swank-kawa.scm (%%runnable): Use standard
gnu.mapping.RunnableClosure but print the stacktrace on
exceptions.
(listener-loop): Invoke debugger on unhandled exceptions. The
debugger will use stacksnapshots if the exception matches.
(invoke-debugger, break, breakpoint, request-breakpoint): New.
Used to "invoke" the debugger from normal code.
(process-vm-event, debug-info, event-stacktrace): Handle
breakpoint events.
(interrupt-thread, throwable-stacktrace, breakpoint-condition):
New.
(throw-to-toplevel): For breakpoint events use
Thread#forceEarlyReturn.
(typecase): Add support for or and eql types.
(bytemethod>src-loc): New.
(src-loc>elisp): Use stratum "java" as this seems to work better.
(print-object, print-unreadable-object): New
(pprint-to-string): Use it.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2010/09/26 18:10:33 1.423
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2010/10/17 10:17:31 1.424
@@ -1,3 +1,26 @@
+2010-10-17 Helmut Eller <heller at common-lisp.net>
+
+ Some updates to the Kawa backend.
+
+ * swank-kawa.scm (%%runnable): Use standard
+ gnu.mapping.RunnableClosure but print the stacktrace on
+ exceptions.
+ (listener-loop): Invoke debugger on unhandled exceptions. The
+ debugger will use stacksnapshots if the exception matches.
+ (invoke-debugger, break, breakpoint, request-breakpoint): New.
+ Used to "invoke" the debugger from normal code.
+ (process-vm-event, debug-info, event-stacktrace): Handle
+ breakpoint events.
+ (interrupt-thread, throwable-stacktrace, breakpoint-condition):
+ New.
+ (throw-to-toplevel): For breakpoint events use
+ Thread#forceEarlyReturn.
+ (typecase): Add support for or and eql types.
+ (bytemethod>src-loc): New.
+ (src-loc>elisp): Use stratum "java" as this seems to work better.
+ (print-object, print-unreadable-object): New
+ (pprint-to-string): Use it.
+
2010-09-26 Stas Boukarev <stassats at gmail.com>
* slime-repl.el (slime-repl-history-pattern): Match \t too,
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2010/09/03 07:25:24 1.23
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2010/10/17 10:17:31 1.24
@@ -24,9 +24,9 @@
(defun kawa-slime-init (file _)
(setq slime-protocol-version 'ignore)
- (let ((zip ".../slime/contrib/swank-kawa.zip")) ; <-- insert the right path
+ (let ((swank ".../slime/contrib/swank-kawa.scm")) ; <-- insert the right path
(format "%S\n"
- `(begin (load ,(expand-file-name zip)) (start-swank ,file)))))
+ `(begin (require ,(expand-file-name swank)) (start-swank ,file)))))
|#
;; 4. Start everything with M-- M-x slime kawa
;;
@@ -34,7 +34,7 @@
;;;; Module declaration
-(module-export start-swank create-swank-server swank-java-source-path)
+(module-export start-swank create-swank-server swank-java-source-path break)
(module-static #t)
@@ -51,9 +51,9 @@
(define-syntax df
(syntax-rules (=>)
((df name (args ... => return-type) body ...)
- (define (name args ...) :: return-type body ...))
+ (define (name args ...) :: return-type (seq body ...)))
((df name (args ...) body ...)
- (define (name args ...) body ...))))
+ (define (name args ...) (seq body ...)))))
(define-syntax fun
(syntax-rules ()
@@ -67,7 +67,9 @@
(define-syntax seq
(syntax-rules ()
- ((seq body ...)
+ ((seq)
+ (begin #!void))
+ ((seq body ...)
(begin body ...))))
(define-syntax esc
@@ -192,8 +194,8 @@
(result #!null))
(if (instance? tmp <pair>)
(let ((tmp :: <pair> tmp))
- (mif (p (@ car tmp))
- (mif (ps (@ cdr tmp))
+ (mif (p (! get-car tmp))
+ (mif (ps (! get-cdr tmp))
(set! result then)
(set! fail? -1))
(set! fail? -1)))
@@ -205,8 +207,8 @@
(tmp value))
(if (instance? tmp <pair>)
(let ((tmp :: <pair> tmp))
- (mif (p (@ car tmp))
- (mif (ps (@ cdr tmp))
+ (mif (p (! get-car tmp))
+ (mif (ps (! get-cdr tmp))
then
(fail))
(fail)))
@@ -241,20 +243,42 @@
((mlet* ((pattern value) ms ...) body ...)
(mlet (pattern value) (mlet* (ms ...) body ...)))))
-(define-syntax typecase
- (syntax-rules (::)
- ((typecase var (type body ...) ...)
+(define-syntax typecase%
+ (syntax-rules (eql or)
+ ((typecase% var (#t body ...) more ...)
+ (seq body ...))
+ ((typecase% var ((eql value) body ...) more ...)
+ (cond ((eqv? var 'value) body ...)
+ (else (typecase% var more ...))))
+ ((typecase% var ((or type) body ...) more ...)
+ (typecase% var (type body ...) more ...))
+ ((typecase% var ((or type ...) body ...) more ...)
+ (let ((f (lambda (var) body ...)))
+ (typecase% var
+ (type (f var)) ...
+ (#t (typecase% var more ...)))))
+ ((typecase% var (type body ...) more ...)
(cond ((instance? var type)
(let ((var :: type var))
body ...))
- ...
- (else (error "typecase failed" var
- (! getClass (as <object> var))))))))
+ (else (typecase% var more ...))))
+ ((typecase% var)
+ (error "typecase% failed" var
+ (! getClass (as <object> var))))))
+
+(define-syntax-case typecase
+ ()
+ ((_ exp more ...) (identifier? (syntax exp))
+ #`(typecase% exp more ...))
+ ((_ exp more ...)
+ #`(let ((tmp exp))
+ (typecase% tmp more ...))))
(define-syntax ignore-errors
(syntax-rules ()
((ignore-errors body ...)
(try-catch (begin body ...)
+ (v <java.lang.Error> #f)
(v <java.lang.Exception> #f)))))
;;(define-syntax dc
@@ -307,6 +331,7 @@
(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> ()
@@ -348,6 +373,7 @@
(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
@@ -425,7 +451,7 @@
((_ (':emacs-interrupt id))
(let* ((vm (vm))
(t (find-thread id (map cdr threads) repl-thread vm)))
- (send dbg `(debug-thread ,t))))
+ (send dbg `(interrupt-thread ,t))))
((_ (':emacs-rex form _ _ id))
(send listener `(,form ,id)))
((_ ('get-vm c))
@@ -567,16 +593,25 @@
(df listener ((c <chan>) (env <env>))
(! set-name (current-thread) "swank-listener")
- (log "listener: ~s ~s ~s ~s\n"
+ (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))
+ (request-uncaught-exception-events vm)
+ (request-caught-exception-events vm)
+ )
(rpc c `(get-vm))
(listener-loop c env out)))
+(define-simple-class <listener-abort> (<throwable>)
+ ((*init*)
+ (invoke-special <throwable> (this) '*init* ))
+ ((abort) :: void
+ (primitive-throw (this))
+ #!void))
+
(df listener-loop ((c <chan>) (env <env>) port)
(while (not (nul? c))
;;(log "listener-loop: ~s ~s\n" (current-thread) c)
@@ -595,10 +630,19 @@
(let* ((val (%eval form env)))
(force-output)
(reply c val id))
+ (ex <java.lang.Exception> (invoke-debugger ex) (restart))
+ (ex <java.lang.Error> (invoke-debugger ex) (restart))
(ex <listener-abort>
(let ((flag (java.lang.Thread:interrupted)))
(log "listener-abort: ~s ~a\n" ex flag))
- (restart)))))))
+ (restart))
+ )))))
+
+(df invoke-debugger (condition)
+ ;;(log "should now invoke debugger: ~a" condition)
+ (try-catch
+ (break condition)
+ (ex <listener-abort> (seq))))
(defslimefun create-repl (env #!rest _)
(list "user" "user"))
@@ -636,7 +680,8 @@
(df values-for-echo-area (values)
(let ((values (values-to-list values)))
- (format "~:[=> ~{~s~^, ~}~;; No values~]" (null? values) values)))
+ (cond ((null? values) "; No value")
+ (#t (format "~{~a~^, ~}" (map pprint-to-string values))))))
;;;; Compilation
@@ -839,6 +884,7 @@
(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) '()))))
@@ -857,10 +903,12 @@
(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))))
+ (<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)))
@@ -878,18 +926,28 @@
name)))
(df class>src-loc ((c <java.lang.Class>) => <location>)
- (let* ((type (! reflectedType (as <com.sun.jdi.ClassObjectReference>
- (vm-mirror *the-vm* c))))
+ (let* ((type (class>class-ref c))
(locs (! all-line-locations type)))
(cond ((not (! isEmpty locs)) (1st locs))
- (#t (<swank-location> (1st (! source-paths type #!null))
+ (#t (<swank-location> (1st (! source-paths type "Java"))
#f)))))
+(df class>class-ref ((class <java.lang.Class>) => <class-ref>)
+ (! reflectedType (as <com.sun.jdi.ClassObjectReference>
+ (vm-mirror *the-vm* class))))
+
+(df bytemethod>src-loc ((m <gnu.bytecode.Method>) => <location>)
+ (let* ((cls (class>class-ref (! get-reflect-class (! get-declaring-class m))))
+ (name (! get-name m))
+ (sig (! get-signature m))
+ (meth (! concrete-method-by-name cls name sig)))
+ (! location meth)))
+
(df src-loc>elisp ((l <location>))
(df src-loc>list ((l <location>))
- (list (ignore-errors (! source-name l))
- (ignore-errors (! source-path l))
- (ignore-errors (! line-number l))))
+ (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)
@@ -906,7 +964,6 @@
path name (source-path)))
(:line ,(or line -1)) ()))))))
-
(df src-loc>str ((l <location>))
(cond ((nul? l) "<null-location>")
(#t (format "~a ~a ~a"
@@ -917,10 +974,13 @@
(ignore-errors (! lineNumber l))))))
(df ferror (fstring #!rest args)
- (primitive-throw (<java.lang.Error> (to-str (apply format fstring args)))))
+ (let ((err (<java.lang.Error> (to-str (apply format fstring args)))))
+ (primitive-throw err)))
;;;;;; class-path hacking
+;; (find-file-in-path "kawa/lib/kawa/hashtable.scm" (source-path))
+
(df find-file-in-path ((filename <str>) (path <list>))
(let ((f (<file> filename)))
(cond ((! isAbsolute f) `(:file ,filename))
@@ -973,9 +1033,9 @@
(let ((f (eval name env)))
(typecase f
(<gnu.expr.ModuleMethod>
- (disassemble (module-method>meth-ref f))))))))
+ (disassemble-to-string (module-method>meth-ref f))))))))
-(df disassemble ((mr <meth-ref>) => <str>)
+(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>))
@@ -1039,9 +1099,9 @@
;;;; 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))
+(defslimefun swank-expand-1 (env s) (%swank-macroexpand s))
+(defslimefun swank-expand (env s) (%swank-macroexpand s))
+(defslimefun swank-expand-all (env s) (%swank-macroexpand s))
(df %swank-macroexpand (string)
(pprint-to-string (%macroexpand (read-from-string string))))
@@ -1180,7 +1240,7 @@
(set! builder:length 0)))) ; pure magic
(closed #f))
(while (not closed)
- (mcase (! poll q 200 <timeunit>:MILLISECONDS)
+ (mcase (! poll q (as long 200) <timeunit>:MILLISECONDS)
('#!null (flush))
(('write s)
(! append builder (as <str> s))
@@ -1202,11 +1262,14 @@
;;;; 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)
- ;;(enable-uncaught-exception-events vm)
+ (request-breakpoint vm)
(mlet* (((ev . _) (spawn/chan/catch
(fun (c)
(let ((q (! eventQueue vm)))
@@ -1235,12 +1298,12 @@
(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 . ('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 (debug-thread t state c))))
+ (set state (interrupt-thread t state c))))
((,c . ('quit-thread-browser id))
(reply c 't id)
(set state (del state 'all-threads)))
@@ -1262,35 +1325,40 @@
(send c `(forward (:return (:ok ,value) ,id))))
(df reply-abort ((c <chan>) id)
- (send c `(forward (:return (:abort) ,id))))
+ (send c `(forward (:return (:abort nil) ,id))))
(df process-vm-event ((e <event>) (c <chan>) state)
- (log "vm-event: ~s\n" e)
+ ;;(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))))
+ ;;(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)))
+ state)
[356 lines skipped]
More information about the slime-cvs
mailing list