Annotation of gforth/arch/r8c/terminal.fs, revision 1.4
1.1 pazsan 1: \ Terminal for R8C
2:
3: require lib.fs
4:
1.3 pazsan 5: s" os-type" environment? [IF]
6: 2dup s" linux-gnu" str= [IF] 2drop
7: [IFUNDEF] libc library libc libc.so.6 [THEN]
8:
9: libc tcgetattr int ptr (int) tcgetattr ( fd termios -- r )
10: libc tcsetattr int int ptr (int) tcsetattr ( fd opt termios -- r )
11: libc tcflow int int (int) tcflow ( fd action -- r )
12: libc ioctl<p> int int ptr (int) ioctl ( d request ptr -- r )
13:
14: 4 4 2Constant int%
15:
16: struct
17: int% field c_iflag
18: int% field c_oflag
19: int% field c_cflag
20: int% field c_lflag
21: 32 chars 0 field c_line
22: int% field c_ispeed
23: int% field c_ospeed
24: end-struct termios
25:
26: Create t_old termios %allot drop
27: Create t_buf termios %allot drop
28:
29: base @ 8 base !
30: 0000001 Constant B50
31: 0000002 Constant B75
32: 0000003 Constant B110
33: 0000004 Constant B134
34: 0000005 Constant B150
35: 0000006 Constant B200
36: 0000007 Constant B300
37: 0000010 Constant B600
38: 0000011 Constant B1200
39: 0000012 Constant B1800
40: 0000013 Constant B2400
41: 0000014 Constant B4800
42: 0000015 Constant B9600
43: 0000016 Constant B19200
44: 0000017 Constant B38400
45: 000000010001 Constant B57600
46: 000000010002 Constant B115200
47: 020000000000 Constant CRTSCTS
48: 000000000060 Constant CS8
49: 000000000200 Constant CREAD
50: 000000004000 Constant CLOCAL
51: 000000010017 Constant CBAUD
52: 000000000001 Constant IGNBRK
53: 000000000004 Constant IGNPAR
54: base !
55:
56: 6 Constant VTIME
57: 7 Constant VMIN
58:
59: : set-baud ( baud fd -- ) >r
60: r@ t_old tcgetattr drop
61: t_old t_buf termios %size move
62: [ IGNBRK IGNPAR or ] Literal t_buf c_iflag l!
63: 0 t_buf c_oflag l!
64: [ CS8 CREAD or CLOCAL or ] Literal or
65: t_buf c_cflag l!
66: 0 t_buf c_lflag l!
67: 1 t_buf c_line VMIN + c!
68: 0 t_buf c_line VTIME + c!
69: 28800 t_buf c_cflag @ $F and lshift
70: dup t_buf c_ispeed l! t_buf c_ospeed l!
71: r> 1 t_buf tcsetattr drop ;
72:
73: : reset-baud ( fd -- )
74: 1 t_old tcsetattr drop ;
75:
76: $541B Constant FIONREAD
77:
78: : check-read ( fd -- n ) >r
79: 0 sp@ r> FIONREAD rot ioctl<p> drop ;
80:
81: : >fd ( wfileid -- fd ) &14 cells + @ ;
82:
83: 0 Value term
84: 0 Value term-fd
85: : open-port ( addr u -- )
86: r/w open-file throw dup to term dup >fd to term-fd ;
87: : term-read ( -- addr u )
88: pad term-fd check-read term read-file throw pad swap ;
89: : term-emit ( char -- )
90: term emit-file throw ;
91: : (term-type) ( addr u -- )
92: term write-file throw ;
93: : term-flush ( -- )
94: term flush-file throw ;
95: [ELSE] s" cygwin" str= [IF]
96: \ Cygwin terminal adoption
97: library kernel32 kernel32
98:
99: kernel32 GetCommState int ptr (int) GetCommState ( handle addr -- r )
100: kernel32 SetCommState int ptr (int) SetCommState ( handle addr -- r )
101: kernel32 CreateFile ptr int int ptr int int ptr (int) CreateFileA ( name access share security disp attr temp -- handle )
1.4 ! pazsan 102: kernel32 WriteFile int ptr int ptr ptr (int) WriteFile ( handle data size &len &data -- flag )
! 103: kernel32 ReadFile int ptr int ptr ptr (int) ReadFile ( handle data size &len &data -- flag )
! 104: kernel32 SetCommTimeouts int ptr (int) SetCommTimeouts ( handle addr -- flag )
! 105: kernel32 GetCommTimeouts int ptr (int) GetCommTimeouts ( handle addr -- flag )
! 106:
1.3 pazsan 107: $80000000 Constant GENERIC_READ
108: $40000000 Constant GENERIC_WRITE
109: 3 Constant OPEN_EXISTING
1.4 ! pazsan 110:
1.3 pazsan 111: 50 Constant B50
112: 75 Constant B75
113: 110 Constant B110
114: 134 Constant B134
115: 150 Constant B150
116: 200 Constant B200
117: 300 Constant B300
118: 600 Constant B600
119: 1200 Constant B1200
120: 1800 Constant B1800
121: 2400 Constant B2400
122: 4800 Constant B4800
123: 9600 Constant B9600
124: 19200 Constant B19200
125: 38400 Constant B38400
126:
127: 4 4 2Constant int%
128: 2 2 2Constant word%
1.4 ! pazsan 129:
1.3 pazsan 130: struct
131: int% field DCBlength
132: int% field BaudRate
133: int% field flags
134: word% field wReserved
135: word% field XonLim
136: word% field XoffLim
137: char% field ByteSize
138: char% field Parity
139: char% field StopBits
140: char% field XonChar
141: char% field XoffChar
142: char% field ErrorChar
143: char% field EofChar
144: char% field EvtChar
145: word% field wReserved1
146: end-struct DCB
147: struct
1.4 ! pazsan 148: int% field ReadIntervalTimeout
! 149: int% field ReadTotalTimeoutMultiplier
! 150: int% field ReadTotalTimeoutConstant
! 151: int% field WriteTotalTimeoutMultiplier
! 152: int% field WriteTotalTimeoutConstant
! 153: end-struct COMMTIMEOUTS
! 154:
1.3 pazsan 155: Create t_old DCB %allot drop
156: Create t_buf DCB %allot drop
1.4 ! pazsan 157: Create tout_buf COMMTIMEOUTS %allot drop
! 158:
1.3 pazsan 159: 0 Value term-fd
160: 0 Value term
161: : open-port ( addr u -- )
162: tuck pad swap move 0 swap pad + c!
163: pad GENERIC_READ GENERIC_WRITE or 0 0 OPEN_EXISTING 0 0 CreateFile
164: to term-fd ;
165: : set-baud ( baud fd -- ) >r
166: r@ t_old GetCommState drop
1.4 ! pazsan 167: 1 t_old flags !
! 168: r@ tout_buf GetCommTimeouts drop
! 169: 3 tout_buf ReadIntervalTimeout !
! 170: 3 tout_buf ReadTotalTimeoutMultiplier !
! 171: 2 tout_buf ReadTotalTimeoutConstant !
! 172: 3 tout_buf WriteTotalTimeoutMultiplier !
! 173: 2 tout_buf WriteTotalTimeoutConstant !
! 174: r@ tout_buf SetCommTimeouts drop
1.3 pazsan 175: t_old t_buf DCB %size move
176: t_buf BaudRate !
177: r> t_buf SetCommState drop ;
178: : reset-baud ( fd -- )
179: t_old SetCommState drop ;
1.4 ! pazsan 180: Create emit-buf 0 c,
1.3 pazsan 181: Variable term-len
182: : term-read ( -- addr u )
1.4 ! pazsan 183: term-fd pad &64 term-len 0 ReadFile drop
! 184: pad term-len @ ;
1.3 pazsan 185: : (term-type) ( addr u -- )
186: term-fd -rot term-len 0 WriteFile drop ;
187: : term-emit ( char -- )
1.4 ! pazsan 188: emit-buf c! emit-buf 1 (term-type) ;
1.3 pazsan 189: : term-flush ( -- ) ;
190: [THEN]
191: [THEN]
1.1 pazsan 192:
193: Create file-buf $40 allot
194: Variable file-len
195:
196: 0 Value termfile
197: Variable term-state
1.2 pazsan 198: Variable progress-state
1.1 pazsan 199:
200: : term-end ( -- )
1.3 pazsan 201: 4 term-emit
202: #cr term-emit
203: term-flush ;
1.1 pazsan 204: : open-include ( -- )
205: file-buf file-len @ r/o open-file
206: IF ." File '" file-buf file-len @ type ." ' not found" term-end drop
207: ELSE to termfile THEN ;
208: : end-include ( -- ) termfile 0= IF EXIT THEN
209: termfile close-file throw 0 to termfile ;
210:
1.2 pazsan 211: Create progress s" /-\|" here over allot swap move
212:
1.1 pazsan 213: : term-type ( addr u -- )
214: bounds ?DO
215: I c@ CASE
216: 2 OF 1 term-state ! ENDOF
217: 3 OF
218: termfile IF
219: file-buf $40 termfile read-line throw
1.2 pazsan 220: progress progress-state @ + c@ emit #bs emit
221: progress-state @ 1+ 3 and progress-state !
1.1 pazsan 222: ELSE
223: 0 0
224: THEN
225: 0= IF
226: term-end
1.3 pazsan 227: ELSE file-buf swap (term-type)
228: #cr term-emit THEN
229: term-flush
1.1 pazsan 230: ENDOF
231: 4 OF end-include ENDOF
232: 5 OF abort ENDOF
233: term-state @ CASE
234: 0 OF emit ENDOF
1.2 pazsan 235: 1 OF $20 - $3F min file-len ! 2 term-state ! ENDOF
1.1 pazsan 236: 2 - file-buf + c! 1 term-state +!
237: term-state @ file-len @ 2 + = IF
238: open-include term-state off THEN
239: 0 ENDCASE
240: 0 ENDCASE
241: LOOP ;
242:
1.2 pazsan 243: : term-loop ( -- )
1.1 pazsan 244: BEGIN
1.3 pazsan 245: term-read term-type
246: key? IF key term-emit term-flush
1.1 pazsan 247: ELSE &10 ms THEN
248: AGAIN ;
1.2 pazsan 249: : terminal ( "name" -- ) cr
1.3 pazsan 250: parse-name open-port
1.2 pazsan 251: B38400 term-fd set-baud ['] term-loop catch
252: dup -1 = IF drop EXIT THEN throw ;
1.1 pazsan 253:
1.3 pazsan 254: s" os-type" environment? [IF]
255: 2dup s" linux-gnu" str= [IF] 2drop
256: script? [IF] terminal /dev/ttyUSB0 bye [THEN]
257: [ELSE] s" cygwin" str= [IF]
258: script? [IF] terminal COM2 bye [THEN]
259: [THEN]
260: [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