mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-19 17:31:23 +00:00
341 lines
21 KiB
Forth
341 lines
21 KiB
Forth
\ *** 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
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|