/
facility.mf
257 lines (184 loc) · 7.45 KB
/
facility.mf
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
( ============================================================================
FACILITY.MF - the FACILITY wordset for MinForth
============================================================================
The following standard words are defined in the kernel:
KEY? EKEY EKEY>CHAR EKEY? EMIT?
Note:
This file includes terminal control words that can be used with ANSI-
compatible terminals. In order to allow other terminals to work with
MinForth, terminal control words defined in EXTEND.MF are defered words.
Different keyboard and screen control configurations should be adaptable
by "simple" modifications in this file.
When you prefer running Linux with XWindow then you should start MinForth
in an xterm as in:
~> xterm -bg black -fg white +cm
~> mf
)
\ Copyright (C) 2002 Andreas Kochenburger (kochenburger@gmx.de)
\
\ This program is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
\ ------ Time Functions ------------------------------------------------------
PRIMITIVE _timedate TIME&DATE \ ( -- sec min hour day month year )
PRIMITIVE _msecs MSECS \ ( -- msecs-since-start )
PRIMITIVE _ticker TICKER \ ( msecs-until-task -- )
BEGIN-PRIVATE
0 VALUE (TIC) 0 VALUE (TOC)
END-PRIVATE
: MS \ ( u -- ) wait u milliseconds
msecs + begin dup msecs u< until drop ;
: TIC \ ( -- ) remember start time
msecs to (tic) ;
: TOC \ ( -- ) remember stop time
msecs to (toc) ;
: .ELAPSED
(toc) (tic) - 1000 /mod 0 u.r [char] . emit
s>d <# # # #> type space [char] s emit ;
MAKE-PRIVATE
\ ------ Operating System Facilities -----------------------------------------
: SH" \ ( string" - ) issue a command to the operating system
[char] " parse state @
if postpone sliteral postpone os-command postpone drop
else s>buf sbuf @ count os-command drop then ; IMMEDIATE
OS-TYPE 2 <= [IF]
: FILES \ show all files in the current directory
cr sh" dir /w" ; \ for DOS, Win32
[ELSE]
: FILES \ show all files in the current directory
cr sh" ls -C -a" ; \ for Linux, Minix
[THEN]
\ ------ Dumb Terminal Control -----------------------------------------------
VARIABLE TERMINAL
DEFER NORMAL \ ( -- ) set standard terminal colours
DEFER PAGE \ ( -- ) clear terminal screen
DEFER AT-XY \ ( col-x row-y -- ) locate cursor
DEFER STORE-XY \ ( -- ) remember current cursor position
DEFER RESTORE-XY \ ( -- ) set cursor to last remembered position
DEFER Y-UP \ ( -- ) cursor up
DEFER Y-DOWN \ ( -- ) cursor down
DEFER X-LEFT \ ( -- ) cursor left
DEFER X-RIGHT \ ( -- ) cursor right
' 2DROP IS AT-XY
' NOOP DUP IS NORMAL
DUP IS PAGE
DUP IS STORE-XY
DUP IS RESTORE-XY
DUP IS Y-UP
DUP IS Y-DOWN
DUP IS X-LEFT
IS X-RIGHT
0 VALUE BLACK 7 VALUE WHITE
1 VALUE RED 2 VALUE GREEN 3 VALUE BROWN
4 VALUE BLUE 5 VALUE MAGENTA 6 VALUE CYAN
: BRIGHT \ ( colour -- bright-colour )
8 or ;
DEFER LETTERS \ ( c -- ) set letters colour
DEFER BACKGROUND \ ( c -- ) set backgound colour
' DROP DUP IS LETTERS
IS BACKGROUND
\ ------ MinForth Command-line Editing ---------------------------------------
BEGIN-PRIVATE
: (DEL-IN) \ ( a am c k -- do. ) delete char under cursor
>r store-xy
dup char+ over span @ pluck 6 pick - - pluck over type space move span decr
restore-xy r> ;
: BS-IN \ ( a am c k -- do. ) backspace
over 4 pick = if exit then \ buffer empty
swap backspace char- swap (del-in) ;
: DEL-IN \ ( a am c k -- do. ) delete
over 4 pick span @ + = if bs-in exit then \ cursor at buffer end
(del-in) ;
: INS-IN \ ( a am c k -- do. ) insert
pluck 4 pick span @ + = if exit then \ buffer full
>r dup 3 pick - span @ swap -
over dup char+ pluck move bl pluck c! span incr
store-xy over swap 1+ type restore-xy r> ;
: LEFT-IN \ ( a am c k -- do. ) cursor left
>r pluck over < if char- x-left then r> ;
: RIGHT-IN \ ( a am c k -- do. ) cursor right
>r dup 3 pick - span @ < if char+ x-right then r> ;
: HOME-IN \ ( a am c k -- do. ) cursor to begin
>r pluck - begin dup while 1- x-left repeat drop over r> ;
: END-IN \ ( a am c k -- do. ) cursor to end
>r pluck span @ + dup rot - begin dup while 1- x-right repeat drop r> ;
: ESC-IN \ ( a am c k -- do. ) escape empties
home-in >r store-xy span @ spaces restore-xy drop over span off r> ;
B/IB 2* VALUE #HISTIB \ history buffer size
CREATE HISTIB #HISTIB ALLOT \ history buffer for input lines
HISTIB #HISTIB ERASE \ lines are stored in ct+line+0 format
1 VALUE HISTLN \ offset to selected line
: HISTLINE \ ( -- adr ) address of actual line in history buffer
histib histln + ;
: GET-HISTLN \ ( a am c k -- do. ) copy line from history buffer
home-in store-xy >r drop
histline count pluck 4 pick - min
span @ spaces restore-xy 2dup type
tuck 4 pick swap move dup span ! pluck + r> ;
: UP-HIST \ cursor up: get last lines from history buffer
histline c@ 0= if exit then
get-histln histline dup c@ 2+ + dup c@ \ get successor
if histib - else drop 1 then to histln ;
: DOWN-HIST \ cursor down: get oldest lines from history buffer
histline c@ 0= if exit then
get-histln histln 1 =
if histib #histib 1- 0 -1 trim + else histline char- then
begin char- dup c@ 0= until \ get predecessor
char+ histib - to histln ;
: STORE-HIST \ ( a am c k -- do. ) store actual input in history buffer
span @ 0= if exit then \ empty line
span @ 2+ histib char+ 2dup + rot #histib swap - 2 - move
3 pick span @ histib char+ splace
histib #histib + char-
begin char- dup c@ while 0 over c! repeat drop
1 to histln ;
:NONAME \ ( a amax cur key -- do. ) handle control characters
terminal @ 0= if defered ctrl-in exit then
dup case
13 of store-hist end-in endof
bs of bs-in endof
27 of esc-in endof
328 of up-hist endof
336 of down-hist endof
331 of left-in endof
333 of right-in endof
327 of home-in endof
335 of end-in endof
338 of ins-in endof
339 of del-in endof
endcase ;
IS CTRL-IN \ extend ACCEPT/EXPECT
END-PRIVATE MAKE-PRIVATE
\ ------ Terminal Selection --------------------------------------------------
OS-TYPE 1 = [IF] \ DOS
REQUIRES ansiterm.mf
REQUIRES doskey.mf
[THEN]
OS-TYPE 2 = [IF] \ Windows
REQUIRES winterm.mf
REQUIRES doskey.mf
[THEN]
OS-TYPE 3 = [IF] \ Linux
REQUIRES ansiterm.mf
REQUIRES linuxkey.mf
[THEN]
OS-TYPE 4 = [IF] \ Minix
REQUIRES ansiterm.mf
REQUIRES linuxkey.mf
[THEN]
\ ------ Updating Environment ------------------------------------------------
:NONAME
s" FACILITY" true ?env
s" FACILITY-EXT" true ?env
defered env? ;
IS ENV?