diff --git a/retroforth.el b/retroforth.el new file mode 100644 index 0000000..38800ae --- /dev/null +++ b/retroforth.el @@ -0,0 +1,285 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; retroforth-mode for emacs +;; version: 0.01 +;; RETRO 12 syntax +;; +;; ---------------------------------------------------------- +;; Copyright (c) 2021 Philippe Brochard +;; +;; Permission to use, copy, modify, and/or distribute this software +;; for any purpose with or without fee is hereby granted, provided +;; that the above copyright notice and this permission notice appear +;; in all copies. +;; +;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR +;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +;; LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, +;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN +;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +;; ---------------------------------------------------------- +;; ( http://en.wikipedia.org/wiki/ISC_license ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; usage : add this to your .emacs file: +;; +;; (add-to-list 'load-path ) +;; (require 'retroforth) +;; +;; files in *.retro will be open in retroforth mode +;; +;; interactions: +;; +;; C-M-x retroforth-eval-block-region +;; C-c C-k forth-kill +;; C-c C-f forth-restart +;; C-c : forth-eval +;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; changelog +;; +;; 2021-03-30 v. 0.01 hocwp +;; retroforth-mode for emacs +;; limited to basic syntax highlighting +;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; implementation +;; + + +;---------------------------------------------------------- +; forth-mode require for basic usage already defined in this mode: +; +(require 'forth-mode) + + + +;---------------------------------------------------------- +; retroforth groups definitions +; +(defgroup retroforth nil + "Major mode for editing and running RETRO Forth." + :prefix "retrofoth-" + :link '(url-link "http://www.retroforth.org/")) + +(defgroup retroforth-lock-faces nil + "Major mode for editing and running RETRO Forth." + :prefix "retrofoth-" + :group 'retroforth + :link '(url-link "http://www.retroforth.org/")) + + +;---------------------------------------------------------- +; tables +; start with empty syntax and abbrev tables +; +(defvar retroforth-mode-syntax-table (make-syntax-table) "") +(defvar retroforth-mode-abbrev-table (make-abbrev-table) "") + +(defvar retroforth-block-regex "~~~\\|```") + + +;---------------------------------------------------------- +; face definitions for syntax highlighting +; ( instead of editing the colors here, use M-x customize-face ) +; +;;; Markdown faces +(defface retroforth-markdown-title-face + '((t (:foreground "blue"))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-markdown-italic-face + '((t (:inherit italic))) + "Face for italic text." + :group 'retroforth-lock-faces) + +(defface retroforth-markdown-bold-face + '((t (:inherit bold))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-markdown-inline-code-face + '((t (:foreground "dark cyan"))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +;;; Code faces +(defface retroforth-block-highlight + '((t (:background "seashell" :extend t))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-define-face + '((t (:foreground "red" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-compile-face + '((t (:foreground "green4" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-execute-face + '((t (:foreground "yellow4" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-number-face + '((t (:foreground "dark blue" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-string-face + '((t (:foreground "VioletRed4" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-comment-face + '((t (:foreground "grey40" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-bracket-face + '((t (:foreground "darkorange3" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-code-face + '((t (:foreground "grey40" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-var-face + '((t (:foreground "dark magenta" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-keyword-face + '((t (:foreground "dark blue" :inherit retroforth-block-highlight))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defface retroforth-highlight-face + '((t (:background "azure2" :extend t))) + "Face for retroforth mode." + :group 'retroforth-lock-faces) + +(defun defprefixhighlight (prefix face) + (cons (format "\\(^\\|[ \n\t]\\)%s[^ \n\t]+" prefix) `(0 ',face t))) + +(setq retroforth-highlights + (let* ((keywords '("bye" "TIB" "abort" "include" "FREE" "dump-stack" "reset" + "tab" "sp" "nl" "unhook" "set-hook" "hook" "indexed-times" + "K" "J" "I" "does" "curry" "reorder" "STRINGS" "TempStringMax" + "TempStrings" "---reveal---" "ScopeList" "copy" "allot" "mod" + "rot" "-if;" "if;" "gteq?" "lteq?" "not" "case" "FALSE" "TRUE" + "times" "until" "while" "tri@" "tri*" "tri" "bi@" "bi*" "bi" "sip" + "dip" "dup-pair" "?dup" "drop-pair" "nip" "over" "tuck" "const" + "var" "var-n" "here" "compiling?" "primitive" "data" "immediate" + "reclass" "depth" "EOM" "Version" "interpret" "again" "repeat" "Dictionary" + "Heap" "Compiler" "-if" "if" "choose" "store-next" "fetch-next" "pop" + "push" "shift" "xor" "or" "and" "/mod" "store" "fetch" + "gt?" "lt?" "-eq?" "eq?" "call" "swap" "drop" "dup")) + (keywords-regexp (regexp-opt keywords 'words))) + `(("\\(~~~\\|```\\)\\(.\\|\n\\)*?\\(~~~\\|```\\)" . (0 'retroforth-block-highlight t)) + ("[]{}\\[]" . (0 'retroforth-bracket-face t)) + ("^#.*$" . (0 'retroforth-markdown-title-face t)) + (,keywords-regexp . (0 'retroforth-keyword-face t)) + (" \\*.*\\*" . (0 'retroforth-markdown-bold-face t)) + (" _.*_" . (0 'retroforth-markdown-italic-face t)) + (" `.*`" . (0 'retroforth-markdown-inline-code-face t)) + ,(defprefixhighlight "\\w+:" 'retroforth-compile-face) + ,(defprefixhighlight "#[0-9]+" 'retroforth-number-face) + ,(defprefixhighlight "\\." 'retroforth-number-face) + ("\\$." (0 'retroforth-number-face t)) + ,(defprefixhighlight "'" 'retroforth-string-face) + ,(defprefixhighlight ":" 'retroforth-define-face) + (" ;" . (0 'retroforth-define-face t)) + ,(defprefixhighlight "(" 'retroforth-comment-face) + ,(defprefixhighlight "&" 'retroforth-var-face) + ,(defprefixhighlight "@" 'retroforth-var-face) + ,(defprefixhighlight "!" 'retroforth-var-face)))) + + +;---------------------------------------------------------- +; forth mode interactions +; +(defun retroforth-interaction-send (&rest strings) + (forth-scrub (or (apply #'forth-interaction-send-raw-result strings) + "OK: No output"))) + +(defun retroforth-eval (string) + (interactive "sForth expression: ") + (message "%s" (retroforth-interaction-send string))) + +(defun retroforth-eval-region (start end) + (interactive "r") + (retroforth-eval (buffer-substring start end))) + +(defun retroforth-eval-block-region () + (interactive) + (save-excursion + (re-search-backward retroforth-block-regex) (next-line) + (beginning-of-line) + (let ((beg (point))) + (re-search-forward retroforth-block-regex) + (beginning-of-line) + (pulse-momentary-highlight-region beg (point) 'retroforth-highlight-face) + (retroforth-eval-region beg (point))))) + +(defvar retroforth-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-M-x") 'retroforth-eval-block-region) + (define-key map (kbd "C-c C-k") 'forth-kill) + (define-key map (kbd "C-c C-f") 'forth-restart) + (define-key map (kbd "C-c :") 'forth-eval) + map)) + + +;---------------------------------------------------------- +; blocks highlight function +; +(defun retroforth-font-lock-extend-region () + "Extend the search region to include an entire block of text." + ;; Avoid compiler warnings about these global variables from font-lock.el. + ;; See the documentation for variable `font-lock-extend-region-functions'. + (eval-when-compile (defvar font-lock-beg) (defvar font-lock-end)) + (save-excursion + (goto-char font-lock-beg) + (let ((found (or (re-search-backward "\n\n" nil t) (point-min)))) + (goto-char font-lock-end) + (when (re-search-forward "\n\n" nil t) + (beginning-of-line) + (setq font-lock-end (point))) + (setq font-lock-beg found)))) + + + +;---------------------------------------------------------- +; retroforth mode +; +(define-derived-mode retroforth-mode text-mode "retroforth" + "major mode for editing RETRO Forth language code." + (setq font-lock-defaults '(retroforth-highlights)) + (set (make-local-variable 'font-lock-multiline) t) + (add-hook 'font-lock-extend-region-functions + 'retroforth-font-lock-extend-region) + (use-local-map retroforth-mode-map)) + +(setq auto-mode-alist (cons '("\\.retro\\'" . retroforth-mode) + auto-mode-alist)) + +(provide 'retroforth) + +;; end.