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