538 lines
18 KiB
EmacsLisp
538 lines
18 KiB
EmacsLisp
;;; gerbil-mode.el --- Gerbil mode -*- lexical-binding: t; -*-
|
|
;;
|
|
;; Copyright (c) 2007-2019 Dimitris Vyzovitis & Contributors
|
|
;;
|
|
;; Author: Dimitris Vyzovitis <vyzo@hackzen.org>
|
|
;; URL: https://github.com/vyzo/gerbil
|
|
;; Version: 1.0
|
|
;; Keywords: gerbil major-mode
|
|
;;
|
|
;; This file is not part of GNU Emacs.
|
|
;;
|
|
;; This program 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 2.1 of the License, or (at
|
|
;; your option) any later version; and the Apache License, Version 2.0 (the
|
|
;; "License"), as published by the Apache Sofware Fundation (ASF).
|
|
;;
|
|
;; This program 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
|
|
;; and the Apache License along with this program. If not, see
|
|
;; <https://www.gnu.org/licenses/> and
|
|
;; <https://www.apache.org/licenses/LICENSE-2.0>.
|
|
;;
|
|
;; Unless required by applicable law or agreed to in writing, software
|
|
;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;; See the License for the specific language governing permissions and
|
|
;; limitations under the License.
|
|
|
|
;;; Commentary:
|
|
;;
|
|
;; This package provides a Gerbil major mode for Emacs. It extends
|
|
;; scheme-mode with font-lock, indentation, runs gxi on an inferior scheme
|
|
;; shell, and defines the following keybindings:
|
|
;;
|
|
;; * Compile the current buffer: `C-c C-f'
|
|
;;
|
|
;; * Import the current buffer: `C-c C-i'
|
|
;;
|
|
;; * Reload the current buffer: `C-c C-r'
|
|
;;
|
|
;; * Build the current project: `C-c C-b'
|
|
;;
|
|
;; * Send and evaluate the selected region to gxi: `C-c C-e'
|
|
;;
|
|
;; * Send the selected region to gxi: `C-c C-c'
|
|
;;
|
|
;; * Restart Scheme: `C-x 9' (also works in gxi)
|
|
|
|
;;; Code:
|
|
|
|
(require 'scheme)
|
|
(require 'cmuscheme)
|
|
|
|
(defgroup gerbil-mode nil
|
|
"Editing Gerbil code"
|
|
:prefix "gerbil-mode-"
|
|
:group 'scheme)
|
|
|
|
;; Redefine the function scheme-send-region from `cmuscheme' so
|
|
;; that we can keep track of all text sent to Gambit's stdin.
|
|
;; By Christopher Eames (Chream) <chream-gmx.com> 2018.
|
|
|
|
(defun scheme-send-region (start end)
|
|
"Send the current region to the inferior Scheme process."
|
|
(interactive "r")
|
|
(scheme-send-string (buffer-substring start end)))
|
|
|
|
(defun scheme-send-string (str)
|
|
"Send a string to the inferior Scheme process."
|
|
(gerbil-send-string str))
|
|
|
|
(defun gerbil-message (string)
|
|
(message (concat "Gerbil-info : SENT=" string " ...")))
|
|
|
|
(defun gerbil-send-string (string)
|
|
(let ((string (concat string "\n")))
|
|
(comint-check-source string)
|
|
(comint-send-string (scheme-proc) string)
|
|
(gerbil-message (seq-subseq string 0 (string-match "\n" string)))))
|
|
|
|
;; -------
|
|
|
|
;; fare's erlang style restart
|
|
(defun restart-scheme ()
|
|
(interactive)
|
|
(let ((process (scheme-get-process)))
|
|
(when process
|
|
(ignore-errors
|
|
(switch-to-buffer "*scheme*")
|
|
(comint-clear-buffer))
|
|
(ignore-errors (kill-process process))
|
|
(sleep-for 1))) ;; <-- poor man's substitute for waitpid(), with a race condition
|
|
;; TODO: elisp doesn't have a synchronous waitpid, so instead we should implement an asynchronous one,
|
|
;; using callbacks: use (set-process-sentinel PROCESS SENTINEL) to watch for the death of the process;
|
|
;; and while we're at it, also set a timer and use kill -9 < https://youtu.be/Fow7iUaKrq4 >
|
|
;; if the process failed to die after one second or two.
|
|
(switch-to-buffer "*scheme*")
|
|
(run-scheme scheme-program-name)
|
|
(ignore-errors (comint-clear-buffer))
|
|
(message "Happy Happy Joy Joy")
|
|
nil)
|
|
|
|
;; this is bound to C-x 9 below
|
|
|
|
;; -------
|
|
|
|
(defun gerbil-import-file (fname)
|
|
(let ((string (concat "(import \"" fname "\")\n")))
|
|
(comint-check-source fname)
|
|
(comint-send-string
|
|
(scheme-proc)
|
|
string)
|
|
(gerbil-message string)))
|
|
|
|
(defun gerbil-reload-file (fname)
|
|
(let ((string (concat "(reload \"" fname "\")\n")))
|
|
(comint-check-source fname)
|
|
(comint-send-string
|
|
(scheme-proc)
|
|
string)
|
|
(gerbil-message string)))
|
|
|
|
(defun gerbil-import-current-buffer ()
|
|
(interactive)
|
|
(gerbil-import-file buffer-file-name))
|
|
|
|
(defun gerbil-reload-current-buffer ()
|
|
(interactive)
|
|
(gerbil-reload-file buffer-file-name))
|
|
|
|
(defvar gerbil-compile-optimize t)
|
|
(defvar gerbil-build-directory nil)
|
|
(defvar gerbil-compiler-name "gxc")
|
|
|
|
(defun gerbil-compile-current-buffer ()
|
|
(interactive)
|
|
(let* ((fname buffer-file-name)
|
|
(buf (get-buffer-create "*gerbil-compile*"))
|
|
(cmd-text (concat "> gxc " (if gerbil-compile-optimize "-O " "") fname "\n")))
|
|
(with-current-buffer buf
|
|
(goto-char (point-max))
|
|
(insert cmd-text))
|
|
(message cmd-text)
|
|
(setq gerbil-build-directory nil)
|
|
(let ((proc
|
|
(apply 'start-process gerbil-compiler-name buf
|
|
gerbil-compiler-name
|
|
(append (if gerbil-compile-optimize '("-O") '())
|
|
(list fname)))))
|
|
(set-process-sentinel proc 'gerbil-compile-sentinel)
|
|
(display-buffer buf))))
|
|
|
|
(defun gerbil-build ()
|
|
(interactive)
|
|
(let* ((dir (file-name-directory buffer-file-name))
|
|
(build (gerbil-find-build-script dir))
|
|
(build-dir (file-name-directory build))
|
|
(build-script (file-name-nondirectory build))
|
|
(buf (get-buffer-create "*gerbil-compile*")))
|
|
(with-current-buffer buf
|
|
(goto-char (point-max))
|
|
(insert "> build " build "\n"))
|
|
(setq gerbil-build-directory build-dir)
|
|
(let ((proc (start-process "build" buf "sh" "-c"
|
|
(concat "cd " build-dir " && ./" build-script))))
|
|
(set-process-sentinel proc 'gerbil-compile-sentinel)
|
|
(display-buffer buf))))
|
|
|
|
(defun gerbil-find-build-script (dir)
|
|
(let ((files (directory-files dir nil "^build.ss$")))
|
|
(cond
|
|
(files
|
|
(concat dir (car files)))
|
|
((equal dir "/")
|
|
(error "Cannot locate build script"))
|
|
(t
|
|
(let ((dir (file-name-directory (directory-file-name dir))))
|
|
(gerbil-find-build-script dir))))))
|
|
|
|
(defvar gerbil-compile-mark-rx
|
|
"^> \\(gxc\\|build\\)")
|
|
(defvar gerbil-error-locat-rx
|
|
"\\(\\\"\\(\\\\\\\\\\|\\\\\"\\|[^\\\"\n]\\)+\\\"\\)@\\([0-9]+\\)\\.\\([0-9]+\\)[^0-9]")
|
|
|
|
(defun gerbil-compile-sentinel (proc evt)
|
|
(let ((buf (process-buffer proc)))
|
|
(when buf
|
|
(cond
|
|
((equal evt "finished\n")
|
|
(kill-buffer buf))
|
|
((or (string-prefix-p "exited" evt)
|
|
(string-prefix-p "failed" evt))
|
|
(with-current-buffer buf
|
|
(goto-char (point-max))
|
|
(when (re-search-backward gerbil-compile-mark-rx nil t)
|
|
(let ((limit (point)))
|
|
(goto-char (point-max))
|
|
(when (re-search-backward gerbil-error-locat-rx limit t)
|
|
(let* ((loc (gerbil-extract-locat (buffer-substring (point) (point-max))))
|
|
(fname (if gerbil-build-directory
|
|
(concat gerbil-build-directory (car loc))
|
|
(car loc))))
|
|
(find-file fname)
|
|
(goto-char (point-min))
|
|
(forward-line (1- (cadr loc)))
|
|
(forward-char (- (caddr loc) 1))
|
|
(mark-sexp)))))))
|
|
(t
|
|
(with-current-buffer buf
|
|
(goto-char (point-max))
|
|
(insert "\nProcess " evt)))))))
|
|
|
|
(defun gerbil-extract-locat (str)
|
|
(and (string-match gerbil-error-locat-rx str)
|
|
(let* ((name (substring str
|
|
(match-beginning 1)
|
|
(match-end 1)))
|
|
(line (substring str
|
|
(match-beginning 3)
|
|
(match-end 3)))
|
|
(col (substring str
|
|
(match-beginning 4)
|
|
(match-end 4))))
|
|
(list (read name) (read line) (read col)))))
|
|
|
|
(defun gerbil-put (syms prop v)
|
|
(dolist (x syms)
|
|
(put x prop v)))
|
|
|
|
(defun gerbil-put-indent (syms v)
|
|
(gerbil-put syms 'scheme-indent-function v))
|
|
|
|
(defun gerbil-fontlock-add (x)
|
|
(font-lock-add-keywords nil (list x) t))
|
|
|
|
(defun gerbil-init-keywords ()
|
|
(interactive)
|
|
(gerbil-put '(import export declare include
|
|
or and
|
|
case-lambda
|
|
call/cc call/values
|
|
begin-syntax
|
|
begin-foreign
|
|
cond-expand
|
|
for-each map foldl foldr
|
|
unwind-protect
|
|
)
|
|
'scheme-indent-function 0)
|
|
|
|
(gerbil-put '(if when unless
|
|
set!
|
|
begin-annotation begin0
|
|
datum->syntax syntax/loc
|
|
core-match core-wrap
|
|
with-syntax with-syntax*
|
|
ast-rules
|
|
with-ast with-ast*
|
|
apply
|
|
let-values letrec-values letrec*-values
|
|
module
|
|
syntax-parameterize
|
|
rec alet alet* awhen
|
|
let-syntax letrec-syntax
|
|
parameterize parameterize*
|
|
error raise-syntax-error raise-type-error
|
|
catch guard
|
|
match match*
|
|
with with*
|
|
let/cc let/esc
|
|
lambda%
|
|
chain
|
|
identifier-rules
|
|
letrec*
|
|
while
|
|
let-hash
|
|
for for* for/collect
|
|
begin-ffi
|
|
test-suite test-case
|
|
)
|
|
'scheme-indent-function 1)
|
|
(gerbil-put '(syntax-case ast-case core-syntax-case core-ast-case
|
|
do-while
|
|
for/fold
|
|
)
|
|
'scheme-indent-function 2)
|
|
(gerbil-put '(def defvalues extern
|
|
defalias defsyntax defrule defrules defrules*
|
|
defstruct defclass defgeneric defmethod
|
|
definline definline*
|
|
define-values define-syntaxes
|
|
)
|
|
'scheme-indent-function 'defun)
|
|
)
|
|
|
|
(defun gerbil-init-fontlock ()
|
|
(interactive)
|
|
(gerbil-fontlock-add
|
|
(cons
|
|
(concat
|
|
"(" (regexp-opt '("import" "export" "declare" "include"
|
|
"module" "extern" "cond-expand" "require" "provide"
|
|
"if" "apply" "eval" "set!"
|
|
"when" "unless" "not"
|
|
"case-lambda"
|
|
"core-syntax-case" "core-ast-case"
|
|
"syntax-case" "ast-case" "ast-rules"
|
|
"identifier-rules"
|
|
"core-match"
|
|
"with-syntax" "with-syntax*"
|
|
"with-ast" "with-ast*"
|
|
"call/cc" "call/values"
|
|
"begin-syntax" "begin-annotation" "begin0"
|
|
"let-values" "letrec-values" "letrec*-values"
|
|
"letrec*" "rec"
|
|
"quote" "quasiquote" "unquote" "unquote-splicing"
|
|
"parameterize" "syntax-parameterize"
|
|
"quote-syntax"
|
|
"syntax" "quasisyntax" "unsyntax" "unsyntax-splicing"
|
|
"syntax/loc"
|
|
"define-values" "define-alias"
|
|
"alet" "alet*"
|
|
"error" "raise"
|
|
"let/cc" "let/esc"
|
|
"unwind-protect"
|
|
"begin-foreign" "begin-ffi"
|
|
"cut"
|
|
"with" "with*"
|
|
"match" "match*"
|
|
"sync" "wait"
|
|
"foldl" "foldr" "andmap" "ormap"
|
|
"type-of"
|
|
"spawn" "spawn*" "spawn/name" "spawn/group"
|
|
;; sugar
|
|
"try" "finally" "catch" "with-destroy"
|
|
"while" "until" "using" "defmethod/alias"
|
|
"with-methods" "with-class-methods" "with-class-method"
|
|
"hash" "hash-eq" "hash-eqv" "let-hash" "assert!" "awhen"
|
|
"chain" "is"
|
|
;; coroutines
|
|
"continue" "yield" "coroutine"
|
|
;; iterators
|
|
"for" "for*" "for/collect" "for/fold"
|
|
;; actor messaging
|
|
"<-" "<<" "->"
|
|
;; test
|
|
"run-tests!" "test-suite" "test-case"
|
|
"check" "checkf" "check-eq?" "check-not-eq?" "check-eqv?"
|
|
"check-not-eqv?" "check-equal?" "check-not-equal?"
|
|
"check-output" "check-predicate" "check-exception"
|
|
)
|
|
t)
|
|
"\\>")
|
|
1))
|
|
(gerbil-fontlock-add
|
|
'("\\(XXX\\|TODO\\)"
|
|
(1 font-lock-warning-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\_<\\(values\\)\\_>"
|
|
(1 font-lock-keyword-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\_<\\(\\sw+:\\)\\_>"
|
|
(1 font-lock-builtin-face)))
|
|
|
|
(gerbil-fontlock-add
|
|
'("\\<\\(<>\\|<\\.\\.\\.>\\>\\)"
|
|
(1 font-lock-builtin-face)))
|
|
|
|
(gerbil-fontlock-add
|
|
'("\\_<\\([.][.][.]\\)"
|
|
(1 font-lock-builtin-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\_<\\(=>\\)"
|
|
(1 font-lock-builtin-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\(#?[`',]\\)"
|
|
(1 font-lock-keyword-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\(#?,@\\)"
|
|
(1 font-lock-keyword-face)))
|
|
|
|
(gerbil-fontlock-add
|
|
'("\\(%#\\w+\\)"
|
|
(1 font-lock-builtin-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\_<\\(:\\sw+\\)\\_>"
|
|
(1 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(@\\)"
|
|
(1 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(def\\)\\s-+(?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-function-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(def\\)\\s-+\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-function-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(def[*]\\)\\s-+(*\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-function-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defvalues\\)\\s-+(\\([^()]*\\))"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-function-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(definline[*]?\\)\\s-+(?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-function-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defsyntax\\)\\s-+(?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defsyntax-\\sw+\\)\\s-+(?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defrule\\)\\s-+(\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defrules\\|defalias\\|module\\)\\s-+\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defun\\|deflabel\\)\\s-+\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-function-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defasm\\|deftemplate\\)\\s-+\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(deftype\\)\\s-+(?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-type-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(def\\sw+-rules\\)\\s-+(?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-variable-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defstruct\\|defclass\\|class\\|struct\\|interface\\|union\\)\\s-+(?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-type-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defstruct-type\\|defclass-type\\)\\s-+\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-type-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defgeneric\\|defmethod[*]?\\)\\s-+[{(]?\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-function-name-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defproto\\)\\s-+\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-type-face)))
|
|
(gerbil-fontlock-add
|
|
'("(\\(defregister\\|defvar\\|defconst\\)\\s-+\\(\\sw+\\)"
|
|
(1 font-lock-keyword-face)
|
|
(2 font-lock-variable-name-face)))
|
|
|
|
(gerbil-fontlock-add
|
|
'("\\_<\\([?!&]+\\)"
|
|
(1 font-lock-builtin-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\<\\(#[tf]\\|#!\\w+\\)"
|
|
(1 font-lock-builtin-face)))
|
|
(gerbil-fontlock-add
|
|
'("\\([_#]+\\)"
|
|
(1 font-lock-builtin-face)))
|
|
|
|
(gerbil-fontlock-add
|
|
'("\\([{}]\\|\\[\\|\\]\\)"
|
|
(1 font-lock-variable-name-face)))
|
|
)
|
|
|
|
(defun gerbil-pretty-lambdas ()
|
|
(interactive)
|
|
(gerbil-fontlock-add
|
|
`("\\(lambda\\)"
|
|
(0 (progn
|
|
(compose-region (match-beginning 1) (match-end 1)
|
|
,(make-char 'greek-iso8859-7 107))
|
|
nil)))))
|
|
|
|
(defun gerbil-init ()
|
|
(interactive)
|
|
(gerbil-init-keywords)
|
|
(gerbil-init-fontlock)
|
|
(when window-system
|
|
(gerbil-pretty-lambdas)))
|
|
|
|
(define-key scheme-mode-map (kbd "C-x 9") 'restart-scheme)
|
|
(define-key inferior-scheme-mode-map (kbd "C-x 9") 'restart-scheme)
|
|
|
|
(defvar gerbil-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(set-keymap-parent map scheme-mode-map)
|
|
(define-key map (kbd "C-c C-f") 'gerbil-compile-current-buffer)
|
|
(define-key map (kbd "C-c C-i") 'gerbil-import-current-buffer)
|
|
(define-key map (kbd "C-c C-r") 'gerbil-reload-current-buffer)
|
|
(define-key map (kbd "C-c C-b") 'gerbil-build)
|
|
(define-key map (kbd "C-c C-e") 'scheme-send-definition)
|
|
(define-key map (kbd "C-c C-c") 'scheme-send-region)
|
|
map))
|
|
|
|
(defvar gerbil-program-name "gxi")
|
|
(defvar gerbil-mode-hook nil)
|
|
|
|
;;;###autoload
|
|
(define-derived-mode gerbil-mode scheme-mode
|
|
"Gerbil" "Major mode for Gerbil."
|
|
(kill-all-local-variables)
|
|
(use-local-map gerbil-mode-map)
|
|
(setq mode-name "Gerbil")
|
|
(setq major-mode 'gerbil-mode)
|
|
(setq scheme-program-name gerbil-program-name)
|
|
(setq comment-start ";;")
|
|
(scheme-mode-variables)
|
|
(gerbil-init)
|
|
(run-hooks 'gerbil-mode-hook))
|
|
|
|
;;;###autoload
|
|
(progn
|
|
(add-to-list 'auto-mode-alist '("\\.ss\\'" . gerbil-mode))
|
|
(modify-coding-system-alist 'file "\\.ss\\'" 'utf-8))
|
|
|
|
|
|
(provide 'gerbil-mode)
|
|
|
|
;;; gerbil-mode.el ends here
|