movitz-mode.el

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2004
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      movitz-mode.el
   9 ;;;; Description:   Modifies Franz' ELI slightly to integrate with Movitz.
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Thu Sep 27 18:12:17 2001
  12 ;;;;
  13 ;;;; $Id: movitz-mode.el,v 1.10 2005/08/21 12:11:51 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (defvar movitz-common-lisp-mode-map nil)
  18
  19 (defun make-movitz-common-lisp-mode-map (&optional new)
  20   (interactive "P")
  21   (when (or new (not movitz-common-lisp-mode-map))
  22     ;; (setq movitz-common-lisp-mode-map (make-keymap))
  23     (fi::initialize-mode-map 'movitz-common-lisp-mode-map))
  24   (define-key movitz-common-lisp-mode-map "\C-c\C-d" 'movitz-dump-image)
  25   (define-key movitz-common-lisp-mode-map "\C-c\C-v" 'movitz-disassemble-defun)
  26   (define-key movitz-common-lisp-mode-map "\C-c\C-b" 'movitz-compile-file)
  27   (define-key movitz-common-lisp-mode-map "\C-\M-x" 'movitz-compile-defun)
  28   (define-key movitz-common-lisp-mode-map "\C-cm" 'movitz-macroexpand)
  29   (define-key movitz-common-lisp-mode-map "\C-ca" 'movitz-arglist)
  30   movitz-common-lisp-mode-map)
  31
  32 (defun in-movitz-package-p ()
  33   (or (and (< 6 (length fi:package))
  34            (string= "MUERTE." (upcase (substring fi:package 0 7))))
  35       (member (upcase fi:package)
  36               '("MUERTE" "X86" "X86-PC"))
  37       (member "MUERTE"
  38               (fi:eval-in-lisp
  39                "(cl:mapcar #'cl:package-name (cl:package-use-list \"%s\"))" (upcase fi:package)))))
  40
  41 (defun movitz-defun-name-and-type ()
  42   (interactive)
  43   (save-excursion
  44     (let ((definition-type
  45             (let ((x (buffer-substring-no-properties (progn (fi:beginning-of-defun)
  46                                                             (forward-char)
  47                                                             (point))
  48                                                      (progn (forward-symbol 1)
  49                                                             (point)))))
  50               (cond
  51                ((string-equal "defun" x)
  52                 "function")
  53                ((string-match "^define-" x)
  54                 (substring x 7))
  55                ((string-match "^def" x)
  56                 (substring x 3))
  57                (t x))))
  58           (definition-name
  59             (buffer-substring-no-properties (progn (forward-char)
  60                                                    (point))
  61                                             (progn (forward-sexp 1)
  62                                                    (point))))
  63           (lambda-list
  64            (buffer-substring-no-properties (progn (forward-char)
  65                                                   (point))
  66                                            (progn (forward-sexp 1)
  67                                                   (point)))))
  68       (if (and (equalp "method" definition-type)
  69                (char-equal 58 (string-to-char lambda-list)))
  70           (let ((qualifier lambda-list)
  71                 ;; XXX we only deal with one (potential) qualifier..
  72                 (lambda-list (buffer-substring-no-properties (progn (forward-char)
  73                                                                     (point))
  74                                                              (progn (forward-sexp 1)
  75                                                                     (point)))))
  76             (values definition-name
  77                     definition-type
  78                     lambda-list
  79                     (list qualifier)))
  80         (values definition-name
  81                 definition-type
  82                 lambda-list
  83                 nil)))))
  84
  85 (defun movitz-arglist (string)
  86   (interactive (fi::get-default-symbol "Movitz arglist for" t t))
  87   (let ((message
  88          (fi:eval-in-lisp
  89           "(cl:let* ((cl:*print-case* :downcase)
  90                        (name (cl:quote %s))
  91                        (funobj (movitz::movitz-env-named-function name)))
  92             (cl:when funobj
  93              (cl:format nil \"~A\" (movitz::movitz-print (movitz::movitz-funobj-lambda-list funobj)))))"
  94           string string)))
  95     (if message
  96         (message "Movitz args for %s: %s." string message)
  97       (fi:lisp-arglist string))))
  98
  99 (defun movitz-dump-image (dont-run-bochs-p)
 100   "Dump a Movitz image."
 101   (interactive "P")
 102   (message "Dumping Movitz image...")
 103   (fi:eval-in-lisp "(movitz::dump-image)")
 104 ;;;  (with-current-buffer "*common-lisp*"
 105 ;;;    (fi:inferior-lisp-newline))
 106   (cond
 107    (dont-run-bochs-p
 108     (message "Dumping Movitz image...done. Bootblock ID: %d. Running qemu.."
 109              (fi:eval-in-lisp "movitz::*bootblock-build*"))
 110 ;;     (call-process "/bin/sh" nil 0 nil "-c"
 111 ;;                (format "DISPLAY=\"%s\" cd ~/clnet/movitz && qemu -fda los0-image -boot a"
 112 ;;                        display-shortcut))
 113     )
 114    (t (message "Dumping Movitz image...done. Bootblock ID: %d. Running bochs on \"%s\"..."
 115                (fi:eval-in-lisp "movitz::*bootblock-build*")
 116                display-shortcut)
 117       (call-process "/bin/sh" nil 0 nil "-c"
 118                     (format "DISPLAY=\"%s\" cd ~/clnet/movitz && ~/tmp/bochs-cvs/bochs -nocp > bochs-parameters"
 119                             display-shortcut)))))
 120
 121 (defun movitz-compile-file ()
 122   (interactive)
 123   (save-some-buffers)
 124   (message "Movitz compiling \"%s\"..." (buffer-file-name))
 125   (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" (buffer-file-name))
 126   (message "Movitz compiling \"%s\"...done."
 127            (buffer-file-name)))
 128
 129 (defun movitz-eval-in-acl (string msg)
 130   (fi::note-background-request nil)
 131   (let ((compilep nil)
 132         (buffer (current-buffer)))
 133     (fi::make-request
 134      (lep::evaluation-request
 135       :transaction-directory fi:emacs-to-lisp-transaction-directory
 136       ;; The addition of the format wrapper in the next line works
 137       ;; around the incredible bogosity of fsf emacs 19.x that prints
 138       ;; strings with non-null fontification using vector syntax.
 139       ;; The format call reliably if inefficiently strips the font data.
 140       ;; bug3330 smh 22jun94
 141       :text (fi::defontify-string string)
 142       :echo fi:echo-evals-from-buffer-in-listener-p
 143       :partialp nil
 144       :pathname (buffer-file-name)
 145       :compilep nil
 146       :return-string (eq 'minibuffer (car fi:pop-up-temp-window-behavior)))
 147      ((buffer compilep msg) (results stuff)
 148       (save-excursion
 149         (set-buffer buffer)
 150         (cond
 151          ((eq 'minibuffer (car fi:pop-up-temp-window-behavior))
 152           (if (and (stringp stuff) (= 0 (length stuff)))
 153               (fi::note-background-reply (list compilep))
 154             (fi:show-some-text nil stuff)))
 155          (t
 156           (fi::note-background-reply (list compilep))))
 157         ;; (fi::note-background-reply (list compilep))
 158         (when (and results (null fi:echo-evals-from-buffer-in-listener-p))
 159           (fi:show-some-text nil results)))
 160       (when fi:pop-to-sublisp-buffer-after-lisp-eval ; bug2683
 161         (pop-to-buffer fi:common-lisp-buffer-name)
 162         (goto-char (point-max)))
 163       (message "%sdone." msg))
 164      ((buffer compilep) (error)
 165       (save-excursion
 166         (set-buffer buffer)
 167         (fi::note-background-reply (list compilep))
 168         (message "Error during %s: %s"
 169                  (if compilep "compile" "eval")
 170                  error)))
 171      nil)))
 172
 173 (defun movitz-compile-defun (&optional inverse-optimize-p)
 174   (interactive "P")
 175   (multiple-value-bind (defun-name defun-type)
 176       (movitz-defun-name-and-type)
 177     (when defun-name
 178       (let* ((end (save-excursion (end-of-defun) (point)))
 179              (start (save-excursion
 180                       (fi:beginning-of-defun)
 181                       (point)))
 182              (tmp-file (make-temp-name "/tmp/movitz-compile-defun-"))
 183              (in-package (format "(in-package %s)\n" fi:package))
 184              (msg (format "Movitz compiling %s %s..." defun-type defun-name)))
 185         (with-temp-file tmp-file
 186           (insert in-package))
 187         (write-region start end tmp-file t)
 188         ;; (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" tmp-file)
 189         (if (not inverse-optimize-p)
 190             (movitz-eval-in-acl (format "(movitz:movitz-compile-file \"%s\" :delete-file-p t)" tmp-file) msg)
 191           (movitz-eval-in-acl
 192            (format "(cl:let ((movitz::*compiler-do-optimize* (cl:not movitz::*compiler-do-optimize*)))
 193                       (movitz:movitz-compile-file \"%s\" :delete-file-p t))" tmp-file) msg))))))
 194 ;;;     (with-current-buffer (get-buffer-create "*MOVITZ-eval*")
 195 ;;;       (erase-buffer)
 196 ;;;       (insert (format "(movitz:movitz-compile-file \"%s\")" tmp-file))
 197 ;;;       (movitz-eval-region-internal (point-min) (point-max) nil))))))
 198
 199 (defun movitz-disassemble-defun (not-recursive-p)
 200   (interactive "P")
 201   (multiple-value-bind (defun-name defun-type lambda-list options)
 202       (movitz-defun-name-and-type)
 203     (cond
 204      ((string= "function" defun-type)
 205       (message "Movitz disassembling %s %s..." defun-type defun-name)
 206       (fi:eval-in-lisp
 207        "(cl:let ((defun-name (cl:let ((cl:*package* (cl:find-package :%s))) (cl:read-from-string \"%s\")))
 208                (cl:*print-base* 16))
 209          (movitz::movitz-disassemble defun-name :recursive %s))"
 210        fi:package defun-name (if not-recursive-p "cl:nil" "cl:t"))
 211       (switch-to-buffer "*common-lisp*")
 212       (message "Movitz disassembling %s %s...done." defun-type defun-name))
 213      ((string= "method" defun-type)
 214       (message "Movitz disassembling %s %s %s..." defun-type defun-name lambda-list)
 215       (fi:eval-in-lisp
 216        "(cl:let* ((gf-name (cl:let ((cl:*package* (cl:find-package :%s)))
 217                                   (cl:read-from-string \"%s\")))
 218                   (qualifiers (cl:read-from-string \"%s\"))
 219                   (lambda-list (cl:let ((cl:*package* (cl:find-package :%s)))
 220                                  (cl:read-from-string \"%s\")))
 221                   (cl:*print-base* 16))
 222          (movitz::movitz-disassemble-method gf-name lambda-list qualifiers))"
 223        fi:package defun-name options fi:package lambda-list)
 224       (switch-to-buffer "*common-lisp*")
 225       (message "Movitz disassembling %s %s...done." defun-type defun-name))
 226      ((string= "primitive-function" defun-type)
 227       (message "Movitz disassembling %s %s..." defun-type defun-name)
 228       (fi:eval-in-lisp
 229        "(cl:let ((defun-name (cl:let ((cl:*package* (cl:find-package :%s)))
 230                                 (cl:read-from-string \"%s\")))
 231                (cl:*print-base* 16))
 232          (movitz::movitz-disassemble-primitive defun-name))"
 233        fi:package defun-name)
 234       (switch-to-buffer "*common-lisp*")
 235       (message "Movitz disassembling %s %s...done." defun-type defun-name))
 236      (t (message "Don't know how to Movitz disassemble %s %s." defun-type defun-name)))))
 237
 238 (defun movitz-macroexpand ()
 239   (interactive)
 240   (let* ((start (point))
 241          (end (save-excursion (forward-sexp) (point)))
 242          (tmp-file (make-temp-name "/tmp/movitz-macroexpand-"))
 243          (expansion (unwind-protect
 244                         (progn
 245                           (write-region start end tmp-file t)
 246                           (fi:eval-in-lisp "
 247   (cl:with-output-to-string (cl:*standard-output*)
 248    (cl:let ((cl:*print-pretty* t) (cl:*package* (cl:find-package :%s)))
 249     (cl:prin1
 250      (movitz::translate-program
 251        (movitz::movitz-macroexpand-1
 252         (cl:let ((cl:*package* (cl:find-package :%s)))
 253          (cl:with-open-file (stream \"%s\" :direction :input)
 254           (cl:read stream))))
 255        :common-lisp :muerte.common-lisp))))"
 256                                            fi:package
 257                                            fi:package
 258                                            tmp-file))
 259                       (delete-file tmp-file))))
 260     (if (and (not (find 10 expansion))
 261              (< (length expansion) 80))
 262         (message "Movitz: \"%s\"" expansion)
 263       (let ((buffer (get-buffer-create "*Movitz Macroexpand*")))
 264         (with-current-buffer buffer
 265           (delete-region 1 (point-max))
 266           (common-lisp-mode)
 267           (insert expansion)
 268           (newline 2)
 269           (pop-to-buffer buffer))))))
 270
 271
 272 (add-hook 'fi:inferior-common-lisp-mode-hook
 273           '(lambda ()
 274             (define-key fi:inferior-common-lisp-mode-map "\C-c\C-d" 'movitz-dump-image)))
 275
 276 (add-hook 'fi:common-lisp-mode-hook
 277           '(lambda ()
 278             (when (in-movitz-package-p)
 279               (message "Switching to Movitz keymap.")
 280               (use-local-map (make-movitz-common-lisp-mode-map)))))
 281
 282 (defun movitz-mode ()
 283   "Switch on Movitz-mode."
 284   (interactive)
 285   (use-local-map (make-movitz-common-lisp-mode-map)))
 286
 287 (let ((tag 'fi:common-lisp-indent-hook))
 288   (put 'compiler-values tag '(like with-open-file))
 289   (put 'compiler-values-list tag '(like with-open-file))
 290   (put 'compiler-values-bind tag '(like multiple-value-bind))
 291   (put 'compiler-values-list-bind tag '(like multiple-value-bind))
 292   (put 'compiler-call tag '(like make-instance))
 293   (put 'compiler-values-setq tag '(like multiple-value-setq))
 294   (put 'named-integer-case tag '(like with-slots))
 295   (put 'with-ne2000-io tag '(like with-slots))
 296   (put 'vector-double-dispatch tag '(like case))
 297   (put 'sequence-dispatch tag '(like case))
 298   (put 'sequence-double-dispatch tag '(like case))
 299   (put 'number-double-dispatch tag '(like case))
 300   (put 'simple-stream-dispatch tag '(like case))
 301   (put 'with-inline-assembly tag '(like prog))
 302   (put 'with-inline-assembly-case tag '(like prog))
 303   (put 'do-case tag '(like prog))
 304   (put 'select tag '(like case))
 305   (put 'compiler-typecase tag '(like case)))
 306
 307