1: \ Terminal for R8C
2:
3: \ Copyright (C) 2006,2007,2008 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation, either version 3
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program. If not, see http://www.gnu.org/licenses/.
19:
20: require lib.fs
21:
22: s" os-type" environment? [IF]
23: 2dup 2dup s" linux-gnu" str= -rot s" darwin" string-prefix? or [IF] 2drop
24: [IFUNDEF] libc library libc libc.so.6 [THEN]
25:
26: libc tcgetattr int ptr (int) tcgetattr ( fd termios -- r )
27: libc tcsetattr int int ptr (int) tcsetattr ( fd opt termios -- r )
28: libc tcflow int int (int) tcflow ( fd action -- r )
29: libc ioctl<p> int int ptr (int) ioctl ( d request ptr -- r )
30: libc fileno ptr (int) fileno ( file* -- fd )
31:
32: s" os-type" environment? [IF] s" linux-gnu" str= [IF]
33: 4 4 2Constant int%
34: $20 Constant NCCS
35: [ELSE]
36: cell dup 2Constant int%
37: 20 Constant NCCS
38: [THEN]
39:
40: struct
41: int% field c_iflag
42: int% field c_oflag
43: int% field c_cflag
44: int% field c_lflag
45: char% NCCS * field c_line
46: int% field c_ispeed
47: int% field c_ospeed
48: end-struct termios
49:
50: Create t_old termios %allot drop
51: Create t_buf termios %allot drop
52:
53: s" os-type" environment? [IF] s" linux-gnu" str= [IF]
54: base @ 8 base !
55: 0000001 Constant B50
56: 0000002 Constant B75
57: 0000003 Constant B110
58: 0000004 Constant B134
59: 0000005 Constant B150
60: 0000006 Constant B200
61: 0000007 Constant B300
62: 0000010 Constant B600
63: 0000011 Constant B1200
64: 0000012 Constant B1800
65: 0000013 Constant B2400
66: 0000014 Constant B4800
67: 0000015 Constant B9600
68: 0000016 Constant B19200
69: 0000017 Constant B38400
70: 000000010001 Constant B57600
71: 000000010002 Constant B115200
72: 020000000000 Constant CRTSCTS
73: 000000000060 Constant CS8
74: 000000000200 Constant CREAD
75: 000000004000 Constant CLOCAL
76: 000000010017 Constant CBAUD
77: 000000000001 Constant IGNBRK
78: 000000000004 Constant IGNPAR
79: base !
80:
81: 6 Constant VTIME
82: 7 Constant VMIN
83:
84: $541B Constant FIONREAD
85:
86: : set-baud ( baud fd -- ) >r
87: r@ t_old tcgetattr drop
88: t_old t_buf termios %size move
89: [ IGNBRK IGNPAR or ] Literal t_buf c_iflag l!
90: 0 t_buf c_oflag l!
91: [ CS8 CREAD or CLOCAL or ] Literal or
92: t_buf c_cflag l!
93: 0 t_buf c_lflag l!
94: 1 t_buf c_line VMIN + c!
95: 0 t_buf c_line VTIME + c!
96: 28800 t_buf c_cflag @ $F and lshift
97: dup t_buf c_ispeed l! t_buf c_ospeed l!
98: r> 1 t_buf tcsetattr drop ;
99: [ELSE]
100: 0 Constant B0
101: 50 Constant B50
102: 75 Constant B75
103: 110 Constant B110
104: 134 Constant B134
105: 150 Constant B150
106: 200 Constant B200
107: 300 Constant B300
108: 600 Constant B600
109: 1200 Constant B1200
110: 1800 Constant B1800
111: 2400 Constant B2400
112: 4800 Constant B4800
113: 9600 Constant B9600
114: 19200 Constant B19200
115: 38400 Constant B38400
116: 57600 Constant B57600
117: 115200 Constant B115200
118: $00060000 Constant CRTSCTS
119: $300 Constant CS8
120: $800 Constant CREAD
121: $8000 Constant CLOCAL
122: 0 Constant CBAUD
123: 1 Constant IGNBRK
124: 4 Constant IGNPAR
125:
126: 17 Constant VTIME
127: 16 Constant VMIN
128:
129: $4004667F Constant FIONREAD
130:
131: : set-baud ( baud fd -- ) >r
132: r@ t_old tcgetattr drop
133: t_old t_buf termios %size move
134: [ IGNBRK IGNPAR or ] Literal t_buf c_iflag l!
135: 0 t_buf c_oflag l!
136: [ CS8 CREAD or CLOCAL or ] Literal
137: t_buf c_cflag l!
138: 0 t_buf c_lflag l!
139: 1 t_buf c_line VMIN + c!
140: 0 t_buf c_line VTIME + c!
141: dup t_buf c_ispeed l! t_buf c_ospeed l!
142: r> 1 t_buf tcsetattr drop ;
143: [THEN]
144: [THEN]
145:
146: : reset-baud ( fd -- )
147: 1 t_old tcsetattr drop ;
148:
149: : check-read ( fd -- n ) >r
150: 0 sp@ r> FIONREAD rot ioctl<p> drop ;
151:
152: 0 Value term
153: 0 Value term-fd
154: : open-port ( addr u -- )
155: r/w open-file throw dup to term fileno to term-fd ;
156: : term-read ( -- addr u )
157: pad term-fd check-read term read-file throw pad swap ;
158: : term-emit ( char -- )
159: term emit-file throw ;
160: : (term-type) ( addr u -- )
161: term write-file throw ;
162: : term-flush ( -- )
163: term flush-file throw ;
164: [ELSE] s" cygwin" str= [IF]
165: \ Cygwin terminal adoption
166: library kernel32 kernel32
167:
168: kernel32 GetCommState int ptr (int) GetCommState ( handle addr -- r )
169: kernel32 SetCommState int ptr (int) SetCommState ( handle addr -- r )
170: kernel32 CreateFile ptr int int ptr int int ptr (int) CreateFileA ( name access share security disp attr temp -- handle )
171: kernel32 WriteFile int ptr int ptr ptr (int) WriteFile ( handle data size &len &data -- flag )
172: kernel32 ReadFile int ptr int ptr ptr (int) ReadFile ( handle data size &len &data -- flag )
173: kernel32 SetCommTimeouts int ptr (int) SetCommTimeouts ( handle addr -- flag )
174: kernel32 GetCommTimeouts int ptr (int) GetCommTimeouts ( handle addr -- flag )
175:
176: $80000000 Constant GENERIC_READ
177: $40000000 Constant GENERIC_WRITE
178: 3 Constant OPEN_EXISTING
179:
180: 50 Constant B50
181: 75 Constant B75
182: 110 Constant B110
183: 134 Constant B134
184: 150 Constant B150
185: 200 Constant B200
186: 300 Constant B300
187: 600 Constant B600
188: 1200 Constant B1200
189: 1800 Constant B1800
190: 2400 Constant B2400
191: 4800 Constant B4800
192: 9600 Constant B9600
193: 19200 Constant B19200
194: 38400 Constant B38400
195:
196: 4 4 2Constant int%
197: 2 2 2Constant word%
198:
199: struct
200: int% field DCBlength
201: int% field BaudRate
202: int% field flags
203: word% field wReserved
204: word% field XonLim
205: word% field XoffLim
206: char% field ByteSize
207: char% field Parity
208: char% field StopBits
209: char% field XonChar
210: char% field XoffChar
211: char% field ErrorChar
212: char% field EofChar
213: char% field EvtChar
214: word% field wReserved1
215: end-struct DCB
216: struct
217: int% field ReadIntervalTimeout
218: int% field ReadTotalTimeoutMultiplier
219: int% field ReadTotalTimeoutConstant
220: int% field WriteTotalTimeoutMultiplier
221: int% field WriteTotalTimeoutConstant
222: end-struct COMMTIMEOUTS
223:
224: Create t_old DCB %allot drop
225: Create t_buf DCB %allot drop
226: Create tout_buf COMMTIMEOUTS %allot drop
227:
228: 0 Value term-fd
229: 0 Value term
230: : open-port ( addr u -- )
231: tuck pad swap move 0 swap pad + c!
232: pad GENERIC_READ GENERIC_WRITE or 0 0 OPEN_EXISTING 0 0 CreateFile
233: to term-fd ;
234: : set-baud ( baud fd -- ) >r
235: r@ t_old GetCommState drop
236: 1 t_old flags !
237: r@ tout_buf GetCommTimeouts drop
238: 3 tout_buf ReadIntervalTimeout !
239: 3 tout_buf ReadTotalTimeoutMultiplier !
240: 2 tout_buf ReadTotalTimeoutConstant !
241: 3 tout_buf WriteTotalTimeoutMultiplier !
242: 2 tout_buf WriteTotalTimeoutConstant !
243: r@ tout_buf SetCommTimeouts drop
244: t_old t_buf DCB %size move
245: t_buf BaudRate !
246: 8 t_buf ByteSize c!
247: r> t_buf SetCommState drop ;
248: : reset-baud ( fd -- )
249: t_old SetCommState drop ;
250: Create emit-buf 0 c,
251: Variable term-len
252: : term-read ( -- addr u )
253: term-fd pad &64 term-len 0 ReadFile drop
254: pad term-len @ ;
255: : (term-type) ( addr u -- )
256: term-fd -rot term-len 0 WriteFile drop ;
257: : term-emit ( char -- )
258: emit-buf c! emit-buf 1 (term-type) ;
259: : term-flush ( -- ) ;
260: [THEN]
261: [THEN]
262:
263: Create file-buf $40 allot
264: Variable file-len
265: Variable term-stack $10 cells allot
266:
267: : 'term ( -- addr ) term-stack @ cells term-stack + ;
268: : termfile ( -- file ) 'term @ ;
269: : >term ( o -- ) 1 term-stack +! 'term ! ;
270: : term> ( -- ) -1 term-stack +! ;
271: Variable term-state
272: Variable progress-state
273:
274: : term-end ( -- )
275: 4 term-emit
276: #cr term-emit
277: term-flush ;
278: : open-include ( -- )
279: file-buf file-len @ r/o open-file
280: IF ." File '" file-buf file-len @ type ." ' not found" term-end drop
281: ELSE >term THEN ;
282: : end-include ( -- ) termfile 0= IF EXIT THEN
283: termfile close-file throw term> ;
284:
285: Create progress s" /-\|" here over allot swap move
286:
287: : term-type ( addr u -- )
288: bounds ?DO
289: I c@ CASE
290: 2 OF 1 term-state ! ENDOF
291: 3 OF
292: BEGIN
293: termfile IF
294: file-buf $40 termfile read-line throw
295: progress progress-state @ + c@ emit #bs emit
296: progress-state @ 1+ 3 and progress-state !
297: ELSE
298: 0 0
299: THEN
300: 0= termfile and WHILE
301: drop end-include
302: REPEAT
303: term-stack @ 0= IF
304: drop term-end
305: ELSE
306: file-buf swap (term-type)
307: #cr term-emit
308: THEN
309: term-flush
310: ENDOF
311: 4 OF end-include ENDOF
312: 5 OF abort ENDOF
313: term-state @ CASE
314: 0 OF emit ENDOF
315: 1 OF $20 - $3F min file-len ! 2 term-state ! ENDOF
316: 2 - file-buf + c! 1 term-state +!
317: term-state @ file-len @ 2 + = IF
318: open-include term-state off THEN
319: 0 ENDCASE
320: 0 ENDCASE
321: LOOP ;
322:
323: : term-loop ( -- )
324: BEGIN
325: term-read term-type
326: key? IF key term-emit term-flush
327: ELSE &10 ms THEN
328: AGAIN ;
329: : say-hallo
330: ." Gforth terminal"
331: cr ." Press ENTER to get ok from connected device."
332: cr ." Leave with BYE"
333: cr ;
334: : terminal ( "name" -- )
335: parse-name open-port
336: B38400 term-fd set-baud say-hallo ['] term-loop catch
337: dup -1 = IF drop cr EXIT THEN throw ;
338:
339: s" os-type" environment? [IF]
340: 2dup s" linux-gnu" str= [IF] 2drop
341: script? [IF] terminal /dev/ttyUSB0 bye [THEN]
342: [ELSE] 2dup s" cygwin" str= [IF]
343: script? [IF] terminal COM2 bye [THEN]
344: [ELSE] s" darwin" string-prefix? [IF]
345: script? [IF] terminal /dev/cu.PL2303-0000101D bye [THEN]
346: [THEN] [THEN]
347: [THEN]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to terminal.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / arch / r8c