gst-mode.el.in

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright 1988-92, 1994-95, 1999, 2000, 2003, 2007, 2008
;;; Free Software Foundation, Inc.
;;; Written by Steve Byrne.
;;;
;;; This file is part of GNU Smalltalk.
;;;
;;; GNU Smalltalk is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by the Free
;;; Software Foundation; either version 2, or (at your option) any later 
;;; version.
;;;
;;; GNU Smalltalk is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
;;; for more details.
;;;
;;; You should have received a copy of the GNU General Public License along
;;; with GNU Smalltalk; see the file COPYING.  If not, write to the Free
;;; Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Incorporates Frank Caggiano's changes for Emacs 19.
;;; Updates and changes for Emacs 20 and 21 by David Forster

(require 'comint)

(defvar smalltalk-prompt-pattern "^st> *"
  "Regexp to match prompts in smalltalk buffer.")

(defvar *gst-process* nil
  "Holds the GNU Smalltalk process")
(defvar gst-program-name "@bindir@/gst -V"
  "GNU Smalltalk command to run.  Do not use the -a, -f or -- options.")

(defvar smalltalk-command-string nil
  "Non nil means that we're accumulating output from Smalltalk")

(defvar smalltalk-eval-data nil
  "?")

(defvar smalltalk-ctl-t-map
  (let ((keymap (make-sparse-keymap)))
    (define-key keymap "\C-d" 'smalltalk-toggle-decl-tracing)
    (define-key keymap "\C-e" 'smalltalk-toggle-exec-tracing)
    (define-key keymap "\C-v" 'smalltalk-toggle-verbose-exec-tracing)
    keymap)
  "Keymap of subcommands of C-c C-t, tracing related commands")

(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.")

(defun gst (command-line)
  "Invoke GNU Smalltalk"
  (interactive (list (if (null current-prefix-arg)
			 gst-program-name
		       (read-smalltalk-command))))
  (setq gst-program-name command-line)
  (funcall (if (not (eq major-mode 'gst-mode))
	       #'switch-to-buffer-other-window
	     ;; invoked from a Smalltalk interactor window, so stay
	     ;; there
	     #'identity)
	   (apply 'make-gst "gst" (parse-smalltalk-command gst-program-name)))
  (setq *smalltalk-process* (get-buffer-process (current-buffer))))

(defun read-smalltalk-command (&optional command-line)
  "Reads the program name and arguments to pass to Smalltalk,
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 (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 "*")))
	proc status size)
    (setq proc (get-buffer-process buffer))
    (if proc (setq status (process-status proc)))
    (save-excursion
      (set-buffer buffer)
      ;;    (setq size (buffer-size))
      (if (memq status '(run stop))
	  nil
	(if proc (delete-process proc))
	(setq proc (apply  'start-process
			   name buffer
			   "env"
			   ;; I'm choosing to leave these here
			   ;;"-"
			   (format "TERMCAP=emacs:co#%d:tc=unknown:"
				   (frame-width))
			   "TERM=emacs"
			   "EMACS=t"
			   switches))
	(setq name (process-name proc)))
      (goto-char (point-max))
      (set-marker (process-mark proc) (point))
      (set-process-filter proc 'gst-filter)
      (gst-mode))
    buffer))

(defun gst-filter (process string)
  "Make sure that the window continues to show the most recently output
text."
  (let (where ch command-str)
    (setq where 0)			;fake to get through the gate
    (while (and string where)
      (if smalltalk-command-string
	  (setq string (smalltalk-accum-command string)))
      (if (and string
	       (setq where (string-match "\C-a\\|\C-b" string)))
	  (progn
	    (setq ch (aref string where))
	    (cond ((= ch ?\C-a)		;strip these out
		   (setq string (concat (substring string 0 where)
					(substring string (1+ where)))))
		  ((= ch ?\C-b)		;start of command
		   (setq smalltalk-command-string "") ;start this off
		   (setq string (substring string (1+ where))))))))
    (save-excursion
      (set-buffer (process-buffer process))
      (goto-char (point-max))
      (and string
	   (setq mode-status "idle")
	   (insert string))
      (if (process-mark process)
	  (set-marker (process-mark process) (point-max)))))
  ;;  (if (eq (process-buffer process)
  ;;	  (current-buffer))
  ;;      (goto-char (point-max)))
					;  (save-excursion
					;      (set-buffer (process-buffer process))
					;      (goto-char (point-max))
  ;;      (set-window-point (get-buffer-window (current-buffer)) (point-max))
					;      (sit-for 0))
  (let ((buf (current-buffer)))
    (set-buffer (process-buffer process))
    (goto-char (point-max)) (sit-for 0)
    (set-window-point (get-buffer-window (current-buffer)) (point-max))
    (set-buffer buf)))

(defun smalltalk-accum-command (string)
  (let (where)
    (setq where (string-match "\C-a" string))
    (setq smalltalk-command-string
	  (concat smalltalk-command-string (substring string 0 where)))
    (if where
	(progn
	  (unwind-protect		;found the delimiter...do it
	      (smalltalk-handle-command smalltalk-command-string)
	    (setq smalltalk-command-string nil))
	  ;; return the remainder
	  (substring string where))
      ;; we ate it all and didn't do anything with it
      nil)))

(defun smalltalk-handle-command (str)
  (eval (read str)))

(defun gst-mode ()
  "Major mode for interacting Smalltalk subprocesses.

Entry to this mode calls the value of gst-mode-hook with no arguments,
if that value is non-nil; likewise with the value of comint-mode-hook.
gst-mode-hook is called after comint-mode-hook."
  (interactive)
  (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") "-%-"))

  (setq comint-prompt-regexp smalltalk-prompt-pattern)
  (setq comint-use-prompt-regexp t) 
  (use-local-map gst-mode-map)
  (make-local-variable 'mode-status)
  (make-local-variable 'smalltalk-command-string)
  (setq smalltalk-command-string nil)
  (setq mode-status "starting-up")
  (run-hooks 'comint-mode-hook 'gst-mode-hook))


(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)
	(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 (1- (point)))
	(setq filename (buffer-file-name))
	(widen)
	(setq line (1+ (count-lines 1 (point))))))
    (send-to-smalltalk (format "(%s) printNl%s\n" str extra)
		       (or label "eval")
		       (smalltalk-pos line pos))))

(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 (min start end))
	(setq pos (point))
	(setq filename (buffer-file-name))
	(widen)
	(setq line (1+ (count-lines 1 (point))))))
    (send-to-smalltalk (concat str "\n")
		       (or label "eval")
		       (smalltalk-pos line pos))))

(defun smalltalk-doit (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-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."
  (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)
    (save-excursion
      (set-buffer (get-buffer-create " st-dummy "))
      (erase-buffer)
      (insert str)
      (goto-char 1)
      (while (and (not (eobp))
		  (search-forward "'" nil 'to-end))
	(insert "'"))
      (buffer-string))))

(defun smalltalk-snapshot (&optional snapshot-name)
  (interactive (if current-prefix-arg
		   (list (setq snapshot-name 
			       (expand-file-name 
				(read-file-name "Snapshot to: "))))))
  (if snapshot-name
      (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"))

(defun smalltalk-filein (filename)
  "Do a FileStream>>fileIn: on FILENAME."
  (interactive "fSmalltalk file to load: ")
  (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\n"))

(defun smalltalk-toggle-exec-tracing ()
  (interactive)
  (send-to-smalltalk 
   "Smalltalk executionTrace: Smalltalk executionTrace not\n"))


(defun smalltalk-toggle-verbose-exec-tracing ()
  (interactive)
  (send-to-smalltalk
   "Smalltalk verboseTrace: Smalltalk verboseTrace not\n"))

(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"))))

      (if mode (setq mode-status mode))

      (if 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)
	  (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)