emacs/guile-scheme.el

   1 ;;; guile-scheme.el --- Guile Scheme editing mode
   2
   3 ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free
  17 ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  18 ;;;; 02111-1307 USA
  19
  20 ;;; Commentary:
  21
  22 ;; Put the following lines in your ~/.emacs:
  23 ;;
  24 ;;   (require 'guile-scheme)
  25 ;;   (setq initial-major-mode 'scheme-interaction-mode)
  26
  27 ;;; Code:
  28
  29 (require 'guile)
  30 (require 'scheme)
  31
  32 (defgroup guile-scheme nil
  33   "Editing Guile-Scheme code"
  34   :group 'lisp)
  35
  36 (defvar guile-scheme-syntax-keywords
  37   '((begin 0) (if 1) (cond 0) (case 1) (do 2)
  38     quote syntax lambda and or else delay receive use-modules
  39     (match 1) (match-lambda 0) (match-lambda* 0)
  40     (let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1)
  41     (let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2)))
  42
  43 (defvar guile-scheme-special-procedures
  44   '((catch 1) (lazy-catch 1) (stack-catch 1)
  45     map for-each (dynamic-wind 3)))
  46
  47 ;; set indent functions
  48 (dolist (x (append guile-scheme-syntax-keywords
  49                    guile-scheme-special-procedures))
  50   (when (consp x)
  51     (put (car x) 'scheme-indent-function (cadr x))))
  52
  53 (defconst guile-scheme-font-lock-keywords
  54   (eval-when-compile
  55     (list
  56      (list (concat "(\\(define\\*?\\("
  57                    ;; Function names.
  58                    "\\(\\|-public\\|-method\\|-generic\\)\\|"
  59                    ;; Macro names, as variable names.
  60                    "\\(-syntax\\|-macro\\)\\|"
  61                    ;; Others
  62                    "-\\sw+\\)\\)\\>"
  63                    ;; Any whitespace and declared object.
  64                    "\\s *(?\\(\\sw+\\)?")
  65            '(1 font-lock-keyword-face)
  66            '(5 (cond ((match-beginning 3) font-lock-function-name-face)
  67                      ((match-beginning 4) font-lock-variable-name-face)
  68                      (t font-lock-type-face)) nil t))
  69      (list (concat
  70             "(" (regexp-opt
  71                  (mapcar (lambda (e)
  72                            (prin1-to-string (if (consp e) (car e) e)))
  73                          (append guile-scheme-syntax-keywords
  74                                  guile-scheme-special-procedures)) 'words))
  75            '(1 font-lock-keyword-face))
  76      '("<\\sw+>" . font-lock-type-face)
  77      '("\\<:\\sw+\\>" . font-lock-builtin-face)
  78      ))
  79   "Expressions to highlight in Guile Scheme mode.")
  80
  81 \f
  82 ;;;
  83 ;;; Guile Scheme mode
  84 ;;;
  85
  86 (defvar guile-scheme-mode-map nil
  87   "Keymap for Guile Scheme mode.
  88 All commands in `lisp-mode-shared-map' are inherited by this map.")
  89
  90 (unless guile-scheme-mode-map
  91   (let ((map (make-sparse-keymap "Guile-Scheme")))
  92     (setq guile-scheme-mode-map map)
  93     (cond ((boundp 'lisp-mode-shared-map)
  94            (set-keymap-parent map lisp-mode-shared-map))
  95           ((boundp 'shared-lisp-mode-map)
  96            (set-keymap-parent map shared-lisp-mode-map)))
  97     (define-key map [menu-bar] (make-sparse-keymap))
  98     (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map))
  99     (define-key map [uncomment-region]
 100       '("Uncomment Out Region" . (lambda (beg end)
 101                                    (interactive "r")
 102                                    (comment-region beg end '(4)))))
 103     (define-key map [comment-region] '("Comment Out Region" . comment-region))
 104     (define-key map [indent-region] '("Indent Region" . indent-region))
 105     (define-key map [indent-line] '("Indent Line" . lisp-indent-line))
 106     (define-key map "\e\C-i" 'guile-scheme-complete-symbol)
 107     (define-key map "\e\C-x" 'guile-scheme-eval-define)
 108     (define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp)
 109     (define-key map "\C-c\C-b" 'guile-scheme-eval-buffer)
 110     (define-key map "\C-c\C-r" 'guile-scheme-eval-region)
 111     (define-key map "\C-c:" 'guile-scheme-eval-expression)
 112     (define-key map "\C-c\C-a" 'guile-scheme-apropos)
 113     (define-key map "\C-c\C-d" 'guile-scheme-describe)
 114     (define-key map "\C-c\C-k" 'guile-scheme-kill-process)
 115
 116     (put 'comment-region 'menu-enable 'mark-active)
 117     (put 'uncomment-region 'menu-enable 'mark-active)
 118     (put 'indent-region 'menu-enable 'mark-active)))
 119
 120 (defcustom guile-scheme-mode-hook nil
 121   "Normal hook run when entering `guile-scheme-mode'."
 122   :type 'hook
 123   :group 'guile-scheme)
 124
 125 ;;;###autoload
 126 (defun guile-scheme-mode ()
 127   "Major mode for editing Guile Scheme code.
 128 Editing commands are similar to those of `scheme-mode'.
 129
 130 \\{scheme-mode-map}
 131 Entry to this mode calls the value of `scheme-mode-hook'
 132 if that value is non-nil."
 133   (interactive)
 134   (kill-all-local-variables)
 135   (setq mode-name "Guile Scheme")
 136   (setq major-mode 'guile-scheme-mode)
 137   (use-local-map guile-scheme-mode-map)
 138   (scheme-mode-variables)
 139   (setq mode-line-process
 140         '(:eval (if (processp guile-scheme-adapter)
 141                     (format " [%s]" guile-scheme-command)
 142                   "")))
 143   (setq font-lock-defaults
 144         '((guile-scheme-font-lock-keywords)
 145           nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun
 146           (font-lock-mark-block-function . mark-defun)))
 147   (run-hooks 'guile-scheme-mode-hook))
 148
 149 \f
 150 ;;;
 151 ;;; Scheme interaction mode
 152 ;;;
 153
 154 (defvar scheme-interaction-mode-map ()
 155   "Keymap for Scheme Interaction mode.
 156 All commands in `guile-scheme-mode-map' are inherited by this map.")
 157
 158 (unless scheme-interaction-mode-map
 159   (let ((map (make-sparse-keymap)))
 160     (setq scheme-interaction-mode-map map)
 161     (set-keymap-parent map guile-scheme-mode-map)
 162     (define-key map "\C-j" 'guile-scheme-eval-print-last-sexp)
 163     ))
 164
 165 (defvar scheme-interaction-mode-hook nil
 166   "Normal hook run when entering `scheme-interaction-mode'.")
 167
 168 (defun scheme-interaction-mode ()
 169   "Major mode for evaluating Scheme expressions with Guile.
 170
 171 \\{scheme-interaction-mode-map}"
 172   (interactive)
 173   (guile-scheme-mode)
 174   (use-local-map scheme-interaction-mode-map)
 175   (setq major-mode 'scheme-interaction-mode)
 176   (setq mode-name "Scheme Interaction")
 177   (run-hooks 'scheme-interaction-mode-hook))
 178
 179 \f
 180 ;;;
 181 ;;; Guile Scheme adapter
 182 ;;;
 183
 184 (defvar guile-scheme-command "guile")
 185 (defvar guile-scheme-adapter nil)
 186 (defvar guile-scheme-module nil)
 187
 188 (defun guile-scheme-adapter ()
 189   (if (and (processp guile-scheme-adapter)
 190            (eq (process-status guile-scheme-adapter) 'run))
 191       guile-scheme-adapter
 192     (setq guile-scheme-module nil)
 193     (setq guile-scheme-adapter
 194           (guile:make-adapter guile-scheme-command 'emacs-scheme-channel))))
 195
 196 (defun guile-scheme-set-module ()
 197   "Set the current module based on buffer contents.
 198 If there is a (define-module ...) form, evaluate it.
 199 Otherwise, choose module (guile-user)."
 200   (save-excursion
 201     (let ((module (if (re-search-backward "^(define-module " nil t)
 202                       (let ((start (match-beginning 0)))
 203                         (goto-char start)
 204                         (forward-sexp)
 205                         (buffer-substring-no-properties start (point)))
 206                     "(define-module (emacs-user))")))
 207       (unless (string= guile-scheme-module module)
 208         (prog1 (guile:eval module (guile-scheme-adapter))
 209           (setq guile-scheme-module module))))))
 210
 211 (defun guile-scheme-eval-string (string)
 212   (guile-scheme-set-module)
 213   (guile:eval string (guile-scheme-adapter)))
 214
 215 (defun guile-scheme-display-result (value flag)
 216   (if (string= value "#<unspecified>")
 217       (setq value "done"))
 218   (if flag
 219       (insert value)
 220     (message "%s" value)))
 221
 222 \f
 223 ;;;
 224 ;;; Interactive commands
 225 ;;;
 226
 227 (defun guile-scheme-eval-expression (string)
 228   "Evaluate the expression in STRING and show value in echo area."
 229   (interactive "SGuile Scheme Eval: ")
 230   (guile-scheme-display-result (guile-scheme-eval-string string) nil))
 231
 232 (defun guile-scheme-eval-region (start end)
 233   "Evaluate the region as Guile Scheme code."
 234   (interactive "r")
 235   (guile-scheme-eval-expression (buffer-substring-no-properties start end)))
 236
 237 (defun guile-scheme-eval-buffer ()
 238   "Evaluate the current buffer as Guile Scheme code."
 239   (interactive)
 240   (guile-scheme-eval-expression (buffer-string)))
 241
 242 (defun guile-scheme-eval-last-sexp (arg)
 243   "Evaluate sexp before point; show value in echo area.
 244 With argument, print output into current buffer."
 245   (interactive "P")
 246   (guile-scheme-display-result
 247    (guile-scheme-eval-string
 248     (buffer-substring-no-properties
 249      (point) (save-excursion (backward-sexp) (point)))) arg))
 250
 251 (defun guile-scheme-eval-print-last-sexp ()
 252   "Evaluate sexp before point; print value into current buffer."
 253   (interactive)
 254   (let ((start (point)))
 255     (guile-scheme-eval-last-sexp t)
 256     (insert "\n")
 257     (save-excursion (goto-char start) (insert "\n"))))
 258
 259 (defun guile-scheme-eval-define ()
 260   (interactive)
 261   (guile-scheme-eval-region (save-excursion (end-of-defun) (point))
 262                             (save-excursion (beginning-of-defun) (point))))
 263
 264 (defun guile-scheme-load-file (file)
 265   "Load a Guile Scheme file."
 266   (interactive "fGuile Scheme load file: ")
 267   (guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
 268   (message "done"))
 269
 270 (guile-import guile-emacs-complete-alist)
 271
 272 (defun guile-scheme-complete-symbol ()
 273   (interactive)
 274   (let* ((end (point))
 275          (start (save-excursion (skip-syntax-backward "w_") (point)))
 276          (pattern (buffer-substring-no-properties start end))
 277          (alist (guile-emacs-complete-alist pattern)))
 278     (goto-char end)
 279     (let ((completion (try-completion pattern alist)))
 280       (cond ((eq completion t))
 281             ((not completion)
 282              (message "Can't find completion for \"%s\"" pattern)
 283              (ding))
 284             ((not (string= pattern completion))
 285              (delete-region start end)
 286              (insert completion))
 287             (t
 288              (message "Making completion list...")
 289              (with-output-to-temp-buffer "*Completions*"
 290                (display-completion-list alist))
 291              (message "Making completion list...done"))))))
 292
 293 (guile-import guile-emacs-apropos)
 294
 295 (defun guile-scheme-apropos (regexp)
 296   (interactive "sGuile Scheme apropos (regexp): ")
 297   (guile-scheme-set-module)
 298   (with-output-to-temp-buffer "*Help*"
 299     (princ (guile-emacs-apropos regexp))))
 300
 301 (guile-import guile-emacs-describe)
 302
 303 (defun guile-scheme-describe (symbol)
 304   (interactive (list (guile-scheme-input-symbol "Describe Guile variable")))
 305   (guile-scheme-set-module)
 306   (with-output-to-temp-buffer "*Help*"
 307     (princ (guile-emacs-describe symbol))))
 308
 309 (defun guile-scheme-kill-process ()
 310   (interactive)
 311   (if guile-scheme-adapter
 312       (guile-process-kill guile-scheme-adapter))
 313   (setq guile-scheme-adapter nil))
 314
 315 \f
 316 ;;;
 317 ;;; Internal functions
 318 ;;;
 319
 320 (guile-import apropos-internal guile-apropos-internal)
 321
 322 (defvar guile-scheme-complete-table (make-vector 151 nil))
 323
 324 (defun guile-scheme-input-symbol (prompt)
 325   (mapc (lambda (sym)
 326           (if (symbolp sym)
 327               (intern (symbol-name sym) guile-scheme-complete-table)))
 328         (guile-apropos-internal ""))
 329   (let* ((str (thing-at-point 'symbol))
 330          (default (if (intern-soft str guile-scheme-complete-table)
 331                       (concat " (default " str ")")
 332                     "")))
 333     (intern (completing-read (concat prompt default ": ")
 334                              guile-scheme-complete-table nil t nil nil str))))
 335
 336 \f
 337 ;;;
 338 ;;; Turn on guile-scheme-mode for .scm files by default.
 339 ;;;
 340
 341 (setq auto-mode-alist
 342       (cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist))
 343
 344 (provide 'guile-scheme)
 345
 346 ;;; guile-scheme.el ends here