gforth/gforth.el - view

File: [gforth] / gforth / gforth.el
Revision 1.55: download - view: text, annotated - select for diffs
Sat Dec 15 22:44:52 2001 UTC (22 years, 4 months ago) by dvdkhlng
Branches: MAIN
CVS tags: HEAD

Cleaned up motion-dectection, used for displaying screen-numbers in
forth-block-mode. Added support for just-in-time hilighting feature of
Emacs21 (using fontification-functions hook).

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