]+\\)>[^<]+[ ]*\\([^ ]+\\)[ ]*\
154 | \\(?:\\([^\<]+\\)\\)?"))
155 | (search-forward "")
156 | (while (re-search-forward rx nil t)
157 | (push (list (forth-spec--decode-entities (match-string 2))
158 | (match-string 1)
159 | (match-string 3))
160 | index))
161 | (reverse index)))
162 |
163 | (declare-function mm-url-decode-entities "gnus/mm-url")
164 | (autoload 'mm-url-decode-entities "gnus/mm-url")
165 | ;; For annoying reasons, we need to declare this here.
166 | (autoload 'mm-disable-multibyte "gnus/mm-util")
167 |
168 | (defun forth-spec--decode-entities (string)
169 | (with-temp-buffer
170 | (insert string)
171 | (goto-char (point-min))
172 | (save-match-data
173 | (mm-url-decode-entities))
174 | (buffer-string)))
175 |
176 | (provide 'forth-spec)
177 |
178 | ;;; forth-spec.el ends here
179 |
--------------------------------------------------------------------------------
/forth-syntax.el:
--------------------------------------------------------------------------------
1 | ;;; forth-syntax.el -- syntax-propertize function -*-lexical-binding:t-*-
2 |
3 | ;; This code mimics the Forth text interpreter and adds text
4 | ;; properties as side effect.
5 |
6 | (require 'cl-lib)
7 |
8 |
9 | ;;; Helpers
10 |
11 | (defvar forth-syntax-whitespace " \t\n\f\r")
12 | (defvar forth-syntax-non-whitespace (concat "^" forth-syntax-whitespace))
13 |
14 | ;; Skip forward over whitespace and the following word. Return the
15 | ;; start position of the word.
16 | (defun forth-syntax--skip-word ()
17 | (skip-chars-forward forth-syntax-whitespace)
18 | (let ((start (point)))
19 | (skip-chars-forward forth-syntax-non-whitespace)
20 | start))
21 |
22 | ;; Return the whitespace-delimited word at position POS.
23 | ;; Return nil if POS is at end-of-buffer.
24 | (defun forth-syntax--word-at (pos)
25 | (save-excursion
26 | (goto-char pos)
27 | (let ((start (forth-syntax--skip-word)))
28 | (cond ((= start (point)) nil)
29 | (t (buffer-substring-no-properties start (point)))))))
30 |
31 | (defmacro forth-syntax--set-syntax (start end syntax)
32 | "Set the 'syntax-table property in the region START/END to SYNTAX.
33 | SYNTAX must be a valid argument for `string-to-syntax'."
34 | `(put-text-property ,start ,end 'syntax-table ',(string-to-syntax syntax)))
35 |
36 | ;; Set the syntax in the region START/END to "word" or "symbol". Do
37 | ;; nothing for characters that already have the correct syntax so that
38 | ;; word movement commands work "naturally".
39 | (defun forth-syntax--set-word-syntax (start end)
40 | (save-excursion
41 | (goto-char start)
42 | (while (progn
43 | (skip-syntax-forward "w_" end)
44 | (cond ((< (point) end)
45 | (let ((start (point)))
46 | (skip-syntax-forward "^w_" end)
47 | (forth-syntax--set-syntax start (point) "_")
48 | t))
49 | (t nil))))))
50 |
51 |
52 | ;;; State functions
53 |
54 | ;; The parser is a loop that calls "state-functions".
55 | ;; A state function parses forward from point, adds text-properties as needed,
56 | ;; and returns the next state-function.
57 | ;;
58 | ;; The naming convention for state-functions is forth-syntax--state-FOO.
59 |
60 | (defun forth-syntax--state-eob ()
61 | (cl-assert (eobp))
62 | (error "This state function should never be called"))
63 |
64 | ;; One line strings
65 | (defun forth-syntax--state-string ()
66 | (forth-syntax--set-syntax (1- (point)) (point) "|")
67 | (cond ((re-search-forward "[\"\n]" nil t)
68 | (forth-syntax--set-syntax (1- (point)) (point) "|")
69 | #'forth-syntax--state-normal)
70 | (t
71 | (goto-char (point-max))
72 | #'forth-syntax--state-eob)))
73 |
74 | (defun forth-syntax--state-s\\\" ()
75 | (forth-syntax--set-syntax (1- (point)) (point) "|")
76 | (while (and (re-search-forward "\\([\"\n]\\|\\\\\\\\\\|\\\\\"\\)" nil t)
77 | (cond ((= (char-after (match-beginning 0)) ?\\)
78 | (forth-syntax--set-syntax (match-beginning 0)
79 | (1+ (match-beginning 0))
80 | "\\")
81 | t))))
82 | (cond ((looking-back "[\"\n]" 1)
83 | (forth-syntax--set-syntax (1- (point)) (point) "|")
84 | #'forth-syntax--state-normal)
85 | (t
86 | (goto-char (point-max))
87 | #'forth-syntax--state-eob)))
88 |
89 | ;; The position where the current word started. It is setup by
90 | ;; `forth-syntax--state-normal'. It avoids the need to scan backward
91 | ;; so often.
92 | (defvar forth-syntax--current-word-start -1)
93 |
94 | ;; For the word before point, set the font-lock-face property.
95 | (defun forth-syntax--mark-font-lock-keyword ()
96 | (let ((start forth-syntax--current-word-start))
97 | (put-text-property start (point) 'font-lock-face font-lock-keyword-face)))
98 |
99 | (defun forth-syntax--state-font-lock-keyword ()
100 | (forth-syntax--mark-font-lock-keyword)
101 | (forth-syntax--state-normal))
102 |
103 |
104 | ;; State for words that parse the following word, e.g. POSTPONE S"
105 | ;; where POSTPONE parses S".
106 | ;;
107 | ;; FIXME: It would nice be to know if we are in compilation state for
108 | ;; things like this: : FOO CREATE , ;
109 | ;; Because in this case CREATE doesn't parse immediately.
110 | (defun forth-syntax--state-parsing-word ()
111 | (let ((start (forth-syntax--skip-word)))
112 | (cond ((= start (point))
113 | #'forth-syntax--state-eob)
114 | (t
115 | (forth-syntax--set-word-syntax start (point))
116 | #'forth-syntax--state-normal))))
117 |
118 | ;; This is like `forth-syntax--state-parsing-word' but additionally
119 | ;; sets the font-lock-keyword-face.
120 | (defun forth-syntax--state-parsing-keyword ()
121 | (forth-syntax--mark-font-lock-keyword)
122 | (forth-syntax--state-parsing-word))
123 |
124 | ;; This is also like `forth-syntax--state-parsing-word' but
125 | ;; additionally set font-lock-keyword-face for the current word and
126 | ;; font-lock-function-name-face for the following word.
127 | ;; It's intended for thigs like: DEFER S"
128 | (defun forth-syntax--state-defining-word ()
129 | (forth-syntax--mark-font-lock-keyword)
130 | (let ((start (forth-syntax--skip-word)))
131 | (cond ((= start (point))
132 | #'forth-syntax--state-eob)
133 | (t
134 | (forth-syntax--set-word-syntax start (point))
135 | (put-text-property start (point) 'font-lock-face
136 | font-lock-function-name-face)
137 | #'forth-syntax--state-normal))))
138 |
139 | (defun forth-syntax--parse-comment (backward-regexp forward-regexp)
140 | (let ((pos (point)))
141 | (re-search-backward backward-regexp)
142 | (forth-syntax--set-syntax (point) (1+ (point)) "!")
143 | (goto-char pos)
144 | (cond ((re-search-forward forward-regexp nil t)
145 | (forth-syntax--set-syntax (1- (point)) (point) "!")
146 | #'forth-syntax--state-normal)
147 | (t
148 | (goto-char (point-max))
149 | #'forth-syntax--state-eob))))
150 |
151 | ;; Define a state-function for comments. The comment starts with
152 | ;; the string BEGIN and ends with the string END.
153 | (defmacro forth-syntax--define-comment-state (begin end)
154 | (let ((fname (intern (concat "forth-syntax--state-" begin))))
155 | `(defun ,fname ()
156 | (forth-syntax--parse-comment ,(concat (regexp-quote begin) "\\=")
157 | ,(regexp-quote end)))))
158 |
159 | (forth-syntax--define-comment-state "(" ")")
160 | (forth-syntax--define-comment-state "\\" "\n")
161 | (forth-syntax--define-comment-state ".(" ")")
162 |
163 | ;; For now, treat locals like comments
164 | (forth-syntax--define-comment-state "{:" ":}")
165 |
166 | ;; Hashtable that maps strings (word names) to parser functions.
167 | (defvar forth-syntax--parsers (make-hash-table :test 'equal))
168 |
169 | (defun forth-syntax--define (word parsing-function)
170 | (setf (gethash (downcase word) forth-syntax--parsers) parsing-function))
171 |
172 | ;; Find the parsing function for WORD.
173 | (defun forth-syntax--lookup (word)
174 | (gethash (downcase word) forth-syntax--parsers))
175 |
176 | (forth-syntax--define "s\"" #'forth-syntax--state-string)
177 | (forth-syntax--define ".\"" #'forth-syntax--state-string)
178 | (forth-syntax--define "c\"" #'forth-syntax--state-string)
179 | (forth-syntax--define "abort\"" #'forth-syntax--state-string)
180 |
181 | (forth-syntax--define "s\\\"" #'forth-syntax--state-s\\\")
182 |
183 | (forth-syntax--define "(" #'forth-syntax--state-\()
184 | (forth-syntax--define "\\" #'forth-syntax--state-\\)
185 | (forth-syntax--define ".(" #'forth-syntax--state-.\()
186 | (forth-syntax--define "{:" #'forth-syntax--state-{:)
187 |
188 | (forth-syntax--define "postpone" #'forth-syntax--state-parsing-keyword)
189 |
190 | (defvar forth-syntax--parsing-words
191 | '("'" "[']" "char" "[char]"))
192 |
193 | (defvar forth-syntax--defining-words
194 | '(":" "create" "synonym" "defer" "code"
195 | "constant" "2constant" "fconstant"
196 | "value" "2value" "fvalue"
197 | "variable" "2variable" "fvariable"
198 | "+field" "field:" "cfield:" "ffield:" "sffield:" "dffield:"
199 | ))
200 |
201 | (defvar forth-syntax--font-lock-keywords
202 | '("if" "else" "then"
203 | "?do" "do" "unloop" "exit" "leave" "loop" "+loop"
204 | "begin" "while" "repeat" "again" "until"
205 | "case" "?of" "of" "endof" "endcase"
206 | ":noname" ";" "does>" "immediate"
207 | "is" "to"
208 | "literal" "2literal" "fliteral" "sliteral"
209 | "begin-structure" "end-structure"))
210 |
211 | (dolist (w forth-syntax--parsing-words)
212 | (forth-syntax--define w #'forth-syntax--state-parsing-word))
213 |
214 | (dolist (w forth-syntax--defining-words)
215 | (forth-syntax--define w #'forth-syntax--state-defining-word))
216 |
217 | (dolist (w forth-syntax--font-lock-keywords)
218 | (forth-syntax--define w #'forth-syntax--state-font-lock-keyword))
219 |
220 | ;; Look for the next whitespace delimited word; mark all its
221 | ;; characters as "word constituents"; finally return state-function
222 | ;; for the word.
223 | (defun forth-syntax--state-normal ()
224 | (let ((start (forth-syntax--skip-word)))
225 | (cond ((= start (point))
226 | #'forth-syntax--state-eob)
227 | (t
228 | (forth-syntax--set-word-syntax start (point))
229 | (let* ((word (buffer-substring-no-properties start (point)))
230 | (parser (forth-syntax--lookup word)))
231 | (cond (parser
232 | (setq forth-syntax--current-word-start start)
233 | (funcall parser))
234 | (t
235 | #'forth-syntax--state-normal)))))))
236 |
237 |
238 | ;;; Guess initial state
239 |
240 | ;; Is it normal that `syntax-ppss' moves point or is that a bug?
241 | (defun forth-syntax--ppss (pos)
242 | (save-excursion
243 | (syntax-ppss pos)))
244 |
245 | (defun forth-syntax--in-comment-p (pos)
246 | (not (null (elt (forth-syntax--ppss pos) 4))))
247 |
248 | (defun forth-syntax--comment-start-position (pos)
249 | (elt (forth-syntax--ppss pos) 8))
250 |
251 | ;; Make a guess for the syntax state at position POS.
252 | ;; Return a pair (START . PARSING-FUNCTION).
253 | (defun forth-syntax--guess-state (pos)
254 | (cond ((and (< (point-min) pos)
255 | (forth-syntax--in-comment-p (1- pos)))
256 | (cons (forth-syntax--comment-start-position (1- pos))
257 | #'forth-syntax--state-normal))
258 | (t
259 | (cons pos #'forth-syntax--state-normal))))
260 |
261 |
262 | ;;; Main entry point
263 |
264 | ;; Guess a state for the position START, then call state-functions
265 | ;; until the position END is reached.
266 | (defun forth-syntax-propertize (start end)
267 | (save-excursion
268 | (remove-text-properties start end '(font-lock-face))
269 | (let* ((guess (forth-syntax--guess-state start))
270 | (state (cdr guess)))
271 | ;;(message "forth-syntax-propertize: %s %s %s" start end guess)
272 | (goto-char (car guess))
273 | (while (< (point) end)
274 | (let ((start (point)))
275 | (setq state (funcall state))
276 | (cl-assert (< start (point))))))))
277 |
278 | (provide 'forth-syntax)
279 |
--------------------------------------------------------------------------------
/test/block1.fth:
--------------------------------------------------------------------------------
1 |
--------------------------------------------------------------------------------
/test/block2.fth:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 |
25 |
26 |
27 |
28 |
29 |
30 |
31 |
32 |
33 |
--------------------------------------------------------------------------------
/test/noblock.fth:
--------------------------------------------------------------------------------
1 | : foo ;
2 |
--------------------------------------------------------------------------------
/test/tests.el:
--------------------------------------------------------------------------------
1 | (require 'forth-mode)
2 | (require 'forth-interaction-mode)
3 | (require 'forth-block-mode)
4 |
5 | (unless forth-executable
6 | (setq forth-executable (getenv "FORTH")))
7 |
8 | (ert-deftest load-not-block ()
9 | (find-file "test/noblock.fth")
10 | (should (eq major-mode 'forth-mode))
11 | (should-not (and (boundp 'forth-block-mode) forth-block-mode))
12 | (kill-buffer))
13 |
14 | (ert-deftest load-block-with-newlines ()
15 | (find-file "test/block2.fth")
16 | (should (eq major-mode 'forth-mode))
17 | (should (and (boundp 'forth-block-mode) forth-block-mode))
18 | (kill-buffer))
19 |
20 | (ert-deftest load-block-without-newlines ()
21 | (find-file "test/block1.fth")
22 | (should (eq major-mode 'forth-mode))
23 | (should (and (boundp 'forth-block-mode) forth-block-mode))
24 | (kill-buffer))
25 |
26 | (defmacro forth-with-temp-buffer (contents &rest body)
27 | (declare (indent 1) (debug t))
28 | `(with-temp-buffer
29 | (insert ,contents)
30 | (forth-mode)
31 | ,@body))
32 |
33 | (unless (boundp 'font-lock-ensure)
34 | ;; Emacs 24 doesn't have font-lock-ensure.
35 | (defun font-lock-ensure ()
36 | (font-lock-fontify-buffer)))
37 |
38 | (defun forth-strip-| (string)
39 | (replace-regexp-in-string "^[ \t]*|" "" (substring-no-properties string)))
40 |
41 | (defun forth-strip-|-and-→ (string)
42 | (let* ((s2 (forth-strip-| string))
43 | (pos (1+ (string-match "→" s2))))
44 | (list (remove ?→ s2) pos)))
45 |
46 | (defun forth-strip-|-and-¹² (string)
47 | (let* ((s2 (forth-strip-| string))
48 | (start (1+ (string-match "¹" (remove ?² s2))))
49 | (end (1+ (string-match "²" (remove ?¹ s2)))))
50 | (list (remove ?² (remove ?¹ s2))
51 | start end)))
52 |
53 | (defun forth-assert-face (content face)
54 | (when (boundp 'syntax-propertize-function)
55 | (cl-destructuring-bind (content pos) (forth-strip-|-and-→ content)
56 | (forth-with-temp-buffer content
57 | (font-lock-ensure)
58 | (should (eq face (or (get-text-property pos 'face)
59 | (get-text-property pos 'font-lock-face))))))))
60 |
61 | (defun forth-should-indent (expected &optional content)
62 | "Assert that CONTENT turns into EXPECTED after the buffer is re-indented.
63 | If CONTENT is not supplied uses EXPECTED as input.
64 | The whitespace before and including \"|\" on each line is removed."
65 | (let ((content (or content expected)))
66 | (forth-with-temp-buffer (forth-strip-| content)
67 | (let ((inhibit-message t)) ; Suppress "Indenting region ... done" message
68 | (indent-region (point-min) (point-max)))
69 | ;; TODO: Can we check for a missing function in Emacs 23?
70 | (unless (version< emacs-version "24")
71 | (should (string= (forth-strip-| expected)
72 | (substring-no-properties (buffer-string))))))))
73 |
74 | (defun forth-assert-forward-sexp (content)
75 | (cl-destructuring-bind (content start end) (forth-strip-|-and-¹² content)
76 | (forth-with-temp-buffer content
77 | (goto-char start)
78 | (forward-sexp)
79 | (should (= (point) end)))))
80 |
81 | (defun forth-assert-forward-word (content)
82 | (cl-destructuring-bind (content start end) (forth-strip-|-and-¹² content)
83 | (forth-with-temp-buffer content
84 | (goto-char start)
85 | (font-lock-ensure) ; Make sure syntax-propertize function is called
86 | (forward-word)
87 | (should (= (point) end)))))
88 |
89 | (defun forth-should-before/after (before after fun)
90 | (cl-destructuring-bind (before point-before) (forth-strip-|-and-→ before)
91 | (cl-destructuring-bind (after point-after) (forth-strip-|-and-→ after)
92 | (forth-with-temp-buffer before
93 | (goto-char point-before)
94 | (funcall fun)
95 | (should (string= after (substring-no-properties (buffer-string))))
96 | (should (= (point) point-after))))))
97 |
98 | (defun forth-should-region-before/after (before after fun)
99 | (cl-destructuring-bind (before start1 end1) (forth-strip-|-and-¹² before)
100 | (cl-destructuring-bind (after point-after) (forth-strip-|-and-→ after)
101 | (forth-with-temp-buffer before
102 | (set-mark start1)
103 | (goto-char end1)
104 | (activate-mark)
105 | (funcall fun)
106 | (should (string= after (substring-no-properties (buffer-string))))
107 | (should (= (point) point-after))))))
108 |
109 | (defmacro forth-with-forth (&rest body)
110 | (declare (indent 0))
111 | `(let* ((proc (get-buffer-process forth-interaction-buffer)))
112 | ;; FIXME: there should be a better way to do this. Probably a
113 | ;; callback function.
114 | (while (not (processp proc))
115 | (run-forth)
116 | (message "Waiting for Forth to start ...")
117 | (accept-process-output nil 0.3)
118 | (setq proc (get-buffer-process forth-interaction-buffer)))
119 | (unwind-protect
120 | (progn . ,body)
121 | (kill-process proc))))
122 |
123 | (defun forth-assert-backward-token (content token)
124 | (cl-destructuring-bind (content pos1 pos2) (forth-strip-|-and-¹² content)
125 | (forth-with-temp-buffer content
126 | (goto-char pos1)
127 | (let ((token2 (forth-smie--backward-token)))
128 | (should (equal token2 token))
129 | (should (= (point) pos2))))))
130 |
131 | (defun forth-assert-forward-token (content token)
132 | (cl-destructuring-bind (content pos1 pos2) (forth-strip-|-and-¹² content)
133 | (forth-with-temp-buffer content
134 | (goto-char pos1)
135 | (let ((token2 (forth-smie--forward-token)))
136 | (should (equal token2 token))
137 | (should (= (point) pos2))))))
138 |
139 | (ert-deftest forth-paren-comment-font-lock ()
140 | (forth-assert-face "→( )" font-lock-comment-delimiter-face)
141 | (forth-assert-face "→.( )" font-lock-comment-face)
142 | (forth-assert-face "( →)" font-lock-comment-delimiter-face)
143 | (forth-assert-face " →( )" font-lock-comment-delimiter-face)
144 | (forth-assert-face "\t→( )" font-lock-comment-delimiter-face)
145 | (forth-assert-face "→(\t)" font-lock-comment-delimiter-face)
146 | (forth-assert-face "(fo→o) " nil)
147 | (forth-assert-face "(fo→o)" nil)
148 | (forth-assert-face "(→) " nil)
149 | (forth-assert-face "( →foo) " font-lock-comment-face)
150 | (forth-assert-face "( a b --
151 | →x y )" font-lock-comment-face))
152 |
153 | (ert-deftest forth-backslash-comment-font-lock ()
154 | (forth-assert-face "→\\" font-lock-comment-face)
155 | (forth-assert-face "→\\ " font-lock-comment-delimiter-face)
156 | (forth-assert-face " →\\" font-lock-comment-face)
157 | (forth-assert-face "\t→\\ " font-lock-comment-delimiter-face)
158 | (forth-assert-face " →\\\t" font-lock-comment-delimiter-face)
159 | (forth-assert-face " →\\\n" font-lock-comment-face)
160 | (forth-assert-face "a→\\b" nil)
161 | (forth-assert-face "a→\\b " nil))
162 |
163 | (ert-deftest forth-brace-colon-font-lock ()
164 | (forth-assert-face "→{: :}" font-lock-comment-face)
165 | (forth-assert-face "{: :→}" font-lock-comment-face)
166 | (forth-assert-face "{: →a b :}" font-lock-comment-face)
167 | (forth-assert-face "→{::}" nil)
168 | (forth-assert-face "{: a b --
169 | →x y :}" font-lock-comment-face)
170 | (forth-assert-face "t→{ 2 1+ -> 3 }t" nil))
171 |
172 | (ert-deftest forth-string-font-lock ()
173 | (forth-assert-face "→s\" ab\"" nil)
174 | (forth-assert-face "s→\" ab\"" font-lock-string-face)
175 | (forth-assert-face "abort→\" ab\"" font-lock-string-face)
176 | (forth-assert-face ".→\" ab\"" font-lock-string-face)
177 | (forth-assert-face "c→\" ab\"" font-lock-string-face)
178 | (forth-assert-face "[char] \" →swap" nil)
179 | (forth-assert-face "frob\" →ab\" " nil)
180 | (forth-assert-face "s\" →a \n b " font-lock-string-face)
181 | (forth-assert-face "s\" a \n →b " nil)
182 | (forth-assert-face "→s\\\" ab\"" nil)
183 | (forth-assert-face "s\\→\" ab\"" font-lock-string-face)
184 | (forth-assert-face "s\\\" a→b\"" font-lock-string-face)
185 | (forth-assert-face "s\\\" a\\\"→c\"" font-lock-string-face)
186 | (forth-assert-face "s\\\" \\\\ →a \" b" font-lock-string-face)
187 | (forth-assert-face "s\\\" \\\\ a \" →b" nil)
188 | (forth-assert-face "s\\\" \\\" →a \" b" font-lock-string-face)
189 | (forth-assert-face "s\\\" \\\" a \" →b" nil)
190 | (forth-assert-face "s\\\" →a \n b " font-lock-string-face)
191 | (forth-assert-face "s\\\" a \n →b " nil))
192 |
193 | (ert-deftest forth-parsing-words-font-lock ()
194 | (forth-assert-face "postpone ( →x " nil)
195 | (forth-assert-face "' s\" →x "nil)
196 | (forth-assert-face "case [char] ' →of exit endof " font-lock-keyword-face)
197 | (forth-assert-face "case [char] ' →?of exit endof " font-lock-keyword-face)
198 | (forth-assert-face "→postpone postpone" font-lock-keyword-face)
199 | (forth-assert-face "postpone →postpone" nil)
200 | (forth-assert-face "→literal" font-lock-keyword-face)
201 | (forth-assert-face "postpone →literal" nil)
202 | (forth-assert-face "[ 48 ] →literal" font-lock-keyword-face)
203 | (forth-assert-face "→: frob ;" font-lock-keyword-face)
204 | (forth-assert-face ": →frob ;" font-lock-function-name-face)
205 | (forth-assert-face "constant →foo" font-lock-function-name-face)
206 | (forth-assert-face "create →foo" font-lock-function-name-face)
207 | (forth-assert-face "value →foo" font-lock-function-name-face)
208 | (forth-assert-face "variable →foo" font-lock-function-name-face)
209 | (forth-assert-face "synonym →foo bar" font-lock-function-name-face))
210 |
211 | (ert-deftest forth-indent-colon-definition ()
212 | (forth-should-indent
213 | ": foo ( x y -- y x )
214 | | swap
215 | |;")
216 | ;; Open Firmware style
217 | (let ((forth-smie-basic-indent 3))
218 | (forth-should-indent
219 | ": foo ( x y -- y x )
220 | | swap
221 | |;")))
222 |
223 | (ert-deftest forth-indent-if-then-else ()
224 | (forth-should-indent
225 | "x if
226 | | 3 +
227 | |then")
228 | (forth-should-indent
229 | "x if
230 | | 3 +
231 | |else
232 | | 1+
233 | |then")
234 | (forth-should-indent
235 | "x IF
236 | | 3 +
237 | |ELSE
238 | | 1+
239 | |THEN"))
240 |
241 | (ert-deftest forth-indent-begin-while-repeat ()
242 | (forth-should-indent
243 | "begin
244 | | 0>
245 | |while
246 | | 1-
247 | |repeat")
248 | (forth-should-indent
249 | "begin
250 | | 0>
251 | |while
252 | | begin
253 | | foo
254 | | while
255 | | bar
256 | | repeat
257 | | 1-
258 | |repeat"))
259 |
260 | ;; FIXME: this kind of code is indented poorly (difficult for SMIE)
261 | ;; |: foo ( )
262 | ;; | begin
263 | ;; | bar while
264 | ;; | baz while
265 | ;; |again then then ;
266 |
267 | (ert-deftest forth-indent-do ()
268 | (forth-should-indent
269 | "10 0 ?do
270 | | .
271 | |loop")
272 | (forth-should-indent
273 | "10 0 ?do
274 | | . 2
275 | |+loop"))
276 |
277 | (ert-deftest forth-indent-case ()
278 | (forth-should-indent
279 | "x case
280 | | [char] f of
281 | | foo
282 | | endof
283 | | [char] b of bar
284 | | baz
285 | | endof
286 | | test ?of
287 | | drop exit
288 | |endcase"))
289 |
290 | (ert-deftest forth-indent-customization ()
291 | (forth-should-indent
292 | "\ -*- forth-smie-bnf-extensions: ((ext (\"?of\" words \"endof\"))) -*-
293 | |x case
294 | | [char] f of
295 | | foo
296 | | endof
297 | | test ?of
298 | | bar
299 | | endof
300 | |endcase"))
301 |
302 | ;; This is an tricky case because SMIE thinks, depending on
303 | ;; `comment-start-skip` (which indirectly depends on `comment-start`
304 | ;; thru `comment-normalize-vars`), that (foo) is a comment. But since
305 | ;; (foo) is not actually a comment this leads to an endless recursion.
306 | (ert-deftest forth-indent-\(foo\) ()
307 | (forth-should-indent
308 | ": foo
309 | | (foo) ;"))
310 |
311 | (ert-deftest forth-indent-structure ()
312 | (forth-should-indent
313 | "BEGIN-STRUCTURE point
314 | | 1 CELLS +FIELD p.x
315 | | 1 CELLS +FIELD p.y
316 | |END-STRUCTURE"))
317 |
318 | (ert-deftest forth-indent-noname ()
319 | (forth-should-indent
320 | "1 2 :noname
321 | | swap
322 | | ;
323 | |execute"))
324 |
325 | (ert-deftest forth-indent-postpone ()
326 | (forth-should-indent
327 | ": foo
328 | | postpone :
329 | | 42 postpone literal
330 | | postpone ;
331 | |;")
332 | (forth-should-indent
333 | ": foo
334 | | POSTPONE :
335 | | 42 POSTPONE literal
336 | | postpone ;
337 | |;")
338 | (forth-should-indent
339 | ": foo
340 | | postpone if
341 | | if
342 | | postpone then
343 | | else
344 | | postpone then
345 | | then
346 | |;")
347 | (forth-should-indent
348 | ": foo
349 | | ['] :
350 | | if
351 | | postpone ;
352 | | else
353 | | postpone recurse postpone ;
354 | | then
355 | |;")
356 | )
357 |
358 | (ert-deftest forth-sexp-movements ()
359 | (forth-assert-forward-sexp " ¹: foo bar ;² \ x")
360 | (forth-assert-forward-sexp " ¹:noname foo bar ;² \ x")
361 | (forth-assert-forward-sexp " ¹if drop exit else 1+ then² bar ")
362 | (forth-assert-forward-sexp " : foo ¹postpone if² postpone then ;"))
363 |
364 | ;; IDEA: give the filename in "include filename" string syntax.
365 | (ert-deftest forth-word-movements ()
366 | (forth-assert-forward-word "¹include² /tmp/foo.fth \ bar")
367 | (forth-assert-forward-word "include¹ /tmp²/foo.fth \ bar")
368 | (forth-assert-forward-word "¹foo²-bar"))
369 |
370 | (ert-deftest forth-spec-parsing ()
371 | (should (equal (forth-spec--build-url "SWAP" 1994)
372 | "http://lars.nocrew.org/dpans/dpans6.htm#6.1.2260"))
373 | (should (string-match "core/ColonNONAME"
374 | (forth-spec--build-url ":NONAME" 2012)))
375 | (should (string-match "memory/ALLOCATE"
376 | (forth-spec--build-url "ALLOCATE" 2012)))
377 | (should (= (length (cdr (assoc 2012 forth-spec--index-cache)))
378 | 450)))
379 |
380 | (ert-deftest forth-fill-comment ()
381 | (forth-should-before/after
382 | "\\ foo bar
383 | |\\ baz→
384 | |: frob ( x y -- z ) ;"
385 | "\\ foo bar baz→
386 | |: frob ( x y -- z ) ;"
387 | #'fill-paragraph))
388 |
389 | (ert-deftest forth-beginning-of-defun ()
390 | (forth-should-before/after
391 | ": foo bar ;
392 | |: baz ( x -- )
393 | | if foo→ then ;"
394 | ": foo bar ;
395 | |→: baz ( x -- )
396 | | if foo then ;"
397 | #'beginning-of-defun))
398 |
399 | ;; FIXME: maybe insert "( )" instead of "()".
400 | (ert-deftest forth-comment-dwim ()
401 | (forth-should-before/after
402 | ": frob
403 | | begin ( x y )
404 | | swap→
405 | | again ;"
406 | ": frob
407 | | begin ( x y )
408 | | swap ( → )
409 | | again ;"
410 | (lambda ()
411 | (call-interactively #'comment-dwim)))
412 | (forth-should-region-before/after
413 | "²: frob
414 | | begin ( x y )
415 | | swap
416 | | again ;
417 | |¹"
418 | "→\\ : frob
419 | |\\ begin ( x y )
420 | |\\ swap
421 | |\\ again ;
422 | |"
423 | (lambda ()
424 | (call-interactively #'comment-dwim)))
425 | (forth-should-region-before/after
426 | "¹\\ : frob
427 | |\\ begin ( x y )
428 | |\\ swap
429 | |\\ again ;
430 | |²"
431 | ": frob
432 | | begin ( x y )
433 | | swap
434 | | again ;
435 | |→"
436 | (lambda ()
437 | (call-interactively #'comment-dwim))))
438 |
439 | (ert-deftest forth-completion-at-point ()
440 | (forth-with-forth
441 | (forth-should-before/after
442 | "2c→"
443 | "2Constant→"
444 | #'completion-at-point)))
445 |
446 | (ert-deftest forth-smie-backward-token ()
447 | (forth-assert-backward-token "²foo¹" "foo")
448 | (forth-assert-backward-token "²foo-bar¹" "foo-bar")
449 | (forth-assert-backward-token " ²foo-bar ¹baz" "foo-bar")
450 | (forth-assert-backward-token " ²?#!-+ ¹" "?#!-+")
451 | (forth-assert-backward-token " ²foo ( x y ) ¹" "foo")
452 | (forth-assert-backward-token " foo \ x ²y ¹" "y")
453 | (forth-assert-backward-token " ²postpone foo¹" '("postpone" "foo"))
454 | (forth-assert-backward-token " ²['] foo ¹" '("[']" "foo"))
455 | (forth-assert-backward-token " ²[char] : ¹" '("[char]" ":"))
456 | ;; We're mostly interested in getting indentation inside colon
457 | ;; definitions right, so here we don't treat ' as parsing word.
458 | (forth-assert-backward-token " ' ²foo¹" "foo")
459 | (forth-assert-backward-token " : ²foo¹" "foo"))
460 |
461 | (ert-deftest forth-smie-forward-token ()
462 | (forth-assert-forward-token "¹foo²" "foo")
463 | (forth-assert-forward-token "¹foo-bar²" "foo-bar")
464 | (forth-assert-forward-token " ¹foo-bar² baz" "foo-bar")
465 | (forth-assert-forward-token " ¹?#!-+² " "?#!-+")
466 | (forth-assert-forward-token " ¹foo² ( x y )" "foo")
467 | (forth-assert-forward-token " foo \ x ¹y² " "y")
468 | (forth-assert-forward-token " ¹postpone foo²" '("postpone" "foo"))
469 | (forth-assert-forward-token " ¹ ['] foo² " '("[']" "foo"))
470 | (forth-assert-forward-token " ¹[char] :² " '("[char]" ":"))
471 | (forth-assert-forward-token " ¹'² foo" "'")
472 | (forth-assert-forward-token " ¹:² foo" ":"))
473 |
--------------------------------------------------------------------------------