[gforth] / gforth / contrib / terminal.fs  

gforth: gforth/contrib/terminal.fs

1 : anton 1.1 \ terminal.fs
2 :     \
3 :     \ Simple terminal emulator for gforth (ported from kForth)
4 :     \
5 :     \ Written by David P. Wallace and Krishna Myneni
6 :     \ Provided under the terms of the GNU General Public License
7 :     \
8 :     \ Requires:
9 :     \
10 :     \ strings.fs
11 :     \ ansi.fs
12 :     \ syscalls386.fs
13 :     \ serial.fs
14 :     \
15 :     \ Revisions:
16 :     \ 2004-03-13 Avoid response lag to input due to key? in terminal;
17 :     \ added Send File function KM
18 :     \ 2004-09-17 Ported to gforth from kForth; use WRITE-FILE instead
19 :     \ of "write" to store data in capture file KM
20 : anton 1.2 \ 2005-09-28 Fixed problem associated with read-line KM
21 :     \
22 : anton 1.1 include strings.fs
23 :     include ansi.fs
24 :     include syscalls386.fs
25 :     include serial.fs
26 :    
27 :     \ ============= defs from kForth files.4th
28 :     base @
29 :     hex
30 :     A constant EOL
31 :     40 constant O_CREAT
32 :     80 constant O_EXCL
33 :     200 constant O_TRUNC
34 :     400 constant O_APPEND
35 :     0 constant SEEK_SET
36 :     1 constant SEEK_CUR
37 :     2 constant SEEK_END
38 :     base !
39 :     create EOL_BUF 4 allot
40 :     EOL EOL_BUF c!
41 :     0 EOL_BUF 1+ c!
42 :    
43 :     : file-exists ( ^filename -- flag | return true if file exists )
44 :     count R/O open-file
45 :     if drop false else close-file drop true then ;
46 :     \ =============
47 :    
48 :     : ms@ ( -- u ) utime 1 1000 m*/ d>s ;
49 :    
50 :    
51 :     : >UPC 95 AND ;
52 :     : EKEY ( -- u | return extended key as concatenated byte sequence )
53 :     BEGIN key? UNTIL
54 :     0 BEGIN key? WHILE 8 LSHIFT key or REPEAT ;
55 :    
56 :    
57 :     variable com
58 :     create buf 64 allot
59 :    
60 :     \ examples of using terminal:
61 :     \
62 :     \ COM2 B9600 c" 8N1" terminal ( terminal on com2 at 9600 baud, 8N1 )
63 :     \ COM1 B57600 c" E71" terminal ( terminal on com1 at 57.6 Kbaud, 7E1 )
64 :    
65 :     HEX
66 :     0D CONSTANT <CR>
67 :     1B CONSTANT ESC
68 :     1B4F50 CONSTANT F1
69 :     1B4F51 CONSTANT F2
70 :     1B4F52 CONSTANT F3
71 :     DECIMAL
72 :    
73 :     0 CONSTANT HELP_ROW
74 :     BLUE CONSTANT HELP_EKEY_COLOR
75 :     BLACK CONSTANT HELP_TEXT_COLOR
76 :     WHITE CONSTANT HELP_BACK_COLOR
77 :     BLACK CONSTANT TERM_BACK_COLOR
78 :     WHITE CONSTANT TERM_TEXT_COLOR
79 :    
80 :     : clear-line ( row background -- ) background dup 0 SWAP AT-XY
81 :     80 spaces 0 SWAP AT-XY ;
82 :    
83 :     : set-terminal-colors ( -- )
84 :     TERM_TEXT_COLOR foreground
85 :     TERM_BACK_COLOR background ;
86 :    
87 :     : terminal-help ( -- | show the help line )
88 :     save_cursor
89 :     HELP_ROW HELP_BACK_COLOR clear-line
90 :     HELP_EKEY_COLOR foreground ." Esc "
91 :     HELP_TEXT_COLOR foreground ." Exit "
92 :     HELP_EKEY_COLOR foreground ." F1 "
93 :     HELP_TEXT_COLOR foreground ." Show Key Help "
94 :     HELP_EKEY_COLOR foreground ." F2 "
95 :     HELP_TEXT_COLOR foreground ." Capture On/Off "
96 :     HELP_EKEY_COLOR foreground ." F3 "
97 :     HELP_TEXT_COLOR foreground ." Send Text File "
98 :     restore_cursor
99 :     ;
100 :    
101 :    
102 :     variable fid
103 :     FALSE VALUE ?capture
104 :     create filename 256 allot
105 :     create capture-filename 256 allot
106 :    
107 :     : close-capture-file ( -- ) fid @ close drop FALSE to ?capture ;
108 :    
109 :     : capture-file ( -- )
110 :     ?capture IF close-capture-file
111 :     HELP_ROW HELP_BACK_COLOR clear-line
112 :     HELP_TEXT_COLOR foreground
113 :     ." Capture file closed!"
114 :     ELSE
115 :     HELP_ROW HELP_BACK_COLOR clear-line
116 :     HELP_TEXT_COLOR foreground
117 :     ." Capture to file named: "
118 :     filename 254 accept
119 :     filename swap strpck capture-filename strcpy
120 :     capture-filename file-exists IF
121 :     HELP_ROW HELP_BACK_COLOR clear-line
122 :     ." File " capture-filename count type
123 :     ." already exists! Overwrite (Y/N)? "
124 :     key >upc [char] Y = IF
125 :     capture-filename count W/O O_TRUNC or open-file
126 :     0= IF fid ! TRUE to ?capture
127 :     ELSE HELP_ROW HELP_BACK_COLOR clear-line
128 :     ." Unable to open output file!"
129 :     EXIT
130 :     THEN
131 :     ELSE
132 :     HELP_ROW HELP_BACK_COLOR clear-line
133 :     ." Capture cancelled!" EXIT
134 :     THEN
135 :     ELSE
136 :     capture-filename count W/O create-file
137 :     0= IF fid ! TRUE to ?capture
138 :     ELSE HELP_ROW HELP_BACK_COLOR clear-line
139 :     ." Unable to open output file!"
140 :     EXIT
141 :     THEN
142 :     THEN
143 :     THEN ;
144 :    
145 :    
146 :     create send-filename 256 allot
147 :     create send-line-buffer 256 allot
148 :     variable txfid
149 :     variable last-send-time
150 :     10 VALUE LINE-DELAY \ delay in ms between sending each line of text
151 :     1 VALUE CHAR-DELAY \ to send data to *slow* terminals
152 :     FALSE VALUE ?sending
153 :    
154 :     : send-file ( -- )
155 :     HELP_ROW HELP_BACK_COLOR clear-line
156 :     HELP_TEXT_COLOR foreground
157 :     ." Text File to Send: "
158 :     filename 254 accept
159 :     filename swap strpck send-filename strcpy
160 :     send-filename file-exists 0= IF
161 :     HELP_ROW HELP_BACK_COLOR clear-line
162 :     ." Input file does not exist!"
163 :     EXIT
164 :     THEN
165 :     send-filename count R/O open-file 0= IF
166 :     txfid !
167 :     HELP_ROW HELP_BACK_COLOR clear-line
168 :     ." Sending file " send-filename count type ." ..."
169 :     TRUE to ?sending
170 :     ELSE
171 :     HELP_ROW HELP_BACK_COLOR clear-line
172 :     ." Unable to open input file!"
173 :     EXIT
174 :     THEN
175 :     ms@ last-send-time ! ;
176 :    
177 :    
178 :     : terminal-status? ( -- flag | TRUE equals ok to exit terminal )
179 :     ?sending IF
180 :     HELP_ROW HELP_BACK_COLOR clear-line
181 :     HELP_TEXT_COLOR foreground
182 :     ." File Send in Progress! Halt Sending and Exit (Y/N)? "
183 :     KEY >UPC [CHAR] Y = IF
184 :     txfid @ close-file drop
185 :     FALSE TO ?sending
186 :     ELSE
187 :     0 EXIT
188 :     THEN
189 :     THEN
190 :     ?capture IF close-capture-file THEN
191 :     TRUE ;
192 :    
193 :     : terminal ( port baud ^str_param -- | terminal emulator )
194 :     TERM_BACK_COLOR background
195 :     page
196 :     terminal-help
197 :     set-terminal-colors
198 :     0 HELP_ROW 1+ AT-XY
199 :    
200 :     rot
201 :     serial_open com !
202 :     com @ swap serial_setparams
203 :     com @ swap serial_setbaud
204 :    
205 :     BEGIN
206 :    
207 :     ?sending ms@ last-send-time @ - LINE-DELAY >= AND IF
208 :     ms@ last-send-time !
209 : anton 1.2 send-line-buffer 256 txfid @ read-line IF
210 :     \ error reading file
211 :     2drop txfid @ close-file drop FALSE to ?sending
212 : anton 1.1 save_cursor
213 :     HELP_ROW HELP_BACK_COLOR clear-line
214 :     HELP_TEXT_COLOR foreground
215 : anton 1.2 ." Error reading file!"
216 :     restore_cursor set-terminal-colors
217 :     ELSE
218 :     FALSE = IF
219 :     \ reached EOF
220 :     drop txfid @ close-file drop
221 :     FALSE to ?sending
222 :     save_cursor
223 :     HELP_ROW HELP_BACK_COLOR clear-line
224 :     HELP_TEXT_COLOR foreground
225 :     ." <<Terminal: Send Completed!>>"
226 :     restore_cursor set-terminal-colors
227 :     ELSE
228 :     com @ swap send-line-buffer swap serial_write drop
229 :     THEN
230 : anton 1.1 THEN
231 :     THEN
232 :    
233 :     BEGIN
234 :     com @ serial_lenrx
235 :     WHILE
236 :     com @ buf 1 serial_read drop
237 :     buf c@ dup <CR> = IF CR ELSE emit THEN
238 :     ?capture IF
239 :     buf c@ <CR> = IF EOL_BUF dup strlen ELSE buf 1 THEN
240 :     fid @ write-file drop
241 :     THEN
242 :     REPEAT
243 :    
244 :     key?
245 :    
246 :     IF
247 :     EKEY CASE
248 :     ESC OF terminal-status? IF
249 :     com @ serial_close drop
250 :     text_normal \ restore normal colors and attributes
251 :     PAGE EXIT \ clear the screen and exit
252 :     THEN ENDOF
253 :     F1 OF terminal-help set-terminal-colors ENDOF
254 :     F2 OF save_cursor capture-file restore_cursor
255 :     set-terminal-colors ENDOF
256 :     F3 OF save_cursor send-file restore_cursor
257 :     set-terminal-colors ENDOF
258 :     dup dup emit buf c! com @ buf 1 serial_write drop
259 :     ENDCASE
260 :     THEN
261 :     AGAIN ;
262 :    
263 :     : term ( -- | start the default terminal )
264 :     COM1 B9600 c" 8N1" terminal ( terminal on com1 at 9600 baud, 8N1 )
265 :     ;
266 :    
267 :     CR CR
268 :     .( Type 'term' to start a 9600 baud terminal on COM1 configured with 8N1.)
269 :     CR CR
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help