;;; forth-mode.el --- Programming language mode for Forth
;;; Copyright 2014 Lars Brinkhoff

;; Author: Lars Brinkhoff <lars@nocrew.org>
;; Keywords: languages forth
;; URL: http://github.com/larsbrinkhoff/forth-mode
;; Version: 0.2

;;; Commentary:
;; Programming language mode for Forth

;;; Code:

(eval-when-compile (byte-compile-disable-warning 'cl-functions))
(require 'cl)
(require 'forth-syntax)
(require 'forth-smie)
(require 'forth-spec)

(defvar forth-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-c C-r")   'forth-eval-region)
    (define-key map (kbd "C-c C-l")   'forth-load-file)
    (define-key map (kbd "C-c C-s")   'forth-see)
    (define-key map (kbd "C-M-x")     'forth-eval-defun)
    (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 C-e")   'forth-eval-last-expression)
    (define-key map (kbd "C-x M-e")   'forth-eval-last-expression-display-output)
    (define-key map (kbd "C-c C-z")   'forth-switch-to-output-buffer)
    (define-key map (kbd "C-c :")     'forth-eval)
    (define-key map (kbd "C-c C-d 1") 'forth-spec-lookup-1994)
    (define-key map (kbd "C-c C-d 2") 'forth-spec-lookup-2012)
    ;; (define-key map (kbd "C-c C-c") 'eval-buffer)
    ;; (define-key map (kbd "C-x `") #'forth-next-error)
    ;; (define-key map (kbd "M-n") #'forth-next-note)
    ;; (define-key map (kbd "M-p") #'forth-previous-note)
    ;; (define-key map (kbd "M-.") #'forth-find-definition)
    map))

(defvar forth-mode-syntax-table
  (let ((table (make-syntax-table)))
    (modify-syntax-entry ?\\ "<" table)
    (modify-syntax-entry ?\n ">" table)
    (modify-syntax-entry ?\( "<1b" table)
    (modify-syntax-entry ?\) ">4b" table)
    (modify-syntax-entry ?* "_23n" table)
    (modify-syntax-entry ?\{ "_" table)
    (modify-syntax-entry ?\} "_" table)
    (modify-syntax-entry ?\: "(" table)
    (modify-syntax-entry ?\; ")" table)
    (modify-syntax-entry ?\[ "_" table)
    (modify-syntax-entry ?\] "_" table)
    (modify-syntax-entry ?\? "_" table)
    (modify-syntax-entry ?! "_" table)
    (modify-syntax-entry ?@ "_" table)
    (modify-syntax-entry ?< "_" table)
    (modify-syntax-entry ?> "_" table)
    (modify-syntax-entry ?. "_" table)
    (modify-syntax-entry ?, "_" table)
    (modify-syntax-entry ?' "_" table)
    (modify-syntax-entry ?\" "\"" table)
    table))

;; forth-menu-entries:
;; In the list,  the three elements are
;; 1. menu name (internal)
;; 2. menu string (shown to the user)
;; 3. function name (to be called whe this menu entry iss
;;    clicked on
(defvar forth-menu-entries
  (reverse (list
	    '(see          "See"                   forth-see)
	    '(eval         "Eval"                  forth-eval)
	    '(eval-defun   "Eval defun"            forth-eval-defun)
	    '(eval-region  "Eval region"           forth-eval-region)
	    '(eval-last    "Eval last"             forth-eval-last-expression)
	    '(eval-display "Eval last and display" forth-eval-last-expression-display-output)
	    '(separator1   "--")
	    '(lookup-1994  "Lookup 1994 spec"      forth-spec-lookup-1994)
	    '(lookup-2012  "Lookup-2012 spec"      forth-spec-lookup-2012)
	    '(separator2   "--")
	    '(load-file    "Load file"             forth-load-file)
	    '(run          "Run Forth"             run-forth)
	    '(restart      "Restart Forth"         forth-restart)
	    '(kill         "Kill"                  forth-kill))))

;; forth-create-menu will actually call define-key to
;; add meu entries. The format is that of the variable
;; forth-menu-entries.
(defun forth-create-menu (entries)
  (mapcar (lambda (entry)
	     (let ((menu-name (first entry))
		   (menu-string (second entry))
		   (menu-function (third entry)))
		  (define-key forth-mode-map
		    (vector 'menu-bar 'forth menu-name)
		    (cons menu-string menu-function))))
	  entries))

(defun forth-mode-init-menu ()
  (define-key-after
    forth-mode-map
    [menu-bar forth]
    (cons "Forth" (make-sparse-keymap "Forth"))
    'tools)
  (forth-create-menu forth-menu-entries))

(defvar forth-mode-hook)

(defun forth-symbol-start ()
  (save-excursion
    (skip-chars-backward forth-syntax-non-whitespace)
    (point)))

(defun forth-symbol-end ()
  (save-excursion
    (skip-chars-forward forth-syntax-non-whitespace)
    (point)))

(defun forth-word-at-point ()
  (buffer-substring (forth-symbol-start) (forth-symbol-end)))

(defun forth-expand-symbol ()
  (let ((list (forth-words)))
    (when (fboundp 'imenu--make-index-alist)
      (dolist (index (imenu--make-index-alist t))
	(when (listp (rest index))
	  (dolist (def (rest index))
	    (push (car def) list)))))
    (list (forth-symbol-start) (forth-symbol-end)
	  ;; FIXME: this should use `completion-table-case-fold' or
	  ;; closures but neither is available in Emacs23.
	  `(lambda (string pred action)
	     (let ((completion-ignore-case t))
	       (complete-with-action action ',list string pred))))))

(defun forth-block-with-newlines-p ()
  (save-excursion
    (forth-beginning)
    (let ((result t))
      (dotimes (i 16)
	(goto-char (* 64 (1+ i)))
	(unless (looking-at "\n")
	  (setq result nil)))
      result)))

(defun forth-block-without-newlines-p ()
  (save-excursion
    (forth-beginning)
    (not (search-forward "\n" 1024 t))))

(defun forth-block-p ()
  "Guess whether the current buffer is a Forth block file."
  (and (> (point-max) 1)
       (eq (logand (point-max) 1023) 1)
       (or (forth-block-with-newlines-p)
	   (forth-block-without-newlines-p))))

;; This just calls the standard `fill-paragraph' with adjusted
;; paramaters.
(defun forth-fill-paragraph (&rest args)
  (let ((fill-paragraph-function nil)
	(fill-paragraph-handle-comment t)
	(comment-start "\\ ")
	(comment-end ""))
    (apply #'fill-paragraph args)))

(defun forth-comment-region (&rest args)
  (let ((comment-start "\\ ")
	(comment-end ""))
    (apply #'comment-region-default args)))

(defun forth-beginning-of-defun (arg)
  (and (re-search-backward "^\\s *: \\_<" nil t (or arg 1))
       (beginning-of-line)))

(unless (fboundp 'prog-mode)
  (defalias 'prog-mode 'fundamental-mode))

(unless (fboundp 'setq-local)
  (defmacro setq-local (var val)
    `(set (make-local-variable ',var) ,val)))

;;;###autoload
(define-derived-mode forth-mode prog-mode "Forth"
		     "Major mode for editing Forth files."
		     :syntax-table forth-mode-syntax-table
  (if (forth-block-p)
      (forth-block-mode))
  (setq font-lock-defaults '(nil))
  (setq-local completion-at-point-functions '(forth-expand-symbol))
  (when (boundp 'syntax-propertize-function)
    (setq-local syntax-propertize-function #'forth-syntax-propertize))
  (setq-local parse-sexp-lookup-properties t)
  (hack-local-variables)
  (forth-smie-setup)
  (setq-local fill-paragraph-function #'forth-fill-paragraph)
  (setq-local beginning-of-defun-function #'forth-beginning-of-defun)
  (setq-local comment-start-skip "[(\\][ \t*]+")
  (setq-local comment-start "( ")
  (setq-local comment-end " )")
  (setq-local comment-region-function #'forth-comment-region)
  (setq imenu-generic-expression
	'(("Words"
	   "^\\s-*\\(:\\|code\\|defer\\)\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 2)
	  ("Variables"
	   "^\\s-*2?\\(variable\\|create\\|value\\)\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 2)
	  ("Constants"
	   "\\s-2?constant\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1))) 
  (forth-mode-init-menu))

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.\\(f\\|fs\\|fth\\|4th\\)\\'" . forth-mode))

(unless (fboundp 'with-eval-after-load)
  (defmacro with-eval-after-load (lib &rest forms)
    `(eval-after-load ,lib '(progn ,@forms))))

(with-eval-after-load "speedbar"
  (when (fboundp 'speedbar-add-supported-extension)
    (speedbar-add-supported-extension ".f")
    (speedbar-add-supported-extension ".fs")
    (speedbar-add-supported-extension ".fth")
    (speedbar-add-supported-extension ".forth")
    (speedbar-add-supported-extension ".4th")))

(defun forth-beginning ()
  (goto-char (point-min)))

(add-hook 'forth-mode-hook 'forth-mode-init-menu)

(provide 'forth-mode)
;;; forth-mode.el ends here