File:  [gforth] / gforth / arch / r8c / terminal.fs
Revision 1.20: download - view: text, annotated - select for diffs
Mon Dec 31 15:25:18 2012 UTC (9 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright year

    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>