[slime-cvs] CVS slime/contrib
heller
heller at common-lisp.net
Mon Mar 24 07:22:21 UTC 2008
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv31829/contrib
Modified Files:
ChangeLog swank-kawa.scm
Log Message:
* swank-kawa.scm: Save stacktraces with locals on throw events.
This is quite costly but makes debugging easier.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/03/18 13:21:28 1.101
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/03/24 07:22:20 1.102
@@ -1,3 +1,8 @@
+2008-03-24 Helmut Eller <heller at common-lisp.net>
+
+ * swank-kawa.scm: Save stacktraces with locals on throw events.
+ This is quite costly but makes debugging easier.
+
2008-03-14 Tobias C. Rittweiler <tcr at freebits.de>
* swank-fancy-inspector.lisp (add-slots-for-inspector): Remove
@@ -16,7 +21,7 @@
* slime-fuzzy.lisp (slime-fuzzy-insert-completion-choice):
(slime-fuzzy-fill-completions-buffer): Adapted to API change.
-
+
2008-03-14 Tobias C. Rittweiler <tcr at freebits.de>
* swank-fancy-inspector.lisp (make-symbols-listing :classification):
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/03/18 13:22:17 1.3
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/03/24 07:22:20 1.4
@@ -3,7 +3,7 @@
;;; 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 to view it).
+;;; License as distributed with Emacs (press C-h C-c for details).
;;;; Installation
;;
@@ -40,7 +40,8 @@
(module-compile-options
:warn-invoke-unknown-method #t
- :warn-undefined-variable #t)
+ :warn-undefined-variable #t
+ )
(require 'hash-table)
@@ -102,7 +103,7 @@
(syntax-rules ()
((dotimes (i n result) body ...)
(let ((max :: <int> n))
- (do ((i :: <int> 0 (1+ i)))
+ (do ((i :: <int> 0 (as <int> (+ i 1))))
((= i max) result)
body ...)))
((dotimes (i n) body ...)
@@ -110,38 +111,25 @@
(define-syntax dolist
(syntax-rules ()
- ((dolist (e list) body ...)
- (for-each (lambda (e) body ...) list))
- ((dolist ((e type) list) body ...)
- (for-each (lambda ((e type)) body ...) list)
- )))
+ ((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)
- (let ((var (! next iter)))
- body ...))))))
+ ((lambda (var) body ...)
+ (! next iter)))))))
(define-syntax packing
(syntax-rules ()
((packing (var) body ...)
- (let ((var '()))
+ (let ((var :: <list> '()))
(let ((var (lambda (v) (set! var (cons v var)))))
body ...)
(reverse! var)))))
-;;(define-syntax packing
-;; (syntax-rules ()
-;; ((packing (var) body ...)
-;; (let* ((var '()))
-;; (let-syntax ((var (syntax-rules ()
-;; ((var 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)
@@ -196,15 +184,20 @@
((mif (,x value) then else)
(if (eq? x value) then else))
((mif (() value) then else)
- (if (null? value) then else))
- ((mif ((pattern . rest) value) then else)
+ (if (eq? value '()) then else))
+ ((mif ((p . ps) value) then else)
(let ((tmp value)
- (fail (lambda () else)))
- (if (pair? tmp)
- (mif (pattern (car tmp))
- (mif (rest (cdr tmp)) then (fail))
- (fail))
- (fail))))
+ (fail? :: <int> 0)
+ (result #!null))
+ (if (instance? tmp <pair>)
+ (let ((tmp :: <pair> tmp))
+ (mif (p tmp:car)
+ (mif (ps tmp:cdr)
+ (set! result then)
+ (set! fail? -1))
+ (set! fail? -1)))
+ (set! fail? -1))
+ (if (= fail? 0) result else)))
((mif (_ value) then else)
then)
((mif (var value) then else)
@@ -219,7 +212,7 @@
(mif (pattern tmp)
(begin body ...)
(mcase tmp more ...))))
- ((mcase exp) (error "mcase failed" exp))))
+ ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp (pprint-to-string exp)))))
(define-syntax mlet
(syntax-rules ()
@@ -281,6 +274,8 @@
(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>)
@@ -294,6 +289,7 @@
(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>)
@@ -336,8 +332,9 @@
;;;; Event dispatcher
-;; for debugging
-(define the-vm #f)
+(define-variable *the-vm* #f)
+(define-variable *last-exception* #f)
+(define-variable *last-stacktrace* #f)
(df dispatch-events ((s <socket>))
(mlet* ((charset "iso-8859-1")
@@ -351,6 +348,9 @@
"user" (interaction-environment))
;;(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)
@@ -427,14 +427,16 @@
((_ ('set-listener x))
(set repl-thread x))
((_ ('publish-vm vm))
- (set the-vm vm))
+ (set *the-vm* vm))
)))))
(df find-thread (id threads listener (vm <vm>))
(cond ((== id :repl-thread) listener)
- ((== id 't) (if (null? threads)
- listener
- (vm-mirror vm (car threads))))
+ ((== id 't) listener
+ ;;(if (null? threads)
+ ;; listener
+ ;; (vm-mirror vm (car threads)))
+ )
(#t
(let ((f (find-if threads
(fun (t :: <thread>)
@@ -449,15 +451,16 @@
(df reader ((in <in>) (c <chan>))
(! set-name (current-thread) "swank-reader")
- (define-namespace ReadTable "class:gnu.kawa.lispexpr.ReadTable")
- (ReadTable:setCurrent (ReadTable:createInitial)) ; ':' not special
- (while #t
- (send c (decode-message in))))
+ (let ((rt (gnu.kawa.lispexpr.ReadTable:createInitial))) ; ':' not special
+ (while #t
+ (send c (decode-message in rt)))))
-(df decode-message ((in <in>) => <list>)
+(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) read)))
+ (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))
@@ -465,6 +468,16 @@
(assert (= count len) "count: ~d len: ~d" count len)
(<str> chars)))
+;;; FIXME: not thread safe
+(df %read ((port <gnu.mapping.InPort>) (table <gnu.kawa.lispexpr.ReadTable>))
+ ;; (parameterize ((current-readtable table))
+ ;; (read)))
+ (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
@@ -505,16 +518,17 @@
;; (<ucex-handler> (fun (t e) (reply-abort c id))))
(reply c (%eval form env) id))
-(define-constant slime-funs (tab))
+(define-variable *slime-funs*)
+(set *slime-funs* (tab))
(df %eval (form env)
- (apply (lookup-slimefun (car form)) env (cdr form)))
+ (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form)))
-(df lookup-slimefun ((name <symbol>))
+(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 slime-funs (string->symbol sub) #f)
+ (or (get tab (string->symbol sub) #f)
(ferror "~a not implemented" sub))))
(define-syntax defslimefun
@@ -522,7 +536,7 @@
((defslimefun name (args ...) body ...)
(seq
(df name (args ...) body ...)
- (put slime-funs 'name name)))))
+ (put *slime-funs* 'name name)))))
(defslimefun connection-info ((env <env>))
(let ((prop java.lang.System:getProperty))
@@ -546,8 +560,9 @@
(let ((out (rpc c `(get-channel))))
(set (current-output-port) (make-swank-outport out)))
(let ((vm (as <vm> (rpc c `(get-vm)))))
- (enable-uncaught-exception-events vm)
- (send c `(set-listener ,(vm-mirror vm (current-thread)))))
+ (send c `(set-listener ,(vm-mirror vm (current-thread))))
+ (enable-uncaught-exception-events vm))
+ (rpc c `(get-vm))
(listener-loop c env))
(df listener-loop ((c <chan>) (env <env>))
@@ -587,7 +602,12 @@
(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))))
@@ -606,7 +626,7 @@
(define-constant compilation-messages (<gnu.text.SourceMessages>))
-(defslimefun compile-file-for-emacs (env (filename <string>) load?)
+(defslimefun compile-file-for-emacs (env (filename <str>) load?)
(let ((zip (cat (path-sans-extension (filepath filename)) ".zip")))
(wrap-compilation
(fun () (kawa.lang.CompileFile:read filename compilation-messages))
@@ -625,12 +645,13 @@
(log "compilation done.\n")
(when (and env
(zero? (! get-error-count compilation-messages)))
- (eval `(load ,zip) env))
+ (log "loading ...\n")
+ (eval `(load ,zip) env)
+ (log "loading ... done.\n"))
(when delete?
(ignore-errors (delete-file zip)))
(let ((end-time (current-time)))
- (list 'nil (format "~3f" (/ (as <double> (- end-time start-time))
- 1000))))))
+ (list 'nil (format "~3f" (/ (- end-time start-time) 1000))))))
(defslimefun compile-string-for-emacs (env string buffer offset dir)
(wrap-compilation
@@ -666,7 +687,8 @@
:location (error-loc>elisp e)))
(df error-loc>elisp ((e <source-error>))
- (cond ((! starts-with (@ filename e) "(buffer ")
+ (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)
@@ -678,17 +700,16 @@
nil))))
(df line>offset ((line <int>) (s <str>) => <int>)
- (let ((offset :: <int> -1))
+ (let ((offset :: <int> 0))
(dotimes (i line)
- (set offset (! index-of s (as <char> #\newline) (as <int> (1+ offset))))
- (assert (>= offset 0)))
+ (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))
-;; (let ((offset -1)) (! index-of "\n" (as <char> #\newline) (as <int> (1+ offset))))
-
(defslimefun load-file (env filename)
- (format "~s\n" (eval `(load ,filename) env)))
+ (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env)))
;;;; Completion
@@ -741,6 +762,28 @@
`(,(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))
@@ -749,28 +792,27 @@
(if s (all-definitions s) '()))))
(<java.lang.Class> (list o))
(<gnu.mapping.Procedure> (all-definitions (! get-class o)))
- ))
+ (<kawa.lang.Macro> (list o))))
(df gf-methods ((f <gnu.expr.GenericProc>))
- (let* ((o :: <obj-ref> (vm-mirror the-vm f))
+ (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))))
+ (ms (vm-demirror *the-vm* (! get-value o f))))
(filter (array-to-list ms) (fun (x) (not (nul? x))))))
-(df src-loc (o)
+(df src-loc (o => <location>)
(typecase o
(<gnu.expr.ModuleMethod> (module-method>src-loc o))
- (<gnu.expr.GenericProc> `(:error "no src-loc available"))
+ (<gnu.expr.GenericProc> (<swank-location> #f #f))
(<java.lang.Class> (class>src-loc o))
- ;; XXX handle macros, variables etc.
- ))
+ (<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)))))
+ (as <obj-ref> (vm-mirror *the-vm* (@ module f)))))
(name (mangled-name f)))
(as <meth-ref> (1st (! methods-by-name module name)))))
@@ -780,22 +822,42 @@
(cat name "$V")
name)))
-(df class>src-loc ((c <java.lang.Class>))
- (1st (! all-line-locations (! reflectedType
- (as <com.sun.jdi.ClassObjectReference>
[812 lines skipped]
More information about the slime-cvs
mailing list