mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-14 16:29:26 +00:00
Make v4th.com tests independent of .fb sources:
Provide .fth variants of asm.fb, extend.fb, dos.fb, multi.vid Also add detection of unresolved symbols to v4th.com make rule
This commit is contained in:
Philip Zembrod
parent
c9a62fc7ff
commit
f3376268f8
|
|
@ -32,6 +32,7 @@ v4th.com: metafile.com src/meta.fb src/mk-v4th.fth \
|
|||
dos2unix -n OUTPUT.LOG v4th.log
|
||||
mv V4TH.COM v4th.com
|
||||
grep -F 'new kernel written as v4th.com' v4th.log
|
||||
grep -i 'unresolved:.*[^ ]' v4th.log && exit 1 || true
|
||||
|
||||
# o4th for old volks4th - the new v4th is built with precompiled
|
||||
# metacompiler metafile.com and mk-v4th.fth which writes a compile log.
|
||||
|
|
@ -60,6 +61,9 @@ logappendtest.log: v4thfile.com tests/logapp.fth
|
|||
|
||||
prepsrcs = asm.fb extend.fb multi.vid dos.fb include.fb
|
||||
|
||||
prepfths = asm.fb extend.fb multi.vid dos.fb include.fb 86asm.fth \
|
||||
t86asm.fth extend2.fth multivid.fth dos2.fth dos3.fth
|
||||
|
||||
incltest.log: \
|
||||
$(patsubst %, dosfiles/%, v4th.com $(prepsrcs) log2file.fb \
|
||||
incltest.fth)
|
||||
|
|
@ -69,7 +73,7 @@ incltest.log: \
|
|||
dos2unix -n dosfiles/OUTPUT.LOG $@
|
||||
|
||||
test-min.log: \
|
||||
$(patsubst %, dosfiles/%, v4th.com $(prepsrcs)) \
|
||||
$(patsubst %, dosfiles/%, v4th.com $(prepfths)) \
|
||||
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||
rm -f dosfiles/OUTPUT.LOG
|
||||
(cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \
|
||||
|
|
@ -77,7 +81,7 @@ test-min.log: \
|
|||
dos2unix -n dosfiles/OUTPUT.LOG $@
|
||||
|
||||
test-std.log: \
|
||||
$(patsubst %, dosfiles/%, v4th.com $(prepsrcs)) \
|
||||
$(patsubst %, dosfiles/%, v4th.com $(prepfths)) \
|
||||
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||
rm -f dosfiles/OUTPUT.LOG
|
||||
(cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \
|
||||
|
|
@ -85,7 +89,7 @@ test-std.log: \
|
|||
dos2unix -n dosfiles/OUTPUT.LOG $@
|
||||
|
||||
test-blk.log: \
|
||||
$(patsubst %, dosfiles/%, v4th.com $(prepsrcs)) \
|
||||
$(patsubst %, dosfiles/%, v4th.com $(prepfths)) \
|
||||
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||
rm -f dosfiles/OUTPUT.LOG
|
||||
(cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \
|
||||
|
|
|
|||
397
8086/msdos/src/86asm.fth
Normal file
397
8086/msdos/src/86asm.fth
Normal file
|
|
@ -0,0 +1,397 @@
|
|||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ 8086 Assembler cas 10nov05
|
||||
\ This 8086 Assembler was written by Klaus Schleisiek.
|
||||
\ Assembler Definitions are created with the definig word
|
||||
\ CODE and closed with the word END-CODE.
|
||||
|
||||
\ The 8086 Registers naming and usage in volksFORTH
|
||||
|
||||
\ Intel vForth Used for 8bit-Register
|
||||
\ AX A free A+ A-
|
||||
\ DX D topmost Stackitem D+ D-
|
||||
\ CX C free C+ C-
|
||||
\ BX R Returnstack Pointer R+ R-
|
||||
\ BP U User Pointer
|
||||
\ SP S Stack Pointer
|
||||
\ SI I Instruction Pointer
|
||||
\ DI W Word Pointer, mostly free
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ 8086 Assembler loadscreen cas 10nov05
|
||||
Onlyforth
|
||||
|
||||
| : u2/ ( 16b -- 15b ) 2/ $7FFF and ;
|
||||
| : 8* ( 15b -- 16b ) 2* 2* 2* ;
|
||||
| : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ;
|
||||
|
||||
Vocabulary Assembler
|
||||
Assembler also definitions
|
||||
|
||||
\ 3 &21 thru clear .( Assembler loaded ) cr
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ Code generating primitives cas 10nov05
|
||||
|
||||
Variable >codes \ points at table of execution vectors
|
||||
|
||||
| Create nrc ] c, , here ! c! [
|
||||
|
||||
: nonrelocate nrc >codes ! ; nonrelocate
|
||||
|
||||
| : >exec ( n -- n+2 ) Create dup c, 2+
|
||||
Does> c@ >codes @ + perform ;
|
||||
|
||||
0 | >exec >c, | >exec >, | >exec >here
|
||||
| >exec >! | >exec >c! drop
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 4, Hexblock 4
|
||||
|
||||
\ 8086 Registers cas 10nov05
|
||||
|
||||
0 Constant A 1 Constant C 2 Constant D 3 Constant R
|
||||
4 Constant S 5 Constant U 6 Constant I 7 Constant W
|
||||
' I Alias SI ' W Alias DI ' R Alias BX
|
||||
|
||||
8 Constant A- 9 Constant C- $A Constant D- $B Constant R-
|
||||
$C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+
|
||||
' R- Alias B- ' R+ Alias B+
|
||||
|
||||
$100 Constant E: $101 Constant C:
|
||||
$102 Constant S: $103 Constant D:
|
||||
|
||||
| Variable isize ( specifies Size by prefix)
|
||||
| : Size: ( n -- ) Create c, Does> c@ isize ! ;
|
||||
0 Size: byte 1 Size: word word 2 Size: far
|
||||
|
||||
\ *** Block No. 5, Hexblock 5
|
||||
|
||||
\ 8086 Assembler System variables cas 10nov05
|
||||
|
||||
| Variable direction \ 0 reg>EA, -1 EA>reg
|
||||
| Variable size \ 1 word, 0 byte, -1 undefined
|
||||
| Variable displaced \ 1 direct, 0 nothing, -1 displaced
|
||||
| Variable displacement
|
||||
|
||||
| : setsize isize @ size ! ;
|
||||
| : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ;
|
||||
| : wexit rdrop word ;
|
||||
| : moderr word true Abort" invalid" ;
|
||||
| : ?moderr ( f -- ) 0=exit moderr ;
|
||||
| : ?word size @ 1- ?moderr ;
|
||||
| : far? ( -- f ) size @ 2 = ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 6, Hexblock 6
|
||||
|
||||
\ 8086 addressing modes cas 10nov05
|
||||
|
||||
| Create (EA 7 c, 0 c, 6 c, 4 c, 5 c,
|
||||
| : () ( 8b1 -- 8b2 )
|
||||
3 - dup 4 u> over 1 = or ?moderr (EA + c@ ;
|
||||
|
||||
-1 Constant # $C6 Constant #) -1 Constant C*
|
||||
|
||||
: ) ( u1 -- u2 )
|
||||
() 6 case? IF 0 $86 exit THEN $C0 or ;
|
||||
: I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ;
|
||||
|
||||
: D) ( n u1 -- n u2 )
|
||||
() over long? IF $40 ELSE $80 THEN or ;
|
||||
: DI) ( n u1 u2 -- n u3 )
|
||||
I) over long? IF $80 ELSE $40 THEN xor ;
|
||||
|
||||
\ *** Block No. 7, Hexblock 7
|
||||
|
||||
\ 8086 Registers and addressing modes cas 10nov05
|
||||
|
||||
| : displaced? ( [n] u1 -- [n] u1 f )
|
||||
dup #) = IF 1 exit THEN
|
||||
dup $C0 and dup $40 = swap $80 = or ;
|
||||
|
||||
| : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit
|
||||
displaced @ ?moderr displaced ! swap displacement ! ;
|
||||
|
||||
| : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit
|
||||
size off $FF07 and ;
|
||||
|
||||
| : mmode? ( 9b - 9b f) dup $C0 and ;
|
||||
|
||||
| : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ;
|
||||
|
||||
|
||||
\ *** Block No. 8, Hexblock 8
|
||||
|
||||
\ 8086 decoding addressing modes cas 10nov05
|
||||
|
||||
| : 2address ( [n] source [displ] dest -- 15b / [n] 16b )
|
||||
size on displaced off dup # = ?moderr mmode?
|
||||
IF displace False ELSE rmode True THEN direction !
|
||||
>r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit
|
||||
THEN direction @
|
||||
IF r> 8* >r mmode? IF displace
|
||||
ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN
|
||||
ELSE rmode 8*
|
||||
THEN r> or $C0 xor ;
|
||||
|
||||
| : 1address ( [displ] 9b -- 9b )
|
||||
# case? ?moderr size on displaced off direction off
|
||||
mmode? IF displace setsize ELSE rmode THEN $C0 xor ;
|
||||
|
||||
|
||||
\ *** Block No. 9, Hexblock 9
|
||||
|
||||
\ 8086 assembler cas 10nov05
|
||||
| : immediate? ( u -- u f ) dup 0< ;
|
||||
|
||||
| : nonimmediate ( u -- u ) immediate? ?moderr ;
|
||||
|
||||
| : r/m 7 and ;
|
||||
|
||||
| : reg $38 and ;
|
||||
|
||||
| : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ;
|
||||
|
||||
| : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and
|
||||
IF dup $100 and IF dup r/m 8* swap reg 8/
|
||||
or $C0 or direction off
|
||||
THEN True exit
|
||||
THEN False ;
|
||||
|
||||
\ *** Block No. 10, Hexblock a
|
||||
|
||||
\ 8086 Registers and addressing modes cas 10nov05
|
||||
|
||||
| : w, size @ or >c, ;
|
||||
|
||||
| : dw, size @ or direction @ IF 2 xor THEN >c, ;
|
||||
|
||||
| : ?word, ( u1 f -- ) IF >, exit THEN >c, ;
|
||||
|
||||
| : direct, displaced @ 0=exit
|
||||
displacement @ dup long? displaced @ 1+ or ?word, ;
|
||||
|
||||
| : r/m, >c, direct, ;
|
||||
|
||||
| : data, size @ ?word, ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 11, Hexblock b
|
||||
|
||||
\ 8086 Arithmetic instructions cas 10nov05
|
||||
|
||||
| : Arith: ( code -- ) Create ,
|
||||
Does> @ >r 2address immediate?
|
||||
IF rmode? IF ?akku IF r> size @
|
||||
IF 5 or >c, >, wexit THEN
|
||||
4 or >c, >c, wexit THEN THEN
|
||||
r@ or $80 size @ or r> 0<
|
||||
IF size @ IF 2 pick long? 0= IF 2 or size off THEN
|
||||
THEN THEN >c, >c, direct, data, wexit
|
||||
THEN r> dw, r/m, wexit ;
|
||||
|
||||
$8000 Arith: add $0008 Arith: or
|
||||
$8010 Arith: adc $8018 Arith: sbb
|
||||
$0020 Arith: and $8028 Arith: sub
|
||||
$0030 Arith: xor $8038 Arith: cmp
|
||||
|
||||
\ *** Block No. 12, Hexblock c
|
||||
|
||||
\ 8086 move push pop cas 10nov05
|
||||
|
||||
: mov [ Forth ] 2address immediate?
|
||||
IF rmode? IF r/m $B0 or size @ IF 8 or THEN
|
||||
>c, data, wexit
|
||||
THEN $C6 w, r/m, data, wexit
|
||||
THEN 6 case? IF $A2 dw, direct, wexit THEN
|
||||
smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit
|
||||
THEN $88 dw, r/m, wexit ;
|
||||
|
||||
| : pupo [ Forth ] >r 1address ?word
|
||||
smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN
|
||||
rmode? IF r/m $50 or r> or >c, wexit THEN
|
||||
r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ;
|
||||
|
||||
: push 0 pupo ; : pop 8 pupo ;
|
||||
|
||||
\ *** Block No. 13, Hexblock d
|
||||
|
||||
\ 8086 inc & dec , effective addresses cas 10nov05
|
||||
|
||||
| : inc/dec [ Forth ] >r 1address rmode?
|
||||
IF size @ IF r/m $40 or r> or >c, wexit THEN
|
||||
THEN $FE w, r> or r/m, wexit ;
|
||||
|
||||
: dec 8 inc/dec ; : inc 0 inc/dec ;
|
||||
|
||||
| : EA: ( code -- ) Create c, [ Forth ]
|
||||
Does> >r 2address nonimmediate
|
||||
rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ;
|
||||
|
||||
$C4 EA: les $8D EA: lea $C5 EA: lds
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 14, Hexblock e
|
||||
|
||||
\ 8086 xchg segment prefix cas 10nov05
|
||||
: xchg [ Forth ] 2address nonimmediate rmode?
|
||||
IF size @ IF dup r/m 0=
|
||||
IF 8/ true ELSE dup $38 and 0= THEN
|
||||
IF r/m $90 or >c, wexit THEN
|
||||
THEN THEN $86 w, r/m, wexit ;
|
||||
|
||||
| : 1addr: ( code -- ) Create c, [ Forth ]
|
||||
Does> c@ >r 1address $F6 w, r> or r/m, wexit ;
|
||||
|
||||
$10 1addr: com $18 1addr: neg
|
||||
$20 1addr: mul $28 1addr: imul
|
||||
$38 1addr: idiv $30 1addr: div
|
||||
|
||||
: seg ( 8b -) [ Forth ]
|
||||
$100 xor dup $FFFC and ?moderr 8* $26 or >c, ;
|
||||
|
||||
\ *** Block No. 15, Hexblock f
|
||||
|
||||
\ 8086 test not neg mul imul div idiv cas 10nov05
|
||||
|
||||
: test [ Forth ] 2address immediate?
|
||||
IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN
|
||||
$F6 w, r/m, data, wexit
|
||||
THEN $84 w, r/m, wexit ;
|
||||
|
||||
| : in/out [ Forth ] >r 1address setsize
|
||||
$C2 case? IF $EC r> or w, wexit THEN
|
||||
6 - ?moderr $E4 r> or w, displacement @ >c, wexit ;
|
||||
|
||||
: out 2 in/out ; : in 0 in/out ;
|
||||
|
||||
: int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 16, Hexblock 10
|
||||
|
||||
\ 8086 shifts and string instructions cas 10nov05
|
||||
|
||||
| : Shifts: ( code -- ) Create c, [ Forth ]
|
||||
Does> c@ >r C* case? >r 1address
|
||||
r> direction ! $D0 dw, r> or r/m, wexit ;
|
||||
|
||||
$00 Shifts: rol $08 Shifts: ror
|
||||
$10 Shifts: rcl $18 Shifts: rcr
|
||||
$20 Shifts: shl $28 Shifts: shr
|
||||
$38 Shifts: sar ' shl Alias sal
|
||||
|
||||
| : Str: ( code -- ) Create c,
|
||||
Does> c@ setsize w, wexit ;
|
||||
|
||||
$A6 Str: cmps $AC Str: lods $A4 Str: movs
|
||||
$AE Str: scas $AA Str: stos
|
||||
|
||||
\ *** Block No. 17, Hexblock 11
|
||||
|
||||
\ implied 8086 instructions cas 10nov05
|
||||
|
||||
: Byte: ( code -- ) Create c, Does> c@ >c, ;
|
||||
: Word: ( code -- ) Create , Does> @ >, ;
|
||||
|
||||
$37 Byte: aaa $AD5 Word: aad $AD4 Word: aam
|
||||
$3F Byte: aas $98 Byte: cbw $F8 Byte: clc
|
||||
$FC Byte: cld $FA Byte: cli $F5 Byte: cmc
|
||||
$99 Byte: cwd $27 Byte: daa $2F Byte: das
|
||||
$F4 Byte: hlt $CE Byte: into $CF Byte: iret
|
||||
$9F Byte: lahf $F0 Byte: lock $90 Byte: nop
|
||||
$9D Byte: popf $9C Byte: pushf $9E Byte: sahf
|
||||
$F9 Byte: stc $FD Byte: std $FB Byte: sti
|
||||
$9B Byte: wait $D7 Byte: xlat
|
||||
$C3 Byte: ret $CB Byte: lret
|
||||
$F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep
|
||||
|
||||
\ *** Block No. 18, Hexblock 12
|
||||
|
||||
\ 8086 jmp call conditions cas 10nov05
|
||||
| : jmp/call >r setsize # case? [ Forth ]
|
||||
IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit
|
||||
THEN >here 2+ - r>
|
||||
IF dup long? 0= IF $EB >c, >c, wexit THEN $E9
|
||||
ELSE $E8 THEN >c, 1- >, wexit
|
||||
THEN 1address $FF >c, $10 or r> +
|
||||
far? IF 8 or THEN r/m, wexit ;
|
||||
: call 0 jmp/call ; : jmp $10 jmp/call ;
|
||||
|
||||
$71 Constant OS $73 Constant CS
|
||||
$75 Constant 0= $77 Constant >=
|
||||
$79 Constant 0< $7B Constant PE
|
||||
$7D Constant < $7F Constant <=
|
||||
$E2 Constant C0= $E0 Constant ?C0=
|
||||
: not 1 [ Forth ] xor ;
|
||||
|
||||
\ *** Block No. 19, Hexblock 13
|
||||
|
||||
\ 8086 conditional branching cas 10nov05
|
||||
|
||||
: +ret $C2 >c, >, ;
|
||||
: +lret $CA >c, >, ;
|
||||
|
||||
| : ?range dup long? abort" out of range" ;
|
||||
|
||||
: ?[ >, >here 1- ;
|
||||
: ]? >here over 1+ - ?range swap >c! ;
|
||||
: ][ $EB ?[ swap ]? ;
|
||||
: ?[[ ?[ swap ;
|
||||
: [[ >here ;
|
||||
: ?] >c, >here 1+ - ?range >c, ;
|
||||
: ]] $EB ?] ;
|
||||
: ]]? ]] ]? ;
|
||||
|
||||
|
||||
\ *** Block No. 20, Hexblock 14
|
||||
|
||||
\ Next user' end-code ;c: cas 10nov05
|
||||
|
||||
: Next lods A W xchg W ) jmp
|
||||
>here next-link @ >, next-link ! ;
|
||||
|
||||
: u' ' >body c@ ;
|
||||
|
||||
Forth definitions
|
||||
|
||||
\needs end-code : end-code toss also ;
|
||||
|
||||
Assembler definitions
|
||||
|
||||
: ;c: recover # call last off end-code 0 ] ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 21, Hexblock 15
|
||||
|
||||
\ 8086 Assembler, Forth words cas 10nov05
|
||||
Onlyforth
|
||||
|
||||
: Assembler Assembler [ Assembler ] wexit ;
|
||||
|
||||
: ;code 0 ?pairs compile (;code
|
||||
reveal [compile] [ Assembler ; immediate
|
||||
|
||||
: Code Create [ Assembler ] >here dup 2- >! Assembler ;
|
||||
|
||||
: >label ( addr -- )
|
||||
here | Create immediate swap , 4 hallot
|
||||
here 4 - heap 4 cmove heap last @ (name> ! dp !
|
||||
Does> ( -- addr ) @ state @ 0=exit [compile] Literal ;
|
||||
|
||||
: Label [ Assembler ] >here >label Assembler ;
|
||||
|
||||
|
||||
clear .( Assembler loaded ) cr
|
||||
255
8086/msdos/src/dos2.fth
Normal file
255
8086/msdos/src/dos2.fth
Normal file
|
|
@ -0,0 +1,255 @@
|
|||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ 28 jun 88
|
||||
|
||||
\ This file is a pure .fth-version of dos.fb.
|
||||
|
||||
\ DOS loads higher level file functions which go beyond
|
||||
\ including a screen file. Calls to MS-DOS are implemented
|
||||
\ and used for directory manipulation. These functions may
|
||||
\ not work for versions before MS-DOS 3.0.
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ MS-DOS file handli cas 09jun20
|
||||
Onlyforth \needs Assembler 2 loadfrom asm.fb
|
||||
|
||||
: fswap isfile@ fromfile @ isfile ! fromfile ! ;
|
||||
|
||||
$80 Constant dta
|
||||
|
||||
| : COMSPEC ( -- string ) [ dos ]
|
||||
$2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove
|
||||
filename counted &60 min filename place filename ;
|
||||
|
||||
\ 1 &12 +thru .( MS-DOS functions loaed ) cr
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ moving blocks ks 04 okt 87
|
||||
|
||||
| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ;
|
||||
|
||||
: used? ( blk -- f )
|
||||
block count b/blk 1- swap skip nip 0<> ;
|
||||
|
||||
| : (copy ( from to -- )
|
||||
full? IF save-buffers THEN isfile@ fromfile @ -
|
||||
IF dup used? Abort" target block not empty" THEN
|
||||
dup isfile@ core? IF prev @ emptybuf THEN
|
||||
isfile@ 0= IF offset @ + THEN
|
||||
isfile@ rot fromfile @ (block 6 - 2! update ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ moving blocks ks 04 okt 87
|
||||
|
||||
| : blkmove ( from to quan -- ) 3 arguments save-buffers
|
||||
>r over r@ + over u> >r 2dup u< r> and
|
||||
IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP
|
||||
ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP
|
||||
THEN save-buffers 2drop ;
|
||||
|
||||
: copy ( from to -- ) 1 blkmove ;
|
||||
|
||||
: convey ( blk1 blk2 to.blk -- )
|
||||
3 arguments >r 2dup swap - >r
|
||||
fswap dup capacity 1- > isfile@ 0<> and
|
||||
fswap r> r@ + capacity 1- > isfile@ 0<> and or >r
|
||||
1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ;
|
||||
|
||||
|
||||
\ *** Block No. 4, Hexblock 4
|
||||
|
||||
\ MORE extending forth files ks 10 okt 87
|
||||
Dos also definitions
|
||||
|
||||
| : addblock ( blk -- ) dup buffer dup b/blk blank
|
||||
isfile@ f.size dup 2@ b/blk 0 d+ rot 2!
|
||||
swap isfile@ fblock! ;
|
||||
|
||||
Forth definitions
|
||||
|
||||
: more ( n -- ) 1 arguments isfile@
|
||||
IF capacity swap bounds ?DO I addblock LOOP close exit
|
||||
THEN drop ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 5, Hexblock 5
|
||||
|
||||
\ file eof? create dta-addressing ks 03 apr 88
|
||||
Dos definitions
|
||||
|
||||
: ftime ( -- mm hh )
|
||||
isfile@ f.time @ $20 u/mod nip $40 u/mod ;
|
||||
|
||||
: fdate ( -- dd mm yy )
|
||||
isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
|
||||
|
||||
: .when base push decimal
|
||||
fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r
|
||||
ftime 3 .r ." :" 2 .r ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 6, Hexblock 6
|
||||
|
||||
\ ks 20mar88
|
||||
|
||||
: (.fcb ( fcb -- )
|
||||
dup .file ?dup 0=exit pushfile
|
||||
isfile ! &13 tab ." is"
|
||||
isfile@ f.handle @ 2 .r
|
||||
isfile@ f.size 2@ 7 d.r .when
|
||||
space isfile@ f.name count type ;
|
||||
|
||||
Forth definitions
|
||||
|
||||
: files file-link
|
||||
BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ;
|
||||
|
||||
: ?file isfile@ (.fcb ;
|
||||
|
||||
|
||||
\ *** Block No. 7, Hexblock 7
|
||||
|
||||
\ dir make makefile ks 25 okt 87
|
||||
Forth definitions
|
||||
|
||||
: killfile close
|
||||
isfile@ f.name filename >asciz ~unlink drop ;
|
||||
|
||||
: emptyfile isfile@ 0=exit
|
||||
isfile@ f.name filename >asciz 0 ~creat ?diskerror
|
||||
isfile@ f.handle ! isfile@ f.size 4 erase ;
|
||||
|
||||
: make close name isfile@ fname! emptyfile ;
|
||||
|
||||
: makefile File last @ name> execute emptyfile ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 8, Hexblock 8
|
||||
|
||||
\ getpath ks 10 okt 87
|
||||
Dos definitions
|
||||
|
||||
| &40 Constant pathlen
|
||||
| Create pathes 0 c, pathlen allot
|
||||
|
||||
| : (setpath ( string -- ) count
|
||||
dup pathlen u> Abort" path too long" pathes place ;
|
||||
|
||||
| : getpath ( +n -- string / ff )
|
||||
>r 0 pathes count r> 0
|
||||
DO rot drop Ascii ; skip stash Ascii ; scan LOOP
|
||||
drop over - ?dup
|
||||
IF here place here dup count + 1- c@
|
||||
?" :\" ?exit Ascii \ here append exit
|
||||
THEN 0= ;
|
||||
|
||||
\ *** Block No. 9, Hexblock 9
|
||||
|
||||
\ pathsearch .path path ks 09 okt 87
|
||||
|
||||
: pathsearch ( string -- asciz *f ) dup >r
|
||||
(fsearch dup 0= IF rdrop exit THEN 2drop 0 0
|
||||
BEGIN drop 1+ dup getpath ?dup 0=
|
||||
IF drop r> filename >asciz 2 exit THEN
|
||||
r@ count 2 pick attach (fsearch
|
||||
0= UNTIL nip rdrop false ;
|
||||
|
||||
' pathsearch Is fsearch
|
||||
|
||||
Forth definitions
|
||||
|
||||
: .path pathes count type ;
|
||||
|
||||
: path name nullstring? IF .path exit THEN (setpath ;
|
||||
|
||||
\ *** Block No. 10, Hexblock a
|
||||
|
||||
\ call another executable file ks 04 aug 87
|
||||
Dos definitions
|
||||
|
||||
| Create cpb 0 , \ inherit parent environment
|
||||
dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 ,
|
||||
|
||||
| Code ~exec ( asciz -- *f )
|
||||
I push R push U push S ssave #) mov cpb # R mov
|
||||
$4B00 # A mov $21 int C: D mov D D: mov D S: mov
|
||||
D E: mov ssave #) S mov CS not
|
||||
?[ A A xor A push $2F # A+ mov $21 int E: A mov
|
||||
A D: mov C: A mov A E: mov R I mov dta # W mov
|
||||
$40 # C mov rep movs A D: mov A pop
|
||||
]? A W xchg dta # D mov $1A # A+ mov $21 int
|
||||
W D mov U pop R pop I pop Next
|
||||
end-code
|
||||
|
||||
\ *** Block No. 11, Hexblock b
|
||||
|
||||
\ calling MS-DOS thru forth interpreter ks 19 mr 88
|
||||
|
||||
| : execute? ( extension -- *f )
|
||||
count filename count Ascii . scan drop swap
|
||||
2dup 1+ erase move filename 1+ ~exec ;
|
||||
|
||||
: fcall ( string -- ) count filename place ds@ cpb 4+ !
|
||||
" .EXE" execute? dup IF drop " .COM" execute? THEN
|
||||
?diskerror ;
|
||||
|
||||
: fdos ( string -- )
|
||||
dta $80 erase " /c " count dta place count dta attach
|
||||
status push status off .status COMSPEC fcall curat? at ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 12, Hexblock c
|
||||
|
||||
\ einige MS-DOS Funktionen msdos call ks 10 okt 87
|
||||
|
||||
: dos: Create ," Does> count here place
|
||||
Ascii " parse here attach here fdos ;
|
||||
|
||||
Forth definitions
|
||||
|
||||
dos: dir dir "
|
||||
dos: ren ren "
|
||||
dos: md md "
|
||||
dos: cd cd "
|
||||
dos: rd rd "
|
||||
dos: fcopy copy "
|
||||
dos: delete del "
|
||||
dos: ftype type "
|
||||
|
||||
|
||||
\ *** Block No. 13, Hexblock d
|
||||
|
||||
\ msdos call ks 23 okt 88
|
||||
|
||||
: msdos savevideo status push status off .status
|
||||
flush dta off COMSPEC fcall restorevideo ;
|
||||
|
||||
: call name source >in @ /string c/l umin
|
||||
dta place dta dta >asciz drop [compile] \
|
||||
status push status off .status fcall curat? at ;
|
||||
|
||||
|
||||
.( MS-DOS functions loaed ) cr
|
||||
|
||||
Onlyforth
|
||||
195
8086/msdos/src/dos3.fth
Normal file
195
8086/msdos/src/dos3.fth
Normal file
|
|
@ -0,0 +1,195 @@
|
|||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ 28 jun 88
|
||||
|
||||
\ This file is an .fth-version of dos.fb without the block-related
|
||||
\ words.
|
||||
|
||||
\ DOS loads higher level file functions which go beyond
|
||||
\ including a screen file. Calls to MS-DOS are implemented
|
||||
\ and used for directory manipulation. These functions may
|
||||
\ not work for versions before MS-DOS 3.0.
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ MS-DOS file handli cas 09jun20
|
||||
Onlyforth \needs Assembler 2 loadfrom asm.fb
|
||||
|
||||
: fswap isfile@ fromfile @ isfile ! fromfile ! ;
|
||||
|
||||
$80 Constant dta
|
||||
|
||||
| : COMSPEC ( -- string ) [ dos ]
|
||||
$2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove
|
||||
filename counted &60 min filename place filename ;
|
||||
|
||||
|
||||
\ *** Block No. 5, Hexblock 5
|
||||
|
||||
\ file eof? create dta-addressing ks 03 apr 88
|
||||
Dos also definitions
|
||||
|
||||
: ftime ( -- mm hh )
|
||||
isfile@ f.time @ $20 u/mod nip $40 u/mod ;
|
||||
|
||||
: fdate ( -- dd mm yy )
|
||||
isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
|
||||
|
||||
: .when base push decimal
|
||||
fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r
|
||||
ftime 3 .r ." :" 2 .r ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 6, Hexblock 6
|
||||
|
||||
\ ks 20mar88
|
||||
|
||||
: (.fcb ( fcb -- )
|
||||
dup .file ?dup 0=exit pushfile
|
||||
isfile ! &13 tab ." is"
|
||||
isfile@ f.handle @ 2 .r
|
||||
isfile@ f.size 2@ 7 d.r .when
|
||||
space isfile@ f.name count type ;
|
||||
|
||||
Forth definitions
|
||||
|
||||
: files file-link
|
||||
BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ;
|
||||
|
||||
: ?file isfile@ (.fcb ;
|
||||
|
||||
|
||||
\ *** Block No. 7, Hexblock 7
|
||||
|
||||
\ dir make makefile ks 25 okt 87
|
||||
Forth definitions
|
||||
|
||||
: killfile close
|
||||
isfile@ f.name filename >asciz ~unlink drop ;
|
||||
|
||||
: emptyfile isfile@ 0=exit
|
||||
isfile@ f.name filename >asciz 0 ~creat ?diskerror
|
||||
isfile@ f.handle ! isfile@ f.size 4 erase ;
|
||||
|
||||
: make close name isfile@ fname! emptyfile ;
|
||||
|
||||
: makefile File last @ name> execute emptyfile ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 8, Hexblock 8
|
||||
|
||||
\ getpath ks 10 okt 87
|
||||
Dos definitions
|
||||
|
||||
| &40 Constant pathlen
|
||||
| Create pathes 0 c, pathlen allot
|
||||
|
||||
| : (setpath ( string -- ) count
|
||||
dup pathlen u> Abort" path too long" pathes place ;
|
||||
|
||||
| : getpath ( +n -- string / ff )
|
||||
>r 0 pathes count r> 0
|
||||
DO rot drop Ascii ; skip stash Ascii ; scan LOOP
|
||||
drop over - ?dup
|
||||
IF here place here dup count + 1- c@
|
||||
?" :\" ?exit Ascii \ here append exit
|
||||
THEN 0= ;
|
||||
|
||||
\ *** Block No. 9, Hexblock 9
|
||||
|
||||
\ pathsearch .path path ks 09 okt 87
|
||||
|
||||
: pathsearch ( string -- asciz *f ) dup >r
|
||||
(fsearch dup 0= IF rdrop exit THEN 2drop 0 0
|
||||
BEGIN drop 1+ dup getpath ?dup 0=
|
||||
IF drop r> filename >asciz 2 exit THEN
|
||||
r@ count 2 pick attach (fsearch
|
||||
0= UNTIL nip rdrop false ;
|
||||
|
||||
' pathsearch Is fsearch
|
||||
|
||||
Forth definitions
|
||||
|
||||
: .path pathes count type ;
|
||||
|
||||
: path name nullstring? IF .path exit THEN (setpath ;
|
||||
|
||||
\ *** Block No. 10, Hexblock a
|
||||
|
||||
\ call another executable file ks 04 aug 87
|
||||
Dos definitions
|
||||
|
||||
| Create cpb 0 , \ inherit parent environment
|
||||
dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 ,
|
||||
|
||||
| Code ~exec ( asciz -- *f )
|
||||
I push R push U push S ssave #) mov cpb # R mov
|
||||
$4B00 # A mov $21 int C: D mov D D: mov D S: mov
|
||||
D E: mov ssave #) S mov CS not
|
||||
?[ A A xor A push $2F # A+ mov $21 int E: A mov
|
||||
A D: mov C: A mov A E: mov R I mov dta # W mov
|
||||
$40 # C mov rep movs A D: mov A pop
|
||||
]? A W xchg dta # D mov $1A # A+ mov $21 int
|
||||
W D mov U pop R pop I pop Next
|
||||
end-code
|
||||
|
||||
\ *** Block No. 11, Hexblock b
|
||||
|
||||
\ calling MS-DOS thru forth interpreter ks 19 mr 88
|
||||
|
||||
| : execute? ( extension -- *f )
|
||||
count filename count Ascii . scan drop swap
|
||||
2dup 1+ erase move filename 1+ ~exec ;
|
||||
|
||||
: fcall ( string -- ) count filename place ds@ cpb 4+ !
|
||||
" .EXE" execute? dup IF drop " .COM" execute? THEN
|
||||
?diskerror ;
|
||||
|
||||
: fdos ( string -- )
|
||||
dta $80 erase " /c " count dta place count dta attach
|
||||
status push status off .status COMSPEC fcall curat? at ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 12, Hexblock c
|
||||
|
||||
\ einige MS-DOS Funktionen msdos call ks 10 okt 87
|
||||
|
||||
: dos: Create ," Does> count here place
|
||||
Ascii " parse here attach here fdos ;
|
||||
|
||||
Forth definitions
|
||||
|
||||
dos: dir dir "
|
||||
dos: ren ren "
|
||||
dos: md md "
|
||||
dos: cd cd "
|
||||
dos: rd rd "
|
||||
dos: fcopy copy "
|
||||
dos: delete del "
|
||||
dos: ftype type "
|
||||
|
||||
|
||||
\ *** Block No. 13, Hexblock d
|
||||
|
||||
\ msdos call ks 23 okt 88
|
||||
|
||||
: msdos savevideo status push status off .status
|
||||
flush dta off COMSPEC fcall restorevideo ;
|
||||
|
||||
: call name source >in @ /string c/l umin
|
||||
dta place dta dta >asciz drop [compile] \
|
||||
status push status off .status fcall curat? at ;
|
||||
|
||||
|
||||
.( MS-DOS functions loaed ) cr
|
||||
|
||||
Onlyforth
|
||||
182
8086/msdos/src/extend2.fth
Normal file
182
8086/msdos/src/extend2.fth
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ ks 11 mai 88
|
||||
|
||||
\ This file is a pure .fth-version of extend.fb.
|
||||
\ It contains definitions needed for several further system
|
||||
\ and application files.
|
||||
|
||||
\ Among others there are MSDOS specific commands such as allocating
|
||||
\ memory outside the Forth core 64k memory segment, some routines
|
||||
\ that make using the video display easier, and some string
|
||||
\ manipulation words.
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ loadscreen for often used words ks cas 25sep16
|
||||
|
||||
Onlyforth \needs Assembler include t86asm.fth
|
||||
|
||||
' save-buffers Alias sav
|
||||
|
||||
' name &12 + Constant 'name
|
||||
|
||||
' page Alias cls
|
||||
|
||||
\ 1 8 +thru
|
||||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ Postkernel words ks 22 dez 87
|
||||
|
||||
: blank ( addr quan -- ) bl fill ;
|
||||
|
||||
Code stash ( u1 u2 -- u1 u1 u2 )
|
||||
S W mov W ) push Next end-code
|
||||
\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ;
|
||||
|
||||
: >expect ( addr len -- ) stash expect span @ over place ;
|
||||
|
||||
: .field ( addr len quan -- )
|
||||
over - >r type r> 0 max spaces ;
|
||||
|
||||
: tab ( n -- ) col - 0 max spaces ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ postkernel ks 08 mär 89
|
||||
\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT
|
||||
|
||||
\needs end-code : end-code toss also ;
|
||||
|
||||
: u? ( addr -- ) @ u. ;
|
||||
|
||||
: adr ' >body state @ 0=exit [compile] Literal ; immediate
|
||||
|
||||
: Abort( ( f -- ) IF [compile] .( true abort" !" THEN
|
||||
[compile] ( ;
|
||||
|
||||
: arguments ( n -- )
|
||||
depth 1- > Error" zu wenige Parameter" ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 4, Hexblock 4
|
||||
|
||||
\ MS-DOS memory management
|
||||
|
||||
Code lallocate ( pages -- seg ff / rest err# )
|
||||
R push D R mov $48 # A+ mov $21 int CS
|
||||
?[ A D xchg A pop R push A R xchg
|
||||
][ R pop A push 0 # D mov ]? Next end-code
|
||||
|
||||
Code lfree ( seg -- err# )
|
||||
E: push D E: mov $49 # A+ mov $21 int CS
|
||||
?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 5, Hexblock 5
|
||||
|
||||
\ postkernel ks 03 aug 87
|
||||
|
||||
c/row c/col * 2* Constant c/dis \ characters per display
|
||||
|
||||
Code video@ ( -- seg ) D push R D mov $F # A+ mov
|
||||
$10 int R D xchg 0 # D- mov 7 # A- cmp
|
||||
0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next
|
||||
end-code
|
||||
|
||||
: savevideo ( -- seg / ff )
|
||||
[ c/dis b/seg /mod swap 0<> - ] Literal lallocate
|
||||
IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ;
|
||||
|
||||
: restorevideo ( seg -- ) ?dup 0=exit
|
||||
dup 0 video@ 0 c/dis lmove lfree drop ;
|
||||
|
||||
|
||||
\ *** Block No. 6, Hexblock 6
|
||||
|
||||
\ string operators append attach ks 21 jun 87
|
||||
|
||||
| : .stringoverflow true Abort" String zu lang" ;
|
||||
|
||||
Code append ( char addr -- )
|
||||
D W mov D pop W ) A- mov 1 # A- add CS
|
||||
?[ ;c: .stringoverflow ; Assembler ]?
|
||||
A- W ) mov 0 # A+ mov A W add
|
||||
D- W ) mov D pop Next end-code
|
||||
|
||||
Code attach ( addr len addr1 -- ) D W mov C pop
|
||||
I D mov I pop W ) A- mov A- A+ mov C- A+ add CS
|
||||
?[ ;c: .stringoverflow ; Assembler ]?
|
||||
A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc
|
||||
rep byte movs D I mov D pop Next end-code
|
||||
|
||||
|
||||
\ *** Block No. 7, Hexblock 7
|
||||
|
||||
\\ string operators append attach detract ks 21 jun 87
|
||||
|
||||
: append ( char addr -- )
|
||||
under count + c! dup c@ 1+ swap c! ;
|
||||
|
||||
: attach ( addr len addr.to -- )
|
||||
>r under r@ count + swap move r@ c@ + r> c! ;
|
||||
|
||||
: detract ( addr -- char )
|
||||
dup c@ 1- dup 0> and over c!
|
||||
count >r dup count -rot swap r> cmove ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 8, Hexblock 8
|
||||
|
||||
\ ?" string operator ks 09 feb 88
|
||||
|
||||
\ : (?" ( 8b -- index ) "lit under count rot
|
||||
\ scan IF swap - exit THEN 2drop false ;
|
||||
|
||||
| Create months ," janfebmäraprmaijunjulaugsepoktnovdez"
|
||||
|
||||
: >months ( n -- addr len ) 3 * 2- months + 3 ;
|
||||
|
||||
| Code (?" ( 8b -- index )
|
||||
A D xchg I ) C- mov 0 # C+ mov C I add
|
||||
I W mov I inc std 0<>rep byte scas cld
|
||||
0= ?[ C inc ]? C D mov Next
|
||||
end-code
|
||||
|
||||
: ?" compile (?" ," align ; immediate restrict
|
||||
|
||||
\ *** Block No. 9, Hexblock 9
|
||||
|
||||
\ Conditional compilation ks 12 dez 88
|
||||
| Defer cond
|
||||
|
||||
: .THEN ; immediate
|
||||
|
||||
: .ELSE ( -- ) 0
|
||||
BEGIN name nullstring? IF drop exit THEN
|
||||
find IF cond -1 case? ?exit ELSE drop THEN
|
||||
REPEAT ; immediate
|
||||
|
||||
: .IF ( f -- ) ?exit [compile] .ELSE ; immediate
|
||||
|
||||
| : (cond ( n cfa -- n' )
|
||||
['] .THEN case? IF 1- exit THEN
|
||||
['] .ELSE case? IF dup 0= + exit THEN
|
||||
['] .IF = 0=exit 1+ ; ' (cond is cond
|
||||
|
||||
.( Systemerweiterung geladen) cr
|
||||
192
8086/msdos/src/multivid.fth
Normal file
192
8086/msdos/src/multivid.fth
Normal file
|
|
@ -0,0 +1,192 @@
|
|||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ This file is a pure .fth-version of multi.vid.
|
||||
|
||||
\ This display interface uses BIOS call $10 functions for a fast
|
||||
\ display interface. A couple of state variables is contained
|
||||
\ in a vector that is task specific such that different tasks
|
||||
\ may use different windows. For simplicity windows always
|
||||
\ span the whole width of the screen. They can be defined by
|
||||
\ top and bottom line. This mechanism is used for a convenient
|
||||
\ status display line on the bottom of the screen.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ Multitsking display interface loadscreen ks phz 31jan22
|
||||
Onlyforth \needs Assembler include t86asm.fth
|
||||
|
||||
User area area off \ points at active window
|
||||
Variable status \ to switch status on/off
|
||||
| Variable cursor \ points at area with active cursor
|
||||
|
||||
\ 1 8 +thru .( Multitasking display driver loaded ) cr
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ Multitsking display interface ks 6 sep 86
|
||||
|
||||
: Area: Create 0 , 0 , 7 c, Does> area ! ;
|
||||
\ | col | row | top | bot | att |
|
||||
|
||||
Area: terminal terminal area @ cursor !
|
||||
|
||||
: (area Create dup c, 1+ Does> c@ area @ + ;
|
||||
|
||||
0 | (area ccol | (area crow | (area ctop
|
||||
| (area cbot (area catt drop
|
||||
|
||||
: window ( topline botline -- ) cbot c! ctop c! ;
|
||||
|
||||
: full 0 c/col 2- window ; full
|
||||
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ Multitask (type (emit ks 20 dez 87
|
||||
|
||||
Code (type ( addr len -- ) W pop I push R push
|
||||
u' area U D) I mov U push D U mov
|
||||
$F # A+ mov $10 int u' catt I D) R- mov
|
||||
3 # A+ mov $10 int C push D push $E0E # C mov
|
||||
1 # A+ mov $10 int I ) D mov 1 # C mov
|
||||
U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int
|
||||
D- inc ' c/row >body #) D- cmp 0= not
|
||||
?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]?
|
||||
D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]?
|
||||
2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop
|
||||
R pop I pop D pop ' pause #) jmp end-code
|
||||
|
||||
: (emit ( char -- ) sp@ 1 (type drop ;
|
||||
|
||||
|
||||
\ *** Block No. 4, Hexblock 4
|
||||
|
||||
\ Multitask (at (at? ks 04 aug 87
|
||||
Code (at ( row col -- ) A pop A- D+ mov
|
||||
u' area U D) W mov D W ) mov cursor #) W cmp 0=
|
||||
?[ R push U push $F # A+ mov $10 int
|
||||
2 # A+ mov $10 int U pop R pop
|
||||
]? D pop Next end-code
|
||||
|
||||
Code (at? ( -- row col )
|
||||
D push u' area U D) W mov W ) D mov
|
||||
D+ A- mov 0 # A+ mov A+ D+ mov A push Next
|
||||
end-code
|
||||
|
||||
Code curat? ( -- row col ) D push R push
|
||||
$F # A+ mov $10 int 3 # A+ mov $10 int
|
||||
R pop 0 # A mov D+ A- xchg A push Next
|
||||
end-code
|
||||
|
||||
\ *** Block No. 5, Hexblock 5
|
||||
|
||||
\ cur! curshape setpage ks 28 jun 87
|
||||
|
||||
: cur! \ set cursor into current task's window
|
||||
area @ cursor ! (at? (at ; cur!
|
||||
|
||||
Code curshape ( top bot -- ) D C mov D pop
|
||||
D- C+ mov 1 # A+ mov $10 int D pop Next
|
||||
end-code
|
||||
|
||||
Code setpage ( n -- )
|
||||
$503 # A mov D- A- and $10 int D pop Next
|
||||
end-code
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 6, Hexblock 6
|
||||
|
||||
\ Multitask normal invers blankline ks 01 nov 88
|
||||
: normal 7 catt c! ; : invers $70 catt c! ;
|
||||
: underline 1 catt c! ; : bright $F catt c! ;
|
||||
|
||||
Code blankline D push R push U push $F # A+ mov
|
||||
$10 int u' area U D) W mov u' catt W D) R- mov
|
||||
3 # A+ mov $10 int C push D push
|
||||
$E0E # C mov 1 # A+ mov $10 int W ) D mov
|
||||
2 # A+ mov $10 int ' c/row >body #) C mov
|
||||
D- C- sub bl # A- mov 9 # A+ mov
|
||||
C- C- or 0= not ?[ $10 int ]?
|
||||
D pop 2 # A+ mov $10 int \ set cursor back
|
||||
C pop 1 # A+ mov $10 int \ cursor visible again
|
||||
U pop R pop D pop ' pause #) jmp end-code
|
||||
|
||||
| : lineerase ( line# -- ) 0 (at blankline ;
|
||||
|
||||
\ *** Block No. 7, Hexblock 7
|
||||
|
||||
\ Multitask (del scroll (cr (page ks 04 okt 87
|
||||
|
||||
: (del (at? ?dup
|
||||
IF 1- 2dup (at bl (emit (at exit THEN drop ;
|
||||
|
||||
Code scroll D push R push U push
|
||||
u' area U D) W mov u' catt W D) R+ mov
|
||||
u' ctop W D) D mov D- C+ mov 0 # C- mov
|
||||
' c/row >body #) D- mov D- dec $601 # A mov
|
||||
$10 int U pop R pop D pop Next
|
||||
end-code
|
||||
|
||||
: (cr (at? drop 1+ dup cbot c@ u>
|
||||
IF scroll drop cbot c@ THEN lineerase ;
|
||||
|
||||
: (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ;
|
||||
|
||||
\ *** Block No. 8, Hexblock 8
|
||||
|
||||
\ Multitask status display ks 10 okt 87
|
||||
|
||||
' (emit ' display 2 + ! ' (cr ' display 4 + !
|
||||
' (type ' display 6 + ! ' (del ' display 8 + !
|
||||
' (page ' display &10 + !
|
||||
' (at ' display &12 + ! ' (at? ' display &14 + !
|
||||
|
||||
: .base base @ decimal dup 2 .r base ! ;
|
||||
: .sp ( n -- ) ." s" depth swap 1+ - 2 .r ;
|
||||
: (.drv ( n -- ) Ascii A + emit ." : " ;
|
||||
: .dr ." " drv (.drv ;
|
||||
: .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN
|
||||
@ 5 .r ;
|
||||
: .space ." Dic" s0 @ here $100 + - 6 u.r ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 9, Hexblock 9
|
||||
|
||||
\ statuszeile ks ks 04 aug 87
|
||||
|
||||
| : fstat ( n -- ) .base .sp
|
||||
.space .scr .dr file? 2 spaces order ;
|
||||
|
||||
| Area: statusline
|
||||
statusline c/col 1- dup window page invers terminal
|
||||
|
||||
: (.status output @ display area @ statusline
|
||||
status @ IF (at? drop 0 (at 2 fstat blankline
|
||||
ELSE normal page invers
|
||||
THEN area ! output ! ;
|
||||
' (.status Is .status
|
||||
|
||||
: bye status off .status bye ;
|
||||
|
||||
.( Multitasking display driver loaded ) cr
|
||||
14
8086/msdos/src/t86asm.fth
Normal file
14
8086/msdos/src/t86asm.fth
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ conditional Assembler compiler cas 10nov05
|
||||
here
|
||||
|
||||
: maybe-include-tmp-asm ( addr -- ) hide last off dp !
|
||||
" ASSEMBLER" find nip ?exit here $1800 + sp@ u>
|
||||
IF display cr ." Assembler won't fit" abort THEN
|
||||
here sp@ $1800 - dp !
|
||||
include
|
||||
dp ! ;
|
||||
|
||||
maybe-include-tmp-asm 86asm.fth
|
||||
|
|
@ -1,5 +1,13 @@
|
|||
|
||||
include extend.fb
|
||||
include multi.vid
|
||||
include dos.fb
|
||||
include log2file.fb
|
||||
include extend2.fth
|
||||
include multivid.fth
|
||||
|
||||
\ : .blk|tib
|
||||
\ blk @ ?dup IF ." Blk " u. ?cr exit THEN
|
||||
\ incfile @ IF tib #tib @ cr type THEN ;
|
||||
|
||||
\ ' .blk|tib Is .status
|
||||
|
||||
\ include dos2.fth
|
||||
include dos3.fth
|
||||
include log2file.fth
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user