1: ;; Forth mode for Emacs
2: ;; This file is part of GForth.
3: ;; Changes by anton
4: ;; This is a variant of forth.el that came with TILE.
5: ;; I left most of this stuff untouched and made just a few changes for
6: ;; the things I use (mainly indentation and syntax tables).
7: ;; So there is still a lot of work to do to adapt this to gforth.
8:
9: ;; GForth is distributed in the hope that it will be useful,
10: ;; but WITHOUT ANY WARRANTY. No author or distributor
11: ;; accepts responsibility to anyone for the consequences of using it
12: ;; or for whether it serves any particular purpose or works at all,
13: ;; unless he says so in writing. Refer to the GNU Emacs General Public
14: ;; License for full details.
15:
16: ;; Everyone is granted permission to copy, modify and redistribute
17: ;; GNU Emacs, but only under the conditions described in the
18: ;; GNU Emacs General Public License. A copy of this license is
19: ;; supposed to have been given to you along with Gforth so you
20: ;; can know your rights and responsibilities. It should be in a
21: ;; file named COPYING. Among other things, the copyright notice
22: ;; and this notice must be preserved on all copies.
23:
24: ;;-------------------------------------------------------------------
25: ;; A Forth indentation, documentation search and interaction library
26: ;;-------------------------------------------------------------------
27: ;;
28: ;; Written by Goran Rydqvist, gorry@ida.liu.se, Summer 1988
29: ;; Started: 16 July 88
30: ;; Version: 2.10
31: ;; Last update: 5 December 1989 by Mikael Patel, mip@ida.liu.se
32: ;; Last update: 25 June 1990 by Goran Rydqvist, gorry@ida.liu.se
33: ;;
34: ;; Documentation: See forth-mode (^HF forth-mode)
35: ;;-------------------------------------------------------------------
36:
37:
38: (defvar forth-positives
39: " : :noname code interpretation: ;code does> begin do ?do +do -do u+do u-do while if ?dup-if ?dup-0=-if else case struct [if] [else] "
40: "Contains all words which will cause the indent-level to be incremented
41: on the next line.
42: OBS! All words in forth-positives must be surrounded by spaces.")
43:
44: (defvar forth-negatives
45: " ; end-code ;code does> until repeat while +loop loop -loop s+loop else then endif again endcase end-struct [then] [else] [endif] "
46: "Contains all words which will cause the indent-level to be decremented
47: on the current line.
48: OBS! All words in forth-negatives must be surrounded by spaces.")
49:
50: (defvar forth-zeroes
51: " : :noname code interpretation: "
52: "Contains all words which causes the indent to go to zero")
53:
54: (defvar forth-prefixes
55: " postpone [compile] ['] [char] "
56: "words that prefix and escape other words")
57:
58: (defvar forth-mode-abbrev-table nil
59: "Abbrev table in use in Forth-mode buffers.")
60:
61: (define-abbrev-table 'forth-mode-abbrev-table ())
62:
63: (defvar forth-mode-map nil
64: "Keymap used in Forth mode.")
65:
66: (if (not forth-mode-map)
67: (setq forth-mode-map (make-sparse-keymap)))
68:
69: (global-set-key "\e\C-m" 'forth-send-paragraph)
70: (global-set-key "\C-x\C-m" 'forth-split)
71: (global-set-key "\e " 'forth-reload)
72:
73: ;(define-key forth-mode-map "\M-\C-x" 'compile)
74: (define-key forth-mode-map "\C-x\\" 'comment-region)
75: (define-key forth-mode-map "\C-x~" 'forth-remove-tracers)
76: (define-key forth-mode-map "\e\C-m" 'forth-send-paragraph)
77: (define-key forth-mode-map "\eo" 'forth-send-buffer)
78: (define-key forth-mode-map "\C-x\C-m" 'forth-split)
79: (define-key forth-mode-map "\e " 'forth-reload)
80: (define-key forth-mode-map "\t" 'forth-indent-command)
81: (define-key forth-mode-map "\C-m" 'reindent-then-newline-and-indent)
82: (define-key forth-mode-map "\M-q" 'forth-fill-paragraph)
83: (define-key forth-mode-map "\e." 'forth-find-tag)
84:
85: (load "etags.el")
86:
87: (defun forth-find-tag (tagname &optional next-p regexp-p)
88: (interactive (find-tag-interactive "Find tag: "))
89: (switch-to-buffer
90: (find-tag-noselect (concat " " tagname " ") next-p regexp-p)))
91:
92: (defvar forth-mode-syntax-table nil
93: "Syntax table in use in Forth-mode buffers.")
94:
95: (if (not forth-mode-syntax-table)
96: (progn
97: (setq forth-mode-syntax-table (make-syntax-table))
98: (let ((char 0))
99: (while (< char ?!)
100: (modify-syntax-entry char " " forth-mode-syntax-table)
101: (setq char (1+ char)))
102: (while (< char 256)
103: (modify-syntax-entry char "w" forth-mode-syntax-table)
104: (setq char (1+ char))))
105: (modify-syntax-entry ?\" "\"" forth-mode-syntax-table)
106: (modify-syntax-entry ?\\ "<" forth-mode-syntax-table)
107: (modify-syntax-entry ?\n ">" forth-mode-syntax-table)
108: ))
109: ;I do not define '(' and ')' as comment delimiters, because emacs
110: ;only supports one comment syntax (and a hack to accomodate C++); I
111: ;use '\' for natural language comments and '(' for formal comments
112: ;like stack comments, so for me it's better to have emacs treat '\'
113: ;comments as comments. If you want it different, make the appropriate
114: ;changes (best in your .emacs file).
115: ;
116: ;Hmm, the C++ hack could be used to support both comment syntaxes: we
117: ;can have different comment styles, if both comments start with the
118: ;same character. we could use ' ' as first and '(' and '\' as second
119: ;character. However this would fail for G\ comments.
120:
121: (defconst forth-indent-level 4
122: "Indentation of Forth statements.")
123:
124: (defun forth-mode-variables ()
125: (set-syntax-table forth-mode-syntax-table)
126: (setq local-abbrev-table forth-mode-abbrev-table)
127: (make-local-variable 'paragraph-start)
128: (setq paragraph-start (concat "^$\\|" page-delimiter))
129: (make-local-variable 'paragraph-separate)
130: (setq paragraph-separate paragraph-start)
131: (make-local-variable 'indent-line-function)
132: (setq indent-line-function 'forth-indent-line)
133: ; (make-local-variable 'require-final-newline)
134: ; (setq require-final-newline t)
135: (make-local-variable 'comment-start)
136: (setq comment-start "\\ ")
137: ;(make-local-variable 'comment-end)
138: ;(setq comment-end " )")
139: (make-local-variable 'comment-column)
140: (setq comment-column 40)
141: (make-local-variable 'comment-start-skip)
142: (setq comment-start-skip "\\ ")
143: (make-local-variable 'comment-indent-hook)
144: (setq comment-indent-hook 'forth-comment-indent)
145: (make-local-variable 'parse-sexp-ignore-comments)
146: (setq parse-sexp-ignore-comments t))
147:
148: ;;;###autoload
149: (defun forth-mode ()
150: "
151: Major mode for editing Forth code. Tab indents for Forth code. Comments
152: are delimited with \\ and newline. Paragraphs are separated by blank lines
153: only. Delete converts tabs to spaces as it moves back.
154: \\{forth-mode-map}
155: Forth-split
156: Positions the current buffer on top and a forth-interaction window
157: below. The window size is controlled by the forth-percent-height
158: variable (see below).
159: Forth-reload
160: Reloads the forth library and restarts the forth process.
161: Forth-send-buffer
162: Sends the current buffer, in text representation, as input to the
163: forth process.
164: Forth-send-paragraph
165: Sends the previous or the current paragraph to the forth-process.
166: Note that the cursor only need to be with in the paragraph to be sent.
167: forth-documentation
168: Search for documentation of forward adjacent to cursor. Note! To use
169: this mode you have to add a line, to your .emacs file, defining the
170: directories to search through for documentation files (se variable
171: forth-help-load-path below) e.g. (setq forth-help-load-path '(nil)).
172:
173: Variables controlling interaction and startup
174: forth-percent-height
175: Tells split how high to make the edit portion, in percent of the
176: current screen height.
177: forth-program-name
178: Tells the library which program name to execute in the interation
179: window.
180:
181: Variables controlling indentation style:
182: forth-positives
183: A string containing all words which causes the indent-level of the
184: following line to be incremented.
185: OBS! Each word must be surronded by spaces.
186: forth-negatives
187: A string containing all words which causes the indentation of the
188: current line to be decremented, if the word begin the line. These
189: words also has a cancelling effect on the indent-level of the
190: following line, independent of position.
191: OBS! Each word must be surronded by spaces.
192: forth-zeroes
193: A string containing all words which causes the indentation of the
194: current line to go to zero, if the word begin the line.
195: OBS! Each word must be surronded by spaces.
196: forth-indent-level
197: Indentation increment/decrement of Forth statements.
198:
199: Note! A word which decrements the indentation of the current line, may
200: also be mentioned in forth-positives to cause the indentation to
201: resume the previous level.
202:
203: Variables controling documentation search
204: forth-help-load-path
205: List of directories to search through to find *.doc
206: (forth-help-file-suffix) files. Nil means current default directory.
207: The specified directories must contain at least one .doc file. If it
208: does not and you still want the load-path to scan that directory, create
209: an empty file dummy.doc.
210: forth-help-file-suffix
211: The file names to search for in each directory specified by
212: forth-help-load-path. Defaulted to '*.doc'.
213: "
214: (interactive)
215: (kill-all-local-variables)
216: (use-local-map forth-mode-map)
217: (setq mode-name "Forth")
218: (setq major-mode 'forth-mode)
219: (forth-mode-variables)
220: ; (if (not (forth-process-running-p))
221: ; (run-forth forth-program-name))
222: (run-hooks 'forth-mode-hook))
223:
224: (setq forth-mode-hook
225: '(lambda ()
226: (make-local-variable 'compile-command)
227: (setq compile-command "gforth ")))
228:
229: (defun forth-fill-paragraph ()
230: "Fill comments (starting with '\'; do not fill code (block style
231: programmers who tend to fill code won't use emacs anyway:-)."
232: ; Currently only comments at the start of the line are filled.
233: ; Something like lisp-fill-paragraph may be better. We cannot use
234: ; fill-paragraph, because it removes the \ from the first comment
235: ; line. Therefore we have to look for the first line of the comment
236: ; and use fill-region.
237: (interactive)
238: (save-excursion
239: (beginning-of-line)
240: (while (and
241: (= (forward-line -1) 0)
242: (looking-at "[ \t]*\\\\g?[ \t]+")))
243: (if (not (looking-at "[ \t]*\\\\g?[ \t]+"))
244: (forward-line 1))
245: (let ((from (point))
246: (to (save-excursion (forward-paragraph) (point))))
247: (if (looking-at "[ \t]*\\\\g?[ \t]+")
248: (progn (goto-char (match-end 0))
249: (set-fill-prefix)
250: (fill-region from to nil))))))
251:
252: (defun forth-comment-indent ()
253: (save-excursion
254: (beginning-of-line)
255: (if (looking-at ":[ \t]*")
256: (progn
257: (end-of-line)
258: (skip-chars-backward " \t\n")
259: (1+ (current-column)))
260: comment-column)))
261:
262: (defun forth-current-indentation ()
263: (save-excursion
264: (beginning-of-line)
265: (back-to-indentation)
266: (current-column)))
267:
268: (defun forth-delete-indentation ()
269: (let ((b nil) (m nil))
270: (save-excursion
271: (beginning-of-line)
272: (setq b (point))
273: (back-to-indentation)
274: (setq m (point)))
275: (delete-region b m)))
276:
277: (defun forth-indent-line (&optional flag)
278: "Correct indentation of the current Forth line."
279: (let ((x (forth-calculate-indent)))
280: (forth-indent-to x)))
281:
282: (defun forth-indent-command ()
283: (interactive)
284: (forth-indent-line t))
285:
286: (defun forth-indent-to (x)
287: (let ((p nil))
288: (setq p (- (current-column) (forth-current-indentation)))
289: (forth-delete-indentation)
290: (beginning-of-line)
291: (indent-to x)
292: (if (> p 0) (forward-char p))))
293:
294: ;;Calculate indent
295: (defun forth-calculate-indent ()
296: (let ((w1 nil) (indent 0) (centre 0))
297: (save-excursion
298: (beginning-of-line)
299: (skip-chars-backward " \t\n")
300: (beginning-of-line)
301: (back-to-indentation)
302: (setq indent (current-column))
303: (setq centre indent)
304: (setq indent (+ indent (forth-sum-line-indentation))))
305: (save-excursion
306: (beginning-of-line)
307: (back-to-indentation)
308: (let ((p (point)))
309: (skip-chars-forward "^ \t\n")
310: (setq w1 (buffer-substring p (point)))))
311: (if (> (- indent centre) forth-indent-level)
312: (setq indent (+ centre forth-indent-level)))
313: (if (> (- centre indent) forth-indent-level)
314: (setq indent (- centre forth-indent-level)))
315: (if (< indent 0) (setq indent 0))
316: (setq indent (- indent
317: (if (string-match
318: (regexp-quote (concat " " w1 " "))
319: forth-negatives)
320: forth-indent-level 0)))
321: (if (string-match (regexp-quote (concat " " w1 " ")) forth-zeroes)
322: (setq indent 0))
323: indent))
324:
325: (defun forth-sum-line-indentation ()
326: "Add upp the positive and negative weights of all words on the current line."
327: (let ((b (point)) (e nil) (sum 0) (w nil) (t1 nil) (t2 nil) (first t))
328: (end-of-line) (setq e (point))
329: (goto-char b)
330: (while (< (point) e)
331: (setq w (forth-next-word))
332: (setq t1 (string-match (regexp-quote (concat " " w " "))
333: forth-positives))
334: (setq t2 (string-match (regexp-quote (concat " " w " "))
335: forth-negatives))
336: (if t1
337: (setq sum (+ sum forth-indent-level)))
338: (if (and t2 (not first))
339: (setq sum (- sum forth-indent-level)))
340: (skip-chars-forward " \t")
341: (setq first nil))
342: sum))
343:
344:
345: (defun forth-next-word ()
346: "Return the next forth-word. Skip anything that the forth-word takes from
347: the input stream (comments, arguments, etc.)"
348: ;actually, it would be better to use commands based on the
349: ;syntax-table or comment-start etc.
350: (let ((w1 nil))
351: (while (not w1)
352: (skip-chars-forward " \t\n")
353: (let ((p (point)))
354: (skip-chars-forward "^ \t\n")
355: (setq w1 (buffer-substring p (point))))
356: (cond ((string-match "\"" w1)
357: (progn
358: (skip-chars-forward "^\"\n")
359: (forward-char)))
360: ((string-match "\\\\" w1)
361: (progn
362: (end-of-line)
363: ))
364: ((or (equal "(" w1) (equal ".(" w1))
365: (progn
366: (skip-chars-forward "^)\n")
367: (forward-char)))
368: ((string-match (regexp-quote (concat " " w1 " ")) forth-prefixes)
369: (progn (skip-chars-forward " \t\n")
370: (skip-chars-forward "^ \t\n")))
371: (t nil)))
372: w1))
373:
374:
375: ;; Forth commands
376:
377: (defun forth-remove-tracers ()
378: "Remove tracers of the form `~~ '. Queries the user for each occurrence."
379: (interactive)
380: (query-replace-regexp "\\(~~ \\| ~~$\\)" "" nil))
381:
382: (defvar forth-program-name "gforth"
383: "*Program invoked by the `run-forth' command.")
384:
385: (defvar forth-band-name nil
386: "*Band loaded by the `run-forth' command.")
387:
388: (defvar forth-program-arguments nil
389: "*Arguments passed to the Forth program by the `run-forth' command.")
390:
391: (defun run-forth (command-line)
392: "Run an inferior Forth process. Output goes to the buffer `*forth*'.
393: With argument, asks for a command line. Split up screen and run forth
394: in the lower portion. The current-buffer when called will stay in the
395: upper portion of the screen, and all other windows are deleted.
396: Call run-forth again to make the *forth* buffer appear in the lower
397: part of the screen."
398: (interactive
399: (list (let ((default
400: (or forth-process-command-line
401: (forth-default-command-line))))
402: (if current-prefix-arg
403: (read-string "Run Forth: " default)
404: default))))
405: (setq forth-process-command-line command-line)
406: (forth-start-process command-line)
407: (forth-split)
408: (forth-set-runlight forth-runlight:input))
409:
410: (defun reset-forth ()
411: "Reset the Forth process."
412: (interactive)
413: (let ((process (get-process forth-program-name)))
414: (cond ((or (not process)
415: (not (eq (process-status process) 'run))
416: (yes-or-no-p
417: "The Forth process is running, are you SURE you want to reset it? "))
418: (message "Resetting Forth process...")
419: (forth-reload)
420: (message "Resetting Forth process...done")))))
421:
422: (defun forth-default-command-line ()
423: (concat forth-program-name
424: (if forth-program-arguments
425: (concat " " forth-program-arguments)
426: "")))
427:
428: ;;;; Internal Variables
429:
430: (defvar forth-process-command-line nil
431: "Command used to start the most recent Forth process.")
432:
433: (defvar forth-previous-send ""
434: "Most recent expression transmitted to the Forth process.")
435:
436: (defvar forth-process-filter-queue '()
437: "Queue used to synchronize filter actions properly.")
438:
439: (defvar forth-prompt "ok"
440: "The current forth prompt string.")
441:
442: (defvar forth-start-hook nil
443: "If non-nil, a procedure to call when the Forth process is started.
444: When called, the current buffer will be the Forth process-buffer.")
445:
446: (defvar forth-signal-death-message nil
447: "If non-nil, causes a message to be generated when the Forth process dies.")
448:
449: (defvar forth-percent-height 50
450: "Tells run-forth how high the upper window should be in percent.")
451:
452: (defconst forth-runlight:input ?I
453: "The character displayed when the Forth process is waiting for input.")
454:
455: (defvar forth-mode-string ""
456: "String displayed in the mode line when the Forth process is running.")
457:
458: ;;;; Evaluation Commands
459:
460: (defun forth-send-string (&rest strings)
461: "Send the string arguments to the Forth process.
462: The strings are concatenated and terminated by a newline."
463: (cond ((forth-process-running-p)
464: (forth-send-string-1 strings))
465: ((yes-or-no-p "The Forth process has died. Reset it? ")
466: (reset-forth)
467: (goto-char (point-max))
468: (forth-send-string-1 strings))))
469:
470: (defun forth-send-string-1 (strings)
471: (let ((string (apply 'concat strings)))
472: (forth-send-string-2 string)))
473:
474: (defun forth-send-string-2 (string)
475: (let ((process (get-process forth-program-name)))
476: (if (not (eq (current-buffer) (get-buffer forth-program-name)))
477: (progn
478: (forth-process-filter-output string)
479: (forth-process-filter:finish)))
480: (send-string process (concat string "\n"))
481: (if (eq (current-buffer) (process-buffer process))
482: (set-marker (process-mark process) (point)))))
483:
484:
485: (defun forth-send-region (start end)
486: "Send the current region to the Forth process.
487: The region is sent terminated by a newline."
488: (interactive "r")
489: (let ((process (get-process forth-program-name)))
490: (if (and process (eq (current-buffer) (process-buffer process)))
491: (progn (goto-char end)
492: (set-marker (process-mark process) end))))
493: (forth-send-string "\n" (buffer-substring start end) "\n"))
494:
495: (defun forth-end-of-paragraph ()
496: (if (looking-at "[\t\n ]+") (skip-chars-backward "\t\n "))
497: (if (not (re-search-forward "\n[ \t]*\n" nil t))
498: (goto-char (point-max))))
499:
500: (defun forth-send-paragraph ()
501: "Send the current or the previous paragraph to the Forth process"
502: (interactive)
503: (let (end)
504: (save-excursion
505: (forth-end-of-paragraph)
506: (skip-chars-backward "\t\n ")
507: (setq end (point))
508: (if (re-search-backward "\n[ \t]*\n" nil t)
509: (setq start (point))
510: (goto-char (point-min)))
511: (skip-chars-forward "\t\n ")
512: (forth-send-region (point) end))))
513:
514: (defun forth-send-buffer ()
515: "Send the current buffer to the Forth process."
516: (interactive)
517: (if (eq (current-buffer) (forth-process-buffer))
518: (error "Not allowed to send this buffer's contents to Forth"))
519: (forth-send-region (point-min) (point-max)))
520:
521:
522: ;;;; Basic Process Control
523:
524: (defun forth-start-process (command-line)
525: (let ((buffer (get-buffer-create "*forth*")))
526: (let ((process (get-buffer-process buffer)))
527: (save-excursion
528: (set-buffer buffer)
529: (progn (if process (delete-process process))
530: (goto-char (point-max))
531: (setq mode-line-process '(": %s"))
532: (add-to-global-mode-string 'forth-mode-string)
533: (setq process
534: (apply 'start-process
535: (cons forth-program-name
536: (cons buffer
537: (forth-parse-command-line
538: command-line)))))
539: (set-marker (process-mark process) (point-max))
540: (forth-process-filter-initialize t)
541: (forth-modeline-initialize)
542: (set-process-sentinel process 'forth-process-sentinel)
543: (set-process-filter process 'forth-process-filter)
544: (run-hooks 'forth-start-hook)))
545: buffer)))
546:
547: (defun forth-parse-command-line (string)
548: (setq string (substitute-in-file-name string))
549: (let ((start 0)
550: (result '()))
551: (while start
552: (let ((index (string-match "[ \t]" string start)))
553: (setq start
554: (cond ((not index)
555: (setq result
556: (cons (substring string start)
557: result))
558: nil)
559: ((= index start)
560: (string-match "[^ \t]" string start))
561: (t
562: (setq result
563: (cons (substring string start index)
564: result))
565: (1+ index))))))
566: (nreverse result)))
567:
568:
569: (defun forth-process-running-p ()
570: "True iff there is a Forth process whose status is `run'."
571: (let ((process (get-process forth-program-name)))
572: (and process
573: (eq (process-status process) 'run))))
574:
575: (defun forth-process-buffer ()
576: (let ((process (get-process forth-program-name)))
577: (and process (process-buffer process))))
578:
579: ;;;; Process Filter
580:
581: (defun forth-process-sentinel (proc reason)
582: (let ((inhibit-quit nil))
583: (forth-process-filter-initialize (eq reason 'run))
584: (if (eq reason 'run)
585: (forth-modeline-initialize)
586: (setq forth-mode-string "")))
587: (if (and (not (memq reason '(run stop)))
588: forth-signal-death-message)
589: (progn (beep)
590: (message
591: "The Forth process has died! Do M-x reset-forth to restart it"))))
592:
593: (defun forth-process-filter-initialize (running-p)
594: (setq forth-process-filter-queue (cons '() '()))
595: (setq forth-prompt "ok"))
596:
597:
598: (defun forth-process-filter (proc string)
599: (forth-process-filter-output string)
600: (forth-process-filter:finish))
601:
602: (defun forth-process-filter:enqueue (action)
603: (let ((next (cons action '())))
604: (if (cdr forth-process-filter-queue)
605: (setcdr (cdr forth-process-filter-queue) next)
606: (setcar forth-process-filter-queue next))
607: (setcdr forth-process-filter-queue next)))
608:
609: (defun forth-process-filter:finish ()
610: (while (car forth-process-filter-queue)
611: (let ((next (car forth-process-filter-queue)))
612: (setcar forth-process-filter-queue (cdr next))
613: (if (not (cdr next))
614: (setcdr forth-process-filter-queue '()))
615: (apply (car (car next)) (cdr (car next))))))
616:
617: ;;;; Process Filter Output
618:
619: (defun forth-process-filter-output (&rest args)
620: (if (not (and args
621: (null (cdr args))
622: (stringp (car args))
623: (string-equal "" (car args))))
624: (forth-process-filter:enqueue
625: (cons 'forth-process-filter-output-1 args))))
626:
627: (defun forth-process-filter-output-1 (&rest args)
628: (save-excursion
629: (forth-goto-output-point)
630: (apply 'insert-before-markers args)))
631:
632: (defun forth-guarantee-newlines (n)
633: (save-excursion
634: (forth-goto-output-point)
635: (let ((stop nil))
636: (while (and (not stop)
637: (bolp))
638: (setq n (1- n))
639: (if (bobp)
640: (setq stop t)
641: (backward-char))))
642: (forth-goto-output-point)
643: (while (> n 0)
644: (insert-before-markers ?\n)
645: (setq n (1- n)))))
646:
647: (defun forth-goto-output-point ()
648: (let ((process (get-process forth-program-name)))
649: (set-buffer (process-buffer process))
650: (goto-char (process-mark process))))
651:
652: (defun forth-modeline-initialize ()
653: (setq forth-mode-string " "))
654:
655: (defun forth-set-runlight (runlight)
656: (aset forth-mode-string 0 runlight)
657: (forth-modeline-redisplay))
658:
659: (defun forth-modeline-redisplay ()
660: (save-excursion (set-buffer (other-buffer)))
661: (set-buffer-modified-p (buffer-modified-p))
662: (sit-for 0))
663:
664: ;;;; Process Filter Operations
665:
666: (defun add-to-global-mode-string (x)
667: (cond ((null global-mode-string)
668: (setq global-mode-string (list "" x " ")))
669: ((not (memq x global-mode-string))
670: (setq global-mode-string
671: (cons ""
672: (cons x
673: (cons " "
674: (if (equal "" (car global-mode-string))
675: (cdr global-mode-string)
676: global-mode-string))))))))
677:
678:
679: ;; Misc
680:
681: (setq auto-mode-alist (append auto-mode-alist
682: '(("\\.fs$" . forth-mode))))
683:
684: (defun forth-split ()
685: (interactive)
686: (forth-split-1 "*forth*"))
687:
688: (defun forth-split-1 (buffer)
689: (if (not (eq (window-buffer) (get-buffer buffer)))
690: (progn
691: (delete-other-windows)
692: (split-window-vertically
693: (/ (* (screen-height) forth-percent-height) 100))
694: (other-window 1)
695: (switch-to-buffer buffer)
696: (goto-char (point-max))
697: (other-window 1))))
698:
699: (defun forth-reload ()
700: (interactive)
701: (let ((process (get-process forth-program-name)))
702: (if process (kill-process process t)))
703: (sleep-for-millisecs 100)
704: (forth-mode))
705:
706:
707: ;; Special section for forth-help
708:
709: (defvar forth-help-buffer "*Forth-help*"
710: "Buffer used to display the requested documentation.")
711:
712: (defvar forth-help-load-path nil
713: "List of directories to search through to find *.doc
714: (forth-help-file-suffix) files. Nil means current default directory.
715: The specified directories must contain at least one .doc file. If it
716: does not and you still want the load-path to scan that directory, create
717: an empty file dummy.doc.")
718:
719: (defvar forth-help-file-suffix "*.doc"
720: "The file names to search for in each directory.")
721:
722: (setq forth-search-command-prefix "grep -n \"^ [^(]* ")
723: (defvar forth-search-command-suffix "/dev/null")
724: (defvar forth-grep-error-regexp ": No such file or directory")
725:
726: (defun forth-function-called-at-point ()
727: "Return the space delimited word a point."
728: (save-excursion
729: (save-restriction
730: (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
731: (skip-chars-backward "^ \t\n" (point-min))
732: (if (looking-at "[ \t\n]")
733: (forward-char 1))
734: (let (obj (p (point)))
735: (skip-chars-forward "^ \t\n")
736: (buffer-substring p (point))))))
737:
738: (defun forth-help-names-extend-comp (path-list result)
739: (cond ((null path-list) result)
740: ((null (car path-list))
741: (forth-help-names-extend-comp (cdr path-list)
742: (concat result forth-help-file-suffix " ")))
743: (t (forth-help-names-extend-comp
744: (cdr path-list) (concat result
745: (expand-file-name (car path-list)) "/"
746: forth-help-file-suffix " ")))))
747:
748: (defun forth-help-names-extended ()
749: (if forth-help-load-path
750: (forth-help-names-extend-comp forth-help-load-path "")
751: (error "forth-help-load-path not specified")))
752:
753:
754: ;(define-key forth-mode-map "\C-hf" 'forth-documentation)
755:
756: (defun forth-documentation (function)
757: "Display the full documentation of FORTH word."
758: (interactive
759: (let ((fn (forth-function-called-at-point))
760: (enable-recursive-minibuffers t)
761: search-list
762: val)
763: (setq val (read-string (format "Describe forth word (default %s): " fn)))
764: (list (if (equal val "") fn val))))
765: (forth-get-doc (concat forth-search-command-prefix
766: (grep-regexp-quote (concat function " ("))
767: "[^)]*\-\-\" " (forth-help-names-extended)
768: forth-search-command-suffix))
769: (message "C-x C-m switches back to the forth interaction window"))
770:
771: (defun forth-get-doc (command)
772: "Display the full documentation of command."
773: (let ((curwin (get-buffer-window (window-buffer)))
774: reswin
775: pointmax)
776: (with-output-to-temp-buffer forth-help-buffer
777: (progn
778: (call-process "sh" nil forth-help-buffer t "-c" command)
779: (setq reswin (get-buffer-window forth-help-buffer))))
780: (setq reswin (get-buffer-window forth-help-buffer))
781: (select-window reswin)
782: (save-excursion
783: (goto-char (setq pointmax (point-max)))
784: (insert "--------------------\n\n"))
785: (let (fd doc)
786: (while (setq fd (forth-get-file-data pointmax))
787: (setq doc (forth-get-doc-string fd))
788: (save-excursion
789: (goto-char (point-max))
790: (insert (substring (car fd) (string-match "[^/]*$" (car fd)))
791: ":\n\n" doc "\n")))
792: (if (not doc)
793: (progn (goto-char (point-max)) (insert "Not found"))))
794: (select-window curwin)))
795:
796: (defun forth-skip-error-lines ()
797: (let ((lines 0))
798: (save-excursion
799: (while (re-search-forward forth-grep-error-regexp nil t)
800: (beginning-of-line)
801: (forward-line 1)
802: (setq lines (1+ lines))))
803: (forward-line lines)))
804:
805: (defun forth-get-doc-string (fd)
806: "Find file (car fd) and extract documentation from line (nth 1 fd)."
807: (let (result)
808: (save-window-excursion
809: (find-file (car fd))
810: (goto-line (nth 1 fd))
811: (if (not (eq (nth 1 fd) (1+ (count-lines (point-min) (point)))))
812: (error "forth-get-doc-string: serious error"))
813: (if (not (re-search-backward "\n[\t ]*\n" nil t))
814: (goto-char (point-min))
815: (goto-char (match-end 0)))
816: (let ((p (point)))
817: (if (not (re-search-forward "\n[\t ]*\n" nil t))
818: (goto-char (point-max)))
819: (setq result (buffer-substring p (point))))
820: (bury-buffer (current-buffer)))
821: result))
822:
823: (defun forth-get-file-data (limit)
824: "Parse grep output and return '(filename line#) list. Return nil when
825: passing limit."
826: (forth-skip-error-lines)
827: (if (< (point) limit)
828: (let ((result (forth-get-file-data-cont limit)))
829: (forward-line 1)
830: (beginning-of-line)
831: result)))
832:
833: (defun forth-get-file-data-cont (limit)
834: (let (result)
835: (let ((p (point)))
836: (skip-chars-forward "^:")
837: (setq result (buffer-substring p (point))))
838: (if (< (point) limit)
839: (let ((p (1+ (point))))
840: (forward-char 1)
841: (skip-chars-forward "^:")
842: (list result (string-to-int (buffer-substring p (point))))))))
843:
844: (defun grep-regexp-quote (str)
845: (let ((i 0) (m 1) (res ""))
846: (while (/= m 0)
847: (setq m (string-to-char (substring str i)))
848: (if (/= m 0)
849: (progn
850: (setq i (1+ i))
851: (if (string-match (regexp-quote (char-to-string m))
852: ".*\\^$[]")
853: (setq res (concat res "\\")))
854: (setq res (concat res (char-to-string m))))))
855: res))
856:
857:
858: (define-key forth-mode-map "\C-x\C-e" 'compile)
859: (define-key forth-mode-map "\C-x\C-n" 'next-error)
860: (require 'compile "compile")
861:
862: (defvar forth-compile-command "gforth ")
863: ;(defvar forth-compilation-window-percent-height 30)
864:
865: (defun forth-compile (command)
866: (interactive (list (setq forth-compile-command (read-string "Compile command: " forth-compile-command))))
867: (forth-split-1 "*compilation*")
868: (setq ctools-compile-command command)
869: (compile1 ctools-compile-command "No more errors"))
870:
871:
872: ;;; Forth menu
873: ;;; Mikael Karlsson <qramika@eras70.ericsson.se>
874:
875: (cond ((string-match "XEmacs\\|Lucid" emacs-version)
876: (require 'func-menu)
877:
878: (defconst fume-function-name-regexp-forth
879: "^\\(:\\)[ \t]+\\([^ \t]*\\)"
880: "Expression to get word definitions in Forth.")
881:
882: (setq fume-function-name-regexp-alist
883: (append '((forth-mode . fume-function-name-regexp-forth)
884: ) fume-function-name-regexp-alist))
885:
886: ;; Find next forth word in the buffer
887: (defun fume-find-next-forth-function-name (buffer)
888: "Searches for the next forth word in BUFFER."
889: (set-buffer buffer)
890: (if (re-search-forward fume-function-name-regexp nil t)
891: (let ((beg (match-beginning 2))
892: (end (match-end 2)))
893: (cons (buffer-substring beg end) beg))))
894:
895: (setq fume-find-function-name-method-alist
896: (append '((forth-mode . fume-find-next-forth-function-name))))
897:
898: ))
899: ;;; End Forth menu
900:
901: ;;; File folding of forth-files
902: ;;; uses outline
903: ;;; Toggle activation with M-x fold-f (when editing a forth-file)
904: ;;; Use f9 to expand, f10 to hide, Or the menubar in xemacs
905: ;;;
906: ;;; Works most of the times but loses sync with the cursor occasionally
907: ;;; Could be improved by also folding on comments
908:
909: (require 'outline)
910:
911: ;;(define-key outline-minor-mode-map 'f9 'show-entry)
912: ;;(define-key outline-minor-mode-map 'f10 'hide-entry)
913:
914: (defun fold-f ()
915: (interactive)
916: (add-hook 'outline-minor-mode-hook 'hide-body)
917:
918: ; outline mode header start, i.e. find word definitions
919: (setq outline-regexp "^\\(:\\)[ \t]+\\([^ \t]*\\)")
920:
921: (outline-minor-mode)
922: )
923: ;;; end file folding
924:
925: ;;; func-menu is a package that scans your source file for function definitions
926: ;;; and makes a menubar entry that lets you jump to any particular function
927: ;;; definition by selecting it from the menu. The following code turns this on
928: ;;; for all of the recognized languages. Scanning the buffer takes some time,
929: ;;; but not much.
930: ;;;
931: (cond ((string-match "XEmacs\\|Lucid" emacs-version)
932: (require 'func-menu)
933: ;; (define-key global-map 'f8 'function-menu)
934: (add-hook 'find-fible-hooks 'fume-add-menubar-entry)
935: (define-key global-map "\C-cg" 'fume-prompt-function-goto)
936: (define-key global-map '(shift button3) 'mouse-function-menu)
937: ))
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>