[slime-cvs] CVS slime/contrib

[CVS User heller]

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv24765/contrib

Modified Files:
	ChangeLog swank-kawa.scm 
Log Message:
* swank-kawa.scm (compile-file-for-emacs, wrap-compilation)
(compile-string-for-emacs): Return a :compilation-result as
expected by Emacs.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/10/11 17:13:18	1.131
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/10/11 19:36:48	1.132
@@ -5,6 +5,12 @@
 	slime-scratch-file is set, use 'find-file' instead of
 	`get-buffer-create' to obtain the buffer.
 
+2008-10-11  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-kawa.scm (compile-file-for-emacs, wrap-compilation)
+	(compile-string-for-emacs): Return a :compilation-result as
+	expected by Emacs.
+
 2008-09-13  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-parse.el (slime-has-symbol-syntax-p): New.
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/04/17 14:19:16	1.7
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2008/10/11 19:36:48	1.8
@@ -629,38 +629,40 @@
 
 ;;;; Compilation
 
-(define-constant compilation-messages (<gnu.text.SourceMessages>))
-
 (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))
+     (fun ((m <gnu.text.SourceMessages>))
+       (kawa.lang.CompileFile:read filename m))
      zip (if (lisp-bool load?) env #f) #f)))
 
 (df wrap-compilation (f zip env delete?)
-  (! clear compilation-messages)
-  (let ((start-time (current-time)))
+  (let ((start-time (current-time))
+        (messages (<gnu.text.SourceMessages>)))
     (try-catch
-     (let ((c (as <gnu.expr.Compilation> (f))))
+     (let ((c (as <gnu.expr.Compilation> (f messages))))
        (! compile-to-archive c (! get-module c) zip))
      (ex <throwable>
          (log "error during compilation: ~a\n" ex)
-         (! error compilation-messages (as <char> #\f)
+         (! error messages (as <char> #\f)
             (to-str (exception-message ex)) #!null)))
     (log "compilation done.\n")
-    (when (and env
-               (zero? (! get-error-count compilation-messages)))
-      (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" (/ (- end-time start-time) 1000))))))
+    (let ((success? (zero? (! get-error-count messages))))
+      (when (and env success?)
+        (log "loading ...\n")
+        (eval `(load ,zip) env)
+        (log "loading ... done.\n"))
+      (when delete?
+        (ignore-errors (delete-file zip)))
+      (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 ()
+   (fun ((m <gnu.text.SourceMessages>))
      (let ((c (as <gnu.expr.Compilation>
                   (call-with-input-string 
                    string
@@ -668,7 +670,7 @@
                      (! set-path p 
                         (format "~s" 
                                 `(buffer ,buffer offset ,offset str ,string)))
-                     (kawa.lang.CompileFile:read p compilation-messages))))))
+                     (kawa.lang.CompileFile:read p m))))))
        (let ((o (@ currentOptions c)))
          (! set o "warn-invoke-unknown-method" #t)
          (! set o "warn-undefined-variable" #t))
@@ -677,9 +679,9 @@
        c))
    "/tmp/kawa-tmp.zip" env #t))
 
-(defslimefun compiler-notes-for-emacs (env) 
+(df compiler-notes-for-emacs ((messages <gnu.text.SourceMessages>))
   (packing (pack)
-    (do ((e (! get-errors compilation-messages) (@ next e)))
+    (do ((e (! get-errors messages) (@ next e)))
         ((nul? e))
       (pack (source-error>elisp e)))))
 
@@ -1328,7 +1330,7 @@
                            (<obj-ref> (! name (! referenceType ex)))
                            (<object> (!! getName getClass ex)))))
            (bt (thread-frames tid from to state)))
-      `((,desc ,type nil) () ,bt ()))))
+      `((,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))