[elpa] externals/smalltalk-mode f5845a2 06/34: Emacs interactor mode refinements

[Stefan Monnier]

branch: externals/smalltalk-mode
commit f5845a2791445ddc016b8b2953c3d0f4e642015e
Author: Paolo Bonzini <address@hidden>
Commit: Paolo Bonzini <address@hidden>

    Emacs interactor mode refinements
    
    git-archimport-id: address@hidden/smalltalk--devo--2.2--patch-380
---
 gst-mode.el.in       | 372 +++++++++++++++++----------------------------------
 smalltalk-mode.el.in |   5 +-
 2 files changed, 121 insertions(+), 256 deletions(-)

diff --git a/gst-mode.el.in b/gst-mode.el.in
index a20461a..6c9faf3 100644
--- a/gst-mode.el.in
+++ b/gst-mode.el.in
@@ -51,6 +51,14 @@
 (defvar gst-mode-map
   (let ((keymap (copy-keymap comint-mode-map)))
     (define-key keymap "\C-c\C-t" smalltalk-ctl-t-map)
+
+    (define-key keymap "\C-\M-f"   'smalltalk-forward-sexp)
+    (define-key keymap "\C-\M-b"   'smalltalk-backward-sexp)
+    (define-key keymap "\C-cd" 'smalltalk-doit)
+    (define-key keymap "\C-cf" 'smalltalk-filein)
+    (define-key keymap "\C-cp" 'smalltalk-print)
+    (define-key keymap "\C-cq" 'smalltalk-quit)
+    (define-key keymap "\C-cs" 'smalltalk-snapshot)
     keymap)
   "Keymap used in Smalltalk interactor mode.")
 
@@ -74,18 +82,20 @@ providing COMMAND-LINE as a default (which itself defaults 
to
 `gst-program-name'), answering the string."
   (read-string "Invoke Smalltalk: " (or command-line gst-program-name)))
 
+(defun smalltalk-file-name (str)
+  (if (file-name-directory str) (expand-file-name str) str))
+
 (defun parse-smalltalk-command (&optional str)
   "Parse a list of command-line arguments from STR (default
 `gst-program-name'), adding --emacs-mode and answering the list."
   (unless str (setq str gst-program-name))
   (let (start end result-args)
     (while (setq start (string-match "[^ \t]" str))
-      (setq end (or (string-match " " str start) (length str)))
-      (push (substring str start end) result-args)
-      (setq str (substring str end)))
-    ;; This is an heuristic to insert option --emacs-mode into the gst
-    ;; argument list.  Don't use -f or -- or anything silly like that.
-    (nreverse (cons "--emacs-mode" result-args))))
+               (setq end (or (string-match " " str start) (length str)))
+               (push (smalltalk-file-name (substring str start end)) 
result-args)
+               (if (null (cdr result-args)) (push "--emacs-mode" result-args))
+               (setq str (substring str end)))
+    (nreverse result-args)))
 
 (defun make-gst (name &rest switches)
   (let ((buffer (get-buffer-create (concat "*" name "*")))
@@ -183,13 +193,13 @@ gst-mode-hook is called after comint-mode-hook."
   (kill-all-local-variables)
   (setq major-mode 'gst-mode)
   (setq mode-name "GST")
+  (require 'comint)
+  (comint-mode)
   (setq mode-line-format
        '("" mode-line-modified mode-line-buffer-identification "   "
          global-mode-string "   %[(" mode-name ": " mode-status
          "%n" mode-line-process ")%]----" (-3 . "%p") "-%-"))
 
-  (require 'comint)
-  (comint-mode)
   (setq comint-prompt-regexp smalltalk-prompt-pattern)
   (use-local-map gst-mode-map)
   (make-local-variable 'mode-status)
@@ -199,185 +209,94 @@ gst-mode-hook is called after comint-mode-hook."
   (run-hooks 'comint-mode-hook 'gst-mode-hook))
 
 
-(defun smalltalk-eval-region (start end &optional label)
-  "Evaluate START to END as a Smalltalk expression in Smalltalk window.
-If the expression does not end with an exclamation point, one will be
-added (at no charge)."
-  (interactive "r")
-  (let (str filename line pos)
-    (setq str (buffer-substring start end))
+(defun smalltalk-print-region (start end &optional label)
+  (let (str filename line pos extra)
     (save-excursion
       (save-restriction 
        (goto-char (max start end))
        (smalltalk-backward-whitespace)
-       (if (/= (preceding-char) ?!)    ;canonicalize
-           (setq str (concat str "!")))
+       (setq pos (point))
+       ;canonicalize
+       (while (progn (smalltalk-backward-whitespace)
+                     (or (= (preceding-char) ?!)
+                         (= (preceding-char) ?.)))
+           (backward-char 1))
+
+       (setq str (buffer-substring (min start end) (point)))
+       (setq extra (buffer-substring (point) pos))
+
        ;; unrelated, but reusing save-excursion
        (goto-char (min start end))
-       (setq pos (point))
+       (setq pos (1- (point)))
        (setq filename (buffer-file-name))
        (widen)
        (setq line (1+ (count-lines 1 (point))))))
-    (send-to-smalltalk str (or label "eval")
-                      (list line filename pos))))
+    (send-to-smalltalk (format "(%s) printNl%s\n" str extra)
+                      (or label "eval")
+                      (smalltalk-pos line pos))))
 
-(defun smalltalk-reeval-region (remember)
-  (interactive "P")
-  (and remember
-       (let (rgn start end)
-        (setq rgn (smalltalk-bound-expr))
-        (setq start (car rgn)
-              end (cdr rgn))
-        (setq smalltalk-eval-data
-            (smalltalk-get-eval-region-data start end "re-doIt"))))
-  (apply 'send-to-smalltalk smalltalk-eval-data))
-
-(defun smalltalk-get-eval-region-data (start end &optional label)
-  (interactive "r")
+(defun smalltalk-eval-region (start end &optional label)
+  "Evaluate START to END as a Smalltalk expression in Smalltalk window.
+If the expression does not end with an exclamation point, one will be
+added (at no charge)."
   (let (str filename line pos)
     (setq str (buffer-substring start end))
     (save-excursion
       (save-restriction 
-       (goto-char (max start end))
-       (smalltalk-backward-whitespace)
-       (if (/= (preceding-char) ?!)    ;canonicalize
-           (setq str (concat str "!")))
-       ;; unrelated, but reusing save-excursion
        (goto-char (min start end))
        (setq pos (point))
        (setq filename (buffer-file-name))
        (widen)
        (setq line (1+ (count-lines 1 (point))))))
-    ;; certainly not perfect, should probably use markers to bound the region
-    (list str (or label "eval")
-         (list line filename pos))))
+    (send-to-smalltalk (concat str "\n")
+                      (or label "eval")
+                      (smalltalk-pos line pos))))
 
-(defun smalltalk-eval-region-with-memory (start end &optional label)
-  "Evaluate START to END as a Smalltalk expression in Smalltalk window.
-If the expression does not end with an exclamation point, one will be
-added (at no charge)."
-  (interactive "r")
-
-;  (let (str filename line pos)
-;    (setq str (buffer-substring start end))
-;    (save-excursion
-;      (save-restriction 
-;      (goto-char (max start end))
-;      (smalltalk-backward-whitespace)
-;      (if (/= (preceding-char) ?!)    ;canonicalize
-;          (setq str (concat str "!")))
-;      ;; unrelated, but reusing save-excursion
-;      (goto-char (min start end))
-;      (setq pos (point))
-;      (setq filename (buffer-file-name))
-;      (widen)
-;      (setq line (1+ (count-lines 1 (point))))
-;      )
-;      )
-;    ;; certainly not perfect, should probably use markers to bound the region
-;    (setq smalltalk-eval-data
-;        (list str (or label "eval")
-;              (list line filename pos)))
-  (setq smalltalk-eval-data (smalltalk-get-eval-region-data start end label))
-  (smalltalk-reeval-region 't)) ;)
-
-(defun smalltalk-doit (use-region)
+(defun smalltalk-doit (use-line)
   (interactive "P")
-  (let (start end rgn)
-    (if use-region
-       (progn
-         (setq start (min (mark) (point)))
-         (setq end (max (mark) (point))))
-      (setq rgn (smalltalk-bound-expr))
-      (setq start (car rgn)
-           end (cdr rgn)))
-    (smalltalk-eval-region start end "doIt")))
+  (let* ((start (or (mark) (point)))
+        (end (point))
+        (rgn (if (or use-line
+                     (= start end))
+                 (smalltalk-bound-expr)
+               (cons start end))))
+    (smalltalk-eval-region (car rgn) (cdr rgn) "doIt")))
+
+(defun smalltalk-print (use-line)
+  (interactive "P")
+  (let* ((start (or (mark) (point)))
+        (end (point))
+        (rgn (if (or use-line
+                     (= start end))
+                 (smalltalk-bound-expr)
+               (cons start end))))
+    (smalltalk-print-region (car rgn) (cdr rgn) "printIt")))
 
 (defun smalltalk-bound-expr ()
-  "Returns a cons of the region of the buffer that contains a smalltalk 
expression.
-It's pretty dumb right now...looks for a line that starts with ! at the end and
-a non-white-space line at the beginning, but this should handle the typical
-cases nicely."
-  (let (start end here)
-    (save-excursion
-      (setq here (point))
-      (re-search-forward "^!")
-      (setq end (point))
-      (beginning-of-line)
-      (if (looking-at "^[^ \t\"]")
-         (progn
-           (goto-char here)
-           (re-search-backward "^[^ \t\"]")
-           (while (looking-at "^$") ;this is a hack to get around a bug
-             (re-search-backward "^[^ \t\"]")))) ;with GNU Emacs's regexp 
system
-      (setq start (point))
-      (cons start end))))
-
-(defun smalltalk-compile (use-region)
-  (interactive "P")
-  (let (str start end rgn filename line pos header classname category)
-    (if use-region
-       (progn
-         (setq start (min (point) (mark)))
-         (setq end (max (point) (mark)))
-         (setq str (buffer-substring start end))
-         (save-excursion
-           (goto-char end)
-           (smalltalk-backward-whitespace)
-           (if (/= (preceding-char) ?!) ;canonicalize
-               (setq str (concat str "!"))))
-         (send-to-smalltalk str "compile"))
-      (setq rgn (smalltalk-bound-method))
-      (setq str (buffer-substring (car rgn) (cdr rgn)))
-      (setq filename (buffer-file-name))
-      (setq pos (car rgn))
-      (save-excursion
-       (save-restriction
-         (widen)
-         (setq line (1+ (count-lines 1 (car rgn))))))
-      (if (buffer-file-name)
-         (progn 
-           (save-excursion
-             (re-search-backward "^![ \t]*[A-Za-z]")
-             (setq start (point))
-             (forward-char 1)
-             (search-forward "!")
-             (setq end (point))
-             (setq line (- line (1- (count-lines start end))))
-             ;; extra -1 here to compensate for emacs positions being 1 based,
-             ;; and smalltalk's (really ftell & friends) being 0 based.
-             (setq pos (- pos (- end start) 1)))
-           (setq str (concat (buffer-substring start end) "\n\n" str "!"))
-           (send-to-smalltalk str "compile"
-                      ;-2 accounts for num lines and num chars extra
-                              (list (- line 2) filename (- pos 2))))
-       (save-excursion
-         (re-search-backward "^!\\(.*\\) methodsFor: \\(.*\\)!")
-         (setq classname (buffer-substring
-                          (match-beginning 1) (match-end 1)))
-         (setq category (buffer-substring
-                         (match-beginning 2) (match-end 2)))
-         (goto-char (match-end 0))
-         (setq str (smalltalk-quote-strings str))
-         (setq str (format "%s compile: '%s' classified: %s!\n"
-                           classname (substring str 0 -1) category))
-         (save-excursion (set-buffer (get-buffer-create "junk"))
-                         (erase-buffer)
-                         (insert str))
-         (send-to-smalltalk str "compile"
-                            (list line nil 0)))))))
-
-(defun smalltalk-bound-method ()
-  (let (start end)
-    (save-excursion
-      (re-search-forward "^!")
-      (setq end (point)))
-    (save-excursion
-      (re-search-backward "^[^ \t\"]")
-      (while (looking-at "^$")           ;this is a hack to get around a bug
-       (re-search-backward "^[^ \t\"]")) ;with GNU Emacs's regexp system
-      (setq start (point)))
-    (cons start end)))
+  "Returns a cons of the region of the buffer that contains a smalltalk 
expression."
+  (save-excursion 
+    (beginning-of-line) 
+    (cons
+     (point)
+     (progn (next-line)
+           (smalltalk-backward-whitespace)
+           (point)))))
+
+(defun smalltalk-pos (line pos)
+  (let ((filename (buffer-file-name)))
+    (if filename (list line filename pos) nil)))
+
+(defun smalltalk-compile (start end)
+  (interactive "r")
+  (let ((str (buffer-substring start end))
+       (filename (buffer-file-name))
+       (pos start)
+       (line (save-excursion
+               (save-restriction
+                 (widen)
+                 (setq line (1+ (line-number-at-pos start)))))))
+    (send-to-smalltalk str "compile"
+                      (smalltalk-pos line pos))))
 
 (defun smalltalk-quote-strings (str)
   (let (new-str)
@@ -397,123 +316,72 @@ cases nicely."
                               (expand-file-name 
                                (read-file-name "Snapshot to: "))))))
   (if snapshot-name
-      (send-to-smalltalk (format "ObjectMemory snapshot: '%s'!" "Snapshot"))
-  (send-to-smalltalk "ObjectMemory snapshot!" "Snapshot")))
-
-(defun smalltalk-print (start end)
-  "Evaluate the expression delimited by START and END and print the result.
-Interactively, the region is used.  Printing is done in the standard Smalltalk
-output window."
-  (interactive "r")
-  (let (str)
-    (setq str (buffer-substring start end))
-    (save-excursion
-      (goto-char (max start end))
-      (smalltalk-backward-whitespace)
-      (if (= (preceding-char) ?!)      ;canonicalize
-         (setq str (buffer-substring (min start end)  (point))))
-      (setq str (format "(%s) printNl!" str))
-      (send-to-smalltalk str "print"))))
+      (send-to-smalltalk (format "ObjectMemory snapshot: '%s'\n" "Snapshot"))
+  (send-to-smalltalk "ObjectMemory snapshot\n" "Snapshot")))
 
 (defun smalltalk-quit ()
   "Terminate the Smalltalk session and associated process.  Emacs remains
 running."
   (interactive)
-  (send-to-smalltalk "ObjectMemory quit!" "Quitting"))
+  (send-to-smalltalk "! ! ObjectMemory quit!" "Quitting"))
 
 (defun smalltalk-filein (filename)
   "Do a FileStream>>fileIn: on FILENAME."
   (interactive "fSmalltalk file to load: ")
-  (send-to-smalltalk (format "FileStream fileIn: '%s'!"
+  (send-to-smalltalk (format "FileStream fileIn: '%s'\n"
                             (expand-file-name filename))
                     "fileIn"))
 
+(defun smalltalk-filein-buffer ()
+  (interactive)
+  (send-to-smalltalk (buffer-string) "fileIn" (smalltalk-pos 1 1)))
 
 (defun smalltalk-toggle-decl-tracing ()
   (interactive)
   (send-to-smalltalk
-   "Smalltalk declarationTrace:
-     Smalltalk declarationTrace not!"))
+   "Smalltalk declarationTrace: Smalltalk declarationTrace not\n"))
 
 (defun smalltalk-toggle-exec-tracing ()
   (interactive)
   (send-to-smalltalk 
-   "Smalltalk executionTrace: Smalltalk executionTrace not!"))
+   "Smalltalk executionTrace: Smalltalk executionTrace not\n"))
 
 
 (defun smalltalk-toggle-verbose-exec-tracing ()
   (interactive)
   (send-to-smalltalk
-   "Smalltalk verboseTrace: Smalltalk verboseTrace not!"))
+   "Smalltalk verboseTrace: Smalltalk verboseTrace not\n"))
 
-(defun test-func (arg &optional cmd-arg)
-  (let ((buf (current-buffer)))
-    (unwind-protect
-       (progn
-         (if (not (consp (cdr arg)))
-             (progn
-               (find-file-other-window (car arg))
-               (goto-char (1+ (cdr arg)))
-               (recenter '(0))         ;hack to recenter the window without
-                                       ;redisplaying everything
-               )
-           (switch-to-buffer-other-window (get-buffer-create (car arg)))
-           (smalltalk-mode)
-           (erase-buffer)
-           (insert (format "!%s methodsFor: '%s'!
+(defun send-to-smalltalk (str &optional mode fileinfo)
+    (save-window-excursion
+      (gst gst-program-name)
+      (save-excursion
+       (goto-char (point-max))
+       (beginning-of-line)
+       (if (looking-at smalltalk-prompt-pattern)
+           (progn (end-of-line)
+                  (insert "\n"))))
 
-%s! !" (nth 0 arg) (nth 1 arg) (nth 2 arg)))
-           (beginning-of-buffer)
-           (forward-line 2)))          ;skip to start of method
-      (pop-to-buffer buf))))
+      (if mode (setq mode-status mode)))
 
-(defun send-to-smalltalk (str &optional mode fileinfo)
-  (let (temp-file buf switch-back old-buf)
-    (setq temp-file (concat "/tmp/" (make-temp-name "gst")))
-    (save-excursion
-      (setq buf (get-buffer-create " zap-buffer "))
-      (set-buffer buf)
-      (erase-buffer)
-      (princ str buf)
-      (write-region (point-min) (point-max) temp-file nil 'no-message)
-      )
-    (kill-buffer buf)
-    ;; this should probably be conditional
-    (save-window-excursion (gst gst-program-name))
-;;; why is this like this?
-;;    (if mode
-;;     (progn
-;;       (save-excursion
-;;         (set-buffer (process-buffer *smalltalk-process*))
-;;         (setq mode-status mode))
-;;       ))
-    (setq old-buf (current-buffer))
-    (setq buf (process-buffer *smalltalk-process*))
-    (pop-to-buffer buf)
-    (if mode
-       (setq mode-status mode))
-    (goto-char (point-max))
-    (newline)
-    (pop-to-buffer old-buf)
-;    (if (not (eq buf (current-buffer)))
-;      (progn
-;        (switch-to-buffer-other-window buf)
-;        (setq switch-back t))
-;      )
-;    (if mode
-;      (setq mode-status mode))
-;    (goto-char (point-max))
-;    (newline)
-;    (and switch-back (other-window 1))
-;      ;;(sit-for 0)
     (if fileinfo
-       (process-send-string
-        *smalltalk-process*
-        (format
-         "FileStream fileIn: '%s' line: %d from: '%s' at: %d!\n"
-         temp-file (nth 0 fileinfo) (nth 1 fileinfo) (nth 2 fileinfo)))        
-      (process-send-string *smalltalk-process*
-                          (concat "FileStream fileIn: '" temp-file "'!\n")))))
+       (let (temp-file buf switch-back old-buf)
+         (setq temp-file (concat "/tmp/" (make-temp-name "gst")))
+         (save-excursion
+           (setq buf (get-buffer-create " zap-buffer "))
+           (set-buffer buf)
+           (erase-buffer)
+           (princ str buf)
+           (write-region (point-min) (point-max) temp-file nil 'no-message)
+           )
+         (kill-buffer buf)
+         (process-send-string
+          *smalltalk-process*
+          (format
+           "FileStream fileIn: '%s' line: %d from: '%s' at: %d\n"
+           temp-file (nth 0 fileinfo) (nth 1 fileinfo) (nth 2 fileinfo))))
+      (comint-send-string *smalltalk-process* str))
+    (switch-to-buffer-other-window (process-buffer *smalltalk-process*)))
 
 
 (provide 'gst-mode)
diff --git a/smalltalk-mode.el.in b/smalltalk-mode.el.in
index 54a5618..de5d1ac 100644
--- a/smalltalk-mode.el.in
+++ b/smalltalk-mode.el.in
@@ -126,14 +126,11 @@
 
     ;; -----
 
-    (define-key keymap "\C-cc"     'smalltalk-compile)
     (define-key keymap "\C-cd"     'smalltalk-doit)
-    (define-key keymap "\C-ce"     'smalltalk-eval-region)
-    (define-key keymap "\C-cf"     'smalltalk-filein)
+    (define-key keymap "\C-cf"     'smalltalk-filein-buffer)
     (define-key keymap "\C-cm"     'gst)
     (define-key keymap "\C-cp"     'smalltalk-print)
     (define-key keymap "\C-cq"     'smalltalk-quit)
-    (define-key keymap "\C-cr"     'smalltalk-reeval-region)
     (define-key keymap "\C-cs"     'smalltalk-snapshot)
     
     keymap)