Annotation of gforth/arch/r8c/terminal.fs, revision 1.19
1.1 pazsan 1: \ Terminal for R8C
2:
1.18 anton 3: \ Copyright (C) 2006,2007,2008,2009,2010,2011 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
1.19 ! pazsan 73: 000000010003 Constant B230400
1.3 pazsan 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:
1.11 pazsan 86: $541B Constant FIONREAD
87:
1.3 pazsan 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 ;
1.11 pazsan 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]
1.3 pazsan 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
1.15 pazsan 156: 2 Constant _IONBF
1.3 pazsan 157: : open-port ( addr u -- )
1.15 pazsan 158: r/w open-file throw dup to term fileno to term-fd
1.17 pazsan 159: term 0 _IONBF 0 setvbuf drop ;
1.3 pazsan 160: : term-read ( -- addr u )
1.15 pazsan 161: pad term-fd check-read dup IF term read-file throw pad swap THEN ;
1.3 pazsan 162: : term-emit ( char -- )
163: term emit-file throw ;
164: : (term-type) ( addr u -- )
165: term write-file throw ;
166: : term-flush ( -- )
1.15 pazsan 167: ( term flush-file throw ) ;
1.3 pazsan 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 )
1.4 pazsan 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:
1.3 pazsan 180: $80000000 Constant GENERIC_READ
181: $40000000 Constant GENERIC_WRITE
182: 3 Constant OPEN_EXISTING
1.4 pazsan 183:
1.3 pazsan 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%
1.4 pazsan 202:
1.3 pazsan 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
1.4 pazsan 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:
1.3 pazsan 228: Create t_old DCB %allot drop
229: Create t_buf DCB %allot drop
1.4 pazsan 230: Create tout_buf COMMTIMEOUTS %allot drop
231:
1.3 pazsan 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
1.4 pazsan 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
1.3 pazsan 248: t_old t_buf DCB %size move
249: t_buf BaudRate !
1.5 pazsan 250: 8 t_buf ByteSize c!
1.3 pazsan 251: r> t_buf SetCommState drop ;
252: : reset-baud ( fd -- )
253: t_old SetCommState drop ;
1.4 pazsan 254: Create emit-buf 0 c,
1.3 pazsan 255: Variable term-len
256: : term-read ( -- addr u )
1.4 pazsan 257: term-fd pad &64 term-len 0 ReadFile drop
258: pad term-len @ ;
1.3 pazsan 259: : (term-type) ( addr u -- )
260: term-fd -rot term-len 0 WriteFile drop ;
261: : term-emit ( char -- )
1.4 pazsan 262: emit-buf c! emit-buf 1 (term-type) ;
1.3 pazsan 263: : term-flush ( -- ) ;
264: [THEN]
265: [THEN]
1.1 pazsan 266:
267: Create file-buf $40 allot
268: Variable file-len
1.7 pazsan 269: Variable term-stack $10 cells allot
1.1 pazsan 270:
1.7 pazsan 271: : 'term ( -- addr ) term-stack @ cells term-stack + ;
272: : termfile ( -- file ) 'term @ ;
273: : >term ( o -- ) 1 term-stack +! 'term ! ;
274: : term> ( -- ) -1 term-stack +! ;
1.1 pazsan 275: Variable term-state
1.2 pazsan 276: Variable progress-state
1.1 pazsan 277:
278: : term-end ( -- )
1.3 pazsan 279: 4 term-emit
280: #cr term-emit
281: term-flush ;
1.1 pazsan 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
1.7 pazsan 285: ELSE >term THEN ;
1.1 pazsan 286: : end-include ( -- ) termfile 0= IF EXIT THEN
1.7 pazsan 287: termfile close-file throw term> ;
1.1 pazsan 288:
1.2 pazsan 289: Create progress s" /-\|" here over allot swap move
290:
1.1 pazsan 291: : term-type ( addr u -- )
292: bounds ?DO
293: I c@ CASE
294: 2 OF 1 term-state ! ENDOF
295: 3 OF
1.7 pazsan 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
1.1 pazsan 309: ELSE
1.7 pazsan 310: file-buf swap (term-type)
311: #cr term-emit
1.1 pazsan 312: THEN
1.3 pazsan 313: term-flush
1.1 pazsan 314: ENDOF
315: 4 OF end-include ENDOF
316: 5 OF abort ENDOF
317: term-state @ CASE
318: 0 OF emit ENDOF
1.2 pazsan 319: 1 OF $20 - $3F min file-len ! 2 term-state ! ENDOF
1.1 pazsan 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:
1.2 pazsan 327: : term-loop ( -- )
1.1 pazsan 328: BEGIN
1.3 pazsan 329: term-read term-type
330: key? IF key term-emit term-flush
1.1 pazsan 331: ELSE &10 ms THEN
332: AGAIN ;
1.8 pazsan 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" -- )
1.3 pazsan 339: parse-name open-port
1.19 ! pazsan 340: B38400 term-fd set-baud say-hallo ['] term-loop catch
1.8 pazsan 341: dup -1 = IF drop cr EXIT THEN throw ;
1.1 pazsan 342:
1.3 pazsan 343: s" os-type" environment? [IF]
344: 2dup s" linux-gnu" str= [IF] 2drop
1.19 ! pazsan 345: script? [IF] terminal /dev/ttyUSB0 bye [THEN]
1.11 pazsan 346: [ELSE] 2dup s" cygwin" str= [IF]
1.12 pazsan 347: script? [IF] terminal COM1 bye [THEN]
1.11 pazsan 348: [ELSE] s" darwin" string-prefix? [IF]
349: script? [IF] terminal /dev/cu.PL2303-0000101D bye [THEN]
1.12 pazsan 350: [THEN] [THEN] [THEN]
1.3 pazsan 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