-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathgforth.el
1754 lines (1539 loc) · 67.3 KB
/
gforth.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; gforth.el --- major mode for editing (G)Forth sources
;; Copyright (C) 1995,1996,1997,1998,2000,2001,2003,2004,2007,2008,2010,2011,2012,2013,2014,2015,2016 Free Software Foundation, Inc.
;; This file is part of Gforth.
;; GForth is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY. No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing. Refer to the GNU Emacs General Public
;; License for full details.
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License. A copy of this license is
;; supposed to have been given to you along with Gforth so you
;; can know your rights and responsibilities. It should be in a
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;; Author: Goran Rydqvist <gorry@ida.liu.se>
;; Maintainer: David Kühling <dvdkhlng@gmx.de>
;; Created: 16 July 88 by Goran Rydqvist
;; Keywords: forth, gforth
;; Changes by anton
;; This is a variant of forth.el that came with TILE.
;; I left most of this stuff untouched and made just a few changes for
;; the things I use (mainly indentation and syntax tables).
;; So there is still a lot of work to do to adapt this to gforth.
;; Changes by David
;; Added a syntax-hilighting engine, rewrote auto-indentation engine.
;; Added support for block files.
;; Replaced forth-process code with comint-based implementation.
;; Tested with Emacs 19.34, 20.5, 21 and XEmacs 21
;;-------------------------------------------------------------------
;; A Forth indentation, documentation search and interaction library
;;-------------------------------------------------------------------
;;
;; Written by Goran Rydqvist, gorry@ida.liu.se, Summer 1988
;; Started: 16 July 88
;; Version: 2.10
;; Last update: 5 December 1989 by Mikael Patel, mip@ida.liu.se
;; Last update: 25 June 1990 by Goran Rydqvist, gorry@ida.liu.se
;;
;; Documentation: See forth-mode (^HF forth-mode)
;;-------------------------------------------------------------------
;;; Code:
;(setq debug-on-error t)
;; Code ripped from `version.el' for compatability with Emacs versions
;; prior to 19.23.
(if (not (boundp 'emacs-major-version))
(defconst emacs-major-version
(progn (string-match "^[0-9]+" emacs-version)
(string-to-number (match-string 0 emacs-version)))))
;; Code ripped from `subr.el' for compatability with Emacs versions
;; prior to 20.1
(eval-when-compile
(defun forth-emacs-older (major minor)
(or (< emacs-major-version major)
(and (= emacs-major-version major) (< emacs-minor-version minor))))
(if (forth-emacs-older 20 1)
(progn
(defmacro when (cond &rest body)
"If COND yields non-nil, do BODY, else return nil."
(list 'if cond (cons 'progn body)))
(defmacro unless (cond &rest body)
"If COND yields nil, do BODY, else return nil."
(cons 'if (cons cond (cons nil body)))))))
;; `no-error' argument of require not supported in Emacs versions
;; prior to 20.4 :-(
(eval-and-compile
(defun forth-require (feature)
(condition-case err (require feature) (error nil))))
(require 'font-lock)
;; define `font-lock-warning-face' in emacs-versions prior to 20.1
;; (ripped from `font-lock.el')
(unless (boundp 'font-lock-warning-face)
(message "defining font-lock-warning-face")
(make-face 'font-lock-warning-face)
(defvar font-lock-warning-face 'font-lock-warning-face)
(set-face-foreground font-lock-warning-face "red")
(make-face-bold font-lock-warning-face))
;; define `font-lock-constant-face' in XEmacs (just copy
;; `font-lock-preprocessor-face')
(unless (boundp 'font-lock-constant-face)
(copy-face font-lock-preprocessor-face 'font-lock-constant-face))
;; define `regexp-opt' in emacs versions prior to 20.1
;; (this implementation is extremely inefficient, though)
(eval-and-compile (forth-require 'regexp-opt))
(unless (memq 'regexp-opt features)
(message (concat
"Warning: your Emacs version doesn't support `regexp-opt'. "
"Hilighting will be slow."))
(defun regexp-opt (STRINGS &optional PAREN)
(let ((open (if PAREN "\\(" "")) (close (if PAREN "\\)" "")))
(concat open (mapconcat 'regexp-quote STRINGS "\\|") close)))
(defun regexp-opt-depth (re)
(if (string= (substring re 0 2) "\\(") 1 0)))
; todo:
;
; screen-height existiert nicht in XEmacs, frame-height ersetzen?
;
; Wörter ordentlich hilighten, die nicht auf Whitespace beginnen ( ..)IF
; -- mit aktueller Konzeption nicht möglich??
;
; Konfiguration über customization groups
;
; Bereich nur auf Wortanfang/ende ausweiten, wenn Anfang bzw Ende in einem
; Wort liegen (?) -- speed!
;
; 'forth-word' property muss eindeutig sein!
;
; Forth-Menu
;
; Interface zu GForth Prozessen (Patches von Michael Scholz)
;
; Byte-compile-Code rausschmeißen, Compilieren im Makefile über Emacs
; batch-Modus
;
; forth-help Kram rausschmeißen
;
; XEmacs Kompatibilität? imenu/speedbar -> fume?
;
; Folding neuschreiben (neue Parser-Informationen benutzen)
;;; Motion-hooking (dk)
;;;
(defun forth-idle-function ()
"Function that is called when Emacs is idle to detect cursor motion
in forth-block-mode buffers (which is mainly used for screen number
display in). Currently ignores forth-mode buffers but that may change
in the future."
(if (eq major-mode 'forth-block-mode)
(forth-check-motion)))
(defvar forth-idle-function-timer nil
"Timer that runs `forth-idle-function' or nil if no timer installed.")
(defun forth-install-motion-hook ()
"Install the motion-hooking mechanism. Currently uses idle timers
but might be transparently changed in the future."
(unless forth-idle-function-timer
;; install idle function only once (first time forth-mode is used)
(setq forth-idle-function-timer
(run-with-idle-timer .05 t 'forth-idle-function))))
(defvar forth-was-point nil)
(defun forth-check-motion ()
"Run `forth-motion-hooks', if `point' changed since last call. This
used to be called via `post-command-hook' but uses idle timers now as
users complaint about lagging performance."
(when (or (eq forth-was-point nil) (/= forth-was-point (point)))
(setq forth-was-point (point))
(run-hooks 'forth-motion-hooks)))
;;; Hilighting and indentation engine (dk)
;;;
(defvar forth-disable-parser nil
"*Non-nil means to disable on-the-fly parsing of Forth-code.
This will disable hilighting of forth-mode buffers and will decrease
the smartness of the indentation engine. Only set it to non-nil, if
your computer is very slow. To disable hilighting, set
`forth-hilight-level' to zero.")
(defvar forth-jit-parser nil
"*Non-nil means to parse Forth-code just-in-time.
This eliminates the need for initially parsing forth-mode buffers and
thus speeds up loading of Forth files. That feature is only available
in Emacs21 (and newer versions).")
(defvar forth-words nil
"List of words for hilighting and recognition of parsed text areas.
Hilighting of object-oriented Forth code is achieved, by appending either
`forth-objects-words' or `forth-oof-words' to the list, depending on the values of `forth-use-objects' or `forth-use-oof'.
After `forth-words' changed, `forth-compile-words' must be called to
make the changes take effect.
Each item of `forth-words' has the form
(MATCHER TYPE HILIGHT . &optional PARSED-TEXT ...)
MATCHER is either a list of strings to match, or a REGEXP.
If it's a REGEXP, it should not be surrounded by '\\<' or '\\>', since
that'll be done automatically by the search routines.
TYPE should be one of 'definiton-starter', 'definition-ender', 'compile-only',
'immediate' or 'non-immediate'. Those information are required to determine
whether a word actually parses (and whether that parsed text needs to be
hilighted).
HILIGHT is a cons cell of the form (FACE . MINIMUM-LEVEL)
Where MINIMUM-LEVEL specifies the minimum value of `forth-hilight-level',
that's required for matching text to be hilighted.
PARSED-TEXT specifies whether and how a word parses following text. You can
specify as many subsequent PARSED-TEXT as you wish, but that shouldn't be
necessary very often. It has the following form:
(DELIM-REGEXP SKIP-LEADING-FLAG PARSED-TYPE HILIGHT)
DELIM-REGEXP is a regular expression that should match strings of length 1,
which are delimiters for the parsed text.
A non-nil value for PARSE-LEADING-FLAG means, that leading delimiter strings
before parsed text should be skipped. This is the parsing behaviour of the
Forth word WORD. Set it to t for name-parsing words, nil for comments and
strings.
PARSED-TYPE specifies what kind of text is parsed. It should be on of 'name',
'string' or 'comment'.")
(setq forth-words
'(
(("[") definition-ender (font-lock-keyword-face . 1))
(("]" "]l") definition-starter (font-lock-keyword-face . 1))
((":") definition-starter (font-lock-keyword-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("event:") definition-starter (font-lock-keyword-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("immediate" "compile-only" "restrict")
immediate (font-lock-keyword-face . 1))
(("does>") definition-starter (font-lock-keyword-face . 1))
((":noname" "comp:" "post:" "lit,:") definition-starter (font-lock-keyword-face . 1))
((";" ";code" ";abi-code") definition-ender (font-lock-keyword-face . 1))
(("include" "require" "needs" "use")
non-immediate (font-lock-keyword-face . 1)
"[\n\t ]" t string (font-lock-string-face . 1))
(("included" "required" "thru" "load")
non-immediate (font-lock-keyword-face . 1))
(("code" "abi-code")
non-immediate (font-lock-keyword-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("end-code")
non-immediate (font-lock-keyword-face . 1))
(("[char]") compile-only (font-lock-keyword-face . 1)
"[ \t\n]" t string (font-lock-string-face . 1))
(("char") non-immediate (font-lock-keyword-face . 1)
"[ \t\n]" t string (font-lock-string-face . 1))
("'.'?" non-immediate (font-lock-string-face . 1))
(("s\"" "c\"" "s\\\"") immediate (font-lock-string-face . 1)
"[\"\n]" nil string (font-lock-string-face . 1))
((".\"" ".\\\"") compile-only (font-lock-string-face . 1)
"[\"\n]" nil string (font-lock-string-face . 1))
(("abort\"") compile-only (font-lock-keyword-face . 1)
"[\"\n]" nil string (font-lock-string-face . 1))
(("warning\"") compile-only (font-lock-keyword-face . 1)
"[\"\n]" nil string (font-lock-string-face . 1))
(("{" "{:") compile-only (font-lock-variable-name-face . 1)
"[\n}]" nil name (font-lock-variable-name-face . 1))
((".(" "(") immediate (font-lock-comment-face . 1)
")" nil comment (font-lock-comment-face . 1))
(("\\" "\\G") immediate (font-lock-comment-face . 1)
"[\n]" nil comment (font-lock-comment-face . 1))
(("[if]" "[?do]" "[do]" "[for]" "[begin]"
"[endif]" "[then]" "[loop]" "[+loop]" "[next]" "[until]" "[repeat]"
"[again]" "[while]" "[else]" "[:" ";]" "nope")
immediate (font-lock-keyword-face . 2))
(("[ifdef]" "[ifundef]" "[defined]" "[undefined]") immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("if" "begin" "ahead" "do" "?do" "+do" "u+do" "-do" "u-do" "for"
"case" "of" "?of" "?dup-if" "?dup-0=-if" "then" "endif" "until"
"repeat" "again" "leave" "?leave"
"loop" "+loop" "-loop" "next" "endcase" "next-case" "endof" "contof"
"else" "while" "try"
"recover" "endtry" "iferror" "restore" "endtry-iferror"
"assert(" "assert0(" "assert1(" "assert2("
"assert3(" ")" "<interpretation" "<compilation" "interpretation>"
"compilation>")
compile-only (font-lock-keyword-face . 2))
(("true" "false" "c/l" "bl" "cell" "pi" "w/o" "r/o" "r/w")
non-immediate (font-lock-constant-face . 2))
(("~~" "break:" "dbg" "???" "wtf??" "!!fixme!!" "~~bt" "~~1bt" "bt") compile-only (font-lock-warning-face . 2))
(("break\"") compile-only (font-lock-warning-face . 1)
"[\"\n]" nil string (font-lock-string-face . 1))
(("postpone" "[is]" "defers" "[']" "[compile]")
compile-only (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("is" "what's") immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("<is>" "'" "see") non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("[to]" "[+to]" "[addr]") compile-only (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("to" "+to" "addr") immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("<to>" "<+to>" "<addr>") non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("create" "variable" "constant" "2variable" "2constant" "fvariable"
"fconstant" "value" "2value" "fvalue" "field" "user" "vocabulary"
"cs-vocabulary" "create-interpret/compile" "interpret/compile:"
"debug:" "field:" "2field:" "ffield:" "sffield:" "dffield:"
"uvar" "uvalue" "cfield:" "wfield:" "lfield:" "+field"
"value:" "cvalue:" "wvalue:" "swvalue:" "lvalue:" "slvalue:"
"2value:" "fvalue:" "sfvalue:" "dfvalue:" "$value:" "defer:"
"wrap+value:")
non-immediate (font-lock-type-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
("\\S-+%" non-immediate (font-lock-type-face . 2))
(("defer" "alias" "create-interpret/compile:")
non-immediate (font-lock-type-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("end-struct") non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-type-face . 3))
(("struct" "end-c-library" "c-library-name" "end-structure")
non-immediate (font-lock-keyword-face . 2))
(("c-library" "begin-structure") non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("c-variable") non-immediate (font-lock-type-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("c-function" "c-value") non-immediate (font-lock-type-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3)
"[ \t\n]" t name (font-lock-function-name-face . 3)
"[\n]" nil comment (font-lock-variable-name-face . 3))
(("c-callback") non-immediate (font-lock-type-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3)
"[\n]" nil comment (font-lock-variable-name-face . 3))
(("c-funptr") non-immediate (font-lock-type-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3)
"[}]" t name (font-lock-function-name-face . 3)
"[\n]" nil comment (font-lock-variable-name-face . 3))
(("\\c") non-immediate (font-lock-keyword-face . 1)
"[\n]" nil string (font-lock-string-face . 1))
("-?[0-9]+\\(\\.[0-9]*e\\(-?[0-9]+\\)?\\|\\.?[0-9a-f]*\\)"
immediate (font-lock-constant-face . 3))
("-?\\([&#][0-9.]+\\|\\(0x\\|\\$\\)[0-9a-f.]+\\|%[01]+\\)"
immediate (font-lock-constant-face . 3))
("\\([&#]-?[0-9.]+\\|\\(0x-?\\|\\$-?\\)[0-9a-f.]+\\|%-?[01]+\\)"
immediate (font-lock-constant-face . 3))
("\"[^\"]**" immediate (font-lock-string-face . 1)
"[\"\n]" nil string (font-lock-string-face . 1))
("\".*\""
immediate (font-lock-string-face . 3))
("[a-z\-0-9]+(" immediate (font-lock-comment-face . 1)
")" nil comment (font-lock-comment-face . 1))
))
(defvar forth-use-objects nil
"*Non-nil makes forth-mode also hilight words from the \"Objects\" package.")
(defvar forth-objects-words
'(((":m") definition-starter (font-lock-keyword-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("m:") definition-starter (font-lock-keyword-face . 1))
((";m") definition-ender (font-lock-keyword-face . 1))
(("[current]" "[parent]") compile-only (font-lock-keyword-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("current" "overrides") non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("[to-inst]") compile-only (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("[bind]") compile-only (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-type-face . 3)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("bind") non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-type-face . 3)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("inst-var" "inst-value") non-immediate (font-lock-type-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("method" "selector")
non-immediate (font-lock-type-face . 1)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("end-class" "end-interface")
non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-type-face . 3))
(("public" "protected" "class" "exitm" "implementation" "interface"
"methods" "end-methods" "this")
non-immediate (font-lock-keyword-face . 2))
(("object") non-immediate (font-lock-type-face . 2)))
"Hilighting description for words of the \"Objects\" package")
(defvar forth-use-oof nil
"*Non-nil makes forth-mode also hilight words from the \"OOF\" package.")
(defvar forth-oof-words
'((("class") non-immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-type-face . 3))
(("var") non-immediate (font-lock-type-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("method" "early") non-immediate (font-lock-type-face . 2)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("::" "super" "bind" "bound" "link")
immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-function-name-face . 3))
(("ptr" "asptr" "[]")
immediate (font-lock-keyword-face . 2)
"[ \t\n]" t name (font-lock-variable-name-face . 3))
(("class;" "how:" "self" "new" "new[]" "definitions" "class?" "with"
"endwith")
non-immediate (font-lock-keyword-face . 2))
(("object") non-immediate (font-lock-type-face . 2)))
"Hilighting description for words of the \"OOF\" package")
(defvar forth-local-words nil
"List of Forth words to prepend to `forth-words'. Should be set by a
forth source, using a local variables list at the end of the file
(\"Local Variables: ... forth-local-words: ... End:\" construct).")
(defvar forth-custom-words nil
"List of Forth words to prepend to `forth-words'. Should be set in your
.emacs.")
(defvar forth-hilight-level 3 "*Level of hilighting of Forth code.")
(defvar forth-compiled-words nil "Compiled representation of `forth-words'.")
(defvar forth-indent-words nil
"List of words that have indentation behaviour.
Each element of `forth-indent-words' should have the form
(MATCHER INDENT1 INDENT2 &optional TYPE)
MATCHER is either a list of strings to match, or a REGEXP.
If it's a REGEXP, it should not be surrounded by `\\<` or `\\>`, since
that'll be done automatically by the search routines.
TYPE might be omitted. If it's specified, the only allowed value is
currently the symbol `non-immediate', meaning that the word will not
have any effect on indentation inside definitions. (:NONAME is a good
example for this kind of word).
INDENT1 specifies how to indent a word that's located at the beginning
of a line, following any number of whitespaces.
INDENT2 specifies how to indent words that are not located at the
beginning of a line.
INDENT1 and INDENT2 are indentation specifications of the form
(SELF-INDENT . NEXT-INDENT), where SELF-INDENT is a numerical value,
specifying how the matching line and all following lines are to be
indented, relative to previous lines. NEXT-INDENT specifies how to indent
following lines, relative to the matching line.
Even values of SELF-INDENT and NEXT-INDENT correspond to multiples of
`forth-indent-level'. Odd values get an additional
`forth-minor-indent-level' added/substracted. Eg a value of -2 indents
1 * forth-indent-level to the left, wheras 3 indents
1 * forth-indent-level + forth-minor-indent-level columns to the right.")
(setq forth-indent-words
'((("if" "begin" "do" "?do" "+do" "-do" "u+do"
"u-do" "?dup-if" "?dup-0=-if" "case" "of" "?of" "try" "iferror"
"[if]" "[ifdef]" "[ifundef]" "[begin]" "[for]" "[do]" "[?do]" "[:")
(0 . 2) (0 . 2))
((":" ":noname" "code" "abi-code" "struct" "m:" ":m" "class"
"interface" "c-library" "c-library-name" "comp:" "post:"
"begin-structure" "event:")
(0 . 2) (0 . 2) non-immediate)
("\\S-+%$" (0 . 2) (0 . 0) non-immediate)
((";" ";m") (-2 . 0) (0 . -2))
(("again" "then" "endif" "endtry" "endcase" "next-case" "endof" "contof"
"[then]" "[endif]" "[loop]" "[+loop]" "[next]"
"[until]" "[again]" "loop" ";]" "nope")
(-2 . 0) (0 . -2))
(("end-code" "end-class" "end-interface" "end-class-noname"
"end-interface-noname" "end-struct" "class;" "end-c-library" "end-structure")
(-2 . 0) (0 . -2) non-immediate)
(("protected" "public" "how:") (-1 . 1) (0 . 0) non-immediate)
(("+loop" "-loop" "until") (-2 . 0) (-2 . 0))
(("else" "recover" "restore" "endtry-iferror" "[else]")
(-2 . 2) (0 . 0))
(("does>" "compile>" "int>" ";code" ";abi-code") (-1 . 1) (0 . 0))
(("while" "[while]") (-2 . 4) (0 . 2))
(("repeat" "[repeat]") (-4 . 0) (0 . -4))))
(defvar forth-local-indent-words nil
"List of Forth words to prepend to `forth-indent-words', when a forth-mode
buffer is created. Should be set by a Forth source, using a local variables
list at the end of the file (\"Local Variables: ... forth-local-words: ...
End:\" construct).")
(defvar forth-custom-indent-words nil
"List of Forth words to prepend to `forth-indent-words'. Should be set in
your .emacs.")
(defvar forth-indent-level 4
"*Indentation of Forth statements.")
(defvar forth-minor-indent-level 2
"*Minor indentation of Forth statements.")
(defvar forth-compiled-indent-words nil)
;(setq debug-on-error t)
;; Filter list by predicate. This is a somewhat standard function for
;; functional programming languages. So why isn't it already implemented
;; in Lisp??
(defun forth-filter (predicate list)
(let ((filtered nil))
(dolist (item list)
(when (funcall predicate item)
(if filtered
(nconc filtered (list item))
(setq filtered (cons item nil)))))
filtered))
;; Helper function for `forth-compile-word': return whether word has to be
;; added to the compiled word list, for syntactic parsing and hilighting.
(defun forth-words-filter (word)
(let* ((hilight (nth 2 word))
(level (cdr hilight))
(parsing-flag (nth 3 word)))
(or parsing-flag
(<= level forth-hilight-level))))
;; Helper function for `forth-compile-word': translate one entry from
;; `forth-words' into the form (regexp regexp-depth word-description)
(defun forth-compile-words-mapper (word)
;; warning: we cannot rely on regexp-opt's PAREN argument, since
;; XEmacs will use shy parens by default :-(
(let* ((matcher (car word))
(regexp
(concat "\\(" (cond ((stringp matcher) matcher)
((listp matcher) (regexp-opt matcher))
(t (error "Invalid matcher")))
"\\)"))
(depth (regexp-opt-depth regexp))
(description (cdr word)))
(list regexp depth description)))
;; Read `words' and create a compiled representation suitable for efficient
;; parsing of the form
;; (regexp (subexp-count word-description) (subexp-count2 word-description2)
;; ...)
(defun forth-compile-wordlist (words)
(let* ((mapped (mapcar 'forth-compile-words-mapper words))
(regexp (concat "\\<\\("
(mapconcat 'car mapped "\\|")
"\\)\\>"))
(sub-count 2)
(sub-list (mapcar
(lambda (i)
(let ((sub (cons sub-count (nth 2 i))))
(setq sub-count (+ sub-count (nth 1 i)))
sub
))
mapped)))
(cons regexp sub-list)))
(defun forth-compile-words ()
"Compile the the words from `forth-words' and `forth-indent-words' into
the format that's later used for doing the actual hilighting/indentation.
Store the resulting compiled wordlists in `forth-compiled-words' and
`forth-compiled-indent-words', respective"
(setq forth-compiled-words
(forth-compile-wordlist
(forth-filter 'forth-words-filter forth-words)))
(setq forth-compiled-indent-words
(forth-compile-wordlist forth-indent-words)))
(defun forth-hack-local-variables ()
"Parse and bind local variables, set in the contents of the current
forth-mode buffer. Prepend `forth-local-words' to `forth-words' and
`forth-local-indent-words' to `forth-indent-words'."
(put 'forth-local-indent-words 'safe-local-variable 'listp)
(put 'forth-local-words 'safe-local-variable 'listp)
(hack-local-variables)
(setq forth-words (append forth-local-words forth-words))
(setq forth-indent-words (append forth-local-indent-words
forth-indent-words)))
(defun forth-customize-words ()
"Add the words from `forth-custom-words' and `forth-custom-indent-words'
to `forth-words' and `forth-indent-words', respective. Add
`forth-objects-words' and/or `forth-oof-words' to `forth-words', if
`forth-use-objects' and/or `forth-use-oof', respective is set."
(setq forth-words (append forth-custom-words forth-words
(if forth-use-oof forth-oof-words nil)
(if forth-use-objects forth-objects-words nil)))
(setq forth-indent-words (append
forth-custom-indent-words forth-indent-words)))
;; get location of first character of previous forth word that's got
;; properties
(defun forth-previous-start (pos)
(let* ((word (get-text-property pos 'forth-word))
(prev (previous-single-property-change
(min (point-max) (1+ pos)) 'forth-word
(current-buffer) (point-min))))
(if (or (= (point-min) prev) word) prev
(if (get-text-property (1- prev) 'forth-word)
(previous-single-property-change
prev 'forth-word (current-buffer) (point-min))
(point-min)))))
;; Get location of the last character of the current/next forth word that's
;; got properties, text that's parsed by the word is considered as parts of
;; the word.
(defun forth-next-end (pos)
(let* ((word (get-text-property pos 'forth-word))
(next (next-single-property-change pos 'forth-word
(current-buffer) (point-max))))
(if word next
(if (get-text-property next 'forth-word)
(next-single-property-change
next 'forth-word (current-buffer) (point-max))
(point-max)))))
(defun forth-next-whitespace (pos)
(save-excursion
(goto-char pos)
(skip-syntax-forward "-" (point-max))
(point)))
(defun forth-previous-word (pos)
(save-excursion
(goto-char pos)
(re-search-backward "\\<" pos (point-min) 1)
(point)))
;; Delete all properties, used by Forth mode, from `from' to `to'.
(defun forth-delete-properties (from to)
(remove-text-properties
from to '(face nil fontified nil
forth-parsed nil forth-word nil forth-state nil)))
;; Get the index of the branch of the most recently evaluated regular
;; expression that matched. (used for identifying branches "a\\|b\\|c...")
(defun forth-get-regexp-branch ()
(let ((count 2))
(while (not (condition-case err (match-beginning count)
(args-out-of-range t))) ; XEmacs requires error handling
(setq count (1+ count)))
count))
;; seek to next forth-word and return its "word-description"
(defun forth-next-known-forth-word (to)
(if (<= (point) to)
(progn
(let* ((regexp (car forth-compiled-words))
(pos (re-search-forward regexp to t)))
(if pos (let ((branch (forth-get-regexp-branch))
(descr (cdr forth-compiled-words)))
(goto-char (match-beginning 0))
(cdr (assoc branch descr)))
'nil)))
nil))
;; Set properties of forth word at `point', eventually parsing subsequent
;; words, and parsing all whitespaces. Set point to delimiter after word.
;; The word, including it's parsed text gets the `forth-word' property, whose
;; value is unique, and may be used for getting the word's start/end
;; positions.
(defun forth-set-word-properties (state data)
(let* ((start (point))
(end (progn (re-search-forward "[ \t]\\|$" (point-max) 1)
(point)))
(type (car data))
(hilight (nth 1 data))
(bad-word (and (not state) (eq type 'compile-only)))
(hlface (if bad-word font-lock-warning-face
(if (<= (cdr hilight) forth-hilight-level)
(car hilight) nil))))
(when hlface (put-text-property start end 'face hlface))
;; if word parses in current state, process parsed range of text
(when (or (not state) (eq type 'compile-only) (eq type 'immediate))
(let ((parse-data (nthcdr 2 data)))
(while parse-data
(let ((delim (nth 0 parse-data))
(skip-leading (nth 1 parse-data))
(parse-type (nth 2 parse-data))
(parsed-hilight (nth 3 parse-data))
(parse-start (point))
(parse-end))
(when skip-leading
(while (and (looking-at delim) (> (match-end 0) (point))
(not (looking-at "\n")))
(forward-char)))
(re-search-forward delim (point-max) 1)
(setq parse-end (point))
(forth-delete-properties end parse-end)
(when (<= (cdr parsed-hilight) forth-hilight-level)
(put-text-property
parse-start parse-end 'face (car parsed-hilight)))
(put-text-property
parse-start parse-end 'forth-parsed parse-type)
(setq end parse-end)
(setq parse-data (nthcdr 4 parse-data))))))
(put-text-property start end 'forth-word start)))
;; Search for known Forth words in the range `from' to `to', using
;; `forth-next-known-forth-word' and set their properties via
;; `forth-set-word-properties'.
(defun forth-update-properties (from to &optional loudly)
(save-excursion
(let ((msg-count 0) (state) (word-descr) (last-location))
(goto-char (forth-previous-word (forth-previous-start
(max (point-min) (1- from)))))
(setq to (forth-next-end (min (point-max) (1+ to))))
;; `to' must be on a space delimiter, if a parsing word was changed
(setq to (forth-next-whitespace to))
(setq state (get-text-property (point) 'forth-state))
(setq last-location (point))
(forth-delete-properties (point) to)
(put-text-property (point) to 'fontified t)
;; hilight loop...
(while (setq word-descr (forth-next-known-forth-word to))
(when loudly
(when (equal 0 (% msg-count 100))
(message "Parsing Forth code...%s"
(make-string (/ msg-count 100) ?.)))
(setq msg-count (1+ msg-count)))
(forth-set-word-properties state word-descr)
(when state (put-text-property last-location (point) 'forth-state t))
(let ((type (car word-descr)))
(if (eq type 'definition-starter) (setq state t))
(if (eq type 'definition-ender) (setq state nil))
(setq last-location (point))))
;; update state property up to `to'
(if (and state (< (point) to))
(put-text-property last-location to 'forth-state t))
;; extend search if following state properties differ from current state
(if (< to (point-max))
(if (not (equal state (get-text-property (1+ to) 'forth-state)))
(let ((extend-to (next-single-property-change
to 'forth-state (current-buffer) (point-max))))
(forth-update-properties to extend-to))
))
)))
;; save-buffer-state borrowed from `font-lock.el'
(eval-when-compile
(defmacro forth-save-buffer-state (varlist &rest body)
"Bind variables according to VARLIST and eval BODY restoring buffer state."
`(let* (,@(append varlist
'((modified (buffer-modified-p)) (buffer-undo-list t)
(inhibit-read-only t) (inhibit-point-motion-hooks t)
before-change-functions after-change-functions
deactivate-mark buffer-file-name buffer-file-truename)))
,@body
(when (and (not modified) (buffer-modified-p))
(set-buffer-modified-p nil)))))
;; Function that is added to the `change-functions' hook. Calls
;; `forth-update-properties' and keeps care of disabling undo information
;; and stuff like that.
(defun forth-change-function (from to len &optional loudly)
(save-match-data
(forth-save-buffer-state
()
(unless forth-disable-parser (forth-update-properties from to loudly))
(forth-update-warn-long-lines))))
(defun forth-fontification-function (from)
"Function to be called from `fontification-functions' of Emacs 21."
(save-match-data
(forth-save-buffer-state
((to (min (point-max) (+ from 100))))
(unless (or forth-disable-parser (not forth-jit-parser)
(get-text-property from 'fontified))
(forth-update-properties from to)))))
(byte-compile 'forth-set-word-properties)
(byte-compile 'forth-next-known-forth-word)
(byte-compile 'forth-update-properties)
(byte-compile 'forth-delete-properties)
(byte-compile 'forth-get-regexp-branch)
;;; imenu support
;;;
(defvar forth-defining-words
'("VARIABLE" "CONSTANT" "2VARIABLE" "2CONSTANT" "FVARIABLE" "FCONSTANT"
"USER" "VALUE" "2Value" "field" "end-struct" "VOCABULARY" "CREATE" ":" "CODE"
"DEFER" "ALIAS" "interpret/compile:" "debug:" "field:" "2field:" "ffield:"
"sffield:" "dffield:" "uvar" "uvalue" "voctable")
"List of words, that define the following word.
Used for imenu index generation.")
(defvar forth-defining-words-regexp nil
"Regexp that's generated for matching `forth-defining-words'")
(defun forth-next-definition-starter ()
(progn
(let* ((pos (re-search-forward forth-defining-words-regexp (point-max) t)))
(if pos
(if (or (text-property-not-all (match-beginning 0) (match-end 0)
'forth-parsed nil)
(text-property-not-all (match-beginning 0) (match-end 0)
'forth-state nil))
(forth-next-definition-starter)
t)
nil))))
(defun forth-create-index ()
(let* ((forth-defining-words-regexp
(concat "\\<\\(" (regexp-opt forth-defining-words) "\\)\\>"))
(index nil))
(goto-char (point-min))
(while (forth-next-definition-starter)
(if (looking-at "[ \t]*\\([^ \t\n]+\\)")
(setq index (cons (cons (match-string 1) (point)) index))))
index))
;; top-level require is executed at byte-compile and load time
(eval-and-compile (forth-require 'speedbar))
;; this code is executed at load-time only
(when (memq 'speedbar features)
(speedbar-add-supported-extension ".fs")
(speedbar-add-supported-extension ".fb"))
;; (require 'profile)
;; (setq profile-functions-list '(forth-set-word-properties forth-next-known-forth-word forth-update-properties forth-delete-properties forth-get-regexp-branch))
;;; Indentation
;;;
;; Return, whether `pos' is the first forth word on its line
(defun forth-first-word-on-line-p (pos)
(save-excursion
(beginning-of-line)
(skip-chars-forward " \t")
(= pos (point))))
;; Return indentation data (SELF-INDENT . NEXT-INDENT) of next known
;; indentation word, or nil if there is no word up to `to'.
;; Position `point' at location just after found word, or at `to'. Parsed
;; ranges of text will not be taken into consideration!
(defun forth-next-known-indent-word (to)
(if (<= (point) to)
(progn
(let* ((regexp (car forth-compiled-indent-words))
(pos (re-search-forward regexp to t)))
(if pos
(let* ((start (match-beginning 0))
(end (match-end 0))
(branch (forth-get-regexp-branch))
(descr (cdr forth-compiled-indent-words))
(indent (cdr (assoc branch descr)))
(type (nth 2 indent)))
;; skip words that are parsed (strings/comments) and
;; non-immediate words inside definitions
(if (or (text-property-not-all start end 'forth-parsed nil)
(and (eq type 'non-immediate)
(text-property-not-all start end
'forth-state nil)))
(forth-next-known-indent-word to)
(if (forth-first-word-on-line-p (match-beginning 0))
(nth 0 indent) (nth 1 indent))))
nil)))
nil))
;; Translate indentation value `indent' to indentation column. Multiples of
;; 2 correspond to multiples of `forth-indent-level'. Odd numbers get an
;; additional `forth-minor-indent-level' added (or substracted).
(defun forth-convert-to-column (indent)
(let* ((sign (if (< indent 0) -1 1))
(value (abs indent))
(major (* (/ value 2) forth-indent-level))
(minor (* (% value 2) forth-minor-indent-level)))
(* sign (+ major minor))))
;; Return the column increment, that the current line of forth code does to
;; the current or following lines. `which' specifies which indentation values
;; to use. 1 means the indentation of following lines relative to current
;; line, 0 means the indentation of the current line relative to the previous
;; line. Return `nil', if there are no indentation words on the current line.
(defun forth-get-column-incr (which)
(save-excursion
(let ((regexp (car forth-compiled-indent-words))
(word-indent)
(self-indent nil)
(next-indent nil)
(to (save-excursion (end-of-line) (point))))
(beginning-of-line)
(while (setq word-indent (forth-next-known-indent-word to))
(let* ((self-incr (car word-indent))
(next-incr (cdr word-indent))
(self-column-incr (forth-convert-to-column self-incr))
(next-column-incr (forth-convert-to-column next-incr)))
(setq next-indent (if next-indent next-indent 0))
(setq self-indent (if self-indent self-indent 0))
(if (or (and (> next-indent 0) (< self-column-incr 0))
(and (< next-indent 0) (> self-column-incr 0)))
(setq next-indent (+ next-indent self-column-incr))
(setq self-indent (+ self-indent self-column-incr)))
(setq next-indent (+ next-indent next-column-incr))))
(nth which (list self-indent next-indent)))))
;; Find previous line that contains indentation words, return the column,
;; to which following text should be indented to.
(defun forth-get-anchor-column ()
(save-excursion
(if (/= 0 (forward-line -1)) 0
(let ((indent))
(while (not (or (setq indent (forth-get-column-incr 1))
(<= (point) (point-min))))
(forward-line -1))
(+ (current-indentation) (if indent indent 0))))))
(defun forth-indent-line (&optional flag)
"Correct indentation of the current Forth line."
(let* ((anchor (forth-get-anchor-column))
(column-incr (forth-get-column-incr 0)))
(forth-indent-to (if column-incr (+ anchor column-incr) anchor))))
(defun forth-current-column ()
(- (point) (save-excursion (beginning-of-line) (point))))
(defun forth-current-indentation ()
(- (save-excursion (beginning-of-line) (forward-to-indentation 0) (point))
(save-excursion (beginning-of-line) (point))))
(defun forth-indent-to (x)
(let ((p nil))
(setq p (- (forth-current-column) (forth-current-indentation)))
(forth-delete-indentation)
(beginning-of-line)
(indent-to x)
(if (> p 0) (forward-char p))))
(defun forth-delete-indentation ()
(save-excursion
(delete-region
(progn (beginning-of-line) (point))
(progn (back-to-indentation) (point)))))
(defun forth-indent-command ()
(interactive)
(forth-indent-line t))
;; remove trailing whitespaces in current line
(defun forth-remove-trailing ()
(save-excursion
(end-of-line)
(delete-region (point) (progn (skip-chars-backward " \t") (point)))))
;; insert newline, removing any trailing whitespaces in the current line
(defun forth-newline-remove-trailing ()
(save-excursion
(delete-region (point) (progn (skip-chars-backward " \t") (point))))
(newline))
; (let ((was-point (point-marker)))
; (unwind-protect
; (progn (forward-line -1) (forth-remove-trailing))
; (goto-char (was-point)))))
;; workaround for bug in `reindent-then-newline-and-indent'
(defun forth-reindent-then-newline-and-indent ()
(interactive "*")
(indent-according-to-mode)
(forth-newline-remove-trailing)
(indent-according-to-mode))
;;; Block file encoding/decoding (dk)
;;;
(defconst forth-c/l 64 "Number of characters per block line")
(defconst forth-l/b 16 "Number of lines per block")
;; Check whether the unconverted block file line, point is in, does not
;; contain `\n' and `\t' characters.
(defun forth-check-block-line (line)
(let ((end (save-excursion (beginning-of-line) (forward-char forth-c/l)
(point))))
(save-excursion
(beginning-of-line)
(when (search-forward "\n" end t)
(message "Warning: line %i contains newline character #10" line)
(ding t))
(beginning-of-line)
(when (search-forward "\t" end t)
(message "Warning: line %i contains tab character #8" line)
(ding t)))))
(defun forth-convert-from-block (from to)
"Convert block file format to stream source in current buffer."
(let ((line (count-lines (point-min) from)))
(save-excursion
(goto-char from)
(set-mark to)
(while (< (+ (point) forth-c/l) (mark t))
(setq line (1+ line))
(forth-check-block-line line)
(forward-char forth-c/l)
(forth-newline-remove-trailing))
(when (= (+ (point) forth-c/l) (mark t))