Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
479 lines (436 sloc) 15.5 KB
;;; (C) vyzo@hackzen.org
;;; gerbil editing mode
(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 scheme-compile-region (start end)
(interactive)
(gerbil-compile-current-buffer))
(defun gerbil-message (string)
(message (concat "Gerbil-info : SENT=" string " ...")))
(defun gerbil-send-string (string)
(let ((string (concat string "\n"))
(string-len (length string)))
(comint-check-source string)
(comint-send-string (scheme-proc) string)
(gerbil-message (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 globally 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-line (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*
let-syntax letrec-syntax
parameterize parameterize*
error raise-syntax-error raise-type-error
catch guard
match match*
with with*
let/cc let/esc
lambda%
identifier-rules
letrec*
while
let-hash
for for* for/collect
begin-ffi
)
'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"
"while" "until" "using"
"hash" "hash-eq" "hash-eqv" "let-hash"
;; coroutines
"continue" "yield" "coroutine"
;; iterators
"for" "for*" "for/collect" "for/fold"
;; actor messaging
"<-" "<<" "->"
)
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 paren-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)))
(global-set-key (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 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)