[movitz-cvs] CVS movitz/ide

[ffjeld]

Update of /project/movitz/cvsroot/movitz/ide
In directory clnet:/tmp/cvs-serv21835

Modified Files:
	movitz-slime.el 
Log Message:
Update the slime-based IDE somewhat. At least the basics work now,
such as compile-defun (M-C-x) and disassemble-defun (C-c C-v).


--- /project/movitz/cvsroot/movitz/ide/movitz-slime.el	2004/07/21 10:54:42	1.1
+++ /project/movitz/cvsroot/movitz/ide/movitz-slime.el	2007/03/01 17:52:59	1.2
@@ -14,6 +14,7 @@
 ;;; core Movitz sources.
 
 (require 'slime)
+(require 'cl)
 
 ;;;; Minor-mode
 
@@ -46,7 +47,14 @@
   (setq movitz-mode-commands-map (make-sparse-keymap))
   (dolist (spec movitz-command-keys)
     (define-key movitz-mode-commands-map (car spec) (cadr spec)))
-  (define-key movitz-mode-map movitz-command-prefix movitz-mode-commands-map))
+  (define-key movitz-mode-map movitz-command-prefix movitz-mode-commands-map)
+
+  (define-key movitz-mode-map "\C-c\C-d" 'movitz-dump-image)
+  (define-key movitz-mode-map "\C-c\C-v" 'movitz-disassemble-defun)
+  (define-key movitz-mode-map "\C-c\C-b" 'movitz-compile-file)
+  (define-key movitz-mode-map "\C-\M-x" 'movitz-compile-defun)
+  (define-key movitz-mode-map "\C-cm" 'movitz-macroexpand)
+  (define-key movitz-mode-map "\C-ca" 'movitz-arglist))
 
 (movitz-init-command-keymap)
 
@@ -79,9 +87,14 @@
 (defun movitz-compile-defun ()
   "Compile the defun at point as Movitz code."
   (interactive)
-  (message "Compiling..")
-  (slime-eval-async `(movitz.ide:compile-defun ,(slime-defun-at-point))
-                    (lambda (_) (message "Compilation finished."))))
+  (multiple-value-bind (defun-name defun-type)
+      (movitz-defun-name-and-type)
+    (lexical-let ((defun-name defun-name)
+                  (defun-type defun-type)
+                  (package-name (slime-current-package)))
+      (message "Compiling %s '%s'.." defun-type defun-name)
+      (slime-eval-async `(movitz.ide:compile-defun ,(slime-defun-at-point) ,package-name)
+                        (lambda (_) (message "Movitz compilation of %s '%s' finished." defun-type defun-name))))))
 
 (defun movitz-disassemble-fdefinition (symbol-name package-name)
   "Show disassembly of the (non-generic) function at point."
@@ -92,6 +105,40 @@
                       (lambda (result)
                         (slime-show-description result package)))))
 
+(defun movitz-disassemble-defun (not-recursive-p)
+  (interactive "P")
+  (multiple-value-bind (defun-name defun-type lambda-list options)
+      (movitz-defun-name-and-type)
+    (lexical-let ((defun-name defun-name)
+                  (defun-type defun-type)
+                  (package-name (slime-current-package))
+                  (lambda-list lambda-list)
+                  (options options))
+      (cond
+       ((string= "function" defun-type)
+        (message "Movitz disassembling %s %s..." defun-type defun-name)
+        (slime-eval-async `(movitz.ide:movitz-disassemble ,defun-name ,package-name)
+                          (lambda (result)
+                            (slime-show-description result package-name)
+                            (message "Movitz disassembling %s %s...done." defun-type defun-name))))
+       ((string= "method" defun-type)
+        (message "Movitz disassembling %s '%s %s'..." defun-type defun-name lambda-list)
+        (slime-eval-async `(movitz.ide:movitz-disassemble-method ,defun-name ,lambda-list ',options ,package-name)
+                          (lambda (result)
+                            (slime-show-description result package-name)
+                            (message "Movitz disassembling %s '%s %s'...done." defun-type defun-name lambda-list))))
+       ;; ((string= "primitive-function" defun-type)
+       ;;       (message "Movitz disassembling %s %s..." defun-type defun-name)
+       ;;       (fi:eval-in-lisp
+       ;;        "(cl:let ((defun-name (cl:let ((cl:*package* (cl:find-package :%s)))
+       ;;                                 (cl:read-from-string \"%s\")))
+       ;;                (cl:*print-base* 16))
+       ;;          (movitz::movitz-disassemble-primitive defun-name))"
+       ;;        fi:package defun-name)
+       ;;       (switch-to-buffer "*common-lisp*")
+       ;;       (message "Movitz disassembling %s %s...done." defun-type defun-name))
+       (t (message "Don't know how to Movitz disassemble %s '%s'." defun-type defun-name))))))
+
 (defvar movitz-default-image-file nil
   "The default filename to dump images to.
 This is set by `movitz-dump-image' and can also be preinitialized in
@@ -109,3 +156,61 @@
   (slime-eval-async `(movitz.ide:dump-image ,filename)
                     (lambda (_) (message "Finished."))))
 
+
+(defun movitz-dump-image-and-qemu ()
+  "Dump the current image to FILENAME."
+  (let ((filename (list (if (and (null current-prefix-arg)
+                                 movitz-default-image-file)
+                            movitz-default-image-file
+                          (let ((filename (read-file-name "Image file: ")))
+                            (setq movitz-default-image-file filename)
+                            filename)))
+  (message "Dumping..")
+  (slime-eval-async `(movitz.ide:dump-image ,filename)
+                    (lambda (_) (message "Finished."))))
+
+
+
+(defun movitz-defun-name-and-type ()
+  (interactive)
+  (save-excursion
+    (let ((definition-type
+	    (let ((x (buffer-substring-no-properties (progn (beginning-of-defun)
+							    (forward-char)
+							    (point))
+						     (progn (forward-symbol 1)
+							    (point)))))
+	      (cond
+	       ((string-equal "defun" x)
+		"function")
+	       ((string-match "^define-" x)
+		(substring x 7))
+	       ((string-match "^def" x)
+		(substring x 3))
+	       (t x))))
+	  (definition-name
+	    (buffer-substring-no-properties (progn (forward-char)
+						   (point))
+					    (progn (forward-sexp 1)
+						   (point))))
+	  (lambda-list
+	   (buffer-substring-no-properties (progn (forward-char)
+						  (point))
+					   (progn (forward-sexp 1)
+						  (point)))))
+      (if (and (equalp "method" definition-type)
+	       (char-equal 58 (string-to-char lambda-list)))
+	  (let ((qualifier lambda-list)
+		;; XXX we only deal with one (potential) qualifier..
+		(lambda-list (buffer-substring-no-properties (progn (forward-char)
+								    (point))
+							     (progn (forward-sexp 1)
+								    (point)))))
+	    (values definition-name
+		    definition-type
+		    lambda-list
+		    (list qualifier)))
+	(values definition-name
+		definition-type
+		lambda-list
+		nil)))))