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