--- gforth/gforth.el 2003/03/09 15:16:49 1.68 +++ gforth/gforth.el 2010/09/29 21:47:42 1.83 @@ -1,6 +1,6 @@ ;;; gforth.el --- major mode for editing (G)Forth sources -;; Copyright (C) 1995,1996,1997,1998,2000,2001,2003 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997,1998,2000,2001,2003,2004,2007,2008 Free Software Foundation, Inc. ;; This file is part of Gforth. @@ -59,15 +59,15 @@ (if (not (boundp 'emacs-major-version)) (defconst emacs-major-version (progn (string-match "^[0-9]+" emacs-version) - (string-to-int (match-string 0 emacs-version))))) + (string-to-number (match-string 0 emacs-version))))) +;; Code ripped from `subr.el' for compatability with Emacs versions +;; prior to 20.1 +(eval-when-compile (defun forth-emacs-older (major minor) (or (< emacs-major-version major) (and (= emacs-major-version major) (< emacs-minor-version minor)))) -;; Code ripped from `subr.el' for compatability with Emacs versions -;; prior to 20.1 -(eval-when-compile (if (forth-emacs-older 20 1) (progn (defmacro when (cond &rest body) @@ -79,8 +79,9 @@ ;; `no-error' argument of require not supported in Emacs versions ;; prior to 20.4 :-( +(eval-and-compile (defun forth-require (feature) - (condition-case err (require feature) (error nil))) + (condition-case err (require feature) (error nil)))) (require 'font-lock) @@ -115,6 +116,9 @@ ; todo: ; +; screen-height existiert nicht in XEmacs, frame-height ersetzen? +; + ; Wörter ordentlich hilighten, die nicht auf Whitespace beginnen ( ..)IF ; -- mit aktueller Konzeption nicht möglich?? ; @@ -237,19 +241,25 @@ PARSED-TYPE specifies what kind of text immediate (font-lock-keyword-face . 1)) (("does>") compile-only (font-lock-keyword-face . 1)) ((":noname") definition-starter (font-lock-keyword-face . 1)) - ((";" ";code") definition-ender (font-lock-keyword-face . 1)) + ((";" ";code" ";abi-code") definition-ender (font-lock-keyword-face . 1)) (("include" "require" "needs" "use") non-immediate (font-lock-keyword-face . 1) "[\n\t ]" t string (font-lock-string-face . 1)) (("included" "required" "thru" "load") non-immediate (font-lock-keyword-face . 1)) + (("code" "abi-code") + non-immediate (font-lock-keyword-face . 1) + "[ \t\n]" t name (font-lock-function-name-face . 3)) + (("end-code") + non-immediate (font-lock-keyword-face . 1)) (("[char]") compile-only (font-lock-keyword-face . 1) "[ \t\n]" t string (font-lock-string-face . 1)) (("char") non-immediate (font-lock-keyword-face . 1) "[ \t\n]" t string (font-lock-string-face . 1)) - (("s\"" "c\"") immediate (font-lock-string-face . 1) + ("'.'?" non-immediate (font-lock-string-face . 1)) + (("s\"" "c\"" "s\\\"") immediate (font-lock-string-face . 1) "[\"\n]" nil string (font-lock-string-face . 1)) - ((".\"") compile-only (font-lock-string-face . 1) + ((".\"" ".\\\"") compile-only (font-lock-string-face . 1) "[\"\n]" nil string (font-lock-string-face . 1)) (("abort\"") compile-only (font-lock-keyword-face . 1) "[\"\n]" nil string (font-lock-string-face . 1)) @@ -270,7 +280,8 @@ PARSED-TYPE specifies what kind of text "case" "of" "?dup-if" "?dup-0=-if" "then" "endif" "until" "repeat" "again" "leave" "?leave" "loop" "+loop" "-loop" "next" "endcase" "endof" "else" "while" "try" - "recover" "endtry" "assert(" "assert0(" "assert1(" "assert2(" + "recover" "endtry" "iferror" "restore" "endtry-iferror" + "assert(" "assert0(" "assert1(" "assert2(" "assert3(" ")" "" "compilation>") compile-only (font-lock-keyword-face . 2)) @@ -296,7 +307,7 @@ PARSED-TYPE specifies what kind of text (("create" "variable" "constant" "2variable" "2constant" "fvariable" "fconstant" "value" "field" "user" "vocabulary" - "create-interpret/compile") + "create-interpret/compile" "interpret/compile:") non-immediate (font-lock-type-face . 2) "[ \t\n]" t name (font-lock-variable-name-face . 3)) ("\\S-+%" non-immediate (font-lock-type-face . 2)) @@ -305,9 +316,23 @@ PARSED-TYPE specifies what kind of text "[ \t\n]" t name (font-lock-function-name-face . 3)) (("end-struct") non-immediate (font-lock-keyword-face . 2) "[ \t\n]" t name (font-lock-type-face . 3)) - (("struct") non-immediate (font-lock-keyword-face . 2)) + (("struct" "end-c-library" "c-library-name") + non-immediate (font-lock-keyword-face . 2)) + (("c-library") non-immediate (font-lock-keyword-face . 2) + "[ \t\n]" t name (font-lock-variable-name-face . 3)) + (("c-variable") non-immediate (font-lock-type-face . 1) + "[ \t\n]" t name (font-lock-function-name-face . 3) + "[ \t\n]" t name (font-lock-function-name-face . 3)) + (("c-function" "c-value") non-immediate (font-lock-type-face . 1) + "[ \t\n]" t name (font-lock-function-name-face . 3) + "[ \t\n]" t name (font-lock-function-name-face . 3) + "[\n]" nil comment (font-lock-variable-name-face . 3)) + (("\\c") non-immediate (font-lock-keyword-face . 1) + "[\n]" nil string (font-lock-string-face . 1)) ("-?[0-9]+\\(\\.[0-9]*e\\(-?[0-9]+\\)?\\|\\.?[0-9a-f]*\\)" immediate (font-lock-constant-face . 3)) + ("-?\\([&#][0-9]+\\|\\(0x\\|\\$\\)[0-9a-f]+\\|%[01]+\\)" + immediate (font-lock-constant-face . 3)) )) (defvar forth-use-objects nil @@ -412,10 +437,11 @@ INDENT1 and INDENT2 are indentation spec (setq forth-indent-words '((("if" "begin" "do" "?do" "+do" "-do" "u+do" - "u-do" "?dup-if" "?dup-0=-if" "case" "of" "try" + "u-do" "?dup-if" "?dup-0=-if" "case" "of" "try" "iferror" "[if]" "[ifdef]" "[ifundef]" "[begin]" "[for]" "[do]" "[?do]") (0 . 2) (0 . 2)) - ((":" ":noname" "code" "struct" "m:" ":m" "class" "interface") + ((":" ":noname" "code" "abi-code" "struct" "m:" ":m" "class" + "interface" "c-library" "c-library-name") (0 . 2) (0 . 2) non-immediate) ("\\S-+%$" (0 . 2) (0 . 0) non-immediate) ((";" ";m") (-2 . 0) (0 . -2)) @@ -424,15 +450,15 @@ INDENT1 and INDENT2 are indentation spec "[until]" "[again]" "loop") (-2 . 0) (0 . -2)) (("end-code" "end-class" "end-interface" "end-class-noname" - "end-interface-noname" "end-struct" "class;") + "end-interface-noname" "end-struct" "class;" "end-c-library") (-2 . 0) (0 . -2) non-immediate) (("protected" "public" "how:") (-1 . 1) (0 . 0) non-immediate) (("+loop" "-loop" "until") (-2 . 0) (-2 . 0)) - (("else" "recover" "[else]") (-2 . 2) (0 . 0)) - (("does>") (-1 . 1) (0 . 0)) + (("else" "recover" "restore" "endtry-iferror" "[else]") + (-2 . 2) (0 . 0)) + (("does>" ";code" ";abi-code") (-1 . 1) (0 . 0)) (("while" "[while]") (-2 . 4) (0 . 2)) - (("repeat" "[repeat]") (-4 . 0) (0 . -4)) - (("\\g") (-2 . 2) (0 . 0)))) + (("repeat" "[repeat]") (-4 . 0) (0 . -4)))) (defvar forth-local-indent-words nil "List of Forth words to prepend to `forth-indent-words', when a forth-mode @@ -457,12 +483,11 @@ End:\" construct).") ;; in Lisp?? (defun forth-filter (predicate list) (let ((filtered nil)) - (mapcar (lambda (item) + (dolist (item list) (when (funcall predicate item) (if filtered (nconc filtered (list item)) - (setq filtered (cons item nil)))) - nil) list) + (setq filtered (cons item nil))))) filtered)) ;; Helper function for `forth-compile-word': return whether word has to be @@ -483,7 +508,7 @@ End:\" construct).") (regexp (concat "\\(" (cond ((stringp matcher) matcher) ((listp matcher) (regexp-opt matcher)) - (t (error "Invalid matcher `%s'"))) + (t (error "Invalid matcher"))) "\\)")) (depth (regexp-opt-depth regexp)) (description (cdr word))) @@ -525,6 +550,8 @@ End:\" construct).") "Parse and bind local variables, set in the contents of the current forth-mode buffer. Prepend `forth-local-words' to `forth-words' and `forth-local-indent-words' to `forth-indent-words'." + (put 'forth-local-indent-words 'safe-local-variable 'listp) + (put 'forth-local-words 'safe-local-variable 'listp) (hack-local-variables) (setq forth-words (append forth-local-words forth-words)) (setq forth-indent-words (append forth-local-indent-words @@ -694,14 +721,14 @@ End:\" construct).") (eval-when-compile (defmacro forth-save-buffer-state (varlist &rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state." - (` (let* ((,@ (append varlist + `(let* (,@(append varlist '((modified (buffer-modified-p)) (buffer-undo-list t) (inhibit-read-only t) (inhibit-point-motion-hooks t) before-change-functions after-change-functions - deactivate-mark buffer-file-name buffer-file-truename)))) - (,@ body) + deactivate-mark buffer-file-name buffer-file-truename))) + ,@body (when (and (not modified) (buffer-modified-p)) - (set-buffer-modified-p nil)))))) + (set-buffer-modified-p nil))))) ;; Function that is added to the `change-functions' hook. Calls ;; `forth-update-properties' and keeps care of disabling undo information @@ -734,7 +761,7 @@ End:\" construct).") (defvar forth-defining-words '("VARIABLE" "CONSTANT" "2VARIABLE" "2CONSTANT" "FVARIABLE" "FCONSTANT" "USER" "VALUE" "field" "end-struct" "VOCABULARY" "CREATE" ":" "CODE" - "DEFER" "ALIAS") + "DEFER" "ALIAS" "interpret/compile:") "List of words, that define the following word. Used for imenu index generation.") @@ -824,8 +851,8 @@ Used for imenu index generation.") ;; Return the column increment, that the current line of forth code does to ;; the current or following lines. `which' specifies which indentation values -;; to use. 0 means the indentation of following lines relative to current -;; line, 1 means the indentation of the current line relative to the previous +;; to use. 1 means the indentation of following lines relative to current +;; line, 0 means the indentation of the current line relative to the previous ;; line. Return `nil', if there are no indentation words on the current line. (defun forth-get-column-incr (which) (save-excursion @@ -1089,7 +1116,6 @@ exceeds 64 characters." (define-key forth-mode-map "\C-x\\" 'comment-region) (define-key forth-mode-map "\C-x~" 'forth-remove-tracers) (define-key forth-mode-map "\C-x\C-m" 'forth-split) -(define-key forth-mode-map "\e " 'forth-reload) (define-key forth-mode-map "\t" 'forth-indent-command) (define-key forth-mode-map "\C-m" 'forth-reindent-then-newline-and-indent) (define-key forth-mode-map "\M-q" 'forth-fill-paragraph) @@ -1104,8 +1130,7 @@ exceeds 64 characters." (unless (memq forth-info-lookup info-lookup-alist) (setq info-lookup-alist (cons forth-info-lookup info-lookup-alist))) ;; in X-Emacs C-h C-i is by default bound to Info-query - (define-key forth-mode-map "\C-h\C-i" 'info-lookup-symbol)) - + (define-key forth-mode-map [?\C-h ?\C-i] 'info-lookup-symbol)) ;; (info-lookup-add-help ;; :topic 'symbol @@ -1381,18 +1406,12 @@ programmers who tend to fill code won't (progn (delete-other-windows) (split-window-vertically - (/ (* (screen-height) forth-percent-height) 100)) + (/ (frame-height) 2)) (other-window 1) (switch-to-buffer buffer) (goto-char (point-max)) (other-window 1)))) -(defun forth-compile (command) - (interactive (list (setq forth-compile-command (read-string "Compile command: " forth-compile-command)))) - (forth-split-1 "*compilation*") - (setq ctools-compile-command command) - (compile1 ctools-compile-command "No more errors")) - ;;; Forth menu ;;; Mikael Karlsson @@ -1612,8 +1631,7 @@ of `forth-program-name'). Runs the hook (forth-end-of-paragraph) (skip-chars-backward "\t\n ") (setq end (point)) - (if (re-search-backward "\n[ \t]*\n" nil t) - (setq start (point)) + (if (null (re-search-backward "\n[ \t]*\n" nil t)) (goto-char (point-min))) (skip-chars-forward "\t\n ") (forth-send-region (point) end)))) @@ -1651,11 +1669,11 @@ With argument, position cursor at end of (push-mark) (goto-char (point-max))))) - (defun forth-send-region-and-go (start end) + (defun forth-send-region-and-go (my-start end) "Send the current region to the inferior Forth process. Then switch to the process buffer." (interactive "r") - (forth-send-region start end) + (forth-send-region my-start end) (forth-switch-to-interactive t)) (defcustom forth-source-modes '(forth-mode forth-block-mode) @@ -1678,12 +1696,10 @@ next one.") forth-source-modes t)) ; T because LOAD ; needs an exact name (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq forth-prev-l/c-dir/file (cons (file-name-directory file-name) + (setq forth-prev-l/c-dir/file (cons (file-name-directory file-name) (file-name-nondirectory file-name))) - (comint-send-string (forth-proc) (concat "(load \"" - file-name - "\"\)\n"))) - + (comint-send-string (forth-proc) + (concat "s\" " file-name "\" included\n"))) (defvar forth-process-buffer nil "*The current Forth process buffer.