home *** CD-ROM | disk | FTP | other *** search
/ The CDPD Public Domain Collection for CDTV 3 / CDPDIII.bin / pd / programming / gnusmalltalk / st.el < prev    next >
Lisp/Scheme  |  1991-12-30  |  55KB  |  1,773 lines
  1. ;;;
  2. ;;; Smalltalk mode for Gnu Emacs
  3. ;;;
  4.  
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;;;
  7. ;;; Copyright (C) 1988, 1989, 1990 Free Software Foundation, Inc.
  8. ;;; Written by Steve Byrne.
  9. ;;;
  10. ;;; This file is part of GNU Smalltalk.
  11. ;;;
  12. ;;; GNU Smalltalk is free software; you can redistribute it and/or modify it
  13. ;;; under the terms of the GNU General Public License as published by the Free
  14. ;;; Software Foundation; either version 1, or (at your option) any later 
  15. ;;; version.
  16. ;;;
  17. ;;; GNU Smalltalk is distributed in the hope that it will be useful, but
  18. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19. ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20. ;;; for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License along
  23. ;;; with GNU Smalltalk; see the file COPYING.  If not, write to the Free
  24. ;;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. (require 'browse)
  29. (provide 'st)
  30.  
  31. (defvar smalltalk-name-regexp "[A-Za-z][A-Za-z0-9]*"
  32.   "A regular expression that matches a Smalltalk identifier")
  33.  
  34. (defvar smalltalk-keyword-regexp (concat smalltalk-name-regexp ":")
  35.   "A regular expression that matches a Smalltalk keyword")
  36.  
  37. (defvar smalltalk-name-chars "a-zA-Z0-9"
  38.   "The collection of character that can compose a Smalltalk identifier")
  39.  
  40. (defvar smalltalk-whitespace " \t\n\f")
  41.  
  42. (defvar smalltalk-mode-abbrev-table nil
  43.   "Abbrev table in use in smalltalk-mode buffers.")
  44. (define-abbrev-table 'smalltalk-mode-abbrev-table ())
  45.  
  46. (defvar smalltalk-c-style-tab t
  47.   "Non-nil means that tab reindents, M-tab tabs to next tab stop.
  48. Nil has the opposite effect.  Examined only when loading. ")
  49.  
  50. ;;; this hack was to play around with adding Smalltalk-specific menu items
  51. ;;; to the Emacstool on the Sun.
  52. (if (featurep 'sun-mouse)
  53.     (let (new-menu i)
  54.       (defmenu smalltalk-menu
  55.     ("Smalltalk")
  56.     ("Do it"))
  57.       (setq new-menu (make-vector (1+ (length emacs-menu)) nil))
  58.       (aset new-menu 0 (aref emacs-menu 0))
  59.       (setq i 1)
  60.       (while (< i (length emacs-menu))
  61.     (aset new-menu (1+ i) (aref emacs-menu i))
  62.     (setq i (1+ i)))
  63.       (aset new-menu 1 '("Smalltalk" . smalltalk-menu))
  64.       (setq emacs-menu new-menu)
  65.       )
  66.   )
  67.  
  68. (defvar smalltalk-mode-map nil "Keymap used in Smalltalk mode.")
  69. (if smalltalk-mode-map
  70.     ()
  71.   (setq smalltalk-mode-map (make-sparse-keymap))
  72.   (if smalltalk-c-style-tab
  73.       (progn
  74.     (define-key smalltalk-mode-map "\M-\t" 'smalltalk-tab)
  75.     (define-key smalltalk-mode-map "\t"    'smalltalk-reindent)
  76.     )
  77.     (define-key smalltalk-mode-map "\t" 'smalltalk-tab)
  78.     (define-key smalltalk-mode-map "\M-\t"    'smalltalk-reindent)
  79.     )
  80.   (define-key smalltalk-mode-map "\177" 'backward-delete-char-untabify)
  81.   (define-key smalltalk-mode-map "\n" 'smalltalk-newline-and-indent)
  82.   (define-key smalltalk-mode-map "\C-\M-a" 'smalltalk-begin-of-defun)
  83.   (define-key smalltalk-mode-map "\C-\M-f" 'smalltalk-forward-sexp)
  84.   (define-key smalltalk-mode-map "\C-\M-b" 'smalltalk-backward-sexp)
  85.   (define-key smalltalk-mode-map "!"     'smalltalk-bang)
  86.   (define-key smalltalk-mode-map ":"    'smalltalk-colon)
  87.   )
  88.  
  89. (defvar smalltalk-mode-syntax-table nil
  90.   "Syntax table in use in smalltalk-mode buffers.")
  91.  
  92. (if smalltalk-mode-syntax-table
  93.     ()
  94.   (setq smalltalk-mode-syntax-table (make-syntax-table))
  95.   (modify-syntax-entry ?\' "\"" smalltalk-mode-syntax-table)
  96.   ;; GNU Emacs is deficient: there seems to be no way to have a comment char
  97.   ;; that is both the start and end character.  This is going to cause
  98.   ;; me great pain.
  99.   (modify-syntax-entry ?\" "\"" smalltalk-mode-syntax-table)
  100.   (modify-syntax-entry ?+ "." smalltalk-mode-syntax-table)
  101.   (modify-syntax-entry ?- "." smalltalk-mode-syntax-table)
  102.   (modify-syntax-entry ?* "." smalltalk-mode-syntax-table)
  103.   (modify-syntax-entry ?/ "." smalltalk-mode-syntax-table)
  104.   (modify-syntax-entry ?= "." smalltalk-mode-syntax-table)
  105.   (modify-syntax-entry ?% "." smalltalk-mode-syntax-table)
  106.   (modify-syntax-entry ?< "." smalltalk-mode-syntax-table)
  107.   (modify-syntax-entry ?> "." smalltalk-mode-syntax-table)
  108.   (modify-syntax-entry ?& "." smalltalk-mode-syntax-table)
  109.   (modify-syntax-entry ?$ "\\" smalltalk-mode-syntax-table)
  110.   (modify-syntax-entry ?# "'" smalltalk-mode-syntax-table)
  111.   (modify-syntax-entry ?| "." smalltalk-mode-syntax-table)
  112.   (modify-syntax-entry ?_ "." smalltalk-mode-syntax-table)
  113.   (modify-syntax-entry ?\\ "." smalltalk-mode-syntax-table)
  114.   (modify-syntax-entry ?! "." smalltalk-mode-syntax-table)
  115.   )
  116.  
  117. (defconst smalltalk-indent-amount 4
  118.   "*'Tab size'; used for simple indentation alignment.")
  119.  
  120. (autoload 'smalltalk-install-change-log-functions "st-changelog.el")
  121. ;;(autoload 'smalltalk-install-change-log-functions "~/mst/st-changelog.el")
  122.  
  123. (defun stm ()
  124.   (smalltalk-mode))
  125.  
  126. (defun smalltalk-mode ()
  127.   "Major mode for editing Smalltalk code.
  128. Comments are delimited with \" ... \".
  129. Paragraphs are separated by blank lines only.
  130. Delete converts tabs to spaces as it moves back.
  131.  
  132. Of special interest are the commands for interacting with a live Smalltalk
  133. session:
  134. \\[mst]
  135.     Invoke the Smalltalk interactor, which basically keeps the current buffer
  136.     in one window, and creates another window with a running Smalltalk in it.
  137.     The other window behaves essentially like a shell-mode window when the
  138.     cursor is in it, but it will receive the operations requested when the
  139.     interactor related commands are used.
  140.  
  141. \\[smalltalk-doit]
  142.     interactively evaluate the expression that the cursor is in in a Smalltalk
  143.     mode window, or with an argument execute the region as smalltalk code
  144.  
  145. \\[smalltalk-compile]
  146.     compile the method definition that the cursor is currently in.
  147.  
  148. \\[smalltalk-snapshot]
  149.     produce a snapshot binary image of the current working Smalltalk system.
  150.     Useful to do periodically as you define new methods to save the state of
  151.     your work.
  152.  
  153. \\{smalltalk-mode-map}
  154.  
  155. Turning on Smalltalk mode calls the value of the variable
  156. smalltalk-mode-hook with no args, if that value is non-nil."
  157.   (interactive)
  158.   (kill-all-local-variables)
  159.   (use-local-map smalltalk-mode-map)
  160.   (setq major-mode 'smalltalk-mode)
  161.   (setq mode-name "Smalltalk")
  162.   (setq local-abbrev-table smalltalk-mode-abbrev-table)
  163.   (set-syntax-table smalltalk-mode-syntax-table)
  164.   (make-local-variable 'paragraph-start)
  165.   (setq paragraph-start (concat "^$\\|" page-delimiter))
  166.   (make-local-variable 'paragraph-separate)
  167.   (setq paragraph-separate paragraph-start)
  168.   (make-local-variable 'paragraph-ignore-fill-prefix)
  169.   (setq paragraph-ignore-fill-prefix t)
  170.   (make-local-variable 'indent-line-function)
  171.   (setq indent-line-function 'smalltalk-indent-line)
  172.   (make-local-variable 'require-final-newline)
  173.   (setq require-final-newline t)
  174.   (make-local-variable 'comment-start)
  175.   (setq comment-start "\"")
  176.   (make-local-variable 'comment-end)
  177.   (setq comment-end "\"")
  178.   (make-local-variable 'comment-column)
  179.   (setq comment-column 32)
  180.   (make-local-variable 'comment-start-skip)
  181.   (setq comment-start-skip "\" *")
  182.   (make-local-variable 'comment-indent-hook)
  183.   (setq comment-indent-hook 'smalltalk-comment-indent)
  184.   (make-local-variable 'parse-sexp-ignore-comments)
  185.   (setq parse-sexp-ignore-comments nil)    ;for interactive f-b sexp
  186.   (smalltalk-install-change-log-functions)
  187.   (run-hooks 'smalltalk-mode-hook))
  188.  
  189. ;; This is used by indent-for-comment
  190. ;; to decide how much to indent a comment in Smalltalk code
  191. ;; based on its context.
  192. (defun smalltalk-comment-indent ()
  193.   (if (looking-at "^\"")
  194.       0                ;Existing comment at bol stays there.
  195.     (save-excursion
  196.       (skip-chars-backward " \t")
  197.       (max (1+ (current-column))    ;Else indent at comment column
  198.        comment-column))))    ; except leave at least one space.
  199.  
  200. (defun smalltalk-indent-line ()
  201.   (let (indent-amount is-keyword)
  202.     (save-excursion
  203.       (beginning-of-line)
  204.       (smalltalk-forward-whitespace)
  205.       (if (looking-at "[a-zA-Z][a-zA-Z0-9]*:") ;indent for colon
  206.       (let ((parse-sexp-ignore-comments t))
  207.         (beginning-of-line)
  208.         (smalltalk-backward-whitespace)
  209.         (if (not (memq (preceding-char) '(?\;)))
  210.         (setq is-keyword t)
  211.           )
  212.         )
  213.     )
  214.       )
  215.     (if is-keyword
  216.     (smalltalk-indent-for-colon)
  217.       (setq indent-amount (calculate-smalltalk-indent))
  218.       (smalltalk-indent-to-column indent-amount)
  219.       )
  220.     )
  221.   )
  222.  
  223. (defun calculate-smalltalk-indent ()
  224.   (let (needs-indent indent-amount done c state start-of-line
  225.              (parse-sexp-ignore-comments t))
  226.     (save-excursion
  227.       (save-restriction
  228.     (widen)
  229.     (narrow-to-region (point-min) (point)) ;only care about what's before
  230.     (setq state (parse-partial-sexp (point-min) (point)))
  231.     (cond ((equal (nth 3 state) ?\") ;in a comment
  232.            (save-excursion
  233.          (smalltalk-backward-comment)
  234.          (setq indent-amount (1+ (current-column)))
  235.          ))
  236.           ((equal (nth 3 state) ?')    ;in a string
  237.            (setq indent-amount 0))
  238.           (t
  239.            (save-excursion
  240.          (smalltalk-backward-whitespace)
  241.          (if (or (bobp)
  242.              (= (preceding-char) ?!))
  243.              (setq indent-amount 0))
  244.          )
  245.            ))
  246.     (if (null indent-amount)
  247.         (progn
  248.           (smalltalk-narrow-to-method)
  249.           (beginning-of-line)
  250.           (setq state (parse-partial-sexp (point-min) (point)))
  251.           (narrow-to-paren state)
  252.           (smalltalk-backward-whitespace)
  253.           (cond ((bobp)        ;must be first statment in block or exp
  254.              (if (nth 1 state)    ;we're in a paren exp
  255.              (setq indent-amount (smalltalk-current-column))
  256.                ;; we're top level
  257.                (setq indent-amount smalltalk-indent-amount)))
  258.             ((= (preceding-char) ?.) ;at end of statement
  259.              (smalltalk-find-statement-begin)
  260.              (setq indent-amount (smalltalk-current-column)))
  261.             ((= (preceding-char) ?:)
  262.              (beginning-of-line)
  263.              (smalltalk-forward-whitespace)
  264.              (setq indent-amount (+ (smalltalk-current-column)
  265.                         smalltalk-indent-amount))
  266.              )
  267.             ((= (preceding-char) ?>) ;maybe <primitive: xxx>
  268.              (setq orig (point))
  269.              (backward-char 1)
  270.              (smalltalk-backward-whitespace)
  271.              (skip-chars-backward "0-9")
  272.              (smalltalk-backward-whitespace)
  273.              (if (= (preceding-char) ?:)
  274.              (progn
  275.                (backward-char 1)
  276.                (skip-chars-backward "a-zA-Z")
  277.                (if (looking-at "primitive:")
  278.                    (progn
  279.                  (smalltalk-backward-whitespace)
  280.                  (if (= (preceding-char) ?<)
  281.                      (setq indent-amount (1- (smalltalk-current-column))))
  282.                  )
  283.                  )
  284.                )
  285.                )
  286.              (if (null indent-amount)
  287.              (progn
  288.                (goto-char orig)
  289.                (smalltalk-find-statement-begin)
  290.                (setq indent-amount (+ (smalltalk-current-column)
  291.                           smalltalk-indent-amount))
  292.                )
  293.                )
  294.              )
  295.             (t            ;must be a statement continuation
  296.              (save-excursion
  297.                (beginning-of-line)
  298.                (setq start-of-line (point)))
  299.              (smalltalk-find-statement-begin)
  300.              (setq indent-amount (+ (smalltalk-current-column)
  301.                         smalltalk-indent-amount))
  302.              )
  303.             )
  304.           )
  305.       )
  306.     indent-amount)
  307.       )
  308.     )
  309.   )
  310.  
  311.  
  312. (defun smalltalk-previous-nonblank-line ()
  313.   (forward-line -1)
  314.   (while (and (not (bobp))
  315.           (looking-at "^[ \t]*$"))
  316.     (forward-line -1))
  317.   )
  318.  
  319. (defun smalltalk-tab ()
  320.   (interactive)
  321.   (let (col)
  322.     ;; round up, with overflow
  323.     (setq col (* (/ (+ (current-column) smalltalk-indent-amount)
  324.             smalltalk-indent-amount)
  325.          smalltalk-indent-amount))
  326.     (indent-to-column col)
  327.   ))
  328.  
  329. (defun smalltalk-begin-of-defun ()
  330.   "Skips to the beginning of the current method.  If already at
  331. the beginning of a method, skips to the beginning of the previous
  332. one."
  333.   (interactive)
  334.   (let ((parse-sexp-ignore-comments t) here delim start)
  335.     (setq here (point))
  336.     (while (and (search-backward "!" nil 'to-end)
  337.         (setq delim (smalltalk-in-string)))
  338.       (search-backward delim))
  339.     (setq start (point))
  340.     (if (looking-at "!")
  341.     (forward-char 1))
  342.     (smalltalk-forward-whitespace)
  343.     ;; check to see if we were already at the start of a method
  344.     ;; in which case, the semantics are to go to the one preceeding
  345.     ;; this one
  346.     (if (and (= here (point))
  347.          (/= start (point-min)))
  348.     (progn
  349.       (goto-char start)
  350.       (smalltalk-backward-whitespace) ;may be at ! "foo" !
  351.       (if (= (preceding-char) ?!)
  352.           (backward-char 1))
  353.       (smalltalk-begin-of-defun)    ;and go to the next one
  354.       )
  355.       )
  356.     )
  357.   )
  358.  
  359. (defun smalltalk-in-string ()
  360.   "Returns non-nil delimiter as a string if the current location is
  361. actually inside a string or string like context."
  362.   (let (state)
  363.     (setq state (parse-partial-sexp (point-min) (point)))
  364.     (and (nth 3 state)
  365.      (char-to-string (nth 3 state)))
  366.     )
  367.   )
  368.  
  369.  
  370.  
  371. (defun smalltalk-forward-whitespace ()
  372.   "Skip white space and comments forward, stopping at end of buffer
  373. or non-white space, non-comment character"
  374.   (while (looking-at (concat "[" smalltalk-whitespace "\"]"))
  375.     (skip-chars-forward smalltalk-whitespace)
  376.     (if (= (following-char) ?\")
  377.     (forward-sexp 1)))
  378.   )
  379.  
  380. (defun smalltalk-backward-whitespace ()
  381.   "Like forward whitespace only going towards the start of the buffer"
  382.   (while (progn (skip-chars-backward smalltalk-whitespace)
  383.         (= (preceding-char) ?\"))
  384.     (backward-sexp 1))
  385.   )
  386.  
  387. (defun smalltalk-forward-sexp (n)
  388.   (interactive "p")
  389.   (let (i)
  390.     (cond ((< n 0)
  391.        (smalltalk-backward-sexp (- n)))
  392.       ((null parse-sexp-ignore-comments)
  393.        (forward-sexp n))
  394.       (t
  395.        (while (> n 0)
  396.          (smalltalk-forward-whitespace)
  397.          (forward-sexp 1)
  398.          (setq n (1- n))
  399.          )
  400.        )
  401.       )
  402.     )
  403.   )
  404.  
  405. (defun smalltalk-backward-sexp (n)
  406.   (interactive "p")
  407.   (let (i)
  408.     (cond ((< n 0)
  409.        (smalltalk-forward-sexp (- n)))
  410.       ((null parse-sexp-ignore-comments)
  411.        (backward-sexp n))
  412.       (t
  413.        (while (> n 0)
  414.          (smalltalk-backward-whitespace)
  415.          (backward-sexp 1)
  416.          (setq n (1- n))
  417.          )
  418.       )))
  419.   )
  420.  
  421. (defun smalltalk-reindent ()
  422.   (interactive)
  423.   ;; +++ Still loses if at first charcter on line
  424.   (smalltalk-indent-line)
  425. ;  (let ((pos (- (point-max) (point))))
  426. ;    (beginning-of-line)
  427. ;    (delete-horizontal-space)
  428. ;    (delete-char -1)
  429. ;    (smalltalk-newline-and-indent 1)
  430. ;    (goto-char (- (point-max) pos))
  431. ;    (if (looking-at "[\t ]*$")
  432. ;    (end-of-line))
  433. ;    )
  434.   )
  435.  
  436. (defun smalltalk-newline-and-indent (levels)
  437.   "Called basically to do newline and indent.  Sees if the current line is a
  438. new statement, in which case the indentation is the same as the previous
  439. statement (if there is one), or is determined by context; or, if the current
  440. line is not the start of a new statement, in which case the start of the
  441. previous line is used, except if that is the start of a new line in which case
  442. it indents by smalltalk-indent-amount."
  443.   (interactive "p")
  444.   (newline)
  445.   (smalltalk-indent-line)
  446.   )
  447.  
  448. ;;;(defun smalltalk-newline-and-indent (levels)
  449. ;;;  "Called basically to do newline and indent.  Sees if the current line is a
  450. ;;;new statement, in which case the indentation is the same as the previous
  451. ;;;statement (if there is one), or is determined by context; or, if the current
  452. ;;;line is not the start of a new statement, in which case the start of the
  453. ;;;previous line is used, except if that is the start of a new line in which case
  454. ;;;it indents by smalltalk-indent-amount."
  455. ;;;  (interactive "p")
  456. ;;;  (let (needs-indent indent-amount done c state start-of-line
  457. ;;;             (parse-sexp-ignore-comments t))
  458. ;;;    (save-excursion
  459. ;;;      (save-restriction
  460. ;;;    (save-excursion
  461. ;;;      (smalltalk-backward-whitespace)
  462. ;;;      (if (or (bobp)
  463. ;;;          (= (preceding-char) ?!))
  464. ;;;          (setq indent-amount 0))
  465. ;;;      )
  466. ;;;    (if (null indent-amount)
  467. ;;;        (progn
  468. ;;;          (smalltalk-narrow-to-method)
  469. ;;;          (setq state (parse-partial-sexp (point-min) (point)))
  470. ;;;          (if (nth 3 state)        ;in a string or comment
  471. ;;;          (cond ((= (nth 3 state) ?\") ;in a comment
  472. ;;;             (save-excursion
  473. ;;;               (smalltalk-backward-comment)
  474. ;;;               (setq indent-amount (1+ (current-column)))
  475. ;;;               ))
  476. ;;;            ((= (nth 3 state) ?')    ;in a string
  477. ;;;             (setq indent-amount 0))
  478. ;;;            )
  479. ;;;        (narrow-to-paren state)
  480. ;;;        (smalltalk-backward-whitespace)
  481. ;;;        (cond ((bobp)            ;must be first statment in block or exp
  482. ;;;               (if (nth 1 state)    ;we're in a paren exp
  483. ;;;               (setq indent-amount (smalltalk-current-column))
  484. ;;;             ;; we're top level
  485. ;;;             (setq indent-amount smalltalk-indent-amount)))
  486. ;;;              ((= (preceding-char) ?.) ;at end of statement
  487. ;;;               (smalltalk-find-statement-begin)
  488. ;;;               (setq indent-amount (smalltalk-current-column)))
  489. ;;;              ((= (preceding-char) ?:)
  490. ;;;               (beginning-of-line)
  491. ;;;               (smalltalk-forward-whitespace)
  492. ;;;               (setq indent-amount (+ (smalltalk-current-column)
  493. ;;;                          smalltalk-indent-amount))
  494. ;;;               )
  495. ;;;              ((= (preceding-char) ?>) ;maybe <primitive: xxx>
  496. ;;;               (setq orig (point))
  497. ;;;               (backward-char 1)
  498. ;;;               (smalltalk-backward-whitespace)
  499. ;;;               (skip-chars-backward "0-9")
  500. ;;;               (smalltalk-backward-whitespace)
  501. ;;;               (if (= (preceding-char) ?:)
  502. ;;;               (progn
  503. ;;;                 (backward-char 1)
  504. ;;;                 (skip-chars-backward "a-zA-Z")
  505. ;;;                 (if (looking-at "primitive:")
  506. ;;;                 (progn
  507. ;;;                   (smalltalk-backward-whitespace)
  508. ;;;                   (if (= (preceding-char) ?<)
  509. ;;;                       (setq indent-amount (1- (smalltalk-current-column))))
  510. ;;;                   )
  511. ;;;                   )
  512. ;;;                 )
  513. ;;;             )
  514. ;;;               (if (null indent-amount)
  515. ;;;               (progn
  516. ;;;                 (goto-char orig)
  517. ;;;                 (smalltalk-find-statement-begin)
  518. ;;;                 (setq indent-amount (+ (smalltalk-current-column)
  519. ;;;                              smalltalk-indent-amount))
  520. ;;;                 )
  521. ;;;             )
  522. ;;;               )
  523. ;;;              (t            ;must be a statement continuation
  524. ;;;               (save-excursion
  525. ;;;             (beginning-of-line)
  526. ;;;             (setq start-of-line (point)))
  527. ;;;               (smalltalk-find-statement-begin)
  528. ;;;               (setq indent-amount (+ (smalltalk-current-column)
  529. ;;;                          smalltalk-indent-amount))
  530. ;;;               )
  531. ;;;              )
  532. ;;;        )
  533. ;;;          ))
  534. ;;;    )
  535. ;;;      )
  536. ;;;    (newline)
  537. ;;;    (delete-horizontal-space)        ;remove any carried-along whites
  538. ;;;    (indent-to indent-amount)
  539. ;;;    (if (looking-at "[a-zA-Z][a-zA-Z0-9]*:") ;indent for colon
  540. ;;;    (save-excursion
  541. ;;;      (goto-char (1- (match-end 0)))
  542. ;;;      (smalltalk-indent-for-colon))
  543. ;;;    )
  544. ;;;    ))
  545.  
  546. (defun smalltalk-current-column ()
  547.   "Returns the current column of the given line, regardless of narrowed buffer."
  548.   (save-restriction
  549.     (widen)
  550.     (current-column)            ;this changed in 18.56
  551.     )
  552.   )
  553.  
  554. (defun smalltalk-find-statement-begin ()
  555.   "Leaves the point at the first non-blank, non-comment character of a new
  556. statement.  If begininning of buffer is reached, then the point is left there.
  557. This routine only will return with the point pointing at the first non-blank
  558. on a line; it won't be fooled by multiple statements on a line into stopping
  559. prematurely.  Also, goes to start of method if we started in the method
  560. selector."
  561.   (let (start ch)
  562.     (if (= (preceding-char) ?.)        ;if we start at eos
  563.     (backward-char 1))        ;we find the begin of THAT stmt
  564.     (while (and (null start) (not (bobp)))
  565.       (smalltalk-backward-whitespace)
  566.       (cond ((= (setq ch (preceding-char)) ?.)
  567.          (let (saved-point)
  568.            (setq saved-point (point))
  569.            (smalltalk-forward-whitespace)
  570.            (if (smalltalk-white-to-bolp)
  571.            (setq start (point))
  572.          (goto-char saved-point)
  573.          (smalltalk-backward-sexp 1))
  574.            ))
  575.         ((= ch ?^)            ;HACK -- presuming that when we back
  576.                     ;up into a return that we're at the
  577.                     ;start of a statement
  578.          (backward-char 1)
  579.          (setq start (point))
  580.          )
  581.         ((= ch ?!)
  582.          (smalltalk-forward-whitespace)
  583.          (setq start (point))
  584.          )
  585.         (t
  586.          (smalltalk-backward-sexp 1)
  587.          )
  588.         )
  589.       )
  590.     (if (null start)
  591.       (progn
  592.     (goto-char (point-min))
  593.     (smalltalk-forward-whitespace)
  594.     (setq start (point))))
  595.   start))
  596.  
  597.  
  598. ;;; hold on to this code for a little bit, but then flush it
  599. ;;;
  600. ;;;      ;; not in a comment, so skip backwards for some indication
  601. ;;;      (smalltalk-backward-whitespace)
  602. ;;;      (if (bobp)
  603. ;;;          (setq indent-amount smalltalk-indent-amount)
  604. ;;;        (setq c (preceding-char))
  605. ;;;        (cond ((eq c ?.)        ;this is a new statement
  606. ;;;           (smalltalk-backward-statement)
  607. ;;;           (setq indent-amount (current-column)))
  608. ;;;          ((memq c '(?|
  609. ;;;
  610. ;;;                 (smalltalk-narrow-to-method)
  611. ;;;
  612. ;;;                 (smalltalk-backward-whitespace)
  613. ;;;                 (setq c (preceding-char))
  614. ;;;                 (cond
  615. ;;;                  ((memq c '(?. ?| ?\[ ?\( )) (setq done t))
  616. ;;;                  ((eq c ?:)
  617. ;;;                   (backward-char 1)
  618. ;;;                   (skip-chars-backward "a-zA-Z0-9")
  619. ;;;                   (setq indent-amount (current-column)))
  620. ;;;                  (t
  621. ;;;                   (smalltalk-backward-sexp 1)))
  622. ;;;                 )
  623. ;;;
  624. ;;;             )
  625. ;;;           )
  626. ;;;          (if indent-amount
  627. ;;;              (save-excursion
  628. ;;;            (beginning-of-line)
  629. ;;;            (delete-horizontal-space)
  630. ;;;            (indent-to indent-amount))
  631. ;;;            )
  632. ;;;          (insert last-command-char)
  633. ;;;          ))
  634.  
  635. (defun narrow-to-paren (state)
  636.   "Narrows the region to between point and the closest previous open paren.
  637. Actually, skips over any block parameters, and skips over the whitespace
  638. following on the same line."
  639.   (let ((paren-addr (nth 1 state))
  640.     start c done)
  641.     (if (not paren-addr) nil
  642.       (save-excursion
  643.     (goto-char paren-addr)
  644.     (setq c (following-char))
  645.     (cond ((eq c ?\()
  646.            (setq start (1+ (point))))
  647.           ((eq c ?\[)
  648.            (setq done nil)
  649.            (forward-char 1)
  650.            (while (not done)
  651.          (skip-chars-forward " \t")
  652.          (setq c (following-char))
  653.          (cond ((eq c ?:)
  654.             (smalltalk-forward-sexp 1))
  655.                ((eq c ?|)
  656.             (forward-char 1) ;skip vbar
  657.             (skip-chars-forward " \t")
  658.             (setq done t))    ;and leave
  659.                (t
  660.             (setq done t))
  661.                )
  662.          )
  663.            (setq start (point))
  664.            )
  665.           )
  666.     )
  667.       (narrow-to-region start (point))
  668.       )
  669.     )
  670.   )
  671.  
  672.  
  673. (defun smalltalk-at-method-begin ()
  674.   "Returns T if at the beginning of a method definition, otherwise nil"
  675.   (let ((parse-sexp-ignore-comments t))
  676.     (if (bolp)
  677.     (save-excursion
  678.       (smalltalk-backward-whitespace)
  679.       (= (preceding-char) ?!)
  680.       )
  681.       )
  682.     )
  683.   )
  684.     
  685.   
  686.  
  687.  
  688. (defun smalltalk-colon ()
  689.   "Possibly reindents a line when a colon is typed.
  690. If the colon appears on a keyword that's at the start of the line (ignoring
  691. whitespace, of course), then the previous line is examined to see if there
  692. is a colon on that line, in which case this colon should be aligned with the
  693. left most character of that keyword.  This function is not fooled by nested
  694. expressions."
  695.   (interactive)
  696.   (let (needs-indent (parse-sexp-ignore-comments t))
  697.     (save-excursion
  698.       (skip-chars-backward "A-Za-z0-9")
  699.       (if (and (looking-at smalltalk-name-regexp)
  700.            (not (smalltalk-at-method-begin)))
  701.       (setq needs-indent (smalltalk-white-to-bolp))
  702.     )
  703.       )
  704.     (and needs-indent
  705.      (smalltalk-indent-for-colon))
  706. ;; out temporarily
  707. ;;    (expand-abbrev)            ;I don't think this is the "correct"
  708. ;;                    ;way to do this...I suspect that
  709. ;;                    ;some flavor of "call interactively"
  710. ;;                    ;is better.
  711.     (self-insert-command 1)
  712.     )
  713.   )
  714.  
  715.  
  716. (defun smalltalk-indent-for-colon ()
  717.   (let (indent-amount c start-line state done default-amount
  718.              (parse-sexp-ignore-comments t))
  719.     ;; we're called only for lines which look like "<whitespace>foo:"
  720.     (save-excursion
  721.       (save-restriction
  722.     (widen)
  723.     (smalltalk-narrow-to-method)
  724.     (beginning-of-line)
  725.     (setq state (parse-partial-sexp (point-min) (point)))
  726.     (narrow-to-paren state)
  727.     (narrow-to-region (point-min) (point))
  728.     (setq start-line (point))
  729.     (smalltalk-backward-whitespace)
  730.     (cond
  731.      ((bobp)
  732.       (setq indent-amount (smalltalk-current-column)))
  733.      ((eq (setq c (preceding-char)) ?\;)    ; cascade before, treat as stmt continuation
  734.       (smalltalk-find-statement-begin)
  735.       (setq indent-amount (+ (smalltalk-current-column)
  736.                  smalltalk-indent-amount)))
  737.      ((eq c ?.)    ; stmt end, indent like it (syntax error here?)
  738.       (smalltalk-find-statement-begin)
  739.       (setq indent-amount (smalltalk-current-column)))
  740.      (t                ;could be a winner
  741.         (smalltalk-find-statement-begin)
  742.         ;; we know that since we weren't at bobp above after backing
  743.         ;; up over white space, and we didn't run into a ., we aren't
  744.         ;; at the beginning of a statement, so the default indentation
  745.         ;; is one level from statement begin
  746.         (setq default-amount
  747.           (+ (smalltalk-current-column) ;just in case
  748.              smalltalk-indent-amount))
  749.         ;; might be at the beginning of a method (the selector), decide
  750.         ;; this here
  751.         (if (not (looking-at smalltalk-keyword-regexp ))
  752.         ;; not a method selector
  753.         (while (and (not done) (not (eobp)))
  754.           (smalltalk-forward-sexp 1) ;skip over receiver
  755.           (smalltalk-forward-whitespace)
  756.           (cond ((eq (following-char) ?\;)
  757.              (setq done t)
  758.              (setq indent-amount default-amount))
  759.             ((and (null indent-amount) ;pick up only first one
  760.                   (looking-at smalltalk-keyword-regexp))
  761.              (setq indent-amount (smalltalk-current-column))
  762.              )
  763.             ) 
  764.           )
  765.           )
  766.         (and (null indent-amount)
  767.          (setq indent-amount default-amount))
  768.         )
  769.      )
  770.     )
  771.       )
  772.     (if indent-amount
  773.     (smalltalk-indent-to-column indent-amount))
  774.     )
  775.   )
  776.  
  777. (defun smalltalk-indent-to-column (col)
  778.   (save-excursion
  779.     (beginning-of-line)
  780.     (delete-horizontal-space)
  781.     (indent-to col)
  782.     )
  783.   (if (bolp)
  784.       ;;delete horiz space may have moved us to bol instead of staying where
  785.       ;; we were.  this fixes it up.
  786.       (move-to-column col))
  787.   )
  788.  
  789. (defun smalltalk-narrow-to-method ()
  790.   "Narrows the buffer to the contents of the method, exclusive of the
  791. method selector and temporaries."
  792.   (let ((end (point))
  793.     (parse-sexp-ignore-comments t)
  794.     done handled)
  795.     (save-excursion
  796.       (smalltalk-begin-of-defun)
  797.       (if (looking-at "[a-zA-z]")    ;either unary or keyword msg
  798.       ;; or maybe an immediate expression...
  799.       (progn
  800.         (forward-sexp)
  801.         (if (= (following-char) ?:) ;keyword selector
  802.         (progn            ;parse full keyword selector
  803.           (backward-sexp 1)    ;setup for common code
  804.           (smalltalk-forward-keyword-selector)
  805.           )
  806.           ;; else maybe just a unary selector or maybe not
  807.           ;; see if there's stuff following this guy on the same line
  808.           (let (here eol-point)
  809.         (setq here (point))
  810.         (end-of-line)
  811.         (setq eol-point (point))
  812.         (goto-char here)
  813.         (smalltalk-forward-whitespace)
  814.         (if (< (point) eol-point) ;if there is, we're not a method
  815.                     ; (a heuristic guess)
  816.             (beginning-of-line)
  817.           (goto-char here)    ;else we're a unary method (guess)
  818.           )
  819.         )
  820.           )
  821.         )
  822.  
  823.     ;; this must be a binary selector, or a temporary
  824.     (if (= (following-char) ?|)
  825.         (progn            ;could be temporary
  826.           (end-of-line)
  827.           (smalltalk-backward-whitespace)
  828.           (if (= (preceding-char) ?|)
  829.           (progn
  830.             (setq handled t))
  831.         )
  832.           (beginning-of-line)
  833.           )
  834.       )
  835.     (if (not handled)
  836.         (progn
  837.           (skip-chars-forward (concat "^" smalltalk-whitespace))
  838.           (smalltalk-forward-whitespace)
  839.           (skip-chars-forward smalltalk-name-chars)) ;skip over operand
  840.       )
  841.     )
  842.       (skip-chars-forward smalltalk-whitespace)
  843.       (if (= (following-char) ?|)    ;scan for temporaries
  844.       (progn
  845.         (forward-char)        ;skip over |
  846.         (smalltalk-forward-whitespace)
  847.         (while (and (not (eobp))
  848.             (looking-at "[a-zA-Z]"))
  849.           (skip-chars-forward smalltalk-name-chars)
  850.           (smalltalk-forward-whitespace)
  851.           )
  852.         (if (and (= (following-char) ?|) ;only if a matching | as a temp
  853.              (< (point) end))    ;and we're after the temps
  854.         (narrow-to-region (1+ (point)) end) ;do we limit the buffer
  855.           )
  856.         )
  857.     ;; added "and <..." Dec 29 1991 as a test
  858.     (and (< (point) end)
  859.          (narrow-to-region (point) end))
  860.     )
  861.       )
  862.     )
  863.   )
  864.  
  865. (defun smalltalk-forward-keyword-selector ()
  866.   "Starting on a keyword, this function skips forward over a keyword selector.
  867. It is typically used to skip over the actual selector for a method."
  868.   (let (done)
  869.     (while (not done)
  870.       (if (not (looking-at "[a-zA-Z]"))
  871.       (setq done t)
  872.     (skip-chars-forward smalltalk-name-chars)
  873.     (if (= (following-char) ?:)
  874.         (progn
  875.           (forward-char)
  876.           (smalltalk-forward-sexp 1)
  877.           (smalltalk-forward-whitespace))
  878.       (setq done t)
  879.       (backward-sexp 1))
  880.     )
  881.       )
  882.     )
  883.   )
  884.  
  885.  
  886. (defun smalltalk-white-to-bolp ()
  887.   "Returns T if from the current position to beginning of line is whitespace.
  888. Whitespace is defined as spaces, tabs, and comments."
  889.   (let (done is-white line-start-pos)
  890.     (save-excursion
  891.       (save-excursion
  892.     (beginning-of-line)
  893.     (setq line-start-pos (point)))
  894.       (while (not done)
  895.     (and (not (bolp))
  896.          (skip-chars-backward " \t"))
  897.     (cond ((bolp)
  898.            (setq done t)
  899.            (setq is-white t))
  900.           ((= (char-after (1- (point))) ?\")
  901.            (backward-sexp)
  902.            (if (< (point) line-start-pos) ;comment is multi line
  903.            (setq done t)
  904.          )
  905.            )
  906.           (t
  907.            (setq done t))
  908.           )
  909.     )
  910.       is-white)
  911.     ))
  912.  
  913.  
  914. (defun smalltalk-bang ()
  915.   (interactive)
  916.   (insert "!")
  917.   (save-excursion
  918.     (beginning-of-line)
  919.     (if (looking-at "^[ \t]+!")
  920.     (delete-horizontal-space))
  921.     )
  922.   )
  923.  
  924.  
  925. (defun smalltalk-backward-comment ()
  926.   (search-backward "\"")        ;find its start
  927.   (while (= (preceding-char) ?\")    ;skip over doubled ones
  928.     (backward-char 1)
  929.     (search-backward "\""))
  930.   )
  931.  
  932.  
  933. ;;;(defun smalltalk-collect-selector ()
  934. ;;;  "Point is stationed inside or at the beginning of the selector in question.
  935. ;;;This function computes the Smalltalk selector (unary, binary, or keyword) and
  936. ;;;returns it as a string.  Point is not changed."
  937. ;;;  (save-excursion
  938. ;;;    (let (start selector done
  939. ;;;        (parse-sexp-ignore-comments t))
  940. ;;;      (skip-chars-backward (concat "^" "\"" smalltalk-whitespace))
  941. ;;;      (setq start (point))
  942. ;;;      (if (looking-at smalltalk-name-regexp)
  943. ;;;      (progn            ;maybe unary, maybe keyword
  944. ;;;        (skip-chars-forward smalltalk-name-chars)
  945. ;;;        (if (= (following-char) ?:)    ;keyword?
  946. ;;;        (progn
  947. ;;;          (forward-char 1)
  948. ;;;          (setq selector (buffer-substring start (point)))
  949. ;;;          (smalltalk-forward-sexp 1)
  950. ;;;          (smalltalk-forward-whitespace)
  951. ;;;          (while (not done)
  952. ;;;            (if (not (looking-at smalltalk-name-regexp))
  953. ;;;            (setq done t)
  954. ;;;              (setq start (point))
  955. ;;;              (skip-chars-forward smalltalk-name-chars)
  956. ;;;              (if (= (following-char) ?:)
  957. ;;;              (progn
  958. ;;;                (forward-char)
  959. ;;;                (setq selector (concat selector
  960. ;;;                           (buffer-substring
  961. ;;;                            start (point))))
  962. ;;;                (smalltalk-forward-sexp 1)
  963. ;;;                (smalltalk-forward-whitespace))
  964. ;;;            (setq done t))
  965. ;;;              )
  966. ;;;            )
  967. ;;;          )
  968. ;;;          (setq selector (buffer-substring start (point)))
  969. ;;;          )
  970. ;;;        )
  971. ;;;    (skip-chars-forward (concat "^" ?\" smalltalk-whitespace))
  972. ;;;    (setq selector (buffer-substring start (point)))
  973. ;;;    )
  974. ;;;      selector
  975. ;;;      )
  976. ;;;    )
  977. ;;;  )
  978.  
  979. (defun smalltalk-collect-selector ()
  980.   "Point is stationed inside or at the beginning of the selector in question.
  981. This function computes the Smalltalk selector (unary, binary, or keyword) and
  982. returns it as a string.  Point is not changed."
  983.   (save-excursion
  984.     (let (start selector done ch
  985.         (parse-sexp-ignore-comments t))
  986.       (skip-chars-backward (concat "^" "\"" smalltalk-whitespace))
  987.       (setq start (point))
  988.       (if (looking-at smalltalk-name-regexp)
  989.       (progn            ;maybe unary, maybe keyword
  990.         (skip-chars-forward smalltalk-name-chars)
  991.         (if (= (following-char) ?:)    ;keyword?
  992.         (progn
  993.           (forward-char 1)
  994.           (setq selector (buffer-substring start (point)))
  995.           (setq start (point))
  996.           (while (not done)
  997.             (smalltalk-forward-whitespace)
  998.             (setq ch (following-char))
  999.             (cond ((memq ch '(?\; ?. ?\] ?\) ?! ))
  1000.                (setq done t))
  1001.               ((= ch ?:)
  1002.                (forward-char 1)
  1003.                (setq selector
  1004.                  (concat selector
  1005.                      (buffer-substring start (point))))
  1006.                )
  1007.               (t
  1008.                (setq start (point))
  1009.                (smalltalk-forward-sexp 1))
  1010.               )
  1011.             )
  1012.           )
  1013.           (setq selector (buffer-substring start (point)))
  1014.           )
  1015.         )
  1016.     (skip-chars-forward (concat "^" ?\" smalltalk-whitespace))
  1017.     (setq selector (buffer-substring start (point)))
  1018.     )
  1019.       selector
  1020.       )
  1021.     )
  1022.   )
  1023.  
  1024.  
  1025.  
  1026. (defun st-test ()            ;just an experimental testing harness
  1027.   (interactive)
  1028.   (let (l end)
  1029.     (setq end (point))
  1030.     (beginning-of-defun)
  1031.     (setq l (parse-partial-sexp (point) end nil nil nil))
  1032.     (message "%s" (prin1-to-string l)) (read-char)
  1033.     (message "depth %s" (nth 1 l)) (goto-char (nth 1 l)) (read-char)
  1034.     (message "last sexp %s" (nth 2 l)) (goto-char (nth 2 l)) (read-char)
  1035.     (message "lstsx %s stp %s com %s quo %s pdep %s"
  1036.          (nth 3 l)
  1037.          (nth 4 l)
  1038.          (nth 5 l)
  1039.          (nth 6 l)
  1040.          (nth 7 l))
  1041.     ))
  1042.  
  1043.  
  1044. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1045. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1046. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1047. ;;;
  1048. ;;; GNU Emacs Smalltalk interactor mode
  1049. ;;;
  1050. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1051. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1052. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1053.  
  1054. (defvar *smalltalk-process* nil)
  1055. (defvar mst-args '("-Vp"))
  1056.  
  1057. (defvar smalltalk-classes
  1058.   nil "The set of class names...used for completion")
  1059.  
  1060. (defvar smalltalk-command-string nil
  1061.   "Non nil means that we're accumulating output from Smalltalk")
  1062.  
  1063. (define-key smalltalk-mode-map "\C-cc"     'smalltalk-compile)
  1064. (define-key smalltalk-mode-map "\C-cd"     'smalltalk-doit)
  1065. (define-key smalltalk-mode-map "\C-ce"     'smalltalk-eval-region)
  1066. (define-key smalltalk-mode-map "\C-cf"     'smalltalk-filein)
  1067. (define-key smalltalk-mode-map "\C-cm"     'mst)
  1068. (define-key smalltalk-mode-map "\C-cp"     'smalltalk-print)
  1069. (define-key smalltalk-mode-map "\C-cq"     'smalltalk-quit)
  1070. (define-key smalltalk-mode-map "\C-cs"     'smalltalk-snapshot)
  1071. (define-key smalltalk-mode-map "\C-c\C-s" 'smalltalk-browse-selectors)
  1072.  
  1073. ;;; experimental
  1074. (define-key smalltalk-mode-map "\C-xc"    'smalltalk-complete-class)
  1075.  
  1076. (defvar smalltalk-ctl-b-map (make-keymap)
  1077.   "Keymap of subcommands of C-c C-b")
  1078. (fset 'smalltalk-ctl-b-prefix smalltalk-ctl-b-map)
  1079. (define-key smalltalk-mode-map "\C-c\C-b" 'smalltalk-ctl-b-prefix)
  1080.                     ;(define-key smalltalk-ctl-b-map "\C-i" 'smalltalk-show-implementors)
  1081. (define-key smalltalk-ctl-b-map "\C-c" 'smalltalk-show-class-methods)
  1082. (define-key smalltalk-ctl-b-map "\C-i" 'smalltalk-show-instance-methods)
  1083. (define-key smalltalk-ctl-b-map "\C-d" 'smalltalk-show-direct-instance-methods)
  1084. (define-key smalltalk-ctl-b-map "\C-h" 'smalltalk-browse-hierarchy)
  1085. (define-key smalltalk-ctl-b-map "\C-o" 'smalltalk-get-class-names)
  1086.  
  1087.                     ; who implements method
  1088.                     ; what methods does a class/instance have
  1089.                     ; something about the class hierarchy
  1090.                     ; like direct subclasses
  1091.                     ; all subclasses
  1092.                     ; all superclasses
  1093.  
  1094.  
  1095. (defvar smalltalk-ctl-t-map (make-keymap)
  1096.   "Keymap of subcommands of C-c C-t")
  1097. (fset 'smalltalk-ctl-t-prefix smalltalk-ctl-t-map)
  1098. (define-key smalltalk-mode-map "\C-c\C-t" 'smalltalk-ctl-t-prefix)
  1099. (define-key smalltalk-ctl-t-map "\C-d" 'smalltalk-toggle-decl-tracing)
  1100. (define-key smalltalk-ctl-t-map "\C-e" 'smalltalk-toggle-exec-tracing)
  1101. (define-key smalltalk-ctl-t-map "\C-v" 'smalltalk-toggle-verbose-exec-tracing)
  1102.  
  1103. (defvar smalltalk-interactor-mode-map nil "Keymap used in Smalltalk interactor mode.")
  1104. (if smalltalk-interactor-mode-map
  1105.     ()
  1106.   (setq smalltalk-interactor-mode-map (copy-keymap smalltalk-mode-map))
  1107.   (define-key smalltalk-interactor-mode-map "\C-m" 'shell-send-input)
  1108.   (define-key smalltalk-interactor-mode-map "\C-c\C-d" 'shell-send-eof)
  1109.   (define-key smalltalk-interactor-mode-map "\C-c\C-u" 'kill-shell-input)
  1110.   (define-key smalltalk-interactor-mode-map "\C-c\C-c" 'interrupt-shell-subjob)
  1111.   (define-key smalltalk-interactor-mode-map "\C-c\C-z" 'stop-shell-subjob)
  1112.   (define-key smalltalk-interactor-mode-map "\C-c\C-\\" 'quit-shell-subjob)
  1113.   (define-key smalltalk-interactor-mode-map "\C-c\C-o" 'kill-output-from-shell)
  1114.   (define-key smalltalk-interactor-mode-map "\C-c\C-r" 'show-output-from-shell)
  1115.   (define-key smalltalk-interactor-mode-map "\C-c\C-y" 'copy-last-shell-input)
  1116.   )
  1117.  
  1118.  
  1119.  
  1120.  
  1121. (defun mst (args)
  1122.   (interactive (list (if (null current-prefix-arg)
  1123.              mst-args
  1124.                (read-smalltalk-args))))
  1125.   (setq mst-args args)
  1126.   (if (not (eq major-mode 'mst-mode))
  1127.       (switch-to-buffer-other-window
  1128.        (apply 'make-mst "mst" mst-args))
  1129.     ;; invoked from a Smalltalk interactor window, so stay there
  1130.     (apply 'make-mst "mst" mst-args)
  1131.     )
  1132.   (setq *smalltalk-process* (get-buffer-process (current-buffer)))
  1133.   )
  1134.  
  1135. (defun read-smalltalk-args ()
  1136.   "Reads the arguments to pass to Smalltalk as a string, returns a list."
  1137.   (let (str args args-str result-args start end)
  1138.     (setq args mst-args)
  1139.     (setq args-str "")
  1140.     (while args
  1141.       (setq args-str (concat args-str " " (car args)))
  1142.       (setq args (cdr args))
  1143.       )
  1144.     (setq str (read-string "Invoke Smalltalk: " args-str))
  1145.     
  1146.     (while (setq start (string-match "[^ ]" str))
  1147.       (setq end (or (string-match " " str start) (length str)))
  1148.       (setq result-args (cons (substring str start end) result-args))
  1149.       (setq str (substring str end))
  1150.       )
  1151.     (reverse result-args)
  1152.     )
  1153.   )
  1154.  
  1155.  
  1156. (defun make-mst (name &rest switches)
  1157.   (let ((buffer (get-buffer-create (concat "*" name "*")))
  1158.     proc status size)
  1159.     (setq proc (get-buffer-process buffer))
  1160.     (if proc (setq status (process-status proc)))
  1161.     (save-excursion
  1162.       (set-buffer buffer)
  1163.       ;;    (setq size (buffer-size))
  1164.       (if (memq status '(run stop))
  1165.       nil
  1166.     (if proc (delete-process proc))
  1167.     (setq proc (apply  'start-process
  1168.                name buffer
  1169.                (concat exec-directory "env")
  1170.                ;; I'm choosing to leave these here
  1171.                (format "TERMCAP=emacs:co#%d:tc=unknown:"
  1172.                    (screen-width))
  1173.                "TERM=emacs"
  1174.                "EMACS=t"
  1175.                "-"
  1176.                "mst"
  1177.                switches))
  1178.     (setq name (process-name proc)))
  1179.       (goto-char (point-max))
  1180.       (set-marker (process-mark proc) (point))
  1181.       (set-process-filter proc 'mst-filter)
  1182.       (mst-mode))
  1183.     buffer))
  1184.  
  1185. (defun mst-filter (process string)
  1186.   "Make sure that the window continues to show the most recently output
  1187. text."
  1188.   (let (where ch command-str)
  1189.     (setq where 0)            ;fake to get through the gate
  1190.     (while (and string where)
  1191.       (if smalltalk-command-string
  1192.       (setq string (smalltalk-accum-command string)))
  1193.       (if (and string
  1194.            (setq where (string-match "\C-a\\|\C-b" string)))
  1195.       (progn
  1196.         (setq ch (aref string where))
  1197.         (cond ((= ch ?\C-a)        ;strip these out
  1198.            (setq string (concat (substring string 0 where)
  1199.                     (substring string (1+ where)))))
  1200.           ((= ch ?\C-b)        ;start of command
  1201.            (setq smalltalk-command-string "") ;start this off
  1202.            (setq string (substring string (1+ where))))
  1203.           )
  1204.         )
  1205.     )
  1206.       )
  1207.     (save-excursion
  1208.       (set-buffer (process-buffer process))
  1209.       (goto-char (point-max))
  1210.       (and string
  1211.        (setq mode-status "idle")
  1212.        (insert string))
  1213.       (if (process-mark process)
  1214.       (set-marker (process-mark process) (point-max)))
  1215.       )
  1216.     )
  1217.   ;;  (if (eq (process-buffer process)
  1218.   ;;      (current-buffer))
  1219.   ;;      (goto-char (point-max)))
  1220.                     ;  (save-excursion
  1221.                     ;      (set-buffer (process-buffer process))
  1222.                     ;      (goto-char (point-max))
  1223.   ;;      (set-window-dot (get-buffer-window (current-buffer)) (point-max))
  1224.                     ;      (sit-for 0))
  1225.   (let ((buf (current-buffer)))
  1226.     (set-buffer (process-buffer process))
  1227.     (goto-char (point-max)) (sit-for 0)
  1228.     (set-window-dot (get-buffer-window (current-buffer)) (point-max))
  1229.     (set-buffer buf))
  1230.   )
  1231.  
  1232. (defun smalltalk-accum-command (string)
  1233.   (let (where)
  1234.     (setq where (string-match "\C-a" string))
  1235.     (setq smalltalk-command-string
  1236.       (concat smalltalk-command-string (substring string 0 where)))
  1237.     (if where
  1238.     (progn
  1239.       (unwind-protect        ;found the delimiter...do it
  1240.           (smalltalk-handle-command smalltalk-command-string)
  1241.         (setq smalltalk-command-string nil))
  1242.       ;; return the remainder
  1243.       (substring string where))
  1244.       ;; we ate it all and didn't do anything with it
  1245.       nil)
  1246.     )
  1247.   )
  1248.  
  1249.  
  1250. (defun smalltalk-handle-command (str)
  1251.   (eval (read str))
  1252.   )
  1253.  
  1254.  
  1255. (defun mst-mode ()
  1256.   "Major mode for interacting Smalltalk subprocesses.
  1257.  
  1258. The following commands imitate the usual Unix interrupt and
  1259. editing control characters:
  1260. \\{smalltalk-mode-map}
  1261.  
  1262. Entry to this mode calls the value of mst-mode-hook with no arguments,
  1263. if that value is non-nil.  Likewise with the value of shell-mode-hook.
  1264. mst-mode-hook is called after shell-mode-hook."
  1265.   (interactive)
  1266.   (kill-all-local-variables)
  1267.   (require 'shell)
  1268.   (setq mode-line-format
  1269.     '("" mode-line-modified mode-line-buffer-identification "   "
  1270.       global-mode-string "   %[(" mode-name ": " mode-status
  1271.       "%n" mode-line-process ")%]----" (-3 . "%p") "-%-"))
  1272.   (setq major-mode 'mst-mode)
  1273.   (setq mode-name "Smalltalk")
  1274.   ;;  (setq mode-line-process '(": %s"))
  1275.   (use-local-map smalltalk-interactor-mode-map)
  1276.   (make-local-variable 'last-input-start)
  1277.   (setq last-input-start (make-marker))
  1278.   (make-local-variable 'last-input-end)
  1279.   (setq last-input-end (make-marker))
  1280.   (make-local-variable 'mode-status)
  1281.   (make-local-variable 'smalltalk-command-string)
  1282.   (setq smalltalk-command-string nil)
  1283.   (setq mode-status "starting-up")
  1284.   (run-hooks 'shell-mode-hook 'mst-mode-hook))
  1285.  
  1286.  
  1287.  
  1288. (defun smalltalk-eval-region (start end &optional label)
  1289.   "Evaluate START to END as a Smalltalk expression in Smalltalk window.
  1290. If the expression does not end with an exclamation point, one will be
  1291. added (at no charge)."
  1292.   (interactive "r")
  1293.   (let (str filename line pos)
  1294.     (setq str (buffer-substring start end))
  1295.     (save-excursion
  1296.       (save-restriction 
  1297.     (goto-char (max start end))
  1298.     (smalltalk-backward-whitespace)
  1299.     (if (/= (preceding-char) ?!)    ;canonicalize
  1300.         (setq str (concat str "!")))
  1301.     ;; unrelated, but reusing save-excursion
  1302.     (goto-char (min start end))
  1303.     (setq pos (point))
  1304.     (setq filename (buffer-file-name))
  1305.     (widen)
  1306.     (setq line (1+ (count-lines 1 (point))))
  1307.     )
  1308.       )
  1309.     (send-to-smalltalk str (or label "eval")
  1310.                (list line filename pos))
  1311.     )
  1312.   )
  1313.  
  1314. (defun smalltalk-doit (use-region)
  1315.   (interactive "P")
  1316.   (let (start end rgn)
  1317.     (if use-region
  1318.     (progn
  1319.       (setq start (min (mark) (point)))
  1320.       (setq end (max (mark) (point)))
  1321.       )
  1322.       (setq rgn (smalltalk-bound-expr))
  1323.       (setq start (car rgn)
  1324.         end (cdr rgn))
  1325.       )
  1326.     (smalltalk-eval-region start end "doIt")
  1327.     )
  1328.   )
  1329.  
  1330. (defun smalltalk-bound-expr ()
  1331.   "Returns a cons of the region of the buffer that contains a smalltalk expression.
  1332. It's pretty dumb right now...looks for a line that starts with ! at the end and
  1333. a non-white-space line at the beginning, but this should handle the typical
  1334. cases nicely."
  1335.   (let (start end here)
  1336.     (save-excursion
  1337.       (setq here (point))
  1338.       (re-search-forward "^!")
  1339.       (setq end (point))
  1340.       (beginning-of-line)
  1341.       (if (looking-at "^[^ \t\"]")
  1342.       (progn
  1343.         (goto-char here)
  1344.         (re-search-backward "^[^ \t\"]")
  1345.         (while (looking-at "^$") ;this is a hack to get around a bug
  1346.           (re-search-backward "^[^ \t\"]") ;with GNU Emacs's regexp system
  1347.           )
  1348.         )
  1349.     )
  1350.       (setq start (point))
  1351.       (cons start end)
  1352.       )
  1353.     )
  1354.   )
  1355.  
  1356. (defun smalltalk-compile (use-region)
  1357.   (interactive "P")
  1358.   (let (str start end rgn filename line pos header classname category)
  1359.     (if use-region
  1360.     (progn
  1361.       (setq start (min (point) (mark)))
  1362.       (setq end (max (point) (mark)))
  1363.       (setq str (buffer-substring start end))
  1364.       (save-excursion
  1365.         (goto-char end)
  1366.         (smalltalk-backward-whitespace)
  1367.         (if (/= (preceding-char) ?!) ;canonicalize
  1368.         (setq str (concat str "!")))
  1369.         )
  1370.       (send-to-smalltalk str "compile"))
  1371.       (setq rgn (smalltalk-bound-method))
  1372.       (setq str (buffer-substring (car rgn) (cdr rgn)))
  1373.       (setq filename (buffer-file-name))
  1374.       (setq pos (car rgn))
  1375.       (save-excursion
  1376.     (save-restriction
  1377.       (widen)
  1378.       (setq line (1+ (count-lines 1 (car rgn))))
  1379.       )
  1380.     )
  1381.       (if (buffer-file-name)
  1382.       (progn 
  1383.         (save-excursion
  1384.           (re-search-backward "^![ \t]*[A-Za-z]")
  1385.           (setq start (point))
  1386.           (forward-char 1)
  1387.           (search-forward "!")
  1388.           (setq end (point))
  1389.           (setq line (- line (1- (count-lines start end))))
  1390.           ;; extra -1 here to compensate for emacs positions being 1 based,
  1391.           ;; and smalltalk's (really ftell & friends) being 0 based.
  1392.           (setq pos (- pos (- end start) 1)))
  1393.         (setq str (concat (buffer-substring start end) "\n\n" str "!"))
  1394.         (send-to-smalltalk str "compile"
  1395.                ;-2 accounts for num lines and num chars extra
  1396.                    (list (- line 2) filename (- pos 2)))
  1397.         )
  1398.     (save-excursion
  1399.       (re-search-backward "^!\\(.*\\) methodsFor: \\(.*\\)!")
  1400.       (setq classname (buffer-substring
  1401.                (match-beginning 1) (match-end 1)))
  1402.       (setq category (buffer-substring
  1403.               (match-beginning 2) (match-end 2)))
  1404.       (goto-char (match-end 0))
  1405.       (setq str (smalltalk-quote-strings str))
  1406.       (setq str (format "%s compile: '%s' classified: %s!\n"
  1407.                 classname (substring str 0 -1) category))
  1408.       (save-excursion (set-buffer (get-buffer-create "junk"))
  1409.               (erase-buffer)
  1410.               (insert str))
  1411.       (send-to-smalltalk str "compile"
  1412.                  (list line nil 0))
  1413.       )
  1414.          
  1415.       )
  1416.     )
  1417.     )
  1418.   )
  1419.  
  1420.  
  1421. (defun smalltalk-bound-method ()
  1422.   (let (start end)
  1423.     (save-excursion
  1424.       (re-search-forward "^!")
  1425.       (setq end (point)))
  1426.     (save-excursion
  1427.       (re-search-backward "^[^ \t\"]")
  1428.       (while (looking-at "^$")        ;this is a hack to get around a bug
  1429.     (re-search-backward "^[^ \t\"]");with GNU Emacs's regexp system
  1430.     )
  1431.       (setq start (point)))
  1432.     (cons start end))
  1433.   )
  1434.  
  1435.  
  1436. (defun smalltalk-quote-strings (str)
  1437.   (let (new-str)
  1438.     (save-excursion
  1439.       (set-buffer (get-buffer-create " st-dummy "))
  1440.       (erase-buffer)
  1441.       (insert str)
  1442.       (goto-char 1)
  1443.       (while (and (not (eobp))
  1444.           (search-forward "'" nil 'to-end))
  1445.     (insert "'"))
  1446.       (buffer-string)
  1447.       )
  1448.     )
  1449.   )
  1450.  
  1451. (defun smalltalk-snapshot (&optional snapshot-name)
  1452.   (interactive (if current-prefix-arg
  1453.            (list (setq snapshot-name (expand-file-name (read-file-name "Snapshot to: "))))))
  1454.   (if snapshot-name
  1455.       (send-to-smalltalk (format "Smalltalk snapshot: '%s'!" "Snapshot"))
  1456.   (send-to-smalltalk "Smalltalk snapshot!" "Snapshot"))
  1457.   )
  1458.  
  1459. (defun smalltalk-print (start end)
  1460.   (interactive "r")
  1461.   (let (str)
  1462.     (setq str (buffer-substring start end))
  1463.     (save-excursion
  1464.       (goto-char (max start end))
  1465.       (smalltalk-backward-whitespace)
  1466.       (if (= (preceding-char) ?!)    ;canonicalize
  1467.       (setq str (buffer-substring (min start end)  (point)))
  1468.     )
  1469.       (setq str (format "(%s) printNl!" str))
  1470.       (send-to-smalltalk str "print")
  1471.       )
  1472.     )
  1473.   )
  1474.  
  1475.  
  1476. (defun smalltalk-quit ()
  1477.   (interactive)
  1478.   (send-to-smalltalk "Smalltalk quitPrimitive!" "Quitting"))
  1479.  
  1480. (defun smalltalk-filein (filename)
  1481.   (interactive "fSmalltalk file to load: ")
  1482.   (send-to-smalltalk (format "FileStream fileIn: '%s'!"
  1483.                  (expand-file-name filename))
  1484.              "fileIn")
  1485.   )
  1486.  
  1487. ;(defun smalltalk-show-implementors ()
  1488. ;  (interactive)
  1489. ;  (let (method-name)
  1490. ;    (save-excursion
  1491. ;      )
  1492. ;    (send-to-smalltalk (format "Browser whoImplements: #%s"
  1493. ;                   method-name)
  1494. ;               "implementors")
  1495.  
  1496.  
  1497. (defun smalltalk-complete-class (name)
  1498.   (interactive (list (completing-read "Class: " smalltalk-class-names nil
  1499.                       t nil)))
  1500.   (message name) (sit-for 3)
  1501.   name
  1502.   )
  1503.  
  1504. (defun smalltalk-get-class-names ()
  1505.   (interactive)
  1506.   (send-to-smalltalk "Browser loadClassNames!" "ClassNames")
  1507.   )
  1508.  
  1509. (defun smalltalk-set-class-names (class-names)
  1510.   (let (sym-str)
  1511.     (setq smalltalk-class-names nil)
  1512.     (while class-names
  1513.       (setq sym-str (symbol-name (car class-names)))
  1514.       (setq smalltalk-class-names (cons (cons sym-str sym-str)
  1515.                     smalltalk-class-names))
  1516.       (setq class-names (cdr class-names))
  1517.       )
  1518.     )
  1519.   )
  1520.  
  1521. (defun smalltalk-set-all-methods (method-names)
  1522.   (let (sym-str)
  1523.     (setq smalltalk-method-names nil)
  1524.     (while method-names
  1525.       (and (not (assoc (car method-names) smalltalk-method-names))
  1526.        (setq smalltalk-method-names (cons (list (car method-names))
  1527.                           smalltalk-method-names)))
  1528.       (setq method-names (cdr method-names))
  1529.       )
  1530.     )
  1531.   )
  1532.  
  1533. (defun smalltalk-show-instance-methods (class-name)
  1534.   (interactive (smalltalk-complete-class-name))
  1535.    ;;(require 'browse)
  1536.   (send-to-smalltalk (format "Browser showMethods: %s for: 'instance'!"
  1537.                  class-name)
  1538.              "ShowInstMethods")
  1539.   )
  1540.  
  1541. (defun smalltalk-generic-show-methods (class-name kind is-class)
  1542.   "IS-CLASS is either the empty string or the word 'Class'.  
  1543. Kind is one of 'Direct', 'Indirect', or 'All'"
  1544.   (require 'browse)
  1545.   (let ((class-selector (downcase is-class))
  1546.     (inst-or-class (if (= (length is-class) 0) "Inst" "Class"))
  1547.     (class-space (if (= (length is-class) 0) "" "Class "))
  1548.     )
  1549.     (send-to-smalltalk
  1550.      (format "Browser show%sMethods: %s %s inBuffer: '*%s %sMethods*'!"
  1551.          kind class-name class-selector kind
  1552.          class-space)
  1553.      (format "Show%sMethods" inst-or-class)
  1554.      )
  1555.     )
  1556.   )
  1557.   
  1558.  
  1559. (defun smalltalk-show-direct-class-methods (class-name)
  1560.   (interactive (smalltalk-complete-class-name))
  1561.   (smalltalk-generic-show-methods class-name "Direct" "Class")
  1562.   )
  1563.  
  1564. (defun smalltalk-show-indirect-class-methods (class-name)
  1565.   (interactive (smalltalk-complete-class-name))
  1566.   (smalltalk-generic-show-methods class-name "Indirect" "Class")
  1567.   )
  1568.  
  1569. (defun smalltalk-show-all-class-methods (class-name)
  1570.   (interactive (smalltalk-complete-class-name))
  1571.   (smalltalk-generic-show-methods class-name "All" "Class")
  1572.   )
  1573.  
  1574. (defun smalltalk-show-direct-instance-methods (class-name)
  1575.   (interactive (smalltalk-complete-class-name))
  1576.   (smalltalk-generic-show-methods class-name "Direct" "")
  1577.   )
  1578.  
  1579. (defun smalltalk-show-all-instance-methods (class-name)
  1580.   (interactive (smalltalk-complete-class-name))
  1581.   (smalltalk-generic-show-methods class-name "All" "")
  1582.   )
  1583.  
  1584. (defun smalltalk-show-indirect-instance-methods (class-name)
  1585.   (interactive (smalltalk-complete-class-name))
  1586.   (smalltalk-generic-show-methods class-name "Indirect" "")
  1587.   )
  1588.  
  1589. (defun smalltalk-show-class-methods (class-name)
  1590.   (interactive (smalltalk-complete-class-name))
  1591.   (require 'browse)
  1592.   (send-to-smalltalk (format "Browser showMethods: %s class
  1593.                                       for: 'class' !"
  1594.                  class-name)
  1595.              "ShowClassMethods")
  1596.   )
  1597.  
  1598. (defun smalltalk-browse-hierarchy ()
  1599.   (interactive)
  1600.   (require 'browse)
  1601.   (send-to-smalltalk "Browser browseHierarchy!" "GetHierarchy")
  1602.   )
  1603.  
  1604.  
  1605. (defun smalltalk-browse-selectors ()
  1606.   "Set up to browse all methods whose selectors match the selector under
  1607. point."
  1608.   (interactive)
  1609.   (let ((selector (smalltalk-collect-selector)))
  1610.     (send-to-smalltalk
  1611.      (format "Browser getAllSelectors: #%s inBuffer: '*%s classes*'!"
  1612.          selector selector)
  1613.                "ShowSelectors")
  1614.     )
  1615.   )
  1616.  
  1617. (defun smalltalk-complete-class-name (&optional prompt)
  1618.   (or prompt
  1619.       (setq prompt "Class name: "))
  1620.   ;; add getting of class names here when required.
  1621.   (list (completing-read prompt smalltalk-class-names nil t))
  1622.   )
  1623.  
  1624. (defun smalltalk-toggle-decl-tracing ()
  1625.   (interactive)
  1626.   (send-to-smalltalk
  1627. "Smalltalk declarationTrace:
  1628.      Smalltalk declarationTrace not!")
  1629.   )
  1630.  
  1631. (defun smalltalk-toggle-exec-tracing ()
  1632.   (interactive)
  1633.   (send-to-smalltalk "Smalltalk executionTrace: Smalltalk executionTrace not!")
  1634.   )
  1635.  
  1636.  
  1637. (defun smalltalk-toggle-verbose-exec-tracing ()
  1638.   (interactive)
  1639.   (send-to-smalltalk "Smalltalk verboseTrace: Smalltalk verboseTrace not!")
  1640.   )
  1641.  
  1642. (defun test-func (arg &optional cmd-arg)
  1643.   (let ((buf (current-buffer)))
  1644.     (unwind-protect
  1645.     (progn
  1646.       (if (not (consp (cdr arg)))
  1647.           (progn
  1648.         (find-file-other-window (car arg))
  1649.         (goto-char (1+ (cdr arg)))
  1650.         (recenter '(0))        ;hack to recenter the window without
  1651.                     ;redisplaying everything
  1652.         )
  1653.         (switch-to-buffer-other-window (get-buffer-create (car arg)))
  1654.         (smalltalk-mode)
  1655.         (erase-buffer)
  1656.         (insert (format "!%s methodsFor: '%s'!
  1657.  
  1658. %s! !" (nth 0 arg) (nth 1 arg) (nth 2 arg)))
  1659.         (beginning-of-buffer)
  1660.         (forward-line 2)        ;skip to start of method
  1661.       )
  1662.       )
  1663.       (pop-to-buffer buf)
  1664.       )
  1665.     )
  1666.   )
  1667.  
  1668. (defun hier-func (arg)
  1669.   ;; browse the direct methods for the given class in the other window.
  1670.   ;; just the local methods
  1671.   ;; idea: use the => marker, split the top pane in two, showing
  1672. ;;;Object                            | Method for class desc 1
  1673. ;;;    Autoload                 | method for class desc 2
  1674. ;;;    Behavior                 | method for class desc 3 
  1675. ;;;=>      ClassDescription         |
  1676. ;;;            Class             |
  1677. ;;;            Metaclass         |
  1678. ;;;    BlockContext             |
  1679.   ;; don't even have to use the marker, just installing any random junk
  1680.   ;; into the buffer should be sufficient.  The bottom window shows the
  1681.   ;; source code.  May even use the marker for the method window?
  1682.   ;; --> be sure to set truncate lines to true (buffer local )
  1683.  
  1684.   (message arg)
  1685.   )
  1686.  
  1687.  
  1688.  
  1689.  
  1690. (defun send-to-smalltalk (str &optional mode fileinfo)
  1691.   (let (temp-file buf switch-back old-buf)
  1692.     (setq temp-file (concat "/tmp/" (make-temp-name "mst")))
  1693.     (save-excursion
  1694.       (setq buf (get-buffer-create " zap-buffer "))
  1695.       (set-buffer buf)
  1696.       (erase-buffer)
  1697.       (princ str buf)
  1698.       (write-region (point-min) (point-max) temp-file nil 'no-message)
  1699.       )
  1700.     (kill-buffer buf)
  1701.     ;; this should probably be conditional
  1702.     (save-window-excursion (mst mst-args))
  1703. ;;; why is this like this?
  1704. ;;    (if mode
  1705. ;;    (progn
  1706. ;;      (save-excursion
  1707. ;;        (set-buffer (process-buffer *smalltalk-process*))
  1708. ;;        (setq mode-status mode))
  1709. ;;      ))
  1710.     (setq old-buf (current-buffer))
  1711.     (setq buf (process-buffer *smalltalk-process*))
  1712.     (pop-to-buffer buf)
  1713.     (if mode
  1714.     (setq mode-status mode))
  1715.     (goto-char (point-max))
  1716.     (newline)
  1717.     (pop-to-buffer old-buf)
  1718. ;    (if (not (eq buf (current-buffer)))
  1719. ;    (progn
  1720. ;      (switch-to-buffer-other-window buf)
  1721. ;      (setq switch-back t))
  1722. ;      )
  1723. ;    (if mode
  1724. ;    (setq mode-status mode))
  1725. ;    (goto-char (point-max))
  1726. ;    (newline)
  1727. ;    (and switch-back (other-window 1))
  1728. ;      ;;(sit-for 0)
  1729.     (if fileinfo
  1730.     (process-send-string
  1731.      *smalltalk-process*
  1732.      (format
  1733.       "FileStream fileIn: '%s' line: %d from: '%s' at: %d!\n"
  1734.       temp-file (nth 0 fileinfo) (nth 1 fileinfo) (nth 2 fileinfo)
  1735.       ))    
  1736.       (process-send-string *smalltalk-process*
  1737.                (concat "FileStream fileIn: '" temp-file "'!\n"))
  1738.       )
  1739.     )
  1740.   )
  1741.  
  1742.  
  1743.  
  1744. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1745. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1746. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1747. ;;;
  1748. ;;; GNU Emacs hooks for invoking Emacs on Smalltalk methods
  1749. ;;;
  1750. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1751. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1752. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1753.  
  1754.  
  1755.  
  1756. (setq command-switch-alist
  1757.       (append '(("-smalltalk" . smalltalk-edit))
  1758.           command-switch-alist))
  1759.  
  1760.  
  1761. (defun smalltalk-edit (rest)
  1762.   (let (file pos done)
  1763.     (setq file (car command-line-args-left))
  1764.     (setq command-line-args-left
  1765.       (cdr command-line-args-left))
  1766.     (setq pos (string-to-int (car command-line-args-left)))
  1767.     (setq command-line-args-left
  1768.       (cdr command-line-args-left))
  1769.     (find-file (expand-file-name file))
  1770.     (goto-char pos)
  1771.     )
  1772.   )
  1773.