mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
53befeb700
(Not quite finished, the following will be done tomorrow. module/srfi/*.scm module/rnrs/*.scm module/scripts/*.scm testsuite/*.scm guile-readline/* )
346 lines
11 KiB
EmacsLisp
346 lines
11 KiB
EmacsLisp
;;; guile-scheme.el --- Guile Scheme editing mode
|
||
|
||
;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library 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
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free
|
||
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
|
||
;;;; 02111-1307 USA
|
||
|
||
;;; Commentary:
|
||
|
||
;; Put the following lines in your ~/.emacs:
|
||
;;
|
||
;; (require 'guile-scheme)
|
||
;; (setq initial-major-mode 'scheme-interaction-mode)
|
||
|
||
;;; Code:
|
||
|
||
(require 'guile)
|
||
(require 'scheme)
|
||
|
||
(defgroup guile-scheme nil
|
||
"Editing Guile-Scheme code"
|
||
:group 'lisp)
|
||
|
||
(defvar guile-scheme-syntax-keywords
|
||
'((begin 0) (if 1) (cond 0) (case 1) (do 2)
|
||
quote syntax lambda and or else delay receive use-modules
|
||
(match 1) (match-lambda 0) (match-lambda* 0)
|
||
(let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1)
|
||
(let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2)))
|
||
|
||
(defvar guile-scheme-special-procedures
|
||
'((catch 1) (lazy-catch 1) (stack-catch 1)
|
||
map for-each (dynamic-wind 3)))
|
||
|
||
;; set indent functions
|
||
(dolist (x (append guile-scheme-syntax-keywords
|
||
guile-scheme-special-procedures))
|
||
(when (consp x)
|
||
(put (car x) 'scheme-indent-function (cadr x))))
|
||
|
||
(defconst guile-scheme-font-lock-keywords
|
||
(eval-when-compile
|
||
(list
|
||
(list (concat "(\\(define\\*?\\("
|
||
;; Function names.
|
||
"\\(\\|-public\\|-method\\|-generic\\)\\|"
|
||
;; Macro names, as variable names.
|
||
"\\(-syntax\\|-macro\\)\\|"
|
||
;; Others
|
||
"-\\sw+\\)\\)\\>"
|
||
;; Any whitespace and declared object.
|
||
"\\s *(?\\(\\sw+\\)?")
|
||
'(1 font-lock-keyword-face)
|
||
'(5 (cond ((match-beginning 3) font-lock-function-name-face)
|
||
((match-beginning 4) font-lock-variable-name-face)
|
||
(t font-lock-type-face)) nil t))
|
||
(list (concat
|
||
"(" (regexp-opt
|
||
(mapcar (lambda (e)
|
||
(prin1-to-string (if (consp e) (car e) e)))
|
||
(append guile-scheme-syntax-keywords
|
||
guile-scheme-special-procedures)) 'words))
|
||
'(1 font-lock-keyword-face))
|
||
'("<\\sw+>" . font-lock-type-face)
|
||
'("\\<:\\sw+\\>" . font-lock-builtin-face)
|
||
))
|
||
"Expressions to highlight in Guile Scheme mode.")
|
||
|
||
|
||
;;;
|
||
;;; Guile Scheme mode
|
||
;;;
|
||
|
||
(defvar guile-scheme-mode-map nil
|
||
"Keymap for Guile Scheme mode.
|
||
All commands in `lisp-mode-shared-map' are inherited by this map.")
|
||
|
||
(unless guile-scheme-mode-map
|
||
(let ((map (make-sparse-keymap "Guile-Scheme")))
|
||
(setq guile-scheme-mode-map map)
|
||
(cond ((boundp 'lisp-mode-shared-map)
|
||
(set-keymap-parent map lisp-mode-shared-map))
|
||
((boundp 'shared-lisp-mode-map)
|
||
(set-keymap-parent map shared-lisp-mode-map)))
|
||
(define-key map [menu-bar] (make-sparse-keymap))
|
||
(define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map))
|
||
(define-key map [uncomment-region]
|
||
'("Uncomment Out Region" . (lambda (beg end)
|
||
(interactive "r")
|
||
(comment-region beg end '(4)))))
|
||
(define-key map [comment-region] '("Comment Out Region" . comment-region))
|
||
(define-key map [indent-region] '("Indent Region" . indent-region))
|
||
(define-key map [indent-line] '("Indent Line" . lisp-indent-line))
|
||
(define-key map "\e\C-i" 'guile-scheme-complete-symbol)
|
||
(define-key map "\e\C-x" 'guile-scheme-eval-define)
|
||
(define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp)
|
||
(define-key map "\C-c\C-b" 'guile-scheme-eval-buffer)
|
||
(define-key map "\C-c\C-r" 'guile-scheme-eval-region)
|
||
(define-key map "\C-c:" 'guile-scheme-eval-expression)
|
||
(define-key map "\C-c\C-a" 'guile-scheme-apropos)
|
||
(define-key map "\C-c\C-d" 'guile-scheme-describe)
|
||
(define-key map "\C-c\C-k" 'guile-scheme-kill-process)
|
||
|
||
(put 'comment-region 'menu-enable 'mark-active)
|
||
(put 'uncomment-region 'menu-enable 'mark-active)
|
||
(put 'indent-region 'menu-enable 'mark-active)))
|
||
|
||
(defcustom guile-scheme-mode-hook nil
|
||
"Normal hook run when entering `guile-scheme-mode'."
|
||
:type 'hook
|
||
:group 'guile-scheme)
|
||
|
||
;;;###autoload
|
||
(defun guile-scheme-mode ()
|
||
"Major mode for editing Guile Scheme code.
|
||
Editing commands are similar to those of `scheme-mode'.
|
||
|
||
\\{scheme-mode-map}
|
||
Entry to this mode calls the value of `scheme-mode-hook'
|
||
if that value is non-nil."
|
||
(interactive)
|
||
(kill-all-local-variables)
|
||
(setq mode-name "Guile Scheme")
|
||
(setq major-mode 'guile-scheme-mode)
|
||
(use-local-map guile-scheme-mode-map)
|
||
(scheme-mode-variables)
|
||
(setq mode-line-process
|
||
'(:eval (if (processp guile-scheme-adapter)
|
||
(format " [%s]" guile-scheme-command)
|
||
"")))
|
||
(setq font-lock-defaults
|
||
'((guile-scheme-font-lock-keywords)
|
||
nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun
|
||
(font-lock-mark-block-function . mark-defun)))
|
||
(run-hooks 'guile-scheme-mode-hook))
|
||
|
||
|
||
;;;
|
||
;;; Scheme interaction mode
|
||
;;;
|
||
|
||
(defvar scheme-interaction-mode-map ()
|
||
"Keymap for Scheme Interaction mode.
|
||
All commands in `guile-scheme-mode-map' are inherited by this map.")
|
||
|
||
(unless scheme-interaction-mode-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(setq scheme-interaction-mode-map map)
|
||
(set-keymap-parent map guile-scheme-mode-map)
|
||
(define-key map "\C-j" 'guile-scheme-eval-print-last-sexp)
|
||
))
|
||
|
||
(defvar scheme-interaction-mode-hook nil
|
||
"Normal hook run when entering `scheme-interaction-mode'.")
|
||
|
||
(defun scheme-interaction-mode ()
|
||
"Major mode for evaluating Scheme expressions with Guile.
|
||
|
||
\\{scheme-interaction-mode-map}"
|
||
(interactive)
|
||
(guile-scheme-mode)
|
||
(use-local-map scheme-interaction-mode-map)
|
||
(setq major-mode 'scheme-interaction-mode)
|
||
(setq mode-name "Scheme Interaction")
|
||
(run-hooks 'scheme-interaction-mode-hook))
|
||
|
||
|
||
;;;
|
||
;;; Guile Scheme adapter
|
||
;;;
|
||
|
||
(defvar guile-scheme-command "guile")
|
||
(defvar guile-scheme-adapter nil)
|
||
(defvar guile-scheme-module nil)
|
||
|
||
(defun guile-scheme-adapter ()
|
||
(if (and (processp guile-scheme-adapter)
|
||
(eq (process-status guile-scheme-adapter) 'run))
|
||
guile-scheme-adapter
|
||
(setq guile-scheme-module nil)
|
||
(setq guile-scheme-adapter
|
||
(guile:make-adapter guile-scheme-command 'emacs-scheme-channel))))
|
||
|
||
(defun guile-scheme-set-module ()
|
||
"Set the current module based on buffer contents.
|
||
If there is a (define-module ...) form, evaluate it.
|
||
Otherwise, choose module (guile-user)."
|
||
(save-excursion
|
||
(let ((module (if (re-search-backward "^(define-module " nil t)
|
||
(let ((start (match-beginning 0)))
|
||
(goto-char start)
|
||
(forward-sexp)
|
||
(buffer-substring-no-properties start (point)))
|
||
"(define-module (emacs-user))")))
|
||
(unless (string= guile-scheme-module module)
|
||
(prog1 (guile:eval module (guile-scheme-adapter))
|
||
(setq guile-scheme-module module))))))
|
||
|
||
(defun guile-scheme-eval-string (string)
|
||
(guile-scheme-set-module)
|
||
(guile:eval string (guile-scheme-adapter)))
|
||
|
||
(defun guile-scheme-display-result (value flag)
|
||
(if (string= value "#<unspecified>")
|
||
(setq value "done"))
|
||
(if flag
|
||
(insert value)
|
||
(message "%s" value)))
|
||
|
||
|
||
;;;
|
||
;;; Interactive commands
|
||
;;;
|
||
|
||
(defun guile-scheme-eval-expression (string)
|
||
"Evaluate the expression in STRING and show value in echo area."
|
||
(interactive "SGuile Scheme Eval: ")
|
||
(guile-scheme-display-result (guile-scheme-eval-string string) nil))
|
||
|
||
(defun guile-scheme-eval-region (start end)
|
||
"Evaluate the region as Guile Scheme code."
|
||
(interactive "r")
|
||
(guile-scheme-eval-expression (buffer-substring-no-properties start end)))
|
||
|
||
(defun guile-scheme-eval-buffer ()
|
||
"Evaluate the current buffer as Guile Scheme code."
|
||
(interactive)
|
||
(guile-scheme-eval-expression (buffer-string)))
|
||
|
||
(defun guile-scheme-eval-last-sexp (arg)
|
||
"Evaluate sexp before point; show value in echo area.
|
||
With argument, print output into current buffer."
|
||
(interactive "P")
|
||
(guile-scheme-display-result
|
||
(guile-scheme-eval-string
|
||
(buffer-substring-no-properties
|
||
(point) (save-excursion (backward-sexp) (point)))) arg))
|
||
|
||
(defun guile-scheme-eval-print-last-sexp ()
|
||
"Evaluate sexp before point; print value into current buffer."
|
||
(interactive)
|
||
(let ((start (point)))
|
||
(guile-scheme-eval-last-sexp t)
|
||
(insert "\n")
|
||
(save-excursion (goto-char start) (insert "\n"))))
|
||
|
||
(defun guile-scheme-eval-define ()
|
||
(interactive)
|
||
(guile-scheme-eval-region (save-excursion (end-of-defun) (point))
|
||
(save-excursion (beginning-of-defun) (point))))
|
||
|
||
(defun guile-scheme-load-file (file)
|
||
"Load a Guile Scheme file."
|
||
(interactive "fGuile Scheme load file: ")
|
||
(guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
|
||
(message "done"))
|
||
|
||
(guile-import guile-emacs-complete-alist)
|
||
|
||
(defun guile-scheme-complete-symbol ()
|
||
(interactive)
|
||
(let* ((end (point))
|
||
(start (save-excursion (skip-syntax-backward "w_") (point)))
|
||
(pattern (buffer-substring-no-properties start end))
|
||
(alist (guile-emacs-complete-alist pattern)))
|
||
(goto-char end)
|
||
(let ((completion (try-completion pattern alist)))
|
||
(cond ((eq completion t))
|
||
((not completion)
|
||
(message "Can't find completion for \"%s\"" pattern)
|
||
(ding))
|
||
((not (string= pattern completion))
|
||
(delete-region start end)
|
||
(insert completion))
|
||
(t
|
||
(message "Making completion list...")
|
||
(with-output-to-temp-buffer "*Completions*"
|
||
(display-completion-list alist))
|
||
(message "Making completion list...done"))))))
|
||
|
||
(guile-import guile-emacs-apropos)
|
||
|
||
(defun guile-scheme-apropos (regexp)
|
||
(interactive "sGuile Scheme apropos (regexp): ")
|
||
(guile-scheme-set-module)
|
||
(with-output-to-temp-buffer "*Help*"
|
||
(princ (guile-emacs-apropos regexp))))
|
||
|
||
(guile-import guile-emacs-describe)
|
||
|
||
(defun guile-scheme-describe (symbol)
|
||
(interactive (list (guile-scheme-input-symbol "Describe Guile variable")))
|
||
(guile-scheme-set-module)
|
||
(with-output-to-temp-buffer "*Help*"
|
||
(princ (guile-emacs-describe symbol))))
|
||
|
||
(defun guile-scheme-kill-process ()
|
||
(interactive)
|
||
(if guile-scheme-adapter
|
||
(guile-process-kill guile-scheme-adapter))
|
||
(setq guile-scheme-adapter nil))
|
||
|
||
|
||
;;;
|
||
;;; Internal functions
|
||
;;;
|
||
|
||
(guile-import apropos-internal guile-apropos-internal)
|
||
|
||
(defvar guile-scheme-complete-table (make-vector 151 nil))
|
||
|
||
(defun guile-scheme-input-symbol (prompt)
|
||
(mapc (lambda (sym)
|
||
(if (symbolp sym)
|
||
(intern (symbol-name sym) guile-scheme-complete-table)))
|
||
(guile-apropos-internal ""))
|
||
(let* ((str (thing-at-point 'symbol))
|
||
(default (if (intern-soft str guile-scheme-complete-table)
|
||
(concat " (default " str ")")
|
||
"")))
|
||
(intern (completing-read (concat prompt default ": ")
|
||
guile-scheme-complete-table nil t nil nil str))))
|
||
|
||
|
||
;;;
|
||
;;; Turn on guile-scheme-mode for .scm files by default.
|
||
;;;
|
||
|
||
(setq auto-mode-alist
|
||
(cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist))
|
||
|
||
(provide 'guile-scheme)
|
||
|
||
;;; guile-scheme.el ends here
|