[gforth] / gforth / gforth.el

gforth: gforth/gforth.el

1 :	pazsan	1.48	;;; gforth.el --- major mode for editing (G)Forth sources
2 :	anton	1.31
3 :	dvdkhlng	1.54	;; Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
4 :	anton	1.31
5 :			;; This file is part of Gforth.
6 :	anton	1.1
7 :	anton	1.17	;; GForth is distributed in the hope that it will be useful,
8 :	anton	1.1	;; but WITHOUT ANY WARRANTY. No author or distributor
9 :			;; accepts responsibility to anyone for the consequences of using it
10 :			;; or for whether it serves any particular purpose or works at all,
11 :			;; unless he says so in writing. Refer to the GNU Emacs General Public
12 :			;; License for full details.
13 :
14 :			;; Everyone is granted permission to copy, modify and redistribute
15 :			;; GNU Emacs, but only under the conditions described in the
16 :			;; GNU Emacs General Public License. A copy of this license is
17 :	anton	1.17	;; supposed to have been given to you along with Gforth so you
18 :	anton	1.1	;; can know your rights and responsibilities. It should be in a
19 :			;; file named COPYING. Among other things, the copyright notice
20 :			;; and this notice must be preserved on all copies.
21 :	anton	1.31
22 :	pazsan	1.48	;; Author: Goran Rydqvist <gorry@ida.liu.se>
23 :			;; Maintainer: David Kühling <dvdkhlng@gmx.de>
24 :			;; Created: 16 July 88 by Goran Rydqvist
25 :			;; Keywords: forth, gforth
26 :
27 :	anton	1.31	;; Changes by anton
28 :			;; This is a variant of forth.el that came with TILE.
29 :			;; I left most of this stuff untouched and made just a few changes for
30 :			;; the things I use (mainly indentation and syntax tables).
31 :			;; So there is still a lot of work to do to adapt this to gforth.
32 :	anton	1.1
33 :	pazsan	1.48	;; Changes by David
34 :			;; Added a syntax-hilighting engine, rewrote auto-indentation engine.
35 :			;; Added support for block files.
36 :
37 :	anton	1.1	;;-------------------------------------------------------------------
38 :			;; A Forth indentation, documentation search and interaction library
39 :			;;-------------------------------------------------------------------
40 :			;;
41 :			;; Written by Goran Rydqvist, gorry@ida.liu.se, Summer 1988
42 :			;; Started: 16 July 88
43 :			;; Version: 2.10
44 :			;; Last update: 5 December 1989 by Mikael Patel, mip@ida.liu.se
45 :			;; Last update: 25 June 1990 by Goran Rydqvist, gorry@ida.liu.se
46 :			;;
47 :			;; Documentation: See forth-mode (^HF forth-mode)
48 :			;;-------------------------------------------------------------------
49 :
50 :	pazsan	1.48	;;; Code:
51 :
52 :
53 :
54 :			;;; Hilighting and indentation engine (dk)
55 :			;;;
56 :
57 :			(defvar forth-words nil
58 :			"List of words for hilighting and recognition of parsed text areas.
59 :			You can enable hilighting of object-oriented Forth code, by appending either
60 :			`forth-objects-words' or `forth-oof-words' to the list, depending on which
61 :	dvdkhlng	1.49	OOP package you're using. After `forth-words' changed, `forth-compile-words'
62 :			must be called to make the changes take effect.
63 :	pazsan	1.48
64 :			Each item of `forth-words' has the form
65 :			(MATCHER TYPE HILIGHT . &optional PARSED-TEXT ...)
66 :
67 :			MATCHER is either a list of strings to match, or a REGEXP.
68 :			If it's a REGEXP, it should not be surrounded by '\\<' or '\\>', since
69 :			that'll be done automatically by the search routines.
70 :
71 :			TYPE should be one of 'definiton-starter', 'definition-ender', 'compile-only',
72 :			'immediate' or 'non-immediate'. Those information are required to determine
73 :			whether a word actually parses (and whether that parsed text needs to be
74 :			hilighted).
75 :
76 :			HILIGHT is a cons cell of the form (FACE . MINIMUM-LEVEL)
77 :			Where MINIMUM-LEVEL specifies the minimum value of `forth-hilight-level',
78 :			that's required for matching text to be hilighted.
79 :
80 :			PARSED-TEXT specifies whether and how a word parses following text. You can
81 :			specify as many subsequent PARSED-TEXT as you wish, but that shouldn't be
82 :			necessary very often. It has the following form:
83 :			(DELIM-REGEXP SKIP-LEADING-FLAG PARSED-TYPE HILIGHT)
84 :
85 :			DELIM-REGEXP is a regular expression that should match strings of length 1,
86 :			which are delimiters for the parsed text.
87 :
88 :			A non-nil value for PARSE-LEADING-FLAG means, that leading delimiter strings
89 :			before parsed text should be skipped. This is the parsing behaviour of the
90 :			Forth word WORD. Set it to t for name-parsing words, nil for comments and
91 :			strings.
92 :
93 :			PARSED-TYPE specifies what kind of text is parsed. It should be on of 'name',
94 :			'string' or 'comment'.")
95 :			(setq forth-words
96 :			'(
97 :			(("[") definition-ender (font-lock-keyword-face . 1))
98 :			(("]" "]l") definition-starter (font-lock-keyword-face . 1))
99 :			((":") definition-starter (font-lock-keyword-face . 1)
100 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
101 :			(("immediate" "compile-only" "restrict")
102 :			immediate (font-lock-keyword-face . 1))
103 :			(("does>") compile-only (font-lock-keyword-face . 1))
104 :			((":noname") definition-starter (font-lock-keyword-face . 1))
105 :			((";" ";code") definition-ender (font-lock-keyword-face . 1))
106 :			(("include" "require" "needs" "use")
107 :			non-immediate (font-lock-keyword-face . 1)
108 :			"[\n\t ]" t string (font-lock-string-face . 1))
109 :			(("included" "required" "thru" "load")
110 :			non-immediate (font-lock-keyword-face . 1))
111 :			(("[char]") compile-only (font-lock-keyword-face . 1)
112 :			"[ \t\n]" t string (font-lock-string-face . 1))
113 :			(("char") non-immediate (font-lock-keyword-face . 1)
114 :			"[ \t\n]" t string (font-lock-string-face . 1))
115 :			(("s\"" "c\"") immediate (font-lock-string-face . 1)
116 :			"[\"\n]" nil string (font-lock-string-face . 1))
117 :			((".\"") compile-only (font-lock-string-face . 1)
118 :			"[\"\n]" nil string (font-lock-string-face . 1))
119 :			(("abort\"") compile-only (font-lock-keyword-face . 1)
120 :			"[\"\n]" nil string (font-lock-string-face . 1))
121 :			(("{") compile-only (font-lock-variable-name-face . 1)
122 :			"[\n}]" nil name (font-lock-variable-name-face . 1))
123 :			((".(" "(") immediate (font-lock-comment-face . 1)
124 :			")" nil comment (font-lock-comment-face . 1))
125 :			(("\\" "\\G") immediate (font-lock-comment-face . 1)
126 :			"[\n]" nil comment (font-lock-comment-face . 1))
127 :
128 :			(("[if]" "[?do]" "[do]" "[for]" "[begin]"
129 :			"[endif]" "[then]" "[loop]" "[+loop]" "[next]" "[until]" "[repeat]"
130 :			"[again]" "[while]" "[else]")
131 :			immediate (font-lock-keyword-face . 2))
132 :			(("[ifdef]" "[ifundef]") immediate (font-lock-keyword-face . 2)
133 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
134 :			(("if" "begin" "ahead" "do" "?do" "+do" "u+do" "-do" "u-do" "for"
135 :			"case" "of" "?dup-if" "?dup-0=-if" "then" "until" "repeat" "again"
136 :			"loop" "+loop" "-loop" "next" "endcase" "endof" "else" "while" "try"
137 :			"recover" "endtry" "assert(" "assert0(" "assert1(" "assert2("
138 :			"assert3(" ")" "<interpretation" "<compilation" "interpretation>"
139 :			"compilation>")
140 :			compile-only (font-lock-keyword-face . 2))
141 :
142 :			(("true" "false" "c/l" "bl" "cell" "pi" "w/o" "r/o" "r/w")
143 :			non-immediate (font-lock-constant-face . 2))
144 :			(("~~") compile-only (font-lock-warning-face . 2))
145 :			(("postpone" "[is]" "defers" "[']" "[compile]")
146 :			compile-only (font-lock-keyword-face . 2)
147 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
148 :			(("is" "what's") immediate (font-lock-keyword-face . 2)
149 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
150 :			(("<is>" "'") non-immediate (font-lock-keyword-face . 2)
151 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
152 :			(("[to]") compile-only (font-lock-keyword-face . 2)
153 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
154 :			(("to") immediate (font-lock-keyword-face . 2)
155 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
156 :			(("<to>") non-immediate (font-lock-keyword-face . 2)
157 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
158 :
159 :			(("create" "variable" "constant" "2variable" "2constant" "fvariable"
160 :			"fconstant" "value" "field" "user" "vocabulary"
161 :			"create-interpret/compile")
162 :			non-immediate (font-lock-type-face . 2)
163 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
164 :	dvdkhlng	1.54	("\\S-+%" non-immediate (font-lock-type-face . 2))
165 :	pazsan	1.48	(("defer" "alias" "create-interpret/compile:")
166 :			non-immediate (font-lock-type-face . 1)
167 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
168 :			(("end-struct") non-immediate (font-lock-keyword-face . 2)
169 :			"[ \t\n]" t name (font-lock-type-face . 3))
170 :			(("struct") non-immediate (font-lock-keyword-face . 2))
171 :			("-?[0-9]+\$\\.[0-9]e\\(-?[0-9]+\$?\\\|\\.?[0-9a-f]\\)"
172 :			immediate (font-lock-constant-face . 3))
173 :			))
174 :
175 :	dvdkhlng	1.51	(defvar forth-use-objects nil
176 :			"*Non-nil makes forth-mode also hilight words from the \"Objects\" package.")
177 :	pazsan	1.48	(defvar forth-objects-words nil
178 :	dvdkhlng	1.51	"Hilighting description for words of the \"Objects\" package")
179 :	pazsan	1.48	(setq forth-objects-words
180 :			'(((":m") definition-starter (font-lock-keyword-face . 1)
181 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
182 :			(("m:") definition-starter (font-lock-keyword-face . 1))
183 :			((";m") definition-ender (font-lock-keyword-face . 1))
184 :			(("[current]" "[parent]") compile-only (font-lock-keyword-face . 1)
185 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
186 :			(("current" "overrides") non-immediate (font-lock-keyword-face . 2)
187 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
188 :			(("[to-inst]") compile-only (font-lock-keyword-face . 2)
189 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
190 :			(("[bind]") compile-only (font-lock-keyword-face . 2)
191 :			"[ \t\n]" t name (font-lock-type-face . 3)
192 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
193 :			(("bind") non-immediate (font-lock-keyword-face . 2)
194 :			"[ \t\n]" t name (font-lock-type-face . 3)
195 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
196 :			(("inst-var" "inst-value") non-immediate (font-lock-type-face . 2)
197 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
198 :			(("method" "selector")
199 :			non-immediate (font-lock-type-face . 1)
200 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
201 :			(("end-class" "end-interface")
202 :			non-immediate (font-lock-keyword-face . 2)
203 :			"[ \t\n]" t name (font-lock-type-face . 3))
204 :			(("public" "protected" "class" "exitm" "implementation" "interface"
205 :			"methods" "end-methods" "this")
206 :			non-immediate (font-lock-keyword-face . 2))
207 :			(("object") non-immediate (font-lock-type-face . 2))))
208 :
209 :	dvdkhlng	1.51	(defvar forth-use-oof nil
210 :			"*Non-nil makes forth-mode also hilight words from the \"OOF\" package.")
211 :	pazsan	1.48	(defvar forth-oof-words nil
212 :	dvdkhlng	1.51	"Hilighting description for words of the \"OOF\" package")
213 :	pazsan	1.48	(setq forth-oof-words
214 :			'((("class") non-immediate (font-lock-keyword-face . 2)
215 :			"[ \t\n]" t name (font-lock-type-face . 3))
216 :			(("var") non-immediate (font-lock-type-face . 2)
217 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
218 :			(("method") non-immediate (font-lock-type-face . 2)
219 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
220 :			(("::" "super" "bind" "bound" "link")
221 :			immediate (font-lock-keyword-face . 2)
222 :			"[ \t\n]" t name (font-lock-function-name-face . 3))
223 :			(("ptr" "asptr" "[]")
224 :			immediate (font-lock-keyword-face . 2)
225 :			"[ \t\n]" t name (font-lock-variable-name-face . 3))
226 :			(("class;" "how:" "self" "new" "new[]" "definitions" "class?" "with"
227 :			"endwith")
228 :			non-immediate (font-lock-keyword-face . 2))
229 :			(("object") non-immediate (font-lock-type-face . 2))))
230 :
231 :	dvdkhlng	1.49	(defvar forth-local-words nil
232 :			"List of Forth words to prepend to `forth-words'. Should be set by a
233 :	dvdkhlng	1.51	forth source, using a local variables list at the end of the file
234 :			(\"Local Variables: ... forth-local-words: ... End:\" construct).")
235 :
236 :			(defvar forth-custom-words nil
237 :			"List of Forth words to prepend to `forth-words'. Should be set in your
238 :			.emacs.")
239 :	dvdkhlng	1.49
240 :	pazsan	1.48	(defvar forth-hilight-level 3 "*Level of hilighting of Forth code.")
241 :	dvdkhlng	1.51
242 :	pazsan	1.48	(defvar forth-compiled-words nil "Compiled representation of `forth-words'.")
243 :
244 :	dvdkhlng	1.51
245 :	pazsan	1.48	; todo:
246 :			;
247 :
248 :			; Wörter ordentlich hilighten, die nicht auf whitespace beginning ( ..)IF
249 :	dvdkhlng	1.49	; Additional `forth-use-objects' or
250 :	pazsan	1.48	; `forth-use-oof' could be set to non-nil for automatical adding of those
251 :	dvdkhlng	1.49	; word-lists. Using local variable list?
252 :	pazsan	1.48	;
253 :			; Konfiguration über customization groups
254 :			;
255 :			; Bereich nur auf Wortanfang/ende ausweiten, wenn anfang bzw ende in einem
256 :			; Wort liegen (?) -- speed!
257 :			;
258 :			; User interface
259 :			;
260 :			; 'forth-word' property muss eindeutig sein!
261 :	dvdkhlng	1.51	;
262 :			; imenu support schlauer machen
263 :	pazsan	1.48
264 :			(setq debug-on-error t)
265 :
266 :	dvdkhlng	1.50	;; Filter list by predicate. This is a somewhat standard function for
267 :	pazsan	1.48	;; functional programming languages. So why isn't it already implemented
268 :			;; in Lisp??
269 :	dvdkhlng	1.50	(defun forth-filter (predicate list)
270 :	pazsan	1.48	(let ((filtered nil))
271 :			(mapcar (lambda (item)
272 :	dvdkhlng	1.50	(when (funcall predicate item)
273 :	pazsan	1.48	(if filtered
274 :			(nconc filtered (list item))
275 :			(setq filtered (cons item nil))))
276 :			nil) list)
277 :			filtered))
278 :
279 :			;; Helper function for `forth-compile-word': return whether word has to be
280 :			;; added to the compiled word list, for syntactic parsing and hilighting.
281 :			(defun forth-words-filter (word)
282 :			(let* ((hilight (nth 2 word))
283 :			(level (cdr hilight))
284 :			(parsing-flag (nth 3 word)))
285 :			(or parsing-flag
286 :			(<= level forth-hilight-level))))
287 :
288 :			;; Helper function for `forth-compile-word': translate one entry from
289 :			;; `forth-words' into the form (regexp regexp-depth word-description)
290 :			(defun forth-compile-words-mapper (word)
291 :			(let* ((matcher (car word))
292 :			(regexp (if (stringp matcher) (concat "\$" matcher "\$")
293 :			(if (listp matcher) (regexp-opt matcher t)
294 :			(error "Invalid matcher (stringp or listp expected `%s'"
295 :			matcher))))
296 :			(depth (regexp-opt-depth regexp))
297 :			(description (cdr word)))
298 :			(list regexp depth description)))
299 :
300 :			;; Read `words' and create a compiled representation suitable for efficient
301 :			;; parsing of the form
302 :			;; (regexp (subexp-count word-description) (subexp-count2 word-description2)
303 :			;; ...)
304 :	dvdkhlng	1.49	(defun forth-compile-wordlist (words)
305 :	pazsan	1.48	(let* ((mapped (mapcar 'forth-compile-words-mapper words))
306 :			(regexp (concat "\\<\\("
307 :			(mapconcat 'car mapped "\\\|")
308 :			"\\)\\>"))
309 :			(sub-count 2)
310 :			(sub-list (mapcar
311 :			(lambda (i)
312 :			(let ((sub (cons sub-count (nth 2 i))))
313 :			(setq sub-count (+ sub-count (nth 1 i)))
314 :			sub
315 :			))
316 :			mapped)))
317 :			(let ((result (cons regexp sub-list)))
318 :			(byte-compile 'result)
319 :			result)))
320 :
321 :	dvdkhlng	1.49	(defun forth-compile-words ()
322 :			"Compile the the words from `forth-words' and `forth-indent-words' into
323 :			the format that's later used for doing the actual hilighting/indentation.
324 :	dvdkhlng	1.51	Store the resulting compiled wordlists in `forth-compiled-words' and
325 :	dvdkhlng	1.49	`forth-compiled-indent-words', respective"
326 :			(setq forth-compiled-words
327 :			(forth-compile-wordlist
328 :			(forth-filter 'forth-words-filter forth-words)))
329 :			(setq forth-compiled-indent-words
330 :			(forth-compile-wordlist forth-indent-words)))
331 :
332 :			(defun forth-hack-local-variables ()
333 :	dvdkhlng	1.51	"Parse and bind local variables, set in the contents of the current
334 :			forth-mode buffer. Prepend `forth-local-words' to `forth-words' and
335 :			`forth-local-indent-words' to `forth-indent-words'."
336 :	dvdkhlng	1.49	(hack-local-variables)
337 :			(setq forth-words (append forth-local-words forth-words))
338 :			(setq forth-indent-words (append forth-local-indent-words
339 :			forth-indent-words)))
340 :
341 :	dvdkhlng	1.51	(defun forth-customize-words ()
342 :			"Add the words from `forth-custom-words' and `forth-custom-indent-words'
343 :			to `forth-words' and `forth-indent-words', respective. Add
344 :			`forth-objects-words' and/or `forth-oof-words' to `forth-words', if
345 :			`forth-use-objects' and/or `forth-use-oof', respective is set."
346 :			(setq forth-words (append forth-custom-words forth-words
347 :			(if forth-use-oof forth-oof-words nil)
348 :			(if forth-use-objects forth-objects-words nil)))
349 :			(setq forth-indent-words (append
350 :			forth-custom-indent-words forth-indent-words)))
351 :
352 :
353 :
354 :	pazsan	1.48	;; get location of first character of previous forth word that's got
355 :			;; properties
356 :			(defun forth-previous-start (pos)
357 :			(let* ((word (get-text-property pos 'forth-word))
358 :			(prev (previous-single-property-change
359 :			(min (point-max) (1+ pos)) 'forth-word
360 :			(current-buffer) (point-min))))
361 :			(if (or (= (point-min) prev) word) prev
362 :			(if (get-text-property (1- prev) 'forth-word)
363 :			(previous-single-property-change
364 :			prev 'forth-word (current-buffer) (point-min))
365 :			(point-min)))))
366 :
367 :			;; Get location of the last character of the current/next forth word that's
368 :			;; got properties, text that's parsed by the word is considered as parts of
369 :			;; the word.
370 :			(defun forth-next-end (pos)
371 :			(let* ((word (get-text-property pos 'forth-word))
372 :			(next (next-single-property-change pos 'forth-word
373 :			(current-buffer) (point-max))))
374 :			(if word next
375 :			(if (get-text-property next 'forth-word)
376 :			(next-single-property-change
377 :			next 'forth-word (current-buffer) (point-max))
378 :			(point-max)))))
379 :
380 :			(defun forth-next-whitespace (pos)
381 :			(save-excursion
382 :			(goto-char pos)
383 :			(skip-syntax-forward "-" (point-max))
384 :			(point)))
385 :			(defun forth-previous-word (pos)
386 :			(save-excursion
387 :			(goto-char pos)
388 :			(re-search-backward "\\<" pos (point-min) 1)
389 :			(point)))
390 :
391 :			;; Delete all properties, used by Forth mode, from `from' to `to'.
392 :			(defun forth-delete-properties (from to)
393 :			(remove-text-properties
394 :			from to '(face nil forth-parsed nil forth-word nil forth-state nil)))
395 :
396 :			;; Get the index of the branch of the most recently evaluated regular
397 :			;; expression that matched. (used for identifying branches "a\\\|b\\\|c...")
398 :			(defun forth-get-regexp-branch ()
399 :			(let ((count 2))
400 :			(while (not (match-beginning count))
401 :			(setq count (1+ count)))
402 :			count))
403 :
404 :			;; seek to next forth-word and return its "word-description"
405 :			(defun forth-next-known-forth-word (to)
406 :			(if (<= (point) to)
407 :			(progn
408 :			(let* ((regexp (car forth-compiled-words))
409 :			(pos (re-search-forward regexp to t)))
410 :			(if pos (let ((branch (forth-get-regexp-branch))
411 :			(descr (cdr forth-compiled-words)))
412 :			(goto-char (match-beginning 0))
413 :			(cdr (assoc branch descr)))
414 :			'nil)))
415 :			nil))
416 :
417 :			;; Set properties of forth word at `point', eventually parsing subsequent
418 :			;; words, and parsing all whitespaces. Set point to delimiter after word.
419 :			;; The word, including it's parsed text gets the `forth-word' property, whose
420 :			;; value is unique, and may be used for getting the word's start/end
421 :			;; positions.
422 :			(defun forth-set-word-properties (state data)
423 :			(let* ((start (point))
424 :			(end (progn (re-search-forward "[ \t]\\\|$" (point-max) 1)
425 :			(point)))
426 :			(type (car data))
427 :			(hilight (nth 1 data))
428 :			(bad-word (and (not state) (eq type 'compile-only)))
429 :			(hlface (if bad-word font-lock-warning-face
430 :			(if (<= (cdr hilight) forth-hilight-level)
431 :			(car hilight) nil))))
432 :			(when hlface (put-text-property start end 'face hlface))
433 :			;; if word parses in current state, process parsed range of text
434 :			(when (or (not state) (eq type 'compile-only) (eq type 'immediate))
435 :			(let ((parse-data (nthcdr 2 data)))
436 :			(while parse-data
437 :			(let ((delim (nth 0 parse-data))
438 :			(skip-leading (nth 1 parse-data))
439 :			(parse-type (nth 2 parse-data))
440 :			(parsed-hilight (nth 3 parse-data))
441 :			(parse-start (point))
442 :			(parse-end))
443 :			(when skip-leading
444 :			(while (and (looking-at delim) (> (match-end 0) (point))
445 :			(not (looking-at "\n")))
446 :			(forward-char)))
447 :			(re-search-forward delim (point-max) 1)
448 :			(setq parse-end (point))
449 :			(forth-delete-properties end parse-end)
450 :			(when (<= (cdr parsed-hilight) forth-hilight-level)
451 :			(put-text-property
452 :			parse-start parse-end 'face (car parsed-hilight)))
453 :			(put-text-property
454 :			parse-start parse-end 'forth-parsed parse-type)
455 :			(setq end parse-end)
456 :			(setq parse-data (nthcdr 4 parse-data))))))
457 :			(put-text-property start end 'forth-word start)))
458 :
459 :			;; Search for known Forth words in the range `from' to `to', using
460 :			;; `forth-next-known-forth-word' and set their properties via
461 :			;; `forth-set-word-properties'.
462 :	dvdkhlng	1.51	(defun forth-update-properties (from to &optional loudly)
463 :	pazsan	1.48	(save-excursion
464 :	dvdkhlng	1.51	(let ((msg-count 0) (state) (word-descr) (last-location))
465 :	pazsan	1.48	(goto-char (forth-previous-word (forth-previous-start
466 :			(max (point-min) (1- from)))))
467 :			(setq to (forth-next-end (min (point-max) (1+ to))))
468 :			;; `to' must be on a space delimiter, if a parsing word was changed
469 :			(setq to (forth-next-whitespace to))
470 :			(setq state (get-text-property (point) 'forth-state))
471 :			(setq last-location (point))
472 :			(forth-delete-properties (point) to)
473 :			;; hilight loop...
474 :			(while (setq word-descr (forth-next-known-forth-word to))
475 :	dvdkhlng	1.51	(when loudly
476 :			(when (equal 0 (% msg-count 100))
477 :			(message "Parsing Forth code...%s"
478 :			(make-string (/ msg-count 100) ?.)))
479 :			(setq msg-count (1+ msg-count)))
480 :	pazsan	1.48	(forth-set-word-properties state word-descr)
481 :			(when state (put-text-property last-location (point) 'forth-state t))
482 :			(let ((type (car word-descr)))
483 :			(if (eq type 'definition-starter) (setq state t))
484 :			(if (eq type 'definition-ender) (setq state nil))
485 :			(setq last-location (point))))
486 :			;; update state property up to `to'
487 :			(if (and state (< (point) to))
488 :			(put-text-property last-location to 'forth-state t))
489 :			;; extend search if following state properties differ from current state
490 :			(if (< to (point-max))
491 :			(if (not (equal state (get-text-property (1+ to) 'forth-state)))
492 :			(let ((extend-to (next-single-property-change
493 :			to 'forth-state (current-buffer) (point-max))))
494 :			(forth-update-properties to extend-to))
495 :			))
496 :			)))
497 :
498 :			;; save-buffer-state borrowed from `font-lock.el'
499 :			(eval-when-compile
500 :			(defmacro forth-save-buffer-state (varlist &rest body)
501 :			"Bind variables according to VARLIST and eval BODY restoring buffer state."
502 :			(` (let* ((,@ (append varlist
503 :			'((modified (buffer-modified-p)) (buffer-undo-list t)
504 :			(inhibit-read-only t) (inhibit-point-motion-hooks t)
505 :			before-change-functions after-change-functions
506 :			deactivate-mark buffer-file-name buffer-file-truename))))
507 :			(,@ body)
508 :			(when (and (not modified) (buffer-modified-p))
509 :			(set-buffer-modified-p nil))))))
510 :
511 :			;; Function that is added to the `change-functions' hook. Calls
512 :			;; `forth-update-properties' and keeps care of disabling undo information
513 :			;; and stuff like that.
514 :	dvdkhlng	1.51	(defun forth-change-function (from to len &optional loudly)
515 :	pazsan	1.48	(save-match-data
516 :			(forth-save-buffer-state ()
517 :			(unwind-protect
518 :			(progn
519 :	dvdkhlng	1.51	(forth-update-properties from to loudly)
520 :	pazsan	1.48	(forth-update-show-screen)
521 :			(forth-update-warn-long-lines))))))
522 :
523 :			(eval-when-compile
524 :			(byte-compile 'forth-set-word-properties)
525 :			(byte-compile 'forth-next-known-forth-word)
526 :			(byte-compile 'forth-update-properties)
527 :			(byte-compile 'forth-delete-properties)
528 :			(byte-compile 'forth-get-regexp-branch))
529 :
530 :	dvdkhlng	1.51	;;; imenu support
531 :			;;;
532 :	dvdkhlng	1.52	(defvar forth-defining-words
533 :			'("VARIABLE" "CONSTANT" "2VARIABLE" "2CONSTANT" "FVARIABLE" "FCONSTANT"
534 :			"USER" "VALUE" "field" "end-struct" "VOCABULARY" "CREATE" ":" "CODE"
535 :			"DEFER" "ALIAS")
536 :	dvdkhlng	1.53	"List of words, that define the following word.
537 :	dvdkhlng	1.52	Used for imenu index generation")
538 :
539 :
540 :	dvdkhlng	1.51	(defun forth-next-definition-starter ()
541 :			(progn
542 :	dvdkhlng	1.52	(let* ((pos (re-search-forward forth-defining-words-regexp (point-max) t)))
543 :	dvdkhlng	1.51	(if pos
544 :			(if (or (text-property-not-all (match-beginning 0) (match-end 0)
545 :	dvdkhlng	1.52	'forth-parsed nil)
546 :			(text-property-not-all (match-beginning 0) (match-end 0)
547 :			'forth-state nil))
548 :	dvdkhlng	1.51	(forth-next-definition-starter)
549 :			t)
550 :			nil))))
551 :
552 :			(defun forth-create-index ()
553 :	dvdkhlng	1.52	(let* ((forth-defining-words-regexp
554 :			(concat "\\<\$" (regexp-opt forth-defining-words) "\$\\>"))
555 :	dvdkhlng	1.51	(index nil))
556 :			(goto-char (point-min))
557 :			(while (forth-next-definition-starter)
558 :			(if (looking-at "[ \t]*\$[^ \t\n]+\$")
559 :			(setq index (cons (cons (match-string 1) (point)) index))))
560 :			index))
561 :
562 :	dvdkhlng	1.52	(require 'speedbar)
563 :	dvdkhlng	1.51	(speedbar-add-supported-extension ".fs")
564 :			(speedbar-add-supported-extension ".fb")
565 :
566 :	pazsan	1.48	;; (require 'profile)
567 :			;; (setq profile-functions-list '(forth-set-word-properties forth-next-known-forth-word forth-update-properties forth-delete-properties forth-get-regexp-branch))
568 :
569 :			;;; Indentation
570 :			;;;
571 :
572 :			(defvar forth-indent-words nil
573 :			"List of words that have indentation behaviour.
574 :			Each element of `forth-indent-words' should have the form
575 :	dvdkhlng	1.54	(MATCHER INDENT1 INDENT2 &optional TYPE)
576 :	pazsan	1.48
577 :			MATCHER is either a list of strings to match, or a REGEXP.
578 :			If it's a REGEXP, it should not be surrounded by `\\<` or `\\>`, since
579 :			that'll be done automatically by the search routines.
580 :
581 :	dvdkhlng	1.54	TYPE might be omitted. If it's specified, the only allowed value is
582 :			currently the symbol `non-immediate', meaning that the word will not
583 :			have any effect on indentation inside definitions. (:NONAME is a good
584 :			example for this kind of word).
585 :
586 :	pazsan	1.48	INDENT1 specifies how to indent a word that's located at a line's begin,
587 :			following any number of whitespaces.
588 :
589 :			INDENT2 specifies how to indent words that are not located at a line's begin.
590 :
591 :			INDENT1 and INDENT2 are indentation specifications of the form
592 :			(SELF-INDENT . NEXT-INDENT), where SELF-INDENT is a numerical value,
593 :			specifying how the matching line and all following lines are to be
594 :			indented, relative to previous lines. NEXT-INDENT specifies how to indent
595 :			following lines, relative to the matching line.
596 :
597 :			Even values of SELF-INDENT and NEXT-INDENT correspond to multiples of
598 :			`forth-indent-level'. Odd values get an additional
599 :			`forth-minor-indent-level' added/substracted. Eg a value of -2 indents
600 :			1 * forth-indent-level to the left, wheras 3 indents
601 :			1 * forth-indent-level + forth-minor-indent-level columns to the right.")
602 :
603 :			(setq forth-indent-words
604 :	dvdkhlng	1.54	'((("if" "begin" "do" "?do" "+do" "-do" "u+do"
605 :			"u-do" "?dup-if" "?dup-0=-if" "case" "of" "try"
606 :			"[if]" "[ifdef]" "[ifundef]" "[begin]" "[for]" "[do]" "[?do]")
607 :	pazsan	1.48	(0 . 2) (0 . 2))
608 :	dvdkhlng	1.54	((":" ":noname" "code" "struct" "m:" ":m" "class" "interface")
609 :			(0 . 2) (0 . 2) non-immediate)
610 :			("\\S-+%$" (0 . 2) (0 . 0) non-immediate)
611 :	dvdkhlng	1.49	((";" ";m") (-2 . 0) (0 . -2))
612 :	dvdkhlng	1.54	(("again" "repeat" "then" "endtry" "endcase" "endof"
613 :			"[then]" "[endif]" "[loop]" "[+loop]" "[next]"
614 :			"[until]" "[repeat]" "[again]" "loop")
615 :	pazsan	1.48	(-2 . 0) (0 . -2))
616 :	dvdkhlng	1.54	(("end-code" "end-class" "end-interface" "end-class-noname"
617 :			"end-interface-noname" "end-struct" "class;")
618 :			(-2 . 0) (0 . -2) non-immediate)
619 :			(("protected" "public" "how:") (-1 . 1) (0 . 0) non-immediate)
620 :	pazsan	1.48	(("+loop" "-loop" "until") (-2 . 0) (-2 . 0))
621 :			(("else" "recover" "[else]") (-2 . 2) (0 . 0))
622 :			(("while" "does>" "[while]") (-1 . 1) (0 . 0))
623 :			(("\\g") (-2 . 2) (0 . 0))))
624 :
625 :	dvdkhlng	1.49	(defvar forth-local-indent-words nil
626 :			"List of Forth words to prepend to `forth-indent-words', when a forth-mode
627 :			buffer is created. Should be set by a Forth source, using a local variables
628 :			list at the end of the file (\"Local Variables: ... forth-local-words: ...
629 :			End:\" construct).")
630 :
631 :	dvdkhlng	1.51	(defvar forth-custom-indent-words nil
632 :			"List of Forth words to prepend to `forth-indent-words'. Should be set in
633 :			your .emacs.")
634 :
635 :	pazsan	1.48	(defvar forth-indent-level 4
636 :			"Indentation of Forth statements.")
637 :			(defvar forth-minor-indent-level 2
638 :			"Minor indentation of Forth statements.")
639 :			(defvar forth-compiled-indent-words nil)
640 :
641 :			;; Return, whether `pos' is the first forth word on its line
642 :			(defun forth-first-word-on-line-p (pos)
643 :			(save-excursion
644 :			(beginning-of-line)
645 :			(skip-chars-forward " \t")
646 :			(= pos (point))))
647 :
648 :			;; Return indentation data (SELF-INDENT . NEXT-INDENT) of next known
649 :			;; indentation word, or nil if there is no word up to `to'.
650 :			;; Position `point' at location just after found word, or at `to'. Parsed
651 :			;; ranges of text will not be taken into consideration!
652 :			(defun forth-next-known-indent-word (to)
653 :			(if (<= (point) to)
654 :			(progn
655 :			(let* ((regexp (car forth-compiled-indent-words))
656 :			(pos (re-search-forward regexp to t)))
657 :			(if pos
658 :	dvdkhlng	1.54	(let* ((start (match-beginning 0))
659 :			(end (match-end 0))
660 :			(branch (forth-get-regexp-branch))
661 :			(descr (cdr forth-compiled-indent-words))
662 :			(indent (cdr (assoc branch descr)))
663 :			(type (nth 2 indent)))
664 :			;; skip words that are parsed (strings/comments) and
665 :			;; non-immediate words inside definitions
666 :			(if (or (text-property-not-all start end 'forth-parsed nil)
667 :			(and (eq type 'non-immediate)
668 :			(text-property-not-all start end
669 :			'forth-state nil)))
670 :			(forth-next-known-indent-word to)
671 :	pazsan	1.48	(if (forth-first-word-on-line-p (match-beginning 0))
672 :			(nth 0 indent) (nth 1 indent))))
673 :			nil)))
674 :			nil))
675 :
676 :			;; Translate indentation value `indent' to indentation column. Multiples of
677 :			;; 2 correspond to multiples of `forth-indent-level'. Odd numbers get an
678 :			;; additional `forth-minor-indent-level' added (or substracted).
679 :			(defun forth-convert-to-column (indent)
680 :			(let* ((sign (if (< indent 0) -1 1))
681 :			(value (abs indent))
682 :			(major (* (/ value 2) forth-indent-level))
683 :			(minor (* (% value 2) forth-minor-indent-level)))
684 :			(* sign (+ major minor))))
685 :
686 :			;; Return the column increment, that the current line of forth code does to
687 :			;; the current or following lines. `which' specifies which indentation values
688 :			;; to use. 0 means the indentation of following lines relative to current
689 :			;; line, 1 means the indentation of the current line relative to the previous
690 :			;; line. Return `nil', if there are no indentation words on the current line.
691 :			(defun forth-get-column-incr (which)
692 :			(save-excursion
693 :			(let ((regexp (car forth-compiled-indent-words))
694 :			(word-indent)
695 :			(self-indent nil)
696 :			(next-indent nil)
697 :			(to (save-excursion (end-of-line) (point))))
698 :			(beginning-of-line)
699 :			(while (setq word-indent (forth-next-known-indent-word to))
700 :			(let* ((self-incr (car word-indent))
701 :			(next-incr (cdr word-indent))
702 :			(self-column-incr (forth-convert-to-column self-incr))
703 :			(next-column-incr (forth-convert-to-column next-incr)))
704 :			(setq next-indent (if next-indent next-indent 0))
705 :			(setq self-indent (if self-indent self-indent 0))
706 :			(if (or (and (> next-indent 0) (< self-column-incr 0))
707 :			(and (< next-indent 0) (> self-column-incr 0)))
708 :			(setq next-indent (+ next-indent self-column-incr))
709 :			(setq self-indent (+ self-indent self-column-incr)))
710 :			(setq next-indent (+ next-indent next-column-incr))))
711 :			(nth which (list self-indent next-indent)))))
712 :
713 :			;; Find previous line that contains indentation words, return the column,
714 :			;; to which following text should be indented to.
715 :			(defun forth-get-anchor-column ()
716 :			(save-excursion
717 :			(if (/= 0 (forward-line -1)) 0
718 :	dvdkhlng	1.54	(let ((indent))
719 :	pazsan	1.48	(while (not (or (setq indent (forth-get-column-incr 1))
720 :			(<= (point) (point-min))))
721 :			(forward-line -1))
722 :			(+ (current-indentation) (if indent indent 0))))))
723 :
724 :			(defun forth-indent-line (&optional flag)
725 :			"Correct indentation of the current Forth line."
726 :			(let* ((anchor (forth-get-anchor-column))
727 :			(column-incr (forth-get-column-incr 0)))
728 :			(forth-indent-to (if column-incr (+ anchor column-incr) anchor))))
729 :
730 :	dvdkhlng	1.49	(defun forth-current-column ()
731 :			(- (point) (save-excursion (beginning-of-line) (point))))
732 :			(defun forth-current-indentation ()
733 :			(- (save-excursion (beginning-of-line) (forward-to-indentation 0) (point))
734 :			(save-excursion (beginning-of-line) (point))))
735 :
736 :	pazsan	1.48	(defun forth-indent-to (x)
737 :			(let ((p nil))
738 :	dvdkhlng	1.49	(setq p (- (forth-current-column) (forth-current-indentation)))
739 :	pazsan	1.48	(forth-delete-indentation)
740 :			(beginning-of-line)
741 :			(indent-to x)
742 :			(if (> p 0) (forward-char p))))
743 :
744 :			(defun forth-delete-indentation ()
745 :			(save-excursion
746 :			(delete-region
747 :			(progn (beginning-of-line) (point))
748 :			(progn (back-to-indentation) (point)))))
749 :
750 :			(defun forth-indent-command ()
751 :			(interactive)
752 :			(forth-indent-line t))
753 :
754 :			;; remove trailing whitespaces in current line
755 :			(defun forth-remove-trailing ()
756 :			(save-excursion
757 :			(end-of-line)
758 :			(delete-region (point) (progn (skip-chars-backward " \t") (point)))))
759 :
760 :			;; insert newline, removing any trailing whitespaces in the current line
761 :			(defun forth-newline-remove-trailing ()
762 :			(save-excursion
763 :	dvdkhlng	1.49	(delete-region (point) (progn (skip-chars-backward " \t") (point))))
764 :			(newline))
765 :			; (let ((was-point (point-marker)))
766 :			; (unwind-protect
767 :			; (progn (forward-line -1) (forth-remove-trailing))
768 :			; (goto-char (was-point)))))
769 :	pazsan	1.48
770 :			;; workaround for bug in `reindent-then-newline-and-indent'
771 :			(defun forth-reindent-then-newline-and-indent ()
772 :			(interactive "*")
773 :			(indent-according-to-mode)
774 :			(forth-newline-remove-trailing)
775 :			(indent-according-to-mode))
776 :
777 :			;;; end hilighting/indentation
778 :
779 :			;;; Block file encoding/decoding (dk)
780 :			;;;
781 :
782 :			(defconst forth-c/l 64 "Number of characters per block line")
783 :			(defconst forth-l/b 16 "Number of lines per block")
784 :
785 :			;; Check whether the unconverted block file line, point is in, does not
786 :			;; contain `\n' and `\t' characters.
787 :			(defun forth-check-block-line (line)
788 :			(let ((end (save-excursion (beginning-of-line) (forward-char forth-c/l)
789 :			(point))))
790 :			(save-excursion
791 :			(beginning-of-line)
792 :			(when (search-forward "\n" end t)
793 :			(message "Warning: line %i contains newline character #10" line)
794 :			(ding t))
795 :			(beginning-of-line)
796 :			(when (search-forward "\t" end t)
797 :			(message "Warning: line %i contains tab character #8" line)
798 :			(ding t)))))
799 :
800 :			(defun forth-convert-from-block (from to)
801 :			"Convert block file format to stream source in current buffer."
802 :			(let ((line (count-lines (point-min) from)))
803 :			(save-excursion
804 :			(goto-char from)
805 :			(set-mark to)
806 :			(while (< (+ (point) forth-c/l) (mark t))
807 :			(setq line (1+ line))
808 :			(forth-check-block-line line)
809 :			(forward-char forth-c/l)
810 :			(forth-newline-remove-trailing))
811 :			(when (= (+ (point) forth-c/l) (mark t))
812 :			(forth-remove-trailing))
813 :			(mark t))))
814 :
815 :			;; Pad a line of a block file up to `forth-c/l' characters, positioning `point'
816 :			;; at the end of line.
817 :			(defun forth-pad-block-line ()
818 :			(save-excursion
819 :			(end-of-line)
820 :			(if (<= (current-column) forth-c/l)
821 :			(move-to-column forth-c/l t)
822 :			(message "Line %i longer than %i characters, truncated"
823 :			(count-lines (point-min) (point)) forth-c/l)
824 :			(ding t)
825 :			(move-to-column forth-c/l t)
826 :			(delete-region (point) (progn (end-of-line) (point))))))
827 :
828 :			;; Replace tab characters in current line by spaces.
829 :			(defun forth-convert-tabs-in-line ()
830 :			(save-excursion
831 :			(beginning-of-line)
832 :			(while (search-forward "\t" (save-excursion (end-of-line) (point)) t)
833 :			(backward-char)
834 :			(delete-region (point) (1+ (point)))
835 :			(insert-char ?\ (- tab-width (% (current-column) tab-width))))))
836 :
837 :			;; Delete newline at end of current line, concatenating it with the following
838 :			;; line. Place `point' at end of newly formed line.
839 :			(defun forth-delete-newline ()
840 :			(end-of-line)
841 :			(delete-region (point) (progn (beginning-of-line 2) (point))))
842 :
843 :			(defun forth-convert-to-block (from to &optional original-buffer)
844 :			"Convert range of text to block file format in current buffer."
845 :			(let* ((lines 0)) ; I have to count lines myself, since `count-lines' has
846 :			; problems with trailing newlines...
847 :			(save-excursion
848 :			(goto-char from)
849 :			(set-mark to)
850 :			;; pad lines to full length (`forth-c/l' characters per line)
851 :			(while (< (save-excursion (end-of-line) (point)) (mark t))
852 :			(setq lines (1+ lines))
853 :			(forth-pad-block-line)
854 :			(forth-convert-tabs-in-line)
855 :			(forward-line))
856 :			;; also make sure the last line is padded, if `to' is at its end
857 :			(end-of-line)
858 :			(when (= (point) (mark t))
859 :			(setq lines (1+ lines))
860 :			(forth-pad-block-line)
861 :			(forth-convert-tabs-in-line))
862 :			;; remove newlines between lines
863 :			(goto-char from)
864 :			(while (< (save-excursion (end-of-line) (point)) (mark t))
865 :			(forth-delete-newline))
866 :			;; append empty lines, until last block is complete
867 :			(goto-char (mark t))
868 :			(let* ((required (* (/ (+ lines (1- forth-l/b)) forth-l/b) forth-l/b))
869 :			(pad-lines (- required lines)))
870 :			(while (> pad-lines 0)
871 :			(insert-char ?\ forth-c/l)
872 :			(setq pad-lines (1- pad-lines))))
873 :			(point))))
874 :
875 :			(defun forth-detect-block-file-p ()
876 :			"Return non-nil if the current buffer is in block file format. Detection is
877 :			done by checking whether the first line has 1024 characters or more."
878 :			(save-restriction
879 :			(widen)
880 :			(save-excursion
881 :	dvdkhlng	1.54	(goto-char (point-min))
882 :	pazsan	1.48	(end-of-line)
883 :			(>= (current-column) 1024))))
884 :
885 :			;; add block file conversion routines to `format-alist'
886 :			(defconst forth-block-format-description
887 :			'(forth-blocks "Forth block source file" nil
888 :			forth-convert-from-block forth-convert-to-block
889 :			t normal-mode))
890 :			(unless (memq forth-block-format-description format-alist)
891 :			(setq format-alist (cons forth-block-format-description format-alist)))
892 :
893 :			;;; End block file encoding/decoding
894 :
895 :			;;; Block file editing
896 :			;;;
897 :			(defvar forth-overlay-arrow-string ">>")
898 :			(defvar forth-block-base 1 "Number of first block in block file")
899 :			(defvar forth-show-screen nil
900 :			"Non-nil means to show screen starts and numbers (for block files)")
901 :			(defvar forth-warn-long-lines nil
902 :			"Non-nil means to warn about lines that are longer than 64 characters")
903 :
904 :			(defvar forth-screen-marker nil)
905 :
906 :			(defun forth-update-show-screen ()
907 :			"If `forth-show-screen' is non-nil, put overlay arrow to start of screen,
908 :			`point' is in. If arrow now points to different screen than before, display
909 :			screen number."
910 :			(if (not forth-show-screen)
911 :			(setq overlay-arrow-string nil)
912 :			(save-excursion
913 :			(let* ((line (count-lines (point-min) (min (point-max) (1+ (point)))))
914 :			(first-line (1+ (* (/ (1- line) forth-l/b) forth-l/b)))
915 :			(scr (+ forth-block-base (/ first-line forth-l/b))))
916 :			(setq overlay-arrow-string forth-overlay-arrow-string)
917 :			(goto-line first-line)
918 :			(setq overlay-arrow-position forth-screen-marker)
919 :	dvdkhlng	1.50	(set-marker forth-screen-marker
920 :			(save-excursion (goto-line first-line) (point)))
921 :			(setq forth-screen-number-string (format "%d" scr))))))
922 :	pazsan	1.48
923 :			(add-hook 'forth-motion-hooks 'forth-update-show-screen)
924 :
925 :			(defun forth-update-warn-long-lines ()
926 :			"If `forth-warn-long-lines' is non-nil, display a warning whenever a line
927 :			exceeds 64 characters."
928 :			(when forth-warn-long-lines
929 :			(when (> (save-excursion (end-of-line) (current-column)) forth-c/l)
930 :			(message "Warning: current line exceeds %i characters"
931 :			forth-c/l))))
932 :
933 :			(add-hook 'forth-motion-hooks 'forth-update-warn-long-lines)
934 :
935 :			;;; End block file editing
936 :	anton	1.1
937 :	anton	1.6
938 :	anton	1.1	(defvar forth-mode-abbrev-table nil
939 :			"Abbrev table in use in Forth-mode buffers.")
940 :
941 :			(define-abbrev-table 'forth-mode-abbrev-table ())
942 :
943 :			(defvar forth-mode-map nil
944 :			"Keymap used in Forth mode.")
945 :
946 :			(if (not forth-mode-map)
947 :			(setq forth-mode-map (make-sparse-keymap)))
948 :
949 :	anton	1.9	;(define-key forth-mode-map "\M-\C-x" 'compile)
950 :	anton	1.7	(define-key forth-mode-map "\C-x\\" 'comment-region)
951 :			(define-key forth-mode-map "\C-x~" 'forth-remove-tracers)
952 :	anton	1.1	(define-key forth-mode-map "\e\C-m" 'forth-send-paragraph)
953 :			(define-key forth-mode-map "\eo" 'forth-send-buffer)
954 :			(define-key forth-mode-map "\C-x\C-m" 'forth-split)
955 :			(define-key forth-mode-map "\e " 'forth-reload)
956 :			(define-key forth-mode-map "\t" 'forth-indent-command)
957 :	pazsan	1.48	(define-key forth-mode-map "\C-m" 'forth-reindent-then-newline-and-indent)
958 :	anton	1.7	(define-key forth-mode-map "\M-q" 'forth-fill-paragraph)
959 :	pazsan	1.13	(define-key forth-mode-map "\e." 'forth-find-tag)
960 :	anton	1.1
961 :	pazsan	1.48	;;; hook into motion events (realy ugly!) (dk)
962 :			(define-key forth-mode-map "\C-n" 'forth-next-line)
963 :			(define-key forth-mode-map "\C-p" 'forth-previous-line)
964 :			(define-key forth-mode-map [down] 'forth-next-line)
965 :			(define-key forth-mode-map [up] 'forth-previous-line)
966 :			(define-key forth-mode-map "\C-f" 'forth-forward-char)
967 :			(define-key forth-mode-map "\C-b" 'forth-backward-char)
968 :			(define-key forth-mode-map [right] 'forth-forward-char)
969 :			(define-key forth-mode-map [left] 'forth-backward-char)
970 :			(define-key forth-mode-map "\M-f" 'forth-forward-word)
971 :			(define-key forth-mode-map "\M-b" 'forth-backward-word)
972 :			(define-key forth-mode-map [C-right] 'forth-forward-word)
973 :			(define-key forth-mode-map [C-left] 'forth-backward-word)
974 :			(define-key forth-mode-map "\M-v" 'forth-scroll-down)
975 :			(define-key forth-mode-map "\C-v" 'forth-scroll-up)
976 :			(define-key forth-mode-map [prior] 'forth-scroll-down)
977 :			(define-key forth-mode-map [next] 'forth-scroll-up)
978 :
979 :			(defun forth-next-line (arg)
980 :			(interactive "p") (next-line arg) (run-hooks 'forth-motion-hooks))
981 :			(defun forth-previous-line (arg)
982 :			(interactive "p") (previous-line arg) (run-hooks 'forth-motion-hooks))
983 :			(defun forth-backward-char (arg)
984 :			(interactive "p") (backward-char arg) (run-hooks 'forth-motion-hooks))
985 :			(defun forth-forward-char (arg)
986 :			(interactive "p") (forward-char arg) (run-hooks 'forth-motion-hooks))
987 :			(defun forth-forward-word (arg)
988 :			(interactive "p") (forward-word arg) (run-hooks 'forth-motion-hooks))
989 :			(defun forth-backward-word (arg)
990 :			(interactive "p") (backward-word arg) (run-hooks 'forth-motion-hooks))
991 :			(defun forth-scroll-down (arg)
992 :			(interactive "P") (scroll-down arg) (run-hooks 'forth-motion-hooks))
993 :			(defun forth-scroll-up (arg)
994 :			(interactive "P") (scroll-up arg) (run-hooks 'forth-motion-hooks))
995 :
996 :	anton	1.35	;setup for C-h C-i to work
997 :			(if (fboundp 'info-lookup-add-help)
998 :			(info-lookup-add-help
999 :			:topic 'symbol
1000 :			:mode 'forth-mode
1001 :			:regexp "[^
1002 :			]+"
1003 :			:ignore-case t
1004 :			:doc-spec '(("(gforth)Name Index" nil "`" "' "))))
1005 :
1006 :	anton	1.22	(load "etags")
1007 :	pazsan	1.13
1008 :			(defun forth-find-tag (tagname &optional next-p regexp-p)
1009 :			(interactive (find-tag-interactive "Find tag: "))
1010 :	dvdkhlng	1.53	(unless (or regexp-p next-p)
1011 :			(setq tagname (concat "\$^\\\|\\s-\$\\(" (regexp-quote tagname)
1012 :			"\\)\$\\s-\\\|$\$")))
1013 :	pazsan	1.13	(switch-to-buffer
1014 :	dvdkhlng	1.53	(find-tag-noselect tagname next-p t)))
1015 :	pazsan	1.13
1016 :	anton	1.1	(defvar forth-mode-syntax-table nil
1017 :			"Syntax table in use in Forth-mode buffers.")
1018 :
1019 :	pazsan	1.48	;; Important: hilighting/indentation now depends on a correct syntax table.
1020 :			;; All characters, except whitespace must belong to the "word constituent"
1021 :			;; syntax class. If different behaviour is required, use of Categories might
1022 :			;; help.
1023 :			(if (not forth-mode-syntax-table)
1024 :	anton	1.1	(progn
1025 :			(setq forth-mode-syntax-table (make-syntax-table))
1026 :	anton	1.6	(let ((char 0))
1027 :			(while (< char ?!)
1028 :			(modify-syntax-entry char " " forth-mode-syntax-table)
1029 :			(setq char (1+ char)))
1030 :			(while (< char 256)
1031 :			(modify-syntax-entry char "w" forth-mode-syntax-table)
1032 :			(setq char (1+ char))))
1033 :			))
1034 :	anton	1.1
1035 :
1036 :			(defun forth-mode-variables ()
1037 :			(set-syntax-table forth-mode-syntax-table)
1038 :			(setq local-abbrev-table forth-mode-abbrev-table)
1039 :			(make-local-variable 'paragraph-start)
1040 :			(setq paragraph-start (concat "^$\\\|" page-delimiter))
1041 :			(make-local-variable 'paragraph-separate)
1042 :			(setq paragraph-separate paragraph-start)
1043 :			(make-local-variable 'indent-line-function)
1044 :			(setq indent-line-function 'forth-indent-line)
1045 :	anton	1.6	; (make-local-variable 'require-final-newline)
1046 :			; (setq require-final-newline t)
1047 :	anton	1.1	(make-local-variable 'comment-start)
1048 :	anton	1.3	(setq comment-start "\\ ")
1049 :			;(make-local-variable 'comment-end)
1050 :			;(setq comment-end " )")
1051 :	anton	1.1	(make-local-variable 'comment-column)
1052 :			(setq comment-column 40)
1053 :			(make-local-variable 'comment-start-skip)
1054 :	anton	1.3	(setq comment-start-skip "\\ ")
1055 :	pazsan	1.47	(make-local-variable 'comment-indent-hook)
1056 :			(setq comment-indent-hook 'forth-comment-indent)
1057 :	anton	1.1	(make-local-variable 'parse-sexp-ignore-comments)
1058 :	pazsan	1.47	(setq parse-sexp-ignore-comments t)
1059 :	pazsan	1.48	(setq case-fold-search t)
1060 :			(make-local-variable 'forth-words)
1061 :			(make-local-variable 'forth-compiled-words)
1062 :			(make-local-variable 'forth-compiled-indent-words)
1063 :			(make-local-variable 'forth-hilight-level)
1064 :			(make-local-variable 'after-change-functions)
1065 :			(make-local-variable 'forth-show-screen)
1066 :			(make-local-variable 'forth-screen-marker)
1067 :			(make-local-variable 'forth-warn-long-lines)
1068 :	dvdkhlng	1.50	(make-local-variable 'forth-screen-number-string)
1069 :	dvdkhlng	1.51	(make-local-variable 'forth-use-oof)
1070 :			(make-local-variable 'forth-use-objects)
1071 :	pazsan	1.48	(setq forth-screen-marker (copy-marker 0))
1072 :	dvdkhlng	1.51	(add-hook 'after-change-functions 'forth-change-function)
1073 :			(setq imenu-create-index-function 'forth-create-index))
1074 :	pazsan	1.47
1075 :	anton	1.2	;;;###autoload
1076 :	anton	1.1	(defun forth-mode ()
1077 :			"
1078 :			Major mode for editing Forth code. Tab indents for Forth code. Comments
1079 :	anton	1.9	are delimited with \\ and newline. Paragraphs are separated by blank lines
1080 :	dvdkhlng	1.49	only. Block files are autodetected, when read, and converted to normal
1081 :			stream source format. See also `forth-block-mode'.
1082 :	anton	1.1	\\{forth-mode-map}
1083 :			Forth-split
1084 :			Positions the current buffer on top and a forth-interaction window
1085 :			below. The window size is controlled by the forth-percent-height
1086 :			variable (see below).
1087 :			Forth-reload
1088 :			Reloads the forth library and restarts the forth process.
1089 :			Forth-send-buffer
1090 :			Sends the current buffer, in text representation, as input to the
1091 :			forth process.
1092 :			Forth-send-paragraph
1093 :			Sends the previous or the current paragraph to the forth-process.
1094 :			Note that the cursor only need to be with in the paragraph to be sent.
1095 :	pazsan	1.48	forth-documentation
1096 :	anton	1.1	Search for documentation of forward adjacent to cursor. Note! To use
1097 :			this mode you have to add a line, to your .emacs file, defining the
1098 :			directories to search through for documentation files (se variable
1099 :			forth-help-load-path below) e.g. (setq forth-help-load-path '(nil)).
1100 :
1101 :			Variables controlling interaction and startup
1102 :			forth-percent-height
1103 :			Tells split how high to make the edit portion, in percent of the
1104 :			current screen height.
1105 :			forth-program-name
1106 :			Tells the library which program name to execute in the interation
1107 :			window.
1108 :
1109 :	pazsan	1.48	Variables controlling syntax hilighting/recognition of parsed text:
1110 :			`forth-words'
1111 :			List of words that have a special parsing behaviour and/or should be
1112 :	dvdkhlng	1.51	hilighted. Add custom words by setting forth-custom-words in your
1113 :			.emacs, or by setting forth-local-words, in source-files' local
1114 :			variables lists.
1115 :			forth-use-objects
1116 :			Set this variable to non-nil in your .emacs, or a local variables
1117 :			list, to hilight and recognize the words from the \"Objects\" package
1118 :			for object-oriented programming.
1119 :			forth-use-oof
1120 :			Same as above, just for the \"OOF\" package.
1121 :			forth-custom-words
1122 :			List of custom Forth words to prepend to `forth-words'. Should be set
1123 :			in your .emacs.
1124 :	dvdkhlng	1.49	forth-local-words
1125 :			List of words to prepend to `forth-words', whenever a forth-mode
1126 :			buffer is created. That variable should be set by Forth sources, using
1127 :			a local variables list at the end of file, to get file-specific
1128 :			hilighting.
1129 :			0 [IF]
1130 :			Local Variables: ...
1131 :			forth-local-words: ...
1132 :			End:
1133 :			[THEN]
1134 :	pazsan	1.48	forth-hilight-level
1135 :			Controls how much syntax hilighting is done. Should be in the range
1136 :	dvdkhlng	1.51	0..3
1137 :	pazsan	1.48
1138 :	anton	1.1	Variables controlling indentation style:
1139 :	pazsan	1.48	`forth-indent-words'
1140 :			List of words that influence indentation.
1141 :	dvdkhlng	1.51	forth-local-indent-words
1142 :	dvdkhlng	1.49	List of words to prepend to `forth-indent-words', similar to
1143 :	dvdkhlng	1.51	forth-local-words. Should be used for specifying file-specific
1144 :	dvdkhlng	1.49	indentation, using a local variables list.
1145 :	dvdkhlng	1.51	forth-custom-indent-words
1146 :			List of words to prepend to `forth-indent-words'. Should be set in your
1147 :			.emacs.
1148 :	anton	1.1	forth-indent-level
1149 :			Indentation increment/decrement of Forth statements.
1150 :	pazsan	1.48	forth-minor-indent-level
1151 :			Minor indentation increment/decrement of Forth statemens.
1152 :	anton	1.1
1153 :	pazsan	1.48	Variables controlling block-file editing:
1154 :	dvdkhlng	1.51	forth-show-screen
1155 :	pazsan	1.48	Non-nil means, that the start of the current screen is marked by an
1156 :	dvdkhlng	1.50	overlay arrow, and screen numbers are displayed in the mode line.
1157 :			This variable is by default nil for `forth-mode' and t for
1158 :			`forth-block-mode'.
1159 :	dvdkhlng	1.51	forth-overlay-arrow-string
1160 :	pazsan	1.48	String to display as the overlay arrow, when `forth-show-screen' is t.
1161 :			Setting this variable to nil disables the overlay arrow.
1162 :	dvdkhlng	1.51	forth-block-base
1163 :	pazsan	1.48	Screen number of the first block in a block file. Defaults to 1.
1164 :	dvdkhlng	1.51	forth-warn-long-lines
1165 :	pazsan	1.48	Non-nil means that a warning message is displayed whenever you edit or
1166 :			move over a line that is longer than 64 characters (the maximum line
1167 :			length that can be stored into a block file). This variable defaults to
1168 :			t for `forth-block-mode' and to nil for `forth-mode'.
1169 :	anton	1.1
1170 :			Variables controling documentation search
1171 :			forth-help-load-path
1172 :			List of directories to search through to find *.doc
1173 :			(forth-help-file-suffix) files. Nil means current default directory.
1174 :			The specified directories must contain at least one .doc file. If it
1175 :			does not and you still want the load-path to scan that directory, create
1176 :			an empty file dummy.doc.
1177 :			forth-help-file-suffix
1178 :			The file names to search for in each directory specified by
1179 :			forth-help-load-path. Defaulted to '*.doc'.
1180 :			"
1181 :			(interactive)
1182 :			(kill-all-local-variables)
1183 :			(use-local-map forth-mode-map)
1184 :			(setq mode-name "Forth")
1185 :			(setq major-mode 'forth-mode)
1186 :	pazsan	1.48	;; convert buffer contents from block file format, if necessary
1187 :			(when (forth-detect-block-file-p)
1188 :			(widen)
1189 :			(message "Converting from Forth block source...")
1190 :			(forth-convert-from-block (point-min) (point-max))
1191 :			(message "Converting from Forth block source...done"))
1192 :			;; if user switched from forth-block-mode to forth-mode, make sure the file
1193 :			;; is now stored as normal strem source
1194 :			(when (equal buffer-file-format '(forth-blocks))
1195 :			(setq buffer-file-format nil))
1196 :	anton	1.1	(forth-mode-variables)
1197 :			; (if (not (forth-process-running-p))
1198 :			; (run-forth forth-program-name))
1199 :	dvdkhlng	1.49	(run-hooks 'forth-mode-hook))
1200 :	pazsan	1.48
1201 :	dvdkhlng	1.50	;;;###autoload
1202 :	pazsan	1.48	(define-derived-mode forth-block-mode forth-mode "Forth Block Source"
1203 :			"Major mode for editing Forth block source files, derived from
1204 :			`forth-mode'. Differences to `forth-mode' are:
1205 :			* files are converted to block format, when written (`buffer-file-format'
1206 :			is set to `(forth-blocks)')
1207 :			* `forth-show-screen' and `forth-warn-long-lines' are t by default
1208 :
1209 :			Note that the length of lines in block files is limited to 64 characters.
1210 :			When writing longer lines to a block file, a warning is displayed in the
1211 :			echo area and the line is truncated.
1212 :
1213 :			Another problem is imposed by block files that contain newline or tab
1214 :			characters. When Emacs converts such files back to block file format,
1215 :	dvdkhlng	1.50	it'll translate those characters to a number of spaces. However, when
1216 :	pazsan	1.48	you read such a file, a warning message is displayed in the echo area,
1217 :			including a line number that may help you to locate and fix the problem.
1218 :
1219 :			So have a look at the Messages buffer, whenever you hear (or see) Emacs'
1220 :			bell during block file read/write operations."
1221 :			(setq buffer-file-format '(forth-blocks))
1222 :			(setq forth-show-screen t)
1223 :	dvdkhlng	1.50	(setq forth-warn-long-lines t)
1224 :			(setq forth-screen-number-string (format "%d" forth-block-base))
1225 :			(setq mode-line-format (append (reverse (cdr (reverse mode-line-format)))
1226 :			'("--S" forth-screen-number-string "-%-"))))
1227 :	anton	1.1
1228 :	anton	1.44	(add-hook 'forth-mode-hook
1229 :	anton	1.9	'(lambda ()
1230 :			(make-local-variable 'compile-command)
1231 :	dvdkhlng	1.49	(setq compile-command "gforth ")
1232 :			(forth-hack-local-variables)
1233 :	dvdkhlng	1.51	(forth-customize-words)
1234 :	dvdkhlng	1.49	(forth-compile-words)
1235 :	dvdkhlng	1.51	(forth-change-function (point-min) (point-max) nil t)))
1236 :	anton	1.6
1237 :	anton	1.7	(defun forth-fill-paragraph ()
1238 :			"Fill comments (starting with '\'; do not fill code (block style
1239 :			programmers who tend to fill code won't use emacs anyway:-)."
1240 :	anton	1.9	; Currently only comments at the start of the line are filled.
1241 :			; Something like lisp-fill-paragraph may be better. We cannot use
1242 :			; fill-paragraph, because it removes the \ from the first comment
1243 :			; line. Therefore we have to look for the first line of the comment
1244 :			; and use fill-region.
1245 :	anton	1.7	(interactive)
1246 :			(save-excursion
1247 :			(beginning-of-line)
1248 :	anton	1.9	(while (and
1249 :			(= (forward-line -1) 0)
1250 :	anton	1.14	(looking-at "[ \t]*\\\\g?[ \t]+")))
1251 :			(if (not (looking-at "[ \t]*\\\\g?[ \t]+"))
1252 :	anton	1.9	(forward-line 1))
1253 :			(let ((from (point))
1254 :			(to (save-excursion (forward-paragraph) (point))))
1255 :	anton	1.14	(if (looking-at "[ \t]*\\\\g?[ \t]+")
1256 :	anton	1.9	(progn (goto-char (match-end 0))
1257 :			(set-fill-prefix)
1258 :			(fill-region from to nil))))))
1259 :	anton	1.7
1260 :	anton	1.1	(defun forth-comment-indent ()
1261 :			(save-excursion
1262 :			(beginning-of-line)
1263 :			(if (looking-at ":[ \t]*")
1264 :			(progn
1265 :			(end-of-line)
1266 :			(skip-chars-backward " \t\n")
1267 :			(1+ (current-column)))
1268 :			comment-column)))
1269 :
1270 :
1271 :			;; Forth commands
1272 :
1273 :	anton	1.7	(defun forth-remove-tracers ()
1274 :			"Remove tracers of the form `~~ '. Queries the user for each occurrence."
1275 :			(interactive)
1276 :	anton	1.16	(query-replace-regexp "\$~~ \\\| ~~$\$" "" nil))
1277 :	anton	1.7
1278 :	anton	1.5	(defvar forth-program-name "gforth"
1279 :	anton	1.1	"*Program invoked by the `run-forth' command.")
1280 :
1281 :			(defvar forth-band-name nil
1282 :			"*Band loaded by the `run-forth' command.")
1283 :
1284 :			(defvar forth-program-arguments nil
1285 :			"*Arguments passed to the Forth program by the `run-forth' command.")
1286 :
1287 :			(defun run-forth (command-line)
1288 :			"Run an inferior Forth process. Output goes to the buffer `forth'.
1289 :			With argument, asks for a command line. Split up screen and run forth
1290 :			in the lower portion. The current-buffer when called will stay in the
1291 :			upper portion of the screen, and all other windows are deleted.
1292 :			Call run-forth again to make the forth buffer appear in the lower
1293 :			part of the screen."
1294 :			(interactive
1295 :			(list (let ((default
1296 :			(or forth-process-command-line
1297 :			(forth-default-command-line))))
1298 :			(if current-prefix-arg
1299 :			(read-string "Run Forth: " default)
1300 :			default))))
1301 :			(setq forth-process-command-line command-line)
1302 :			(forth-start-process command-line)
1303 :			(forth-split)
1304 :			(forth-set-runlight forth-runlight:input))
1305 :
1306 :	anton	1.28	(defun run-forth-if-not ()
1307 :			(if (not (forth-process-running-p))
1308 :			(run-forth forth-program-name)))
1309 :
1310 :	anton	1.1	(defun reset-forth ()
1311 :			"Reset the Forth process."
1312 :			(interactive)
1313 :			(let ((process (get-process forth-program-name)))
1314 :			(cond ((or (not process)
1315 :			(not (eq (process-status process) 'run))
1316 :			(yes-or-no-p
1317 :			"The Forth process is running, are you SURE you want to reset it? "))
1318 :			(message "Resetting Forth process...")
1319 :			(forth-reload)
1320 :			(message "Resetting Forth process...done")))))
1321 :
1322 :			(defun forth-default-command-line ()
1323 :	pazsan	1.13	(concat forth-program-name
1324 :	anton	1.1	(if forth-program-arguments
1325 :			(concat " " forth-program-arguments)
1326 :			"")))
1327 :
1328 :			;;;; Internal Variables
1329 :
1330 :			(defvar forth-process-command-line nil
1331 :			"Command used to start the most recent Forth process.")
1332 :
1333 :			(defvar forth-previous-send ""
1334 :			"Most recent expression transmitted to the Forth process.")
1335 :
1336 :			(defvar forth-process-filter-queue '()
1337 :			"Queue used to synchronize filter actions properly.")
1338 :
1339 :			(defvar forth-prompt "ok"
1340 :			"The current forth prompt string.")
1341 :
1342 :			(defvar forth-start-hook nil
1343 :			"If non-nil, a procedure to call when the Forth process is started.
1344 :			When called, the current buffer will be the Forth process-buffer.")
1345 :
1346 :			(defvar forth-signal-death-message nil
1347 :			"If non-nil, causes a message to be generated when the Forth process dies.")
1348 :
1349 :	anton	1.9	(defvar forth-percent-height 50
1350 :	anton	1.1	"Tells run-forth how high the upper window should be in percent.")
1351 :
1352 :			(defconst forth-runlight:input ?I
1353 :			"The character displayed when the Forth process is waiting for input.")
1354 :
1355 :			(defvar forth-mode-string ""
1356 :			"String displayed in the mode line when the Forth process is running.")
1357 :
1358 :			;;;; Evaluation Commands
1359 :
1360 :			(defun forth-send-string (&rest strings)
1361 :			"Send the string arguments to the Forth process.
1362 :			The strings are concatenated and terminated by a newline."
1363 :			(cond ((forth-process-running-p)
1364 :			(forth-send-string-1 strings))
1365 :			((yes-or-no-p "The Forth process has died. Reset it? ")
1366 :			(reset-forth)
1367 :			(goto-char (point-max))
1368 :			(forth-send-string-1 strings))))
1369 :
1370 :			(defun forth-send-string-1 (strings)
1371 :			(let ((string (apply 'concat strings)))
1372 :			(forth-send-string-2 string)))
1373 :
1374 :			(defun forth-send-string-2 (string)
1375 :			(let ((process (get-process forth-program-name)))
1376 :			(if (not (eq (current-buffer) (get-buffer forth-program-name)))
1377 :			(progn
1378 :			(forth-process-filter-output string)
1379 :			(forth-process-filter:finish)))
1380 :			(send-string process (concat string "\n"))
1381 :			(if (eq (current-buffer) (process-buffer process))
1382 :			(set-marker (process-mark process) (point)))))
1383 :
1384 :
1385 :			(defun forth-send-region (start end)
1386 :			"Send the current region to the Forth process.
1387 :			The region is sent terminated by a newline."
1388 :			(interactive "r")
1389 :			(let ((process (get-process forth-program-name)))
1390 :			(if (and process (eq (current-buffer) (process-buffer process)))
1391 :			(progn (goto-char end)
1392 :			(set-marker (process-mark process) end))))
1393 :			(forth-send-string "\n" (buffer-substring start end) "\n"))
1394 :
1395 :			(defun forth-end-of-paragraph ()
1396 :			(if (looking-at "[\t\n ]+") (skip-chars-backward "\t\n "))
1397 :			(if (not (re-search-forward "\n[ \t]*\n" nil t))
1398 :			(goto-char (point-max))))
1399 :
1400 :			(defun forth-send-paragraph ()
1401 :			"Send the current or the previous paragraph to the Forth process"
1402 :			(interactive)
1403 :			(let (end)
1404 :			(save-excursion
1405 :			(forth-end-of-paragraph)
1406 :			(skip-chars-backward "\t\n ")
1407 :			(setq end (point))
1408 :			(if (re-search-backward "\n[ \t]*\n" nil t)
1409 :			(setq start (point))
1410 :			(goto-char (point-min)))
1411 :			(skip-chars-forward "\t\n ")
1412 :			(forth-send-region (point) end))))
1413 :
1414 :			(defun forth-send-buffer ()
1415 :			"Send the current buffer to the Forth process."
1416 :			(interactive)
1417 :			(if (eq (current-buffer) (forth-process-buffer))
1418 :			(error "Not allowed to send this buffer's contents to Forth"))
1419 :			(forth-send-region (point-min) (point-max)))
1420 :
1421 :
1422 :			;;;; Basic Process Control
1423 :
1424 :			(defun forth-start-process (command-line)
1425 :			(let ((buffer (get-buffer-create "forth")))
1426 :			(let ((process (get-buffer-process buffer)))
1427 :			(save-excursion
1428 :			(set-buffer buffer)
1429 :			(progn (if process (delete-process process))
1430 :			(goto-char (point-max))
1431 :			(setq mode-line-process '(": %s"))
1432 :			(add-to-global-mode-string 'forth-mode-string)
1433 :			(setq process
1434 :			(apply 'start-process
1435 :			(cons forth-program-name
1436 :			(cons buffer
1437 :			(forth-parse-command-line
1438 :			command-line)))))
1439 :			(set-marker (process-mark process) (point-max))
1440 :			(forth-process-filter-initialize t)
1441 :			(forth-modeline-initialize)
1442 :			(set-process-sentinel process 'forth-process-sentinel)
1443 :			(set-process-filter process 'forth-process-filter)
1444 :			(run-hooks 'forth-start-hook)))
1445 :			buffer)))
1446 :
1447 :			(defun forth-parse-command-line (string)
1448 :			(setq string (substitute-in-file-name string))
1449 :			(let ((start 0)
1450 :			(result '()))
1451 :			(while start
1452 :			(let ((index (string-match "[ \t]" string start)))
1453 :			(setq start
1454 :			(cond ((not index)
1455 :			(setq result
1456 :			(cons (substring string start)
1457 :			result))
1458 :			nil)
1459 :			((= index start)
1460 :			(string-match "[^ \t]" string start))
1461 :			(t
1462 :			(setq result
1463 :			(cons (substring string start index)
1464 :			result))
1465 :			(1+ index))))))
1466 :			(nreverse result)))
1467 :
1468 :
1469 :			(defun forth-process-running-p ()
1470 :			"True iff there is a Forth process whose status is `run'."
1471 :			(let ((process (get-process forth-program-name)))
1472 :			(and process
1473 :			(eq (process-status process) 'run))))
1474 :
1475 :			(defun forth-process-buffer ()
1476 :			(let ((process (get-process forth-program-name)))
1477 :			(and process (process-buffer process))))
1478 :
1479 :			;;;; Process Filter
1480 :
1481 :			(defun forth-process-sentinel (proc reason)
1482 :			(let ((inhibit-quit nil))
1483 :			(forth-process-filter-initialize (eq reason 'run))
1484 :			(if (eq reason 'run)
1485 :			(forth-modeline-initialize)
1486 :			(setq forth-mode-string "")))
1487 :			(if (and (not (memq reason '(run stop)))
1488 :			forth-signal-death-message)
1489 :			(progn (beep)
1490 :			(message
1491 :			"The Forth process has died! Do M-x reset-forth to restart it"))))
1492 :
1493 :			(defun forth-process-filter-initialize (running-p)
1494 :			(setq forth-process-filter-queue (cons '() '()))
1495 :			(setq forth-prompt "ok"))
1496 :
1497 :
1498 :			(defun forth-process-filter (proc string)
1499 :			(forth-process-filter-output string)
1500 :			(forth-process-filter:finish))
1501 :
1502 :			(defun forth-process-filter:enqueue (action)
1503 :			(let ((next (cons action '())))
1504 :			(if (cdr forth-process-filter-queue)
1505 :			(setcdr (cdr forth-process-filter-queue) next)
1506 :			(setcar forth-process-filter-queue next))
1507 :			(setcdr forth-process-filter-queue next)))
1508 :
1509 :			(defun forth-process-filter:finish ()
1510 :			(while (car forth-process-filter-queue)
1511 :			(let ((next (car forth-process-filter-queue)))
1512 :			(setcar forth-process-filter-queue (cdr next))
1513 :			(if (not (cdr next))
1514 :			(setcdr forth-process-filter-queue '()))
1515 :			(apply (car (car next)) (cdr (car next))))))
1516 :
1517 :			;;;; Process Filter Output
1518 :
1519 :			(defun forth-process-filter-output (&rest args)
1520 :			(if (not (and args
1521 :			(null (cdr args))
1522 :			(stringp (car args))
1523 :			(string-equal "" (car args))))
1524 :			(forth-process-filter:enqueue
1525 :			(cons 'forth-process-filter-output-1 args))))
1526 :
1527 :			(defun forth-process-filter-output-1 (&rest args)
1528 :			(save-excursion
1529 :			(forth-goto-output-point)
1530 :			(apply 'insert-before-markers args)))
1531 :
1532 :			(defun forth-guarantee-newlines (n)
1533 :			(save-excursion
1534 :			(forth-goto-output-point)
1535 :			(let ((stop nil))
1536 :			(while (and (not stop)
1537 :			(bolp))
1538 :			(setq n (1- n))
1539 :			(if (bobp)
1540 :			(setq stop t)
1541 :			(backward-char))))
1542 :			(forth-goto-output-point)
1543 :			(while (> n 0)
1544 :			(insert-before-markers ?\n)
1545 :			(setq n (1- n)))))
1546 :
1547 :			(defun forth-goto-output-point ()
1548 :			(let ((process (get-process forth-program-name)))
1549 :			(set-buffer (process-buffer process))
1550 :			(goto-char (process-mark process))))
1551 :
1552 :			(defun forth-modeline-initialize ()
1553 :			(setq forth-mode-string " "))
1554 :
1555 :			(defun forth-set-runlight (runlight)
1556 :			(aset forth-mode-string 0 runlight)
1557 :			(forth-modeline-redisplay))
1558 :
1559 :			(defun forth-modeline-redisplay ()
1560 :			(save-excursion (set-buffer (other-buffer)))
1561 :			(set-buffer-modified-p (buffer-modified-p))
1562 :			(sit-for 0))
1563 :
1564 :			;;;; Process Filter Operations
1565 :
1566 :			(defun add-to-global-mode-string (x)
1567 :			(cond ((null global-mode-string)
1568 :			(setq global-mode-string (list "" x " ")))
1569 :			((not (memq x global-mode-string))
1570 :			(setq global-mode-string
1571 :			(cons ""
1572 :			(cons x
1573 :			(cons " "
1574 :			(if (equal "" (car global-mode-string))
1575 :			(cdr global-mode-string)
1576 :			global-mode-string))))))))
1577 :
1578 :
1579 :			;; Misc
1580 :
1581 :			(setq auto-mode-alist (append auto-mode-alist
1582 :	pazsan	1.4	'(("\\.fs$" . forth-mode))))
1583 :	anton	1.1
1584 :			(defun forth-split ()
1585 :			(interactive)
1586 :			(forth-split-1 "forth"))
1587 :
1588 :			(defun forth-split-1 (buffer)
1589 :			(if (not (eq (window-buffer) (get-buffer buffer)))
1590 :			(progn
1591 :			(delete-other-windows)
1592 :			(split-window-vertically
1593 :			(/ (* (screen-height) forth-percent-height) 100))
1594 :			(other-window 1)
1595 :			(switch-to-buffer buffer)
1596 :			(goto-char (point-max))
1597 :			(other-window 1))))
1598 :
1599 :			(defun forth-reload ()
1600 :			(interactive)
1601 :			(let ((process (get-process forth-program-name)))
1602 :			(if process (kill-process process t)))
1603 :	anton	1.28	(sleep-for 0 100)
1604 :	anton	1.1	(forth-mode))
1605 :
1606 :
1607 :			;; Special section for forth-help
1608 :
1609 :			(defvar forth-help-buffer "Forth-help"
1610 :			"Buffer used to display the requested documentation.")
1611 :
1612 :			(defvar forth-help-load-path nil
1613 :			"List of directories to search through to find *.doc
1614 :			(forth-help-file-suffix) files. Nil means current default directory.
1615 :			The specified directories must contain at least one .doc file. If it
1616 :			does not and you still want the load-path to scan that directory, create
1617 :			an empty file dummy.doc.")
1618 :
1619 :			(defvar forth-help-file-suffix "*.doc"
1620 :			"The file names to search for in each directory.")
1621 :
1622 :			(setq forth-search-command-prefix "grep -n \"^ [^(]* ")
1623 :			(defvar forth-search-command-suffix "/dev/null")
1624 :			(defvar forth-grep-error-regexp ": No such file or directory")
1625 :
1626 :			(defun forth-function-called-at-point ()
1627 :			"Return the space delimited word a point."
1628 :			(save-excursion
1629 :			(save-restriction
1630 :			(narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
1631 :			(skip-chars-backward "^ \t\n" (point-min))
1632 :			(if (looking-at "[ \t\n]")
1633 :			(forward-char 1))
1634 :			(let (obj (p (point)))
1635 :			(skip-chars-forward "^ \t\n")
1636 :			(buffer-substring p (point))))))
1637 :
1638 :			(defun forth-help-names-extend-comp (path-list result)
1639 :			(cond ((null path-list) result)
1640 :			((null (car path-list))
1641 :			(forth-help-names-extend-comp (cdr path-list)
1642 :			(concat result forth-help-file-suffix " ")))
1643 :			(t (forth-help-names-extend-comp
1644 :			(cdr path-list) (concat result
1645 :			(expand-file-name (car path-list)) "/"
1646 :			forth-help-file-suffix " ")))))
1647 :
1648 :			(defun forth-help-names-extended ()
1649 :			(if forth-help-load-path
1650 :			(forth-help-names-extend-comp forth-help-load-path "")
1651 :			(error "forth-help-load-path not specified")))
1652 :
1653 :
1654 :	anton	1.7	;(define-key forth-mode-map "\C-hf" 'forth-documentation)
1655 :	anton	1.1
1656 :			(defun forth-documentation (function)
1657 :			"Display the full documentation of FORTH word."
1658 :			(interactive
1659 :			(let ((fn (forth-function-called-at-point))
1660 :			(enable-recursive-minibuffers t)
1661 :			search-list
1662 :			val)
1663 :			(setq val (read-string (format "Describe forth word (default %s): " fn)))
1664 :			(list (if (equal val "") fn val))))
1665 :			(forth-get-doc (concat forth-search-command-prefix
1666 :			(grep-regexp-quote (concat function " ("))
1667 :			"[^)]*\-\-\" " (forth-help-names-extended)
1668 :			forth-search-command-suffix))
1669 :			(message "C-x C-m switches back to the forth interaction window"))
1670 :
1671 :			(defun forth-get-doc (command)
1672 :			"Display the full documentation of command."
1673 :			(let ((curwin (get-buffer-window (window-buffer)))
1674 :			reswin
1675 :			pointmax)
1676 :			(with-output-to-temp-buffer forth-help-buffer
1677 :			(progn
1678 :			(call-process "sh" nil forth-help-buffer t "-c" command)
1679 :			(setq reswin (get-buffer-window forth-help-buffer))))
1680 :			(setq reswin (get-buffer-window forth-help-buffer))
1681 :			(select-window reswin)
1682 :			(save-excursion
1683 :			(goto-char (setq pointmax (point-max)))
1684 :			(insert "--------------------\n\n"))
1685 :			(let (fd doc)
1686 :			(while (setq fd (forth-get-file-data pointmax))
1687 :			(setq doc (forth-get-doc-string fd))
1688 :			(save-excursion
1689 :			(goto-char (point-max))
1690 :			(insert (substring (car fd) (string-match "[^/]*$" (car fd)))
1691 :			":\n\n" doc "\n")))
1692 :			(if (not doc)
1693 :			(progn (goto-char (point-max)) (insert "Not found"))))
1694 :			(select-window curwin)))
1695 :
1696 :			(defun forth-skip-error-lines ()
1697 :			(let ((lines 0))
1698 :			(save-excursion
1699 :			(while (re-search-forward forth-grep-error-regexp nil t)
1700 :			(beginning-of-line)
1701 :			(forward-line 1)
1702 :			(setq lines (1+ lines))))
1703 :			(forward-line lines)))
1704 :
1705 :			(defun forth-get-doc-string (fd)
1706 :			"Find file (car fd) and extract documentation from line (nth 1 fd)."
1707 :			(let (result)
1708 :			(save-window-excursion
1709 :			(find-file (car fd))
1710 :			(goto-line (nth 1 fd))
1711 :			(if (not (eq (nth 1 fd) (1+ (count-lines (point-min) (point)))))
1712 :			(error "forth-get-doc-string: serious error"))
1713 :			(if (not (re-search-backward "\n[\t ]*\n" nil t))
1714 :			(goto-char (point-min))
1715 :			(goto-char (match-end 0)))
1716 :			(let ((p (point)))
1717 :			(if (not (re-search-forward "\n[\t ]*\n" nil t))
1718 :			(goto-char (point-max)))
1719 :			(setq result (buffer-substring p (point))))
1720 :			(bury-buffer (current-buffer)))
1721 :			result))
1722 :
1723 :			(defun forth-get-file-data (limit)
1724 :			"Parse grep output and return '(filename line#) list. Return nil when
1725 :			passing limit."
1726 :			(forth-skip-error-lines)
1727 :			(if (< (point) limit)
1728 :			(let ((result (forth-get-file-data-cont limit)))
1729 :			(forward-line 1)
1730 :			(beginning-of-line)
1731 :			result)))
1732 :
1733 :			(defun forth-get-file-data-cont (limit)
1734 :			(let (result)
1735 :			(let ((p (point)))
1736 :			(skip-chars-forward "^:")
1737 :			(setq result (buffer-substring p (point))))
1738 :			(if (< (point) limit)
1739 :			(let ((p (1+ (point))))
1740 :			(forward-char 1)
1741 :			(skip-chars-forward "^:")
1742 :			(list result (string-to-int (buffer-substring p (point))))))))
1743 :
1744 :			(defun grep-regexp-quote (str)
1745 :			(let ((i 0) (m 1) (res ""))
1746 :			(while (/= m 0)
1747 :			(setq m (string-to-char (substring str i)))
1748 :			(if (/= m 0)
1749 :			(progn
1750 :			(setq i (1+ i))
1751 :			(if (string-match (regexp-quote (char-to-string m))
1752 :			".*\\^$[]")
1753 :			(setq res (concat res "\\")))
1754 :			(setq res (concat res (char-to-string m))))))
1755 :			res))
1756 :
1757 :
1758 :	anton	1.9	(define-key forth-mode-map "\C-x\C-e" 'compile)
1759 :	anton	1.1	(define-key forth-mode-map "\C-x\C-n" 'next-error)
1760 :			(require 'compile "compile")
1761 :
1762 :	anton	1.6	(defvar forth-compile-command "gforth ")
1763 :	anton	1.9	;(defvar forth-compilation-window-percent-height 30)
1764 :	anton	1.1
1765 :			(defun forth-compile (command)
1766 :			(interactive (list (setq forth-compile-command (read-string "Compile command: " forth-compile-command))))
1767 :			(forth-split-1 "compilation")
1768 :			(setq ctools-compile-command command)
1769 :			(compile1 ctools-compile-command "No more errors"))
1770 :
1771 :
1772 :	pazsan	1.12	;;; Forth menu
1773 :			;;; Mikael Karlsson <qramika@eras70.ericsson.se>
1774 :
1775 :			(cond ((string-match "XEmacs\\\|Lucid" emacs-version)
1776 :			(require 'func-menu)
1777 :
1778 :			(defconst fume-function-name-regexp-forth
1779 :			"^\$:\$[ \t]+\$[^ \t]*\$"
1780 :			"Expression to get word definitions in Forth.")
1781 :
1782 :			(setq fume-function-name-regexp-alist
1783 :			(append '((forth-mode . fume-function-name-regexp-forth)
1784 :			) fume-function-name-regexp-alist))
1785 :
1786 :			;; Find next forth word in the buffer
1787 :			(defun fume-find-next-forth-function-name (buffer)
1788 :			"Searches for the next forth word in BUFFER."
1789 :			(set-buffer buffer)
1790 :			(if (re-search-forward fume-function-name-regexp nil t)
1791 :			(let ((beg (match-beginning 2))
1792 :			(end (match-end 2)))
1793 :			(cons (buffer-substring beg end) beg))))
1794 :
1795 :			(setq fume-find-function-name-method-alist
1796 :			(append '((forth-mode . fume-find-next-forth-function-name))))
1797 :
1798 :			))
1799 :			;;; End Forth menu
1800 :
1801 :			;;; File folding of forth-files
1802 :			;;; uses outline
1803 :			;;; Toggle activation with M-x fold-f (when editing a forth-file)
1804 :			;;; Use f9 to expand, f10 to hide, Or the menubar in xemacs
1805 :			;;;
1806 :			;;; Works most of the times but loses sync with the cursor occasionally
1807 :			;;; Could be improved by also folding on comments
1808 :
1809 :			(require 'outline)
1810 :
1811 :	pazsan	1.29	(defun f-outline-level ()
1812 :			(cond ((looking-at "\\`\\\\")
1813 :			0)
1814 :			((looking-at "\\\\ SEC")
1815 :			0)
1816 :			((looking-at "\\\\ \\\\ .*")
1817 :			0)
1818 :			((looking-at "\\\\ DEFS")
1819 :			1)
1820 :			((looking-at "\\/\\* ")
1821 :			1)
1822 :			((looking-at ": .*")
1823 :			1)
1824 :			((looking-at "\\\\G")
1825 :			2)
1826 :			((looking-at "[ \t]+\\\\")
1827 :			3))
1828 :			)
1829 :	pazsan	1.12
1830 :			(defun fold-f ()
1831 :			(interactive)
1832 :			(add-hook 'outline-minor-mode-hook 'hide-body)
1833 :
1834 :			; outline mode header start, i.e. find word definitions
1835 :	pazsan	1.29	;;; (setq outline-regexp "^\$:\$[ \t]+\$[^ \t]*\$")
1836 :			(setq outline-regexp "\\`\\\\\\\|:\\\|\\\\ SEC\\\|\\\\G\\\|[ \t]+\\\\\\\|\\\\ DEFS\\\|\\/\\\\\|\\\\ \\\\ .")
1837 :			(setq outline-level 'f-outline-level)
1838 :	pazsan	1.12
1839 :			(outline-minor-mode)
1840 :	anton	1.30	(define-key outline-minor-mode-map '(shift up) 'hide-sublevels)
1841 :			(define-key outline-minor-mode-map '(shift right) 'show-children)
1842 :			(define-key outline-minor-mode-map '(shift left) 'hide-subtree)
1843 :			(define-key outline-minor-mode-map '(shift down) 'show-subtree)
1844 :	pazsan	1.29
1845 :	pazsan	1.12	)
1846 :	pazsan	1.29
1847 :			;;(define-key global-map '(shift up) 'fold-f)
1848 :
1849 :	pazsan	1.12	;;; end file folding
1850 :
1851 :			;;; func-menu is a package that scans your source file for function definitions
1852 :			;;; and makes a menubar entry that lets you jump to any particular function
1853 :			;;; definition by selecting it from the menu. The following code turns this on
1854 :			;;; for all of the recognized languages. Scanning the buffer takes some time,
1855 :			;;; but not much.
1856 :			;;;
1857 :			(cond ((string-match "XEmacs\\\|Lucid" emacs-version)
1858 :			(require 'func-menu)
1859 :			;; (define-key global-map 'f8 'function-menu)
1860 :			(add-hook 'find-fible-hooks 'fume-add-menubar-entry)
1861 :	anton	1.30	; (define-key global-map "\C-cg" 'fume-prompt-function-goto)
1862 :			; (define-key global-map '(shift button3) 'mouse-function-menu)
1863 :	pazsan	1.29	))
1864 :
1865 :	pazsan	1.48	;;; gforth.el ends here

CVS Admin

gforth: gforth/gforth.el

ViewCVS and CVS Help