[slime-cvs] CVS slime

[heller]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2122

Modified Files:
	swank-sbcl.lisp 
Log Message:
(swank-compile-string): Create temporary file with the string and
compile-file it instead of compiling an anonymous lambda, as before,
in order to better handle eval-when forms.

(tmpnam, temp-file-name): New functions.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/04/19 09:18:53	1.155
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/06/26 06:24:24	1.156
@@ -291,7 +291,7 @@
       (list :error "No error location available")))
 
 (defun locate-compiler-note (file source-path source)
-  (cond ((and (eq file :lisp)
+  (cond ((and ;;(eq file :lisp)
               *buffer-name*)
          ;; Compiling from a buffer
          (let ((position (+ *buffer-offset*
@@ -377,24 +377,41 @@
 
 ;;;; compile-string
 
+;;; We copy the string to a temporary file in order to get adequate
+;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
+;;; which the previous approach using
+;;;     (compile nil `(lambda () ,(read-from-string string)))
+;;; did not provide.
+
+(sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
+  (dest (* sb-alien:c-string)))
+
+(defun temp-file-name ()
+  "Return a temporary file name to compile strings into."
+  (concatenate 'string (tmpnam nil) ".lisp"))
+
 (defimplementation swank-compile-string (string &key buffer position directory)
   (declare (ignore directory))
-  (flet ((compileit (cont)
-           (let ((*buffer-name* buffer)
-                 (*buffer-offset* position)
-                 (*buffer-substring* string))
+  (let ((*buffer-name* buffer)
+        (*buffer-offset* position)
+        (*buffer-substring* string)
+        (filename (temp-file-name)))
+    (flet ((compile-it (fn) 
              (with-compilation-hooks ()
-               (with-compilation-unit (:source-plist
-                                       (list :emacs-buffer buffer 
-                                             :emacs-string string
-                                             :emacs-position position))
-                 (funcall cont (compile nil
-                                        `(lambda ()
-                                          ,(read-from-string string)))))))))
-    (if *trap-load-time-warnings*
-        (compileit #'funcall)
-        (funcall (compileit #'identity)))))
-
+               (with-compilation-unit
+                   (:source-plist (list :emacs-buffer buffer
+                                        :emacs-string string
+                                        :emacs-position position))
+                 (funcall fn (compile-file filename))))))
+      (with-open-file (s filename :direction :output :if-exists :error)
+        (write-string string s))
+      (unwind-protect
+           (if *trap-load-time-warnings*
+               (compile-it #'load)
+               (load (compile-it #'identity)))
+        (ignore-errors
+          (delete-file filename)
+          (delete-file (compile-file-pathname filename)))))))
 
 ;;;; Definitions