mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-14 16:29:26 +00:00
381 lines
12 KiB
Forth
381 lines
12 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 ü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 ü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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|