VolksForth/sources/msdos/miniterm.fth
2020-07-20 23:47:02 +02:00

341 lines
21 KiB
Forth
Raw Blame History

\ *** Block No. 0 Hexblock 0
\\ Terminalprogramm mit Blockinterface ( 08.03.91/KK )
Autor: Klaus Kohl, 30.01.89 aus FG-FORTH des RTX entnommen
Beschreibung:
Kleines Beispiel zur Implementation eines Fileinterfaces <EFBFBD>ber
die serielle Schnittstelle (Achtung: immer 8 Datenbits)
Die Schnittstellenbefehle stammen aus dem PC-volksFORTH 3.81
von Klaus Schleisiek. Sie wurden weitgehend unver„ndert <EFBFBD>ber-
nommen, sind aber auf 4KByte-Puffer erweitert.
File: SERIAL.SCR
Umstellung des Ports durch Ausmaskierung der entsprechenden
Zeilen in Screen 2 (momentan COM1 aktiviert).
\ *** Block No. 1 Hexblock 1
\ LOADSCREEN cas 28jun20
Onlyforth \ Suchreihenfolge: FORTH FORTH ONLY
\needs Assembler 2 loadfrom asm.fb \ Assembler nachladen
FROM source.img ( File for SAVESYSTEM )
$20 >label I_ctrl \ 8259-Register
$21 >label I_mask \ 8259-Mask
&02 &11 THRU ( SIO-Terminalroutines )
&12 &17 THRU ( extended command words )
&18 LOAD ( Terminalprogram )
\ *** Block No. 2 Hexblock 2
\ Addresses and Constants cas 28jun20
| $C 4 * Constant SINT@ \ SIO-Interuptvector COM 1/3
\ $B 4 * Constant SINT@ \ SIO-Interuptvector COM 2/4
| $10 Constant I_level \ 8259-Interuptlevel COM 1/3
\ $08 Constant I_level \ 8259-Interuptlevel COM 2/4
( Port address)
| $3F8 >label Portadr \ Portaddress COM1:
\ $2F8 >label Portadr \ Portaddress COM2:
\ $3E8 >label Portadr \ Portaddress COM3:
\ $2E8 >label Portadr \ Portaddress COM4:
( Selection of Baud rate )
\ &96 >label baud .( 1200 Baud )
\ &48 >label baud .( 2400 Baud )
| &12 >label baud .( 9600 Baud )
\ &02 >label baud .( 57600 Baud )
\ *** Block No. 3 Hexblock 3
\ Queue and required commands cas 28jun20
( Dataqueue with 128 bytes and two pointer for IRQ service )
( Queue+0: Number of saved characters )
( Queue+1: offset to next char to be send )
Create Queue 0 , 0 , $1000 allot
\ send byte to port address ( b adr -- )
\needs pc! Code pc! A pop D byte out D pop Next
\ Read Byte from port address ( adr -- b )
\needs pc@ Code pc@ D byte in A- D- mov D+ D+ xor Next
\ *** Block No. 4 Hexblock 4
\ tx? = Request status for sending char cas 28jun20
( test if a char cn be send )
Code tx? ( -- f ) \ f=-1, ready to send
D push \ TOS to datastack (TOS=Top Of Stack)
Portadr 5 + # D mov \ move status address into D reg
D in \ get port into register A
D D xor \ set D register to 0
$1020 # A and \ mask % 0001 0000 0010 0000
$1020 # A cmp \ tes if these bits are set
0= ?[ D dec ]? \ char output permitted ?
Next \ compiling "Next" wurg macro
end-code
\ *** Block No. 5 Hexblock 5
\ (tx tx = transmit cas 28jun20
( unconditional send byte directly to 8250-Port )
Code (tx ( char -- )
D- A- xchg \ load char into AL-register
Portadr # D mov \ load port address in D-register
D byte out \ transmit AL
D pop \ load next stack value into D-register
Next \ compiling "Next"
end-code
( wait until last char has been send )
: tx ( char -- )
BEGIN tx? UNTIL \ wait until SIO ready
(tx ; \ now write to port
\ *** Block No. 6 Hexblock 6
\ -DTR +DTR = Data Terminal Ready on/off cas 28jun20
( DTR-Line to +12 V = logical zero )
Code -DTR ( -- )
D push \ save TOS
Portadr 4 + # D mov \ get Address of Port Controllregister
D byte in \ move content to AL register
$1C # A- and \ DTR and RTS to 0 = +12 V
D byte out \ write AL back into port register
D pop \ restore TOS
Next \ next FORTH words
end-code
( set DTR and RTS back to 1 = -12 V )
Code +DTR ( -- )
D push Portadr 4 + # D mov
D byte in 3 # A- or D byte out
D pop Next end-code
\ *** Block No. 7 Hexblock 7
\ receive queue and interrupt service routine ( 21.02.89/KK )
| Label S_INT
D push I push A push
Queue # I mov C: seg I ) A mov
A D mov A inc $FFF # A and C: seg A I ) mov D I ADD
Portadr # D mov D byte in C: seg A- 4 I D) mov
$20 # A- mov I_ctrl #) byte out \ EOI for 8259
A pop I pop D pop iret
end-code
\ *** Block No. 8 Hexblock 8
\ rx? = request status for reading from Queue cas 28jun20
| Code rx? ( -- f ) D push
Queue #) D mov Queue 2+ #) D XOR
Next end-code
\\ Query if a char can be read from the queue
Code rx? ( -- f ) ( f<>0, if char ready )
D push \ TOS to datastack
D D xor \ D-register to 0
Queue #) D- mov \ get number if DL and
D- D- or \ test for 0
0= ?[ [[ D push \ if queue empty
Portadr 4 + # D mov \ activate S8 again
D byte in $B # A- or D byte out \ without changing
D pop \ D register
swap ]? Next end-code
\ *** Block No. 9 Hexblock 9
\ (rx rx = receive char from queue cas 28jun20
( get char from queue, adjust pointer )
Code (rx ( -- char )
D push I push
Queue 2+ # I mov C: seg I ) A mov
A D mov A inc $FFF # A and C: seg A I ) mov D I ADD
C: seg 2 I D) A- mov 0 # A+ mov A D mov
I pop Next end-code
( get char, wait for char available )
: rx ( -- char )
BEGIN rx? UNTIL (rx ;
\ *** Block No. 10 Hexblock A
\ S_init = initialize serial interface cas 28jun20
| Code S_init ( -- )
D push D: push \ save TOS and DS register
A A xor A D: mov C: A mov \ 0 -> DS ; CS -> A
SINT@ # W mov S_INT # W ) mov \ set IRQ vector
A 2 W D) mov D: pop \ and restore DS register
Portadr 3 + # D mov
$80 # A- mov D byte out \ enable Baud-rate register
2 # D sub baud # A mov A- A+ xchg D byte out \ set the
D dec A- A+ xchg D byte out \ BAUD rate
3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT
2 # D sub 1 # A- mov D byte out \ enable RX IRQ
I_mask #) byte in
I_level Forth not Assembler # A- and \ activate 8259
I_mask #) byte out
D pop Next end-code
\ *** Block No. 11 Hexblock B
\ init -init = Initialization / Reset cas 28jun20
\needs init | : init ;
( clear queue pointer and initialize port and interrupt )
: init ( -- )
init Queue off Queue 2+ off S_init ;
( block IRQ, disable RTS and DTR )
: -init ( -- )
0 [ Portadr 1+ ] Literal pc! \ disable 8259 IRQ
0 [ Portadr 4 + ] Literal pc! \ -RTS/-rts/-out2
I_mask pc@ I_level or I_mask pc! ; \ block 8259
\ *** Block No. 12 Hexblock C
\ rxto rxwto = receive char with timeout cas 28jun20
| &1000 Constant Timeout \ exit after 1000 iterations
( get a char )
| : rxto ( -- char 0 | f ) ( f=-1 signals error )
Timeout \ number iterations
BEGIN rx? IF drop (rx 0 exit THEN \ char available?
1- DUP 0= \ Timeout ?
UNTIL DROP -1 ;
( get a word, Highbyte first )
| : rxwto ( -- n 0 | f )
rxto ?dup ?exit \ exit when Timeout in 1st byte
&256 * rxto \ move to highbyte, get lowbyte
if drop -1 else OR 0 then ; \ Timeout -> error flag
\ *** Block No. 13 Hexblock D
\ info. blk>sio sio>blk = Forth Block I/O cas 28jun20
: info. ." Block: " dup . cr ;
: blk>sio ( b -- f ) ( Block to target machine )
dup capacity u<
if cr ." HOST -> TA -" info. block 0 tx
&1024 0 DO dup c@ tx 1+ LOOP drop
else drop 9 tx
then 0 ;
: sio>blk ( b -- f ) ( Block from Target )
dup capacity u<
if cr ." TA -> HOST -" info. flush block 0 tx
&1024 0 do rxto if drop &1234 leave
else over c! 1+ then loop &1234 =
if empty-buffers -1 else update flush 0 then
else drop 9 tx 0 then ;
\ *** Block No. 14 Hexblock E
\ Extension for img>file cas 28jun20
VARIABLE TSEG TSEG OFF ( Segment-Address of Target-RAM )
: TINIT ( len -- )
0 B/SEG UM/MOD SWAP IF 1+ THEN ( number of blocks )
LALLOCATE ABORT" No RAM" ( reserve )
TSEG ! ; ( save address )
: TFREE ( -- ) ( release memory )
TSEG @ LFREE ABORT" RAM allocated" ;
: TC! ( c addr -- ) ( write byte )
TSEG @ SWAP LC! ;
: <TMOVE ( taddr addr n -- ) ( data from target )
>R >R TSEG @ SWAP DS@ R> R> LMOVE ;
\ *** Block No. 15 Hexblock F
\ Terminal part for SAVESYSTEM cas 28jun20
: img>file ( len -- f ) ( save image file )
DUP TINIT DUP 0 0 tx
?DO rxto ABORT" Savesystem-Error" I TC! LOOP
PUSHFILE SOURCE.IMG
CAPACITY 1- 0 DO I BLOCK &1024 -1 FILL UPDATE LOOP
0 $400 UM/MOD DUP 0
?DO I $400 * I BLOCK $400 <TMOVE UPDATE LOOP
SWAP ?DUP
IF OVER DUP $400 * SWAP BLOCK ROT <TMOVE UPDATE THEN
DROP FLUSH CLOSE
TFREE 0 ;
\ *** Block No. 16 Hexblock 10
\ tbu = command interpreter cas 28jun20
( command interpreter for escape codes )
| : tbu ( -- f ) ( Terminal block transmission )
rxto ?dup ?exit \ get code
1 case? if rxwto ?dup ?exit blk>sio exit then \ Transmit
2 case? if rxwto ?dup ?exit sio>blk exit then \ Receive
3 case? if rxwto ?dup ?exit img>file exit then \ ROM
4 case? if rxwto ?dup ?exit drop page 0 exit then \ PAGE
5 case? if rxto ?dup ?exit rxto ?dup if nip exit then
swap at 0 exit then \ AT
$1B case? if $1B tx 0 exit then \ ESCAPE
drop -1 ; \ error unknown command
\ *** Block No. 17 Hexblock 11
\ ?rx = char from terminal cas 28jun20
( receive and interpret char )
| : ?rx ( -- )
pause rx? 0=exit (rx \ return if no char wainting
dup $20 u< \ is control char?
if
$1B case? if tbu abort" Command-Error" exit THEN \ ESCAPE
#LF case? IF cr exit THEN \ CRLF
#CR case? IF Row 0 at exit THEN \ only CR
#BS case? IF del exit THEN \ Backspace
drop \ better ignore these
else
Col &78 u> if cr then \ next line?
emit \ directly emit char
then ;
\ *** Block No. 18 Hexblock 12
\ T - Main Terminal command cas 28jun20
( send char if possible )
| : ?tx ( c -- )
BEGIN ?rx tx? UNTIL \ receive unil SIO is free
tx ; \ then transmit
( Terminal Interpreter Loop )
| : (T ( -- )
BEGIN BEGIN ?rx key? UNTIL \ receive until key pressed
key $1B case? IF -DTR exit THEN ?tx \ exit on ESC
REPEAT ;
( Main program, en-/disables interrupt )
: T ( -- )
CR ." TA-Terminal (Exit with ESC)" CR
INIT (T -INIT
CR ." VolksForth " ;
\ *** Block No. 19 Hexblock 13