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