6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2025-04-06 18:37:24 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #38 from pzembrod/msdos-tests

Browse Source 
First .fth-based v4th.com
This commit is contained in:
Carsten Strotmann 2022-03-22 22:12:24 +00:00 committed by GitHub
commit 1a3bc28e53
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
80 changed files with 15145 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
8086/msdos/Makefile
View File

@ -6,32 +6,92 @@ fbfiles_uppercase = $(wildcard src/*.FB tests/*.FB)
fthfiles_caseconverted = $(patsubst %.fb, %.fth, \
$(shell ../../tools/echo-tolower.py $(fbfiles_uppercase)))
test: incltest.result logtest.result test-min.result
test: incltest.result logtest.result test-min.result \
incltest-volks4th.result test-volks4th-min.result
fth: $(fthfiles) $(fthfiles_caseconverted)
clean:
rm -f *.log *.LOG *.result *.golden
rm -f dosfiles/*
*.log: emulator/run-in-dosbox.sh
metafile.com: v4thfile.com src/meta.fb src/mk-meta.fth tests/log2file.fb
rm -f METAFILE.COM OUTPUT.LOG
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \
v4thfile.com "include mk-meta.fth"
dos2unix -n OUTPUT.LOG metafile.log
grep -F 'Metacompiler saved as metafile.com' metafile.log
v4th.com: metafile.com src/meta.fb src/mk-v4th.fth \
src/vf86core.fth src/vf86dos.fth
rm -f v4th.com V4TH.COM OUTPUT.LOG
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \
metafile.com "include mk-v4th.fth"
dos2unix -n OUTPUT.LOG v4th.log
mv V4TH.COM v4th.com
grep -F 'new kernel written as v4th.com' v4th.log
# o4th for old volks4th - the new v4th is built with precompiled
# metacompiler metafile.com and mk-v4th.fth which writes a compile log.
o4th.com o4th.log: volks4th.com src/kernel.fb
rm -f FORTH.COM forth.com o4th.com
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \
volks4th.com "include kernel.fb"
dos2unix -n OUTPUT.LOG o4th.log
mv FORTH.COM o4th.com
v4thfile.com: volks4th.com src/include.fb src/v4thfile.fb \
emulator/run-in-dosbox.sh
rm -f V4THFILE.COM v4thfile.com
./emulator/run-in-dosbox.sh volks4th.com v4thfile.fb
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include v4thfile.fb"
mv V4THFILE.COM v4thfile.com
logtest.log: volks4th.com tests/log2file.fb tests/logtest.fb \
emulator/run-in-dosbox.sh
./emulator/run-in-dosbox.sh volks4th.com logtest.fb
logtest.log: volks4th.com tests/log2file.fb tests/logtest.fb
rm -f OUTPUT.LOG
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include logtest.fb"
dos2unix -n OUTPUT.LOG $@
incltest.log: v4thfile.com tests/log2file.fb tests/incltest.fth \
emulator/run-in-dosbox.sh
./emulator/run-in-dosbox.sh v4thfile.com incltest.fth
logappendtest.log: v4thfile.com tests/logapp.fth
rm -f OUTPUT.LOG
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh v4thfile.com "include logapp.fth"
dos2unix -n OUTPUT.LOG $@
test-min.log: v4thfile.com tests/* emulator/run-in-dosbox.sh
rm -f TEST.LOG
./emulator/run-in-dosbox.sh v4thfile.com test-min.fth
mv TEST.LOG $@
prepsrcs = asm.fb extend.fb multi.vid dos.fb include.fb
incltest.log: \
$(patsubst %, dosfiles/%, v4th.com $(prepsrcs) log2file.fb \
incltest.fth)
rm -f dosfiles/OUTPUT.LOG
(cd dosfiles && ../emulator/run-in-dosbox.sh \
v4th.com "include include.fb include incltest.fth")
dos2unix -n dosfiles/OUTPUT.LOG $@
test-min.log: \
$(patsubst %, dosfiles/%, v4th.com $(prepsrcs)) \
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
rm -f dosfiles/OUTPUT.LOG
(cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \
"include testprep.fb include test-min.fth")
dos2unix -n dosfiles/OUTPUT.LOG $@
incltest-volks4th.log: v4thfile.com tests/log2file.fb tests/incltest.fth
rm -f OUTPUT.LOG
FORTHPATH="f:\\;f:\\tests" ./emulator/run-in-dosbox.sh \
v4thfile.com "include incltest.fth"
dos2unix -n OUTPUT.LOG $@
test-volks4th-min.log: v4thfile.com tests/* emulator/run-in-dosbox.sh
rm -f OUTPUT.LOG
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \
v4thfile.com "include test-min.fth"
dos2unix -n OUTPUT.LOG $@
run-editor: volks4th.com emulator/run-in-dosbox.sh
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com
test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core)
@ -41,14 +101,35 @@ test-std.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double report-noblk)
cat $? > $@
test-volks4th-min.golden: $(patsubst %, tests/golden/%.golden, \
volks4th-prelim core)
cat $? > $@
%.golden: tests/golden/%.golden
cp -p $< $@
%-volks4th.golden: tests/golden/%.golden
cp -p $< $@
%.result: %.log %.golden tests/evaluate-test.sh
rm -f $@
tests/evaluate-test.sh $(basename $@)
dosfiles/%: %
test -d dosfiles || mkdir dosfiles
cp $< $@
dosfiles/%: src/%
test -d dosfiles || mkdir dosfiles
cp $< $@
dosfiles/%: tests/%
test -d dosfiles || mkdir dosfiles
cp $< $@
src/%.fth: src/%.fb ../../tools/fb2fth.py
../../tools/fb2fth.py $< $@

24
8086/msdos/emulator/run-in-dosbox.sh
View File

@ -2,18 +2,12 @@
set -e
emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")"
basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")"
forth="$1"
include_filename="$2"
include_basename="${include_filename%.*}"
forthcmd=""
forthcmd="$2"
exit=""
bye=""
if [ -n "${include_basename}" ]; then
forthcmd="include ${include_filename}"
logname="${include_basename}.log"
if [ -n "${forthcmd}" ]; then
logname="output.log"
doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')"
rm -f "${logname}" "${doslogname}"
if [ -z "${KEEPEMU}" ]; then
@ -24,13 +18,13 @@ fi
auto_c=""
autocmd=""
pathcmd=""
if [ -n "${forth}" ]; then
auto_c="-c"
autocmd="${forth} path f:\\;f:\\src;f:\\tests ${forthcmd} ${bye}"
if [ -n "${FORTHPATH}" ]; then
pathcmd="path ${FORTHPATH}"
fi
autocmd="${forth} ${pathcmd} ${forthcmd} ${bye}"
fi
dosbox -c "mount f ${basedir}" -c "f:" "${auto_c}" "${autocmd}" $exit
if [ -n "${include_basename}" ]; then
dos2unix -n "${doslogname}" "${logname}"
fi
dosbox -c "mount f ." -c "f:" "${auto_c}" "${autocmd}" $exit

BIN
8086/msdos/metafile.com Normal file
View File

Binary file not shown.

BIN
8086/msdos/o4th.com Normal file
View File

Binary file not shown.

67
8086/msdos/readme.org
View File

@ -1,15 +1,69 @@
#+TITLE: VolksForth MS-DOS README
#+AUTHOR: Carsten Strotmann
#+DATE: <2020-06-19 Fri>
#+AUTHOR: Carsten Strotmann, Philip Zembrod
#+DATE: <2022-03-13 Sun>
* How to meta-compile a new kernel
* Refactoring in progress
MSDOS VolksForth is currently in transition towards make based
and stream file (.fth) based builds.
* Documentation for make based builds
The central Makefile is written for GNU make on Linux and uses
the DOS emulator dosbox to run VolksForth and Metacompiler
binaries for building new VolksForth binaries and for running
tests. The make rules also use several Linux tools, e.g.
bash, Python, grep or dos2unix.
volks4th.com is the old checked-in full VolksForth binary
with editor etc, manually compiled from block sources as
described in the "Previous .fb-based manual build instructions".
It is intended to remain untouched throughout the transition
period until it can be safely replaced by new .fth-based
kernels with build-in .fth interface.
** Binary make targets
=make v4th.com=
builds the new minimal VolksForth kernel v4th.com from
.fth sources using metafile.com.
=make metafile.com=
builds the metacompiler with included .fth file interface.
It is used to build v4th.com, so metafile.com will be built
as part of the make rule for v4th.com. Note: metafile.com
is mostly still built from meta.fb, i.e. from block sources.
=make o4th.com=
builds a new minimal VolksForth kernel from kernel.fb, i.e.
from block sources. This is equivalent to the previous
"How to meta-compile a new kernel" instruction.
=make v4thfile.com=
adds the .fth file interface to the old volks4th binary.
** Test make targets
=make test=
runs all current tests.
=make test-min.result=
runs v4th.com through the initial minimal set of unit tests.
=make test-volks4th-min.result=
runs the same initial minimal set of unit tests on v4thfile.com
which is the old volks4th.com binary with added .fth file interface.
* Previous .fb-based manual build instructions
** How to meta-compile a new kernel
After making changes the the Forth kernel source in =kernel.fb=,
restart =volksforth.com= to have a clean system and compile a new
"minimal" kernel with =include kernel.fb=. This will create a new
=FORTH.COM= executable.
* creating a minimal system with a simple editor
** creating a minimal system with a simple editor
Execute =forth.com include minimal.sys= to generate the file
=minimal.com= which contains a minimal VolksForth system with the
@ -19,11 +73,12 @@
This system can be used to edit the file =volksforth.sys= or other
Forth source block files needed to create a full VolksForth system.
* creating a full VolksForth system from the minimal kernel
** creating a full VolksForth system from the minimal kernel
Execute =forth.com include volks4th.sys= to create a new fully
equipped VolksForth executable =volks4th.com=.
* creating a version of VolksForth that works with emu2
** creating a version of VolksForth that works with emu2
EMU2 is a nice PC Emulator that can run MS-DOS console applications
as Linux/MacOS/Windows console applications. EMU2 can be found at

0
8086/msdos/ansi.vid → 8086/msdos/src/ansi.vid
View File

0
8086/msdos/asm.fb → 8086/msdos/src/asm.fb
View File

437
8086/msdos/src/asm.fth Normal file
View File

@ -0,0 +1,437 @@
\ *** 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. 2, Hexblock 2
\ conditional Assembler compiler cas 10nov05
here
: temp-assembler ( 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 ! 1 load dp ! ;
temp-assembler \\
: blocks ( n -- addr / ff )
first @ >r dup 0 ?DO freebuffer LOOP
[ b/blk negate ] Literal * first @ + r@ u> r> and ;
\ *** 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 ;
\ *** Block No. 22, Hexblock 16

0
8086/msdos/bios.vid → 8086/msdos/src/bios.vid
View File

0
8086/msdos/blocking.fb → 8086/msdos/src/blocking.fb
View File

57
8086/msdos/src/blocking.fth Normal file
View File

@ -0,0 +1,57 @@
\ *** Block No. 0, Hexblock 0
\ cas 11nov05
Routines to copy physical blocks into files.
The copy will done from the current file and drive into a new
file created in on the current MS-DOS drive and sub-directory.
So there can be a different drives used in the DIRECT Mode and
in the FILE Mode.
This command sequence will copy the physical blocks 10-20 on
driver C: into file "TEST.FB" on drive D: in Subdirectory
"\VOLKS".
KERNEL.FB D: CD \VOLKS
DIRECT C:
10 20 BLOCKS>FILE TEST.FB
\ *** Block No. 1, Hexblock 1
\ copy physical blocks to file cas 10nov05
| File outfile
: blocks>file ( <filename> from to -- ) [ Dos ]
isfile@ -rot outfile make 1+ swap
?DO I over (block
ds@ swap b/blk isfile@ lfputs
LOOP close isfile ! ;
\ *** Block No. 2, Hexblock 2

0
8086/msdos/ced.fb → 8086/msdos/src/ced.fb
View File

152
8086/msdos/src/ced.fth Normal file
View File

@ -0,0 +1,152 @@
\ *** Block No. 0, Hexblock 0
\ Commandline EDitor for volksFORTH rev. 3.80 cas 10nov05
This File contains definitions to create an editable Forth
command line with history.
The commandline histroy allows older commands to be recalled.
These older commands will be stored in Screen 0 in a file called
"history" and will be preserved even when calling SAVE-SYSTEM.
Keys:
Cursor left/right  
Delete Char <del> und <-
Delete Line <esc>
toggle Insert <ins>
finish line <enter>
Jump to Beginning/End of Line <pos1> <end>
recall older commands  
\ *** Block No. 1, Hexblock 1
\ Commandline EDitor LOAD-Screen cas 10nov05
: curleft ( -- ) at? 1- at ;
: currite ( -- ) at? 1+ at ;
1 5 +thru \ enhanced Input
.( Commandline Editor loaded ) cr
\ *** Block No. 2, Hexblock 2
\ History -- Commandhistory cas 10nov05
makefile history 1 more
| Variable line# line# off
| Variable lastline# lastline# off
| : 'history ( n -- addr ) isfile push history
c/l * b/blk /mod block + ;
| : @line ( n -- addr len ) 'history c/l -trailing ;
| : !history ( addr line# -- )
'history dup c/l blank span @ c/l min cmove update ;
| : @history ( addr line# -- )
@line rot swap dup span ! cmove ;
| : +line ( n addr -- ) dup @ rot + l/s mod swap ! ;
\ *** Block No. 3, Hexblock 3
\ End of input cas 10nov05
| Variable maxchars | Variable insert insert on
| : -text ( a1 a2 l -- 0=equal ) bounds
?DO count I c@ - ?dup IF nip ENDLOOP exit THEN LOOP 0= ;
| : done ( a p1 -- a p2 ) 2dup
at? rot - span @ dup maxchars ! + at space blankline
line# @ @line span @ = IF span @ -text 0=exit 2dup THEN
drop lastline# @ !history 1 lastline# +line ;
\ *** Block No. 4, Hexblock 4
\ enhanced input cas 10nov05
| : redisplay ( addr pos -- )
at? 2swap span @ swap /string type blankline at ;
| : del ( addr pos -- ) span @ 0=exit dup >r + dup 1+ swap
span @ r> - cmove -1 span +! ;
| : ins ( addr pos1 -- ) dup >r + dup dup 1+
span @ r> - cmove> bl swap c! 1 span +! ;
| : delete ( a p1 -- a p2 ) 2dup del 2dup redisplay ;
| : back ( a p1 -- a p2 ) 1- curleft delete ;
| : recall ( a p1 -- a p2 ) at? rot - at dup line# @ @history
dup 0 redisplay at? span @ + at span @ ;
| : <start ( a1 p1 -- a2 p2 ) at? rot - at 0 ;
\ *** Block No. 5, Hexblock 5
\ Keyassignment for Commandline-Editor MS-DOS cas 10nov05
: (decode ( addr pos1 key -- addr pos2 )
-&77 case? IF dup span @ < 0=exit currite 1+ exit THEN
-&75 case? IF dup 0=exit curleft 1- exit THEN
-&82 case? IF insert @ 0= insert ! exit THEN
#bs case? IF dup 0=exit back exit THEN
-&83 case? IF span @ 2dup < and 0=exit delete exit THEN
-&72 case? IF -1 line# +line recall exit THEN
-&80 case? IF 1 line# +line recall exit THEN
#cr case? IF done exit THEN
#esc case? IF <start span off 2dup redisplay exit THEN
-&71 case? IF <start exit THEN
-&79 case? IF at? rot - span @ + at span @ exit THEN
dup emit >r insert @ IF 2dup ins THEN 2dup +
r> swap c! 1+ dup span @ max span ! 2dup redisplay ;
\ *** Block No. 6, Hexblock 6
\ Patch cas 10nov05
: showcur ( -- )
insert @ IF &11 ELSE &6 THEN &12 curshape ;
: (expect ( addr len -- ) maxchars ! span off
lastline# @ line# ! 0
BEGIN span @ maxchars @ u<
WHILE key decode showcur REPEAT 2drop ;
' (decode ' keyboard 6 + !
' (expect ' keyboard 8 + !
\ *** Block No. 7, Hexblock 7

0
8086/msdos/disasm.fb → 8086/msdos/src/disasm.fb
View File

836
8086/msdos/src/disasm.fth Normal file
View File

@ -0,0 +1,836 @@
\ *** Block No. 0, Hexblock 0
\
\ *** Block No. 1, Hexblock 1
\ A disassembler for the 8086 by Charles Curley cas 10nov05
\ adapted to volksFORTH-83 by B. Molte
| : internal 1 ?head ! ;
| : external ?head off ;
onlyFORTH forth DEFINITIONS DECIMAL
VOCABULARY DISAM DISAM also DEFINITIONS
2 capacity 1- thru
onlyforth
cr .( Use DIS <name> to disassemble word. )
cr .( ESC will stop the output. )
\ *** Block No. 2, Hexblock 2
\ cas 10nov05
internal
: [and] and ; \ the forth and
: [or] or ;
: mask ( n maskb -- n n' ) over and ;
5 constant 5 \ save some space
6 constant 6
7 constant 7
8 constant 8
\ *** Block No. 3, Hexblock 3
\
internal
: EXEC [and] 2* R> + PERFORM ;
: STOP[
0 ?pairs [compile] [ reveal ; immediate restrict
code shift> \ n ct --- n' | shift n right ct times
D C mov D pop D C* shr next end-code
\ : shift> 0 ?DO 2/ ( shift's artihm.!) $7FFF and LOOP ;
code SEXT \ n --- n' | sign extend lower half of n to upper
D A mov cbw A D mov next end-code
\ : hsext $FF and dup $80 and IF $FF00 or THEN ;
\ *** Block No. 4, Hexblock 4
\
external
VARIABLE RELOC 0 , ds@ 0 RELOC 2! \ keeps relocation factor
internal
VARIABLE CP
VARIABLE OPS \ operand count
: cp@ cp @ ;
: C? C@ . ;
: (T@) RELOC 2@ ROT + L@ ; \ in first word, seg in 2nd. You
\ dump/dis any segment w/ any
: (TC@) RELOC 2@ ROT + LC@ ; \ relocation you want by setting
\ RELOC correctly.
: SETSEG RELOC 2+ ! ;
\ *** Block No. 5, Hexblock 5
\
external
DEFER T@ DEFER TC@
: HOMESEG ds@ SETSEG ; HOMESEG
: SEG? RELOC 2+ @ 4 U.r ;
: .seg:off seg? ." :" cp@ 4 u.r 2 spaces ;
: MEMORY ['] (TC@) IS TC@ ['] (T@) IS T@ ; MEMORY
\ *** Block No. 6, Hexblock 6
\
internal
: oops ." ??? " ;
: OOPS0 oops ;
: OOPS1 oops drop ;
: OOPS2 oops 2drop ;
\ *** Block No. 7, Hexblock 7
\
: NEXTB CP@ TC@ 1 CP +! ;
: NEXTW CP@ T@ 2 CP +! ;
: .myself \ --- | have the current word print out its name.
LAST @ [COMPILE] LITERAL COMPILE .name ; IMMEDIATE
\ *** Block No. 8, Hexblock 8
\
internal
VARIABLE IM \ 2nd operand extension flag/ct
: ?DISP \ op ext --- op ext | does MOD operand have a disp?
DUP 6 shift> DUP 3 = OVER 0= [or] 0= IF IM ! exit then
0= IF DUP 7 [and] 6 = IF 2 IM ! THEN THEN ;
: .SELF \ -- | create a word which prints its name
CREATE LAST @ , DOES> @ .name ; \ the ultimate in self-doc!
\ *** Block No. 9, Hexblock 9
\ register byte/word
internal
create wreg-tab ," ACDRSUIW"
create breg-tab ," A-C-D-R-A+C+D+R+"
: .16REG \ r# --- | register printed out
7 and wreg-tab 1+ + c@ emit space ;
: .8REG \ r# --- | register printed out
7 and 2* breg-tab 1+ + 2 type space ;
: .A 0 .16reg ; : .A- 0 .8reg ;
: .D 2 .16reg ;
\ *** Block No. 10, Hexblock a
\ indizierte/indirekte Adressierung cas 10nov05
internal
: ?d DUP 6 shift> 3 [and] 1 3 uwithin ;
: .D) ( disp_flag ext -- op ) \ indirect
?d IF ." D" THEN ." ) " ; \ with/without Displacement
: .I) ( disp_flag ext -- op ) \ indexted indirect
?d IF ." D" THEN ." I) " ; \ with/without Displacement
\ *** Block No. 11, Hexblock b
\ indexed/indirect addressing cas 10nov05
internal
: I) 6 .16reg .D) ;
: W) 7 .16reg .D) ;
: R) 3 .16reg .D) ;
: S) 4 .16reg .D) ;
: U) 5 .16reg .D) ;
: U+W) 5 .16reg 7 .16reg .I) ;
: R+I) 3 .16reg 6 .16reg .I) ;
: U+I) 5 .16reg 6 .16reg .I) ;
: R+W) 3 .16reg 7 .16reg .I) ;
: .# ." # " ;
\ *** Block No. 12, Hexblock c
\
internal
: (.R/M) \ op ext --- | print a register
IM OFF SWAP 1 [and] IF .16REG exit then .8REG ;
: .R/M \ op ext --- op ext | print r/m as register
2DUP (.R/M) ;
: .REG \ op ext --- op ext | print reg as register
2DUP 3 shift> (.R/M) ;
\ *** Block No. 13, Hexblock d
\
internal
CREATE SEGTB ," ECSD"
: (.seg ( n -- )
3 shift> 3 and segtb + 1+ c@ emit ;
: .SEG \ s# --- | register printed out
(.seg ." : " ;
: SEG: \ op --- | print segment overrides
(.seg ." S:" ;
\ *** Block No. 14, Hexblock e
\
internal
: disp@ ( ops-cnt -- )
ops +! CP@ IM @ + IM off ." $" ;
: BDISP \ --- | do if displacement is byte
1 disp@ TC@ sext U. ;
: WDisp \ --- | do if displacement is word
2 disp@ T@ U. ;
: .DISP \ op ext --- op ext | print displacement
DUP 6 shift> 3 EXEC noop BDISP WDISP .R/M STOP[
: BIMM \ --- | do if immed. value is byte
1 disp@ TC@ . ;
\ *** Block No. 15, Hexblock f
\
internal
: .MREG \ op ext --- op ext | register(s) printed out + disp
$C7 mask 6 = IF WDISP ." ) " exit then
$C0 mask $C0 - 0= IF .R/M exit THEN
.DISP DUP 7 exec
R+I) R+W) U+I) U+W) \ I) oder DI)
I) W) U) R) \ ) oder D)
;
\ *** Block No. 16, Hexblock 10
\
internal
: .SIZE \ op --- | decodes for size; WORD is default
1 [and] 0= IF ." BYTE " THEN ;
create adj-tab ," DAADASAAAAASAAMAAD"
: .adj-tab 3 * adj-tab 1+ + 3 type space ;
: ADJUSTS \ op --- | the adjusts
3 shift> 3 [and] .adj-tab ;
: .AAM 4 .adj-tab nextb 2drop ;
: .AAD 5 .adj-tab nextb 2drop ;
\ *** Block No. 17, Hexblock 11
\
internal
: .POP \ op --- | print pops
DUP 8 = IF OOPS1 THEN .SEG ." POP " ;
: .PUSH \ op --- | print pushes
.SEG ." PUSH " ;
: P/P \ op --- | pushes or pops
1 mask IF .pop ELSE .push THEN ;
\ *** Block No. 18, Hexblock 12
\
internal
: P/SEG \ op --- | push or seg overrides
DUP 5 shift> 1 exec P/P SEG: STOP[
: P/ADJ \ op --- | pop or adjusts
DUP 5 shift> 1 exec P/P ADJUSTS STOP[
: 0GP \ op --- op | opcode decoded & printed
4 mask IF 1 mask
IF WDISP ELSE BIMM THEN .#
1 [and] IF .A ELSE .A- THEN ELSE
NEXTB OVER 2 [and]
IF .MREG .REG ELSE ?DISP .REG .MREG
THEN 2DROP THEN ;
\ *** Block No. 19, Hexblock 13
\
external
.SELF ADD .SELF ADC .SELF AND .SELF XOR
.SELF OR .SELF SBB .SELF SUB .SELF CMP
internal
: 0GROUP \ op --- | select 0 group to print
DUP 0GP 3 shift> 7 EXEC
ADD OR ADC SBB AND SUB XOR CMP STOP[
: LOWS \ op --- | 0-3f opcodes printed out
DUP 7 EXEC
0GROUP 0GROUP 0GROUP 0GROUP
0GROUP 0GROUP P/SEG P/ADJ STOP[
\ *** Block No. 20, Hexblock 14
\
internal
: .REGGP \ op --- | register group defining word
CREATE LAST @ , DOES> @ SWAP .16REG .name ;
external
.REGGP INC .REGGP DEC .REGGP PUSH .REGGP POP
: POPs \ op --- | handle illegal opcode for cs pop
$38 mask 8 = IF ." illegal" DROP ELSE POP THEN ;
: REGS \ op --- | 40-5f opcodes printed out
DUP 3 shift> 3 exec INC DEC PUSH POPs STOP[
\ *** Block No. 21, Hexblock 15
\ conditional branches
create branch-tab
," O NO B NB E NE BE NBES NS P NP L GE LE NLE"
: .BRANCH \ op --- | branch printed out w/ dest.
NEXTB SEXT CP@ + u. ASCII J EMIT
&15 [and] 3 * branch-tab 1+ + 3 type ;
\ *** Block No. 22, Hexblock 16
\
\\
\ *** Block No. 23, Hexblock 17
\
internal
: MEDS \ op --- | 40-7f opcodes printed out
DUP 4 shift> 3 exec
REGS REGS OOPS1 .BRANCH STOP[
: 80/81 \ op --- | secondary at 80 or 81
NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# .MREG
SWAP .SIZE 3 shift> 7 EXEC
ADD OR ADC SBB AND SUB XOR CMP STOP[
\ *** Block No. 24, Hexblock 18
\
internal
: 83S \ op --- | secondary at 83
NEXTB ?DISP BIMM .# .MREG
SWAP .SIZE 3 shift> 7 EXEC
ADD OOPS0 ADC SBB oops0 SUB OOPS0 CMP STOP[
: 1GP \ op --- | r/m reg opcodes
CREATE LAST @ , DOES> @ >R NEXTB ?DISP .REG .MREG 2DROP
R> .name ;
external 1GP TEST 1GP XCHG .SELF LEA .SELF MOV internal
: MOVRM/REG NEXTB ?DISP .REG .MREG 2DROP MOV ; \ 88-89
: MOVD NEXTB .MREG .REG 2DROP MOV ; \ 8A-8B
\ *** Block No. 25, Hexblock 19
\
internal
: MOVS>M \ op --- | display instructions 8C-8E
NEXTB OVER $8D = IF .MREG .REG LEA ELSE
OVER $8F = IF .MREG [ ' POP >NAME ] LITERAL .name ELSE
SWAP 1 [or] SWAP \ 16 bit moves only, folks!
OVER 2 [and] IF .MREG DUP .SEG ELSE
DUP .SEG .MREG THEN MOV THEN THEN 2DROP ;
: 8MOVS \ op --- | display instructions 80-8F
DUP 2/ 7 exec
80/81 83S TEST XCHG MOVRM/REG MOVD MOVS>M MOVS>M STOP[
\ *** Block No. 26, Hexblock 1a
\
external
.SELF XCHG .SELF CBW .SELF CWD .SELF CALL .SELF NOP
.SELF WAIT .SELF PUSHF .SELF POPF .SELF SAHF .SELF LAHF
internal
: INTER \ --- | decode interseg jmp or call
NEXTW 4 u.r ." :" NEXTW U. ;
: CALLINTER \ --- | decode interseg call
INTER CALL ;
: 9HIS \ op --- | 98-9F decodes
7 exec
CBW CWD CALLINTER WAIT PUSHF POPF SAHF LAHF STOP[
\ *** Block No. 27, Hexblock 1b
\
internal
: XCHGA \ op --- | 98-9F decodes
dup $90 = IF drop NOP ELSE .A .16REG XCHG THEN ;
: 90S \ op --- | 90-9F decodes
DUP 3 shift> 1 exec XCHGA 9HIS STOP[
: MOVSs \ op --- | A4-A5 decodes
.SIZE ." MOVS " ;
: CMPSs \ op --- | A6-A7 decodes
.SIZE ." CMPS " ;
\ *** Block No. 28, Hexblock 1c
\
internal
: .AL/AX \ op --- | decodes for size
1 EXEC .A- .A STOP[
: MOVS/ACC \ op --- | A0-A3 decodes
2 mask
IF .AL/AX WDISP ." ) " ELSE WDISP ." ) " .AL/AX THEN MOV ;
create ss-tab ," TESTSTOSLODSSCAS"
: .ss-tab 3 [and] 4 * ss-tab 1+ + 4 type space ;
: .TEST \ op --- | A8-A9 decodes
1 mask IF WDISP ELSE BIMM THEN .# .AL/AX 0 .ss-tab ;
\ *** Block No. 29, Hexblock 1d
\
internal
: STOSs ( op --- ) .SIZE 1 .ss-tab ; \ STOS
: LODSs ( op --- ) .SIZE 2 .ss-tab ; \ LODS
: SCASs ( op --- ) .SIZE 3 .ss-tab ; \ SCAS
: A0S \ op --- | A0-AF decodes
DUP 2/ 7 exec
MOVS/ACC MOVS/ACC MOVSs CMPSs .TEST STOSs LODSs SCASs STOP[
: MOVS/IMM \ op --- | B0-BF decodes
8 mask
IF WDISP .# .16REG ELSE BIMM .# .8REG THEN MOV ;
: HMEDS \ op --- | op codes 80 - C0 displayed
DUP 4 shift> 3 exec 8MOVS 90S A0S MOVS/IMM STOP[
\ *** Block No. 30, Hexblock 1e
\
external
.SELF LES .SELF LDS .SELF INTO .SELF IRET
internal
: LES/LDS \ op --- | les/lds instruction C4-C5
NEXTB .MREG .REG DROP 1 exec LES LDS STOP[
external
: RET \ op --- | return instruction C2-C3, CA-CB
1 mask 0= IF WDISP ." SP+" THEN
8 [and] IF ." FAR " THEN .myself ;
internal
: MOV#R/M \ op --- | return instruction C2-C3, CA-CB
NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .#
.MREG MOV 2DROP ;
\ *** Block No. 31, Hexblock 1f
\
external
: INT \ op --- | int instruction CC-CD
1 [and] IF NEXTB ELSE 3 THEN U. .myself ;
internal
: INTO/IRET \ op --- | int & iret instructions CE-CF
1 exec INTO IRET STOP[
: C0S \ op --- | display instructions C0-CF
DUP 2/ 7 exec
OOPS1 RET LES/LDS MOV#R/M OOPS1 RET INT INTO/IRET STOP[
\ *** Block No. 32, Hexblock 20
\
external
.SELF ROL .SELF ROR .SELF RCL .SELF RCR
.SELF SHL/SAL .SELF SHR .SELF SAR
internal
: SHIFTS \ op --- | secondary instructions d0-d3
2 mask IF 0 .8reg ( C-) THEN
NEXTB .MREG NIP 3 shift> 7 exec
ROL ROR RCL RCR SHL/SAL SHR OOPS0 SAR STOP[
: XLAT DROP ." XLAT " ;
: ESC \ op --- | esc instructions d8-DF
NEXTB .MREG 3 shift> 7 [and] U. 7 [and] U. ." ESC " ;
\ *** Block No. 33, Hexblock 21
\
internal
: D0S \ op --- | display instructions D0-DF
8 mask IF ESC EXIT THEN
DUP 7 exec
SHIFTS SHIFTS SHIFTS SHIFTS .AAM .AAD OOPS1 XLAT STOP[
external
.SELF LOOPE/Z .SELF LOOP .SELF JCXZ .SELF LOOPNE/NZ
internal
: LOOPS \ op --- | display instructions E0-E3
NEXTB SEXT CP@ + u. 3 exec
LOOPNE/NZ LOOPE/Z LOOP JCXZ STOP[
external .SELF IN .SELF OUT .SELF JMP
\ *** Block No. 34, Hexblock 22
\
internal
: IN/OUT \ op --- | display instructions E4-E6,EC-EF
8 mask
IF 2 mask IF .AL/AX .D OUT ELSE .D .AL/AX IN THEN
ELSE 2 mask
IF .AL/AX BIMM .# OUT ELSE BIMM .# .AL/AX IN THEN
THEN ;
\ *** Block No. 35, Hexblock 23
\
internal
: CALLs \ op --- | display instructions E7-EB
2 mask IF 1 mask IF NEXTB SEXT CP@ + u.
ELSE INTER THEN
ELSE NEXTW CP@ + u. THEN
3 exec CALL JMP JMP JMP STOP[
: E0S \ op --- | display instructions E0-EF
DUP 2 shift> 3 EXEC LOOPS IN/OUT CALLs IN/OUT STOP[
: FTEST \ op --- | display instructions F6,7:0
?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .#
.MREG DROP .SIZE 0 .ss-tab ; \ TEST
\ *** Block No. 36, Hexblock 24
\
external
.SELF NOT .SELF NEG .SELF MUL .SELF IMUL
.SELF DIV .SELF IDIV .SELF REP/NZ .SELF REPZ
.SELF LOCK .SELF HLT .SELF CMC .SELF CLC
.SELF STC .SELF CLI .SELF STI .SELF CLD
.SELF STD .SELF INC .SELF DEC .SELF PUSH
internal
: MUL/DIV \ op ext --- | secondary instructions F6,7:4-7
.MREG .A OVER 1 [and] IF .D THEN NIP
3 shift> 3 exec MUL IMUL DIV IDIV STOP[
\ *** Block No. 37, Hexblock 25
\
internal
: NOT/NEG \ op ext --- | secondary instructions F6,7:2,3
.MREG SWAP .SIZE 3 shift> 1 exec NOT NEG STOP[
: F6-F7S \ op --- | display instructions F6,7
NEXTB DUP 3 shift> 7 exec FTEST OOPS2 NOT/NEG NOT/NEG
MUL/DIV MUL/DIV MUL/DIV MUL/DIV STOP[
: FES \ op --- | display instructions FE
NEXTB .MREG ." BYTE " NIP 3 shift>
3 exec INC DEC oops oops STOP[
: FCALL/JMP \ op ext --- | display call instructions FF
.MREG 3 shift> 1 mask IF ." FAR " THEN
NIP 2/ 1 exec JMP CALL STOP[
\ *** Block No. 38, Hexblock 26
\
internal
: FPUSH \ op ext --- | display push instructions FF
dup $FF = IF oops2 exit THEN \ FF FF gibt's nicht!
4 mask IF .MREG 2DROP PUSH EXIT THEN OOPS2 ;
: FINC \ op ext --- | display inc/dec instructions FF
.MREG NIP 3 shift> 1 exec INC DEC STOP[
: FFS \ op --- | display instructions FF
NEXTB DUP 4 shift> 3 exec
FINC FCALL/JMP FCALL/JMP FPUSH STOP[
\ *** Block No. 39, Hexblock 27
\
internal
: F0S \ op --- | display instructions F0-FF
&15 mask 7 mask 6 < IF NIP THEN -1 exec
LOCK OOPS0 REP/NZ REPZ HLT CMC F6-F7S F6-F7S
CLC STC CLI STI CLD STD FES FFS STOP[
: HIGHS \ op -- | op codes C0 - FF displayed
DUP 4 shift> 3 exec C0S D0S E0S F0S STOP[
: (INST) \ op --- | highest level vector table
&255 [and] DUP 6 shift>
-1 exec LOWS MEDS HMEDS HIGHS STOP[
\ *** Block No. 40, Hexblock 28
\
internal
: INST \ --- | display opcode at ip, advancing as needed
[ disam ] .seg:off
NEXTB (INST) OPS @ CP +! OPS OFF IM OFF ;
: (DUMP) \ addr ct --- | dump as pointed to by reloc
[ forth ] BOUNDS ?do I TC@ u. LOOP ;
\ *** Block No. 41, Hexblock 29
\
internal
: steps?
1+ dup &10 mod 0= IF key #esc = exit THEN 0 ;
create next-code assembler next forth
: ?next ( steps-count -- steps-count )
cp@ 2@ next-code 2@ D=
IF cr .seg:off ." NEXT Link= " cp@ 4+ @ U.
cp@ 6 + cp ! \ 4 bytes code, 2 byte link
drop 9 \ forces stop at steps?
THEN ;
\ *** Block No. 42, Hexblock 2a
\ ks 28 feb 89
forth definitions
external
: DISASM \ addr --- | disassemble until esc key
[ disam ] CP ! base [ forth ] push hex 0
BEGIN CP@ >R
CR INST R> CP@ OVER - &35 tab (DUMP)
?next ?stack steps?
UNTIL drop ;
: dis ( <name> -- ) ' @ disasm ;
\ *** Block No. 43, Hexblock 2b

0
8086/msdos/disks.cfg → 8086/msdos/src/disks.cfg
View File

0
8086/msdos/dos.fb → 8086/msdos/src/dos.fb
View File

342
8086/msdos/src/dos.fth Normal file
View File

@ -0,0 +1,342 @@
\ *** Block No. 0, Hexblock 0
\ 28 jun 88
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
Onlyforth
\ *** 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 ;
\ *** Block No. 14, Hexblock e
\ time date ks 19 mr 88
Dos definitions
: ftime ( -- mm hh )
open isfile@ f.time @ $20 u/mod nip $40 u/mod ;
: fdate ( -- dd mm yy )
open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
\ *** Block No. 15, Hexblock f
\ ~lseek position? ks 10 okt 87
Dos definitions
Code ~lseek ( d handle method -- d' )
R W mov D A mov R pop C pop D pop
$42 # A+ mov $21 int W R mov CS not
?[ A push Next ]? A D xchg ;c: ?diskerror ;
Forth definitions
: position? ( -- dfaddr )
isfile@ f.handle @ 0= Abort" file not open"
0 0 isfile@ f.handle @ 1 ~lseek ;
\ *** Block No. 16, Hexblock 10
\ *** Block No. 17, Hexblock 11

0
8086/msdos/double.fb → 8086/msdos/src/double.fb
View File

95
8086/msdos/src/double.fth Normal file
View File

@ -0,0 +1,95 @@
\ *** Block No. 0, Hexblock 0
\\ Double words cas 10nov05
This File contains definitions for 32Bit Math
This definitions are already included in the volksFORTH Kernel:
2! 2@ 2drop 2dup 2over 2swap d+ d. d.r
d0= d< d= dabs dnegate
\ *** Block No. 1, Hexblock 1
\ 2constant 2rot 2variable d- d2/ ks 22 dez 87
: 2constant Create , , does> 2@ ;
: 2rot ( d1 d2 d3 -- d2 d3 d1 ) 5 roll 5 roll ;
: 2variable Variable 2 allot ;
: d- ( d1 d2 -- d3 ) dnegate d+ ;
Code d2/ ( d1 -- d2 )
A pop D sar A rcr A push Next end-code
\ *** Block No. 2, Hexblock 2
\ dmax dmin du< ks 22 dez 87
: dmax ( d1 d2 -- d3 )
2over 2over d< IF 2swap THEN 2drop ;
: dmin ( d1 d2 -- d3 )
2over 2over d< IF 2drop exit THEN 2swap 2drop ;
: du< ( 32b1 32b2 -- f )
rot 2dup = IF 2drop u< exit THEN u> -rot 2drop ;
\ *** Block No. 3, Hexblock 3
\ *** Block No. 4, Hexblock 4

0
8086/msdos/editor.fb → 8086/msdos/src/editor.fb
View File

798
8086/msdos/src/editor.fth Normal file
View File

@ -0,0 +1,798 @@
\ *** Block No. 0, Hexblock 0
volksFORTH Full-Screen-Editor HELP Screen cas 11nov05
Quit Editor : flushed: ESC updated: ^E
discard changes : ^U (UNDO)
move cursor : Cursorkeys (delete with DEL or <- )
insert : INS (toggle), ^ENTER (insert Screen)
Tabs : TAB (to right), SHIFT TAB (to left)
paging : Pg Dn (next screen), Pg Up (previous scr)
: F9 (alternate), SHIFT F9 (shadow scr)
mark alternate Scr. : F10
delete/insert line : ^Y (delete), ^N (insert)
split line : ^PgDn (split), ^PgUp (join)
search and replace : F2 (stop with ESC, replace with 'R' )
linebuffer : F3 (push&delete), F5 (push), F7 (pop)
charbuffer : F4 (push&delete), F6 (push), F8 (pop)
misc : ^F (Fix), ^L (Showload), ^S (Screen #)
\ *** Block No. 1, Hexblock 1
--> \ Full-Screen Editor cas 10nov05
This is the Full-Screen Editor for MS-DOS volksFORTH
Features: Line- and Char-Buffer, Find- and Replace, Support for
"Shadow-Screens", View Function and loading of screens with
visual feedback (showload)
The Keybinding can be easily changed by using the integrated
Keytable.
Ported to the MS-DOS volksFORTH by K.Schleisiek on 22 dez 87
Original design by Ullrich Hoffmann
\ *** Block No. 2, Hexblock 2
\ Load Screen for the Editor cas 10nov05
Onlyforth \needs Assembler 2 loadfrom asm.scr
3 load \ PC adaption
4 9 thru \ Editor
\ &10 load \ ANSI display interface
\ &11 load \ BIOS display interface
&12 load \ MULTItasking display interface
&13 &39 thru \ Editor
Onlyforth .( Screen Editor loaded ) cr
\ *** Block No. 3, Hexblock 3
\ BIM adaption UH 11dez88
| : ?range ( n -- n ) isfile@ 0=exit dup 0< 9 and ?diskerror
dup capacity - 1+ 0 max ?dup 0=exit more ;
| : block ( n -- adr ) ?range block ;
$1B Constant #esc
: curon &11 &12 curshape ;
: curoff &14 dup curshape ;
Variable caps caps off
Label ?capital 1 # caps #) byte test
0= ?[ (capital # jmp ]? ret end-code
\ *** Block No. 4, Hexblock 4
\ search delete insert replace ks 20 dez 87
| : delete ( buffer size count -- )
over min >r r@ - ( left over ) dup 0>
IF 2dup swap dup r@ + -rot swap cmove THEN
+ r> bl fill ;
| : insert ( string length buffer size -- )
rot over min >r r@ - ( left over )
over dup r@ + rot cmove> r> cmove ;
| : replace ( string length buffer size -- )
rot min cmove ;
\ *** Block No. 5, Hexblock 5
\ usefull definitions and Editor vocabulary UH 11mai88
Vocabulary Editor
' Forth | Alias [F] immediate
' Editor | Alias [E] immediate
Editor also definitions
| : c ( n --) \ moves cyclic thru the screen
r# @ + b/blk mod r# ! ;
| Variable r#' r#' off
| Variable scr' scr' off
' fromfile | Alias isfile'
| Variable lastfile | Variable lastscr | Variable lastr#
\ *** Block No. 6, Hexblock 6
\\ move cursor with position-checking ks 18 dez 87
\ different versions of cursor positioning error reporting
| : c ( n --) \ checks the cursor position
r# @ + dup 0 b/blk uwithin not
Abort" There is a border!" r# ! ;
| : c ( n --) \ goes thru the screens
r# @ + dup b/blk 1- > IF 1 scr +! THEN
dup 0< IF -1 scr +! THEN b/blk mod r# ! ;
| : c ( n --) \ moves cyclic thru the screen
r# @ + b/blk mod r# ! ;
\ *** Block No. 7, Hexblock 7
\ calculate addresses ks 20 dez 87
| : *line ( l -- adr ) c/l * ;
| : /line ( n -- c l ) c/l /mod ;
| : top ( -- ) r# off ;
| : cursor ( -- n ) r# @ ;
| : 'start ( -- adr ) scr @ block ;
| : 'end ( -- adr ) 'start b/blk + ;
| : 'cursor ( -- adr ) 'start cursor + ;
| : position ( -- c l ) cursor /line ;
| : line# ( -- l ) position nip ;
| : col# ( -- c ) position drop ;
| : 'line ( -- adr ) 'start line# *line + ;
| : 'line-end ( -- adr ) 'line c/l + 1- ;
| : #after ( -- n ) c/l col# - ;
| : #remaining ( -- n ) b/blk cursor - ;
| : #end ( -- n ) b/blk line# *line - ;
\ *** Block No. 8, Hexblock 8
\ move cursor directed UH 11dez88
| Create >at 0 , 0 ,
| : curup c/l negate c ;
| : curdown c/l c ;
| : curleft -1 c ;
| : curright 1 c ;
| : +tab ( 1/4 -> ) cursor $10 / 1+ $10 * cursor - c ;
| : -tab ( 1/8 <- ) cursor 8 mod negate dup 0= 8 * + c ;
| : >last ( adr len -- ) -trailing nip b/blk min r# ! ;
| : <cr> #after c ;
| : <line ( -- ) col# negate c 'line c/l -trailing nip 0=exit
BEGIN 'cursor c@ bl = WHILE curright REPEAT ;
| : line> ( -- ) 'start line# 1+ *line 1- >last ;
| : >""end ( -- ) 'start b/blk >last ;
\ *** Block No. 9, Hexblock 9
\ show border UH 29Sep87
&14 | Constant dx 1 | Constant dy
| : horizontal ( row eck1 eck2 -- row' )
rot dup >r dx 1- at swap emit
c/l 0 DO Ascii - emit LOOP emit r> 1+ ;
| : vertical ( row -- row' )
l/s 0 DO dup dx 1- at Ascii | emit
row dx c/l + at Ascii | emit 1+ LOOP ;
| : border dy 1- Ascii / Ascii \ horizontal
vertical Ascii \ Ascii / horizontal drop ;
| : edit-at ( -- ) position swap dy dx d+ at ;
\ *** Block No. 10, Hexblock a
\ ANSI display interface ks 03 feb 88
| : redisplay ( line# -- )
dup dy + dx at *line 'start + c/l type ;
| : (done ( -- ) ; immediate
| : install-screen ( -- ) l/s 6 + 0 >at 2! page ;
\ *** Block No. 11, Hexblock b
\ BIOS-display interface ks 03 feb 88
| Code (.line ( line addr videoseg -- )
A pop W pop I push E: push D E: mov
$0E # W add W W add A I xchg c/l # C mov
attribut #) A+ mov [[ byte lods stos C0= ?]
E: pop I pop D pop Next end-code
| : redisplay ( line# -- )
dup 1+ c/row * swap c/l * 'start + video@ (.line ;
| : (done ( -- ) ; immediate
| : install-screen ( -- ) l/s 6 + 0 >at 2! page ;
\ *** Block No. 12, Hexblock c
\ MULTI-display interface ks UH 10Sep87
| Code (.line ( line addr videoseg -- )
C pop W pop I push E: push D E: mov
$0E # W add W W add u' area U D) I mov
u' catt I D) A+ mov C I mov
c/l # C mov [[ byte lods stos C0= ?]
E: pop I pop D pop Next end-code
| : redisplay ( line# -- )
dup 1+ c/row * swap c/l * 'start + video@ (.line ;
| : (done ( -- ) line# 2+ c/col 2- window ;
| : cleartop ( -- ) 0 l/s 5 + window (page ;
| : install-screen ( -- ) row l/s 6 + u<
IF l/s 6 + 0 full page ELSE at? cleartop THEN >at 2! ;
\ *** Block No. 13, Hexblock d
\ display screen UH 11mai88
Forth definitions
: updated? ( -- f) 'start 2- @ 0< ;
Editor definitions
| : .updated ( -- ) 9 0 at
updated? IF 4 spaces ELSE ." not " THEN ." updated" ;
| : .screen l/s 0 DO I redisplay LOOP ;
\ | : .file ( fcb -- )
\ ?dup IF body> >name .name exit THEN ." direct" ;
| : .title [ DOS ] 1 0 at isfile@ .file dx 1- tab
2 0 at drv (.drv scr @ 6 .r
4 0 at fromfile @ .file dx 1- tab
5 0 at fswap drv (.drv scr' @ 6 .r fswap .updated ;
| : .all .title .screen ;
\ *** Block No. 14, Hexblock e
\ check errors UH 02Nov86
| : ?bottom ( -- ) 'end c/l - c/l -trailing nip
Abort" You would lose a line" ;
| : ?fit ( n -- ) 'line c/l -trailing nip + c/l >
IF line# redisplay
true Abort" You would lose a char" THEN ;
| : ?end 1 ?fit ;
\ *** Block No. 15, Hexblock f
\ programmer's id ks 18 dez 87
$12 | Constant id-len
Create id id-len allot id id-len erase
| : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ;
| : ?stamp ( -- ) updated? IF stamp THEN ;
| : ## ( n -- ) base push decimal 0 <# # # #> id 1+ attach ;
| : get-id ( -- ) id c@ ?exit ID on
cr ." Enter your ID : " at? 3 0 DO Ascii . emit LOOP at
id 2+ 3 expect normal span @ dup id 1+ c! 0=exit
bl id 1+ append date@ rot ## swap >months id 1+ attach ## ;
\ *** Block No. 16, Hexblock 10
\ update screen-display UH 28Aug87
| : emptybuf prev @ 2+ dup on 4+ off ;
| : undo emptybuf .all ;
| : modified updated? ?exit update .updated ;
| : linemodified modified line# redisplay ;
| : screenmodified modified
l/s line# ?DO I redisplay LOOP ;
| : .modified ( -- ) >at 2@ at space scr @ .
updated? not IF ." un" THEN ." modified" ?stamp ;
\ *** Block No. 17, Hexblock 11
\ leave editor UH 10Sep87
| Variable (pad (pad off
| : memtop ( -- adr) sp@ $100 - ;
| Create char 1 allot
| Variable imode imode off
| : .imode at? 7 0 at
imode @ IF ." insert " ELSE ." overwrite" THEN at ;
| : setimode imode on .imode ;
| : clrimode imode off .imode ;
| : done ( -- ) (done
['] (quit is 'quit ['] (error errorhandler ! quit ;
| : update-exit ( -- ) .modified done ;
| : flushed-exit ( -- ) .modified save-buffers done ;
\ *** Block No. 18, Hexblock 12
\ handle screens UH 21jan89
| : insert-screen ( scr -- ) \ before scr
1 more fromfile push isfile@ fromfile !
capacity 2- over 1+ convey ;
| : wipe-screen ( -- ) 'start b/blk blank ;
| : new-screen ( -- )
scr @ insert-screen wipe-screen top screenmodified ;
\ *** Block No. 19, Hexblock 13
\ handle lines UH 01Nov86
| : (clear-line 'line c/l blank ;
| : clear-line (clear-line linemodified ;
| : clear> 'cursor #after blank linemodified ;
| : delete-line 'line #end c/l delete screenmodified ;
| : backline curup delete-line ;
| : (insert-line
?bottom 'line c/l over #end insert (clear-line ;
| : insert-line (insert-line screenmodified ;
\ *** Block No. 20, Hexblock 14
\ join and split lines UH 11dez88
| : insert-spaces ( n -- ) 'cursor swap
2dup over #remaining insert blank ;
| : split ( -- ) ?bottom cursor col# <cr> insert-spaces r# !
#after insert-spaces screenmodified ;
| : delete-characters ( n -- ) 'cursor #remaining rot delete ;
| : join ( -- ) cursor <cr> line> col# <line col# under -
rot r# ! #after > Abort" next line will not fit!"
#after + dup delete-characters
cursor <cr> c/l rot - dup 0<
IF negate insert-spaces ELSE delete-characters THEN r# !
screenmodified ;
\ *** Block No. 21, Hexblock 15
\ handle characters UH 01Nov86
| : delete-char 'cursor #after 1 delete linemodified ;
| : backspace curleft delete-char ;
| : (insert-char ?end 'cursor 1 over #after insert ;
| : insert-char (insert-char bl 'cursor c! linemodified ;
| : putchar ( --) char c@
imode @ IF (insert-char THEN
'cursor c! linemodified curright ;
\ *** Block No. 22, Hexblock 16
\ stack lines UH 31Oct86
| Create lines 4 allot \ { 2+pointer | 2base }
| : 'lines ( -- adr) lines 2@ + ;
| : @line 'lines memtop u> Abort" line buffer full"
'line 'lines c/l cmove c/l lines +! ;
| : copyline @line curdown ;
| : line>buf @line delete-line ;
| : !line c/l negate lines +! 'lines 'line c/l cmove ;
| : buf>line lines @ 0= Abort" line buffer empty"
?bottom (insert-line !line screenmodified ;
\ *** Block No. 23, Hexblock 17
\ stack characters UH 01Nov86
| Create chars 4 allot \ { 2+pointer | 2base }
| : 'chars ( -- adr) chars 2@ + ;
| : @char 'chars 1- lines 2+ @ u> Abort" char buffer full"
'cursor c@ 'chars c! 1 chars +! ;
| : copychar @char curright ;
| : char>buf @char delete-char ;
| : !char -1 chars +! 'chars c@ 'cursor c! ;
| : buf>char chars @ 0= Abort" char buffer empty"
?end (insert-char !char linemodified ;
\ *** Block No. 24, Hexblock 18
\ switch screens UH 11mai88
| : imprint ( -- ) \ remember valid file
isfile@ lastfile ! scr @ lastscr ! r# @ lastr# ! ;
| : remember ( -- )
lastfile @ isfile ! lastscr @ scr ! lastr# @ r# ! ;
| : associate \ switch to alternate screen
isfile' @ isfile@ isfile' ! isfile !
scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ;
| : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .all ;
| : n ?stamp 1 scr +! .all ;
| : b ?stamp -1 scr +! .all ;
| : a ?stamp associate .all ;
\ *** Block No. 25, Hexblock 19
\ shadow screens UH 03Nov86
Variable shadow shadow off
| : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ;
| : >shadow ?stamp \ switch to shadow screen
(shadow dup scr @ u> not IF negate THEN scr +! .all ;
\ *** Block No. 26, Hexblock 1a
\ load and show screens ks 02 mar 88
| : showoff ['] exit 'name ! normal ;
| : show ( -- ) blk @ 0= IF showoff exit THEN
>in @ 1- r# ! edit-at imprint blk @ scr @ - 0=exit
blk @ scr ! normal curoff .all invers curon ;
| : showload ( -- ) ?stamp save-buffers
['] show 'name ! curon invers
adr .status push ['] noop is .status
scr @ scr push scr off r# push r# @ (load showoff ;
\ *** Block No. 27, Hexblock 1b
\ find strings ks 20 dez 87
| Variable insert-buffer
| Variable find-buffer
| : 'insert ( -- addr ) insert-buffer @ ;
| : 'find ( -- addr ) find-buffer @ ;
| : .buf ( addr -- ) count type ." |" &80 col - spaces ;
| : get ( addr -- ) >r at? r@ .buf
2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN
at r> .buf ;
| : get-buffers dy l/s + 2+ dx 1- 2dup at
." find: |" 'find get swap 1+ swap 2- at
." ? replace: |" 'insert get ;
\ *** Block No. 28, Hexblock 1c
\ ks 20 dez 87
Code match ( addr1 len1 string -- addr2 len2 )
D W mov W ) D- mov $FF # D and 0= ?[ D pop Next ]?
W inc D dec C pop I A mov I pop A push
W ) A- mov W inc ?capital # call A- A+ mov D C sub
>= ?[ I inc Label done I dec
A pop I push A I mov C D add Next ]?
[[ byte lods ?capital # call A+ A- cmp 0=
?[ D D or done 0= not ?]
I push W push C push A push D C mov
[[ byte lods ?capital # call A+ A- xchg
W ) A- mov W inc ?capital # call A+ A- cmp
0= ?[[ C0= ?] A pop C pop
W pop I pop done ]]
]? A pop C pop W pop I pop
]? C0= ?] I inc done ]] end-code
\ *** Block No. 29, Hexblock 1d
\ search for string UH 11mai88
| : skip ( addr -- addr' ) 'find c@ + ;
| : search ( buf len string -- offset flag )
>r stash r@ match r> c@ <
IF drop 0= false exit THEN swap - true ;
| : find? ( -- r# f ) 'cursor #remaining 'find search ;
| : searchthru ( -- r# scr )
find? IF skip cursor + scr @ exit THEN drop
capacity scr @ 1+
?DO I 2 3 at 6 .r I block b/blk 'find search
IF skip I endloop exit THEN stop? Abort" Break!"
LOOP true Abort" not found!" ;
\ *** Block No. 30, Hexblock 1e
\ replace strings UH 14mai88
| : replace? ( -- f ) dy l/s + 3+ dx 3 - at
key dup #cr = IF line# redisplay true Abort" Break!" THEN
capital Ascii R = ;
| : "mark ( -- ) r# push
'find count dup negate c edit-at invers type normal ;
| : (replace 'insert c@ 'find c@ - ?fit
r# push 'find c@ negate c
'cursor #after 'find c@ delete
'insert count 'cursor #after insert modified ;
| : "replace get-buffers BEGIN searchthru
scr @ - ?dup IF ?stamp scr +! .all THEN r# ! imprint
"mark replace? IF (replace THEN line# redisplay REPEAT ;
\ *** Block No. 31, Hexblock 1f
\ Display Help-Screen, misc commands cas 11nov05
| : helpfile ( -- ) fromfile push editor.fb ;
| : .help ( --)
isfile push scr push helpfile scr off .screen ;
| : help ( -- ) .help key drop .screen ;
| : screen# ( -- scr ) scr @ ;
| Defer (fix-word
| : fix-word ( -- ) isfile@ loadfile !
scr @ blk ! cursor >in ! (fix-word ;
\ *** Block No. 32, Hexblock 20
\ Control-Characters IBM-PC Functionkeys UH 10Sep87
Forth definitions
: Ctrl ( -- c )
name 1+ c@ $1F and state @ IF [compile] Literal THEN ;
immediate
\needs #del $7F Constant #del
Editor definitions
| : flipimode imode @ 0= imode ! .imode ;
| : F ( # -- 16b ) $FFC6 swap - ;
| : shift ( n -- n' ) dup 0< + &24 - ;
\ *** Block No. 33, Hexblock 21
\ Control-Characters IBM-PC Functionkeys UH 11dez88
Create keytable
-&72 , -&75 , -&80 , -&77 ,
3 F , 4 F , 7 F , 8 F ,
Ctrl F , Ctrl S , 5 F , 6 F ,
1 F , Ctrl H , #del , -&83 ,
Ctrl Y , Ctrl N ,
-&82 ,
#cr , #tab , #tab shift ,
-&119 , -&117 , 2 F , Ctrl U ,
Ctrl E , #esc , Ctrl L , 9 F shift ,
-&81 , -&73 , 9 F , &10 F ,
-&71 , -&79 , -&118 , -&132 ,
#lf ,
here keytable - 2/ Constant #keys
\ *** Block No. 34, Hexblock 22
\ Try a screen Editor UH 11dez88
Create: actiontable
curup curleft curdown curright
line>buf char>buf buf>line buf>char
fix-word screen# copyline copychar
help backspace backspace delete-char
( insert-char ) delete-line insert-line
flipimode ( clear-line clear> )
<cr> +tab -tab
top >""end "replace undo
update-exit flushed-exit showload >shadow
n b a mark
<line line> split join
new-screen ;
here actiontable - 2/ 1- #keys - abort( # of actions)
\ *** Block No. 35, Hexblock 23
\ find keys ks 20 dez 87
| : findkey ( key -- adr/default )
#keys 0 DO dup keytable [F] I 2* + @ =
IF drop [E] actiontable [F] I 2* + @ endloop exit THEN
LOOP drop ['] putchar ;
\ *** Block No. 36, Hexblock 24
\ allocate buffers UH 01Nov86
c/l 2* | Constant cstack-size
| : nextbuf ( adr -- adr' ) cstack-size + ;
| : ?clearbuffer pad (pad @ = ?exit
pad dup (pad !
nextbuf dup find-buffer ! 'find off
nextbuf dup insert-buffer ! 'insert off
nextbuf dup 0 chars 2!
nextbuf 0 lines 2! ;
\ *** Block No. 37, Hexblock 25
\ enter and exit the editor, editor's loop UH 11mai88
| Variable jingle jingle on | : bell 07 charout jingle off ;
| : clear-error ( -- )
jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ;
| : fullquit ( -- ) BEGIN ?clearbuffer edit-at key dup char c!
findkey imprint execute ( .status ) clear-error REPEAT ;
| : fullerror ( string -- ) jingle @ IF bell THEN count
dy l/s + 1+ over 2/ dx $20 + swap - at invers type normal
&80 col - spaces remember .all quit ;
| : install ( -- )
['] fullquit Is 'quit ['] fullerror errorhandler ! ;
\ *** Block No. 38, Hexblock 26
\ enter and exit the Editor UH 11mai88
Forth definitions
: v ( -- )
[E] 'start drop get-id install-screen
install ?clearbuffer
border .all .imode .status quit ;
' v Alias ed
: l ( scr -- ) 1 arguments scr ! [E] top [F] v ;
' l Alias edit
\ *** Block No. 39, Hexblock 27
\ savesystem enhanced view UH 24jun88
: savesystem [E] id off (pad off savesystem ;
Editor definitions
| : >find ?clearbuffer >in push
name dup c@ 2+ >r bl over c! r> 'find place ;
Forth definitions
: fix [ Dos ] >find ' @view >file
isfile ! scr ! [E] top curdown
find? IF skip 1- THEN c v ;
' fix Is (fix-word
\ *** Block No. 40, Hexblock 28
\ *** Block No. 41, Hexblock 29

0
8086/msdos/epson.prn → 8086/msdos/src/epson.prn
View File

0
8086/msdos/extend.fb → 8086/msdos/src/extend.fb
View File

209
8086/msdos/src/extend.fth Normal file
View File

@ -0,0 +1,209 @@
\ *** Block No. 0, Hexblock 0
\ ks 11 mai 88
Dieses File enthält Definitionen, die zum Laden der weiteren
System- und Applikationsfiles benötigt werden.
Unter anderem finden sich hier auch MS-DOS spezifische
Befehle wie zum Beispiel das Allokieren von Speicher-
platz ausserhalb des auf 64k begrenzten Forthsystems
und einige Routinen, die das Arbeiten mit dem Video-
Display erleichtern sowie einige Operatoren zur String-
manipulation.
\ *** Block No. 1, Hexblock 1
\ loadscreen for often used words ks cas 25sep16
Onlyforth \needs Assembler 2 loadfrom asm.fb
' save-buffers Alias sav
' name &12 + Constant 'name
' page Alias cls
1 8 +thru .( Systemerweiterung geladen) cr
\ *** 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
\ *** Block No. 10, Hexblock a

0
8086/msdos/f83asm.fb → 8086/msdos/src/f83asm.fb
View File

646
8086/msdos/src/f83asm.fth Normal file
View File

@ -0,0 +1,646 @@
\ *** Block No. 0, Hexblock 0
\ 8086 Assembler cas 10nov05
The 8086 Assembler was written by Mike Perry.
To create and assembler language definition, use the defining
word CODE. It must be terminated with either END-CODE or
its synonym C;. How the assembler operates is a very
interesting example of the power of CREATE DOES> Basically
the instructions are categorized and a defining word is
created for each category. When the nmemonic for the
instruction is interpreted, it compiles itself.
Adapted for volksFORTH by Klaus Schleisiek
No really tested, but
CODE TEST TOS PUSH 1 # TOS MOV NEXT END-CODE
works!
\ *** Block No. 1, Hexblock 1
\ 8086 Assembler ks cas 10nov05
Onlyforth
Vocabulary Assembler
: octal 8 Base ! ;
decimal 1 14 +THRU clear
Onlyforth
: Code Create [ Assembler ] here dup 2- ! Assembler ;
CR .( 8086 Assembler loaded )
Onlyforth
\ *** Block No. 2, Hexblock 2
\ 8086 Assembler ks 19 mär 88
: LABEL CREATE ASSEMBLER ;
\ 232 CONSTANT DOES-OP
\ 3 CONSTANT DOES-SIZE
\ : DOES? ( IP -- IP' F )
\ DUP DOES-SIZE + SWAP C@ DOES-OP = ;
ASSEMBLER ALSO DEFINITIONS
: C; ( -- ) END-CODE ;
OCTAL
DEFER C, FORTH ' C, ASSEMBLER IS C,
DEFER , FORTH ' , ASSEMBLER IS ,
DEFER HERE FORTH ' HERE ASSEMBLER IS HERE
DEFER ?>MARK
DEFER ?>RESOLVE
DEFER ?<MARK
DEFER ?<RESOLVE
\ *** Block No. 3, Hexblock 3
\ 8086 Assembler Register Definitions ks 19 mär 88
| : REG 11 * SWAP 1000 * OR CONSTANT ;
| : REGS ( MODE N -- ) SWAP 0 DO DUP I REG LOOP DROP ;
10 0 REGS AL CL DL BL AH CH DH BH
10 1 REGS AX CX DX BX SP BP SI DI
10 2 REGS [BX+SI] [BX+DI] [BP+SI] [BP+DI] [SI] [DI] [BP] [BX]
4 2 REGS [SI+BX] [DI+BX] [SI+BP] [DI+BP]
4 3 REGS ES CS SS DS
3 4 REGS # #) S#)
BP Constant UP [BP] Constant [UP] \ User Pointer
SI CONSTANT IP [SI] CONSTANT [IP] ( INTERPRETER POINTER )
DI Constant W [DI] Constant [W] \ WORKING REGISTER
BX Constant RP [BX] Constant [RP] \ Return Stack Pointer
DX Constant TOS \ Top Of Stack im Register
\ *** Block No. 4, Hexblock 4
\ Addressing Modes ks 19 mär 88
| : MD CREATE 1000 * , DOES> @ SWAP 7000 AND = 0<> ;
| 0 MD R8? | 1 MD R16? | 2 MD MEM? | 3 MD SEG? | 4 MD #?
| : REG? ( n -- f ) 7000 AND 2000 < 0<> ;
| : BIG? ( N -- F ) ABS -200 AND 0<> ;
| : RLOW ( n1 -- n2 ) 7 AND ;
| : RMID ( n1 -- n2 ) 70 AND ;
| VARIABLE SIZE SIZE ON
: BYTE ( -- ) SIZE OFF ;
| : OP, ( N OP -- ) OR C, ;
| : W, ( OP MR -- ) R16? 1 AND OP, ;
| : SIZE, ( OP -- OP' ) SIZE @ 1 AND OP, ;
| : ,/C, ( n f -- ) IF , ELSE C, THEN ;
| : RR, ( MR1 MR2 -- ) RMID SWAP RLOW OR 300 OP, ;
| VARIABLE LOGICAL
| : B/L? ( n -- f ) BIG? LOGICAL @ OR ;
\ *** Block No. 5, Hexblock 5
\ Addressing ks 19 mär 88
| : MEM, ( DISP MR RMID -- ) OVER #) =
IF RMID 6 OP, DROP ,
ELSE RMID OVER RLOW OR -ROT [BP] = OVER 0= AND
IF SWAP 100 OP, C, ELSE SWAP OVER BIG?
IF 200 OP, , ELSE OVER 0=
IF C, DROP ELSE 100 OP, C,
THEN THEN THEN THEN ;
| : WMEM, ( DISP MEM REG OP -- ) OVER W, MEM, ;
| : R/M, ( MR REG -- )
OVER REG? IF RR, ELSE MEM, THEN ;
| : WR/SM, ( R/M R OP -- ) 2 PICK DUP REG?
IF W, RR, ELSE DROP SIZE, MEM, THEN SIZE ON ;
| VARIABLE INTER
: FAR ( -- ) INTER ON ;
| : ?FAR ( n1 -- n2 ) INTER @ IF 10 OR THEN INTER OFF ;
\ *** Block No. 6, Hexblock 6
\ Defining Words to Generate Op Codes ks 19 mär 88
| : 1MI CREATE C, DOES> C@ C, ;
| : 2MI CREATE C, DOES> C@ C, 12 C, ;
| : 3MI CREATE C, DOES> C@ C, HERE - 1-
DUP -200 177 uWITHIN NOT ABORT" Branch out of Range" C, ;
| : 4MI CREATE C, DOES> C@ C, MEM, ;
| : 5MI CREATE C, DOES> C@ SIZE, SIZE ON ;
| : 6MI CREATE C, DOES> C@ SWAP W, ;
| : 7MI CREATE C, DOES> C@ 366 WR/SM, ;
| : 8MI CREATE C, DOES> C@ SWAP R16? 1 AND OR SWAP # =
IF C, C, ELSE 10 OR C, THEN ;
| : 9MI CREATE C, DOES> C@ OVER R16?
IF 100 OR SWAP RLOW OP, ELSE 376 WR/SM, THEN ;
| : 10MI CREATE C, DOES> C@ OVER CL =
IF NIP 322 ELSE 320 THEN WR/SM, ;
\ *** Block No. 7, Hexblock 7
\ Defining Words to Generate Op Codes ks 19 mär 88
| : 11MI CREATE C, C, DOES> OVER #) =
IF NIP C@ INTER @
IF 1 AND IF 352 ELSE 232 THEN C, SWAP , , INTER OFF
ELSE SWAP HERE - 2- SWAP 2DUP 1 AND SWAP BIG? NOT AND
IF 2 OP, C, ELSE C, 1- , THEN THEN
ELSE OVER S#) = IF NIP #) SWAP THEN
377 C, 1+ C@ ?FAR R/M, THEN ;
| : 12MI CREATE C, C, C, DOES> OVER REG?
IF C@ SWAP RLOW OP, ELSE 1+ OVER SEG?
IF C@ RLOW SWAP RMID OP,
ELSE COUNT SWAP C@ C, MEM,
THEN THEN ;
| : 14MI CREATE C, DOES> C@
DUP ?FAR C, 1 AND 0= IF , THEN ;
\ *** Block No. 8, Hexblock 8
\ Defining Words to Generate Op Codes ks 19 mär 88
| : 13MI CREATE C, C, DOES> COUNT >R C@ LOGICAL ! DUP REG?
IF OVER REG?
IF R> OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR
IF R> 2 OR WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? )
IF R> 4 OR OVER W, R16? ,/C,
ELSE OVER B/L? OVER R16? 2DUP AND
-ROT 1 AND SWAP NOT 2 AND OR 200 OP,
SWAP RLOW 300 OR R> OP, ,/C,
THEN THEN THEN
ELSE ( MEM ) ROT DUP REG?
IF R> WMEM,
ELSE ( # ) DROP 2 PICK B/L? DUP NOT 2 AND 200 OR SIZE,
-ROT R> MEM, SIZE @ AND ,/C, SIZE ON
THEN THEN ;
\ *** Block No. 9, Hexblock 9
\ Instructions ks 19 mär 88
: TEST ( source dest -- ) DUP REG?
IF OVER REG?
IF 204 OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR
IF 204 WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? )
IF 250 OVER W,
ELSE 366 OVER W, DUP RLOW 300 OP,
THEN R16? ,/C, THEN THEN
ELSE ( MEM ) ROT DUP REG?
IF 204 WMEM,
ELSE ( # ) DROP 366 SIZE, 0 MEM, SIZE @ ,/C, SIZE ON
THEN THEN ;
\ *** Block No. 10, Hexblock a
\ Instructions ks 19 mär 88
HEX
: ESC ( source ext-opcode -- ) RLOW 0D8 OP, R/M, ;
: INT ( N -- ) 0CD C, C, ;
: SEG ( SEG -- ) RMID 26 OP, ;
: XCHG ( MR1 MR2 -- ) DUP REG?
IF DUP AX =
IF DROP RLOW 90 OP, ELSE OVER AX =
IF NIP RLOW 90 OP, ELSE 86 WR/SM, THEN THEN
ELSE ROT 86 WR/SM, THEN ;
: CS: CS SEG ;
: DS: DS SEG ;
: ES: ES SEG ;
: SS: SS SEG ;
\ *** Block No. 11, Hexblock b
\ Instructions ks 19 mär 88
: MOV ( S D -- ) DUP SEG?
IF 8E C, R/M, ELSE DUP REG?
IF OVER #) = OVER RLOW 0= AND
IF A0 SWAP W, DROP , ELSE OVER SEG?
IF SWAP 8C C, RR, ELSE OVER # =
IF NIP DUP R16? SWAP RLOW OVER 8 AND OR B0 OP, ,/C,
ELSE 8A OVER W, R/M, THEN THEN THEN
ELSE ( MEM ) ROT DUP SEG?
IF 8C C, MEM, ELSE DUP # =
IF DROP C6 SIZE, 0 MEM, SIZE @ ,/C,
ELSE OVER #) = OVER RLOW 0= AND
IF A2 SWAP W, DROP , ELSE 88 OVER W, R/M,
THEN THEN THEN THEN THEN SIZE ON ;
\ *** Block No. 12, Hexblock c
\ Instructions 12Oct83map
37 1MI AAA D5 2MI AAD D4 2MI AAM 3F 1MI AAS
0 10 13MI ADC 0 00 13MI ADD 2 20 13MI AND 10 E8 11MI CALL
98 1MI CBW F8 1MI CLC FC 1MI CLD FA 1MI CLI
F5 1MI CMC 0 38 13MI CMP A6 5MI CMPS 99 1MI CWD
27 1MI DAA 2F 1MI DAS 08 9MI DEC 30 7MI DIV
( ESC ) F4 1MI HLT 38 7MI IDIV 28 7MI IMUL
E4 8MI IN 00 9MI INC ( INT ) 0CE 1MI INTO
0CF 1MI IRET 77 3MI JA 73 3MI JAE 72 3MI JB
76 3MI JBE E3 3MI JCXZ 74 3MI JE 7F 3MI JG
7D 3MI JGE 7C 3MI JL 7E 3MI JLE 20 E9 11MI JMP
75 3MI JNE 71 3MI JNO 79 3MI JNS 70 3MI JO
7A 3MI JPE 7B 3MI JPO 78 3MI JS 9F 1MI LAHF
C5 4MI LDS 8D 4MI LEA C4 4MI LES F0 1MI LOCK
0AC 6MI LODS E2 3MI LOOP E1 3MI LOOPE E0 3MI LOOPNE
\ *** Block No. 13, Hexblock d
\ Instructions 12Apr84map
( MOV ) 0A4 5MI MOVS 20 7MI MUL 18 7MI NEG
90 1MI NOP 10 7MI NOT 2 08 13MI OR E6 8MI OUT
8F 07 58 12MI POP 9D 1MI POPF
0FF 36 50 12MI PUSH 9C 1MI PUSHF
10 10MI RCL 18 10MI RCR
F2 1MI REP F2 1MI REPNZ F3 1MI REPZ
C3 14MI RET 00 10MI ROL 8 10MI ROR 9E 1MI SAHF
38 10MI SAR 0 18 13MI SBB 0AE 5MI SCAS ( SEG )
20 10MI SHL 28 10MI SHR F9 1MI STC FD 1MI STD
FB 1MI STI 0AA 6MI STOS 0 28 13MI SUB ( TEST )
9B 1MI WAIT ( XCHG ) D7 1MI XLAT 2 30 13MI XOR
C2 14MI +RET
\ *** Block No. 14, Hexblock e
\ Structured Conditionals ks 19 mär 88
: A?>MARK ( -- f addr ) TRUE HERE 0 C, ;
: A?>RESOLVE ( f addr -- ) HERE OVER 1+ - SWAP C! true ?pairs ;
: A?<MARK ( -- f addr ) TRUE HERE ;
: A?<RESOLVE ( f addr -- ) HERE 1+ - C, true ?pairs ;
' A?>MARK ASSEMBLER IS ?>MARK
' A?>RESOLVE ASSEMBLER IS ?>RESOLVE
' A?<MARK ASSEMBLER IS ?<MARK
' A?<RESOLVE ASSEMBLER IS ?<RESOLVE
HEX
75 CONSTANT 0= 74 CONSTANT 0<> 79 CONSTANT 0<
78 CONSTANT 0>= 7D CONSTANT < 7C CONSTANT >=
7F CONSTANT <= 7E CONSTANT > 73 CONSTANT U<
72 CONSTANT U>= 77 CONSTANT U<= 76 CONSTANT U>
71 CONSTANT OV
DECIMAL
\ *** Block No. 15, Hexblock f
\ Structured Conditionals cas 10nov05
HEX
: IF C, ?>MARK ;
: THEN ?>RESOLVE ;
: ELSE 0EB IF 2SWAP THEN ;
: BEGIN ?<MARK ;
: UNTIL C, ?<RESOLVE ;
: AGAIN 0EB UNTIL ;
: WHILE IF ;
: REPEAT 2SWAP AGAIN THEN ;
: DO # CX MOV HERE ;
: Next AX lods AX DI xchg 0 [DI] jmp
[ Assembler ] here next-link @ , next-link ! ;
\ volksFORTH uses "inline" Next and a linked list, to find all
\ existing NEXT for the debugger.
DECIMAL
\ *** Block No. 16, Hexblock 10
\ *** Block No. 17, Hexblock 11
\ 8086 Assembler 08OCT83HHL
LABEL marks the start of a subroutine whose name returns its
address.
DOES-OP Is the op code of the call instruction used for DOES> U
C; A synonym for END-CODE
Deferring the definitions of the commas, marks, and resolves
allows the same assembler to serve for both the system and the
Meta-Compiler.
\ *** Block No. 18, Hexblock 12
\ 8086 Assembler Register Definitions 12Oct83map
On the 8086, register names are cleverly defined constants.
The value returned by registers and by modes such as #) contains
both mode and register information. The instructions use the
mode information to decide how many arguments exist, and what to
assemble.
Like many CPUs, the 8086 uses many 3 bit fields in its opcodes
This makes octal ( base 8 ) natural for describing the registers
We redefine the Registers that FORTH uses to implement its
virtual machine.
\ *** Block No. 19, Hexblock 13
\ Addressing Modes 16Oct83map
MD defines words which test for various modes.
R8? R16? MEM? SEG? #? test for mode equal to 0 thru 4.
REG? tests for any register mode ( 8 or 16 bit).
BIG? tests offsets size. True if won't fit in one byte.
RLOW mask off all but low register field.
RMID mask off all but middle register field.
SIZE true for 16 bit, false for 8 bit.
BYTE set size to 8 bit.
OP, for efficiency. OR two numbers and assemble.
W, assemble opcode with W field set for size of register.
SIZE, assemble opcode with W field set for size of data.
,/C, assemble either 8 or 16 bits.
RR, assemble register to register instruction.
LOGICAL true while assembling logical instructions.
B/L? see 13MI
\ *** Block No. 20, Hexblock 14
\ Addressing 16Oct83map
These words perform most of the addressing mode encoding.
MEM, handles memory reference modes. It takes a displacement,
a mode/register, and a register, and encodes and assembles
them.
WMEM, uses MEM, after packing the register size into the opcode
R/M, assembles either a register to register or a register to
or from memory mode.
WR/SM, assembles either a register mode with size field, or a
memory mode with size from SIZE. Default is 16 bit. Use BYTE
for 8 bit size.
INTER true if inter-segment jump, call, or return.
FAR sets INTER true. Usage: FAR JMP, FAR CALL, FAR RET.
?FAR sets far bit, clears flag.
\ *** Block No. 21, Hexblock 15
\ Defining Words to Generate Op Codes 12Oct83map
1MI define one byte constant instructions.
2MI define ascii adjust instructions.
3MI define branch instructions, with one byte offset.
4MI define LDS, LEA, LES instructions.
5MI define string instructions.
6MI define more string instructions.
7MI define multiply and divide instructions.
8MI define input and output instructions.
9MI define increment/decrement instructions.
10MI define shift/rotate instructions.
*NOTE* To allow both 'ax shl' and 'ax cl shl', if the register
on top of the stack is cl, shift second register by cl. If not,
shift top ( only) register by one.
\ *** Block No. 22, Hexblock 16
\ Defining Words to Generate Op Codes 09Apr84map
11MI define calls and jumps.
notice that the first byte stored is E9 for jmp and E8 for call
so C@ 1 AND is zero for call, 1 for jmp.
syntax for direct intersegment: address segment #) FAR JMP
12MI define pushes and pops.
14MI defines returns.
RET FAR RET n +RET n FAR +RET
\ *** Block No. 23, Hexblock 17
\ Defining Words to Generate Op Codes 16Oct83map
13MI define arithmetic and logical instructions.
\ *** Block No. 24, Hexblock 18
\ Instructions 16Oct83map
TEST bits in dest
\ *** Block No. 25, Hexblock 19
\ Instructions 16Oct83map
ESC
INT assemble interrupt instruction.
SEG assemble segment instruction.
XCHG assemble register swap instruction.
CS: DS: ES: SS: assemble segment over-ride instructions.
\ *** Block No. 26, Hexblock 1a
\ Instructions 12Oct83map
MOV as usual, the move instruction is the most complicated.
It allows more addressing modes than any other, each of which
assembles something more or less unique.
\ *** Block No. 27, Hexblock 1b
\ Instructions 12Oct83map
Most instructions are defined on these two screens. Mnemonics in
parentheses are defined earlier or not at all.
\ *** Block No. 28, Hexblock 1c
\ Instructions 12Oct83map
Most instructions are defined on these two screens. Mnemonics in
parentheses are defined earlier or not at all.
\ *** Block No. 29, Hexblock 1d
\ Structured Conditionals 16Oct83map
A?>MARK assembler version of forward mark.
A?>RESOLVE assembler version of forward resolve.
A?<MARK assembler version of backward mark.
A?<RESOLVE assembler version of backward resolve.
These conditional test words leave the opcodes of conditional
branches to be used by the structured conditional words.
For example,
5 # CX CMP 0< IF AX BX ADD ELSE AX BX SUB THEN
\ *** Block No. 30, Hexblock 1e
\ Structured Conditionals 12Oct83map
One of the very best features of FORTH assemblers is the ability
to use structured conditionals instead of branching to nonsense
labels.
\ *** Block No. 31, Hexblock 1f
\ *** Block No. 32, Hexblock 20
\ *** Block No. 33, Hexblock 21

0
8086/msdos/graphic.prn → 8086/msdos/src/graphic.prn
View File

2
8086/msdos/src/include.fb
View File

File diff suppressed because one or more lines are too long

45
8086/msdos/src/include.fth
View File

@ -20,9 +20,9 @@
\ *** Block No. 1, Hexblock 1
\ load screen phz 16jan22
\ load screen phz 06feb22
1 5 +thru
1 6 +thru
@ -39,7 +39,7 @@
\ *** Block No. 2, Hexblock 2
\ fib /fib #fib eolf? phz 06jan22
\ fib /fib #fib eolf? phz 06feb22
context @ dos also context !
$50 constant /tib
@ -58,24 +58,43 @@
\ *** Block No. 3, Hexblock 3
\ freadline probe-for-fb phz 06jan22
\ incfile incpos inc-fgetc phz 06feb22
variable incfile
variable incpos 2 allot
: inc-fgetc ( -- c )
incfile @ f.handle @ 0= IF
incpos 2@ incfile @ fseek THEN
incfile @ fgetc
incpos 2@ 1. d+ incpos 2! ;
\ *** Block No. 4, Hexblock 4
\ freadline probe-for-fb phz 06feb22
: freadline ( -- eof )
tib /tib bounds DO
isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN
inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN
0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN
LOOP /tib #tib !
." warning: line exteeds max " /tib . cr
." extra chars ignored" cr
BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ;
BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ;
: probe-for-fb ( -- flag )
| : probe-for-fb ( -- flag )
\ probes whether current file looks like a block file
/tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN
LOOP true ;
\ *** Block No. 4, Hexblock 4
\ *** Block No. 5, Hexblock 5
\ save/restoretib phz 16jan22
@ -94,9 +113,9 @@
r> #tib ! >in off ;
\ *** Block No. 5, Hexblock 5
\ *** Block No. 6, Hexblock 6
\ interpret-via-tib include phz 16jan22
\ interpret-via-tib include phz 06feb22
: interpret-via-tib
BEGIN freadline >r .status >in off interpret
@ -105,15 +124,15 @@
: include ( -- )
pushfile use cr file?
probe-for-fb isfile@ freset IF 1 load close exit THEN
incfile push isfile@ incfile !
incpos push incpos off incpos 2+ dup push off
savetib >r interpret-via-tib close r> restoretib ;
: (stashquit stash[ stash> ! (quit ;
: stashrestore ['] (stashquit IS 'quit ;
' stashrestore IS 'restart
\ *** Block No. 6, Hexblock 6
\ *** Block No. 7, Hexblock 7
\ \ phz 16jan22

0
8086/msdos/install.fb → 8086/msdos/src/install.fb
View File

342
8086/msdos/src/install.fth Normal file
View File

@ -0,0 +1,342 @@
\ *** Block No. 0, Hexblock 0
\\ Install Editor cas 10nov05
This file contains the Installer for the Forth Editor
The Installer will query for keystrokes that should invoke
the Editor commands.
This allows custom keybinding for the individual requirements
\ *** Block No. 1, Hexblock 1
\ install Editor cas 10nov05
Onlyforth Editor also save warning on
: tab &20 col &20 mod - spaces ;
: .key ( c -- )
dup $7E > IF ." $" u. exit THEN
dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ;
: install \ install editor's keyboard
page ." Press keys requested (Spacebar to confirm)"
#keys 0 ?DO cr I 2* actiontable + @ >name .name
tab ." : " I 2* keytable + dup @ .key tab ." -> "
key dup bl = IF drop dup @ THEN dup .key swap !
LOOP ;
-->
\ *** Block No. 2, Hexblock 2
\ define action-names UH 11mai88
: :a ( addr -- adr' ) dup @ Alias 2+ ;
actiontable
:a up :a left :a down :a right
:a push-line :a push-char :a pull-line :a pull-char
:a fix-word :a screen# :a copy-line :a copy-char
:a backspace :a backspace :a backspace :a delete-char
( :a insert-char ) :a delete-line :a insert-line
:a flipimode ( :a erase-line :a clear-to-right)
:a new-line :a +tab :a -tab
:a home :a to-end :a search :a undo
:a update-exit :a flushed-exit :a showload :a shadow-screen
:a next-Screen :a back-Screen :a alter-Screen :a mark-screen
drop
warning off install empty
\ *** Block No. 3, Hexblock 3
\ *** Block No. 4, Hexblock 4
\ *** Block No. 5, Hexblock 5
\ *** Block No. 6, Hexblock 6
\ *** Block No. 7, Hexblock 7
\ *** Block No. 8, Hexblock 8
\ *** Block No. 9, Hexblock 9
\ *** Block No. 10, Hexblock a
\ *** Block No. 11, Hexblock b
\ *** Block No. 12, Hexblock c
\ *** Block No. 13, Hexblock d
\ *** Block No. 14, Hexblock e
\ *** Block No. 15, Hexblock f
\ *** Block No. 16, Hexblock 10
\ *** Block No. 17, Hexblock 11

0
8086/msdos/kernel.fb → 8086/msdos/src/kernel.fb
View File

3040
8086/msdos/src/kernel.fth Normal file
View File

File diff suppressed because it is too large Load Diff

0
8086/msdos/m130i.prn → 8086/msdos/src/m130i.prn
View File

2
8086/msdos/meta.fb → 8086/msdos/src/meta.fb
View File

File diff suppressed because one or more lines are too long

1007
8086/msdos/src/meta.fth Normal file
View File

File diff suppressed because it is too large Load Diff

0
8086/msdos/minimal.sys → 8086/msdos/src/minimal.sys
View File

0
8086/msdos/miniterm.fb → 8086/msdos/src/miniterm.fb
View File

380
8086/msdos/src/miniterm.fth Normal file
View File

@ -0,0 +1,380 @@
\ *** 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

24
8086/msdos/src/mk-meta.fth Normal file
View File

@ -0,0 +1,24 @@
include log2file.fth
logopen output.log
Onlyforth \ \needs Assembler 2 loadfrom asm.fb
: c+! ( 8b addr -- ) dup c@ rot + swap c! ;
' find $22 + @ Alias found
: search ( string 'vocab -- acf n / string ff )
dup @ [ ' Forth @ ] Literal - Abort" no vocabulary"
>body (find IF found exit THEN false ;
use meta.fb
3 &27 thru Onlyforth
logclose
savesystem metafile.com
logreopen
cr .( Metacompiler saved as metafile.com) cr
logclose

43
8086/msdos/src/mk-v4th.fth Normal file
View File

@ -0,0 +1,43 @@
logopen output.log
\ : .blk|tib
\ blk @ ?dup IF ." Blk " u. ?cr exit THEN
\ incfile @ IF tib #tib @ cr type THEN ;
\ ' .blk|tib Is .status
Onlyforth
2 loadfrom META.fb
use kernel.fb
new v4th.com Onlyforth Target definitions
\ 4 &110 thru \ Standard 8088-System
include vf86core.fth
\ &112 &146 thru \ MS-DOS interface
include vf86dos.fth
: forth-83 ; \ last word in Dictionary
0 ' limit >body ! $DFF6 s0 ! $E77C r0 !
s0 @ s0 2- ! here dp !
Host tudp @ Target udp !
Host tvoc-link @ Target voc-link !
Host tnext-link @ Target next-link !
Host tfile-link @ Target Forth file-link !
Host T move-threads H
save-buffers cr .( unresolved: ) .unresolved
logclose
flush \ close n4th.com
logreopen
cr .( new kernel written as v4th.com) cr
logclose

2
8086/msdos/multi.vid → 8086/msdos/src/multi.vid
View File

File diff suppressed because one or more lines are too long

0
8086/msdos/nec8023.prn → 8086/msdos/src/nec8023.prn
View File

0
8086/msdos/primed.fb → 8086/msdos/src/primed.fb
View File

133
8086/msdos/src/primed.fth Normal file
View File

@ -0,0 +1,133 @@
\ *** Block No. 0, Hexblock 0
\\ Simple Editor for Installation cas 10nov05
If the Full-Screen Editor cannot be used during installation
(incompatible display hardware), the screens must be altered
with this Simple Editor "PRIMED", which contains only one word
definition::
Usage: Select Screen nn with command "nn LIST",
and edit a screen with "ll NEW". It is only possible to
rewrite whole lines. ll is the first line where the editing
should start. The editing can be terminated by entering an
empty line (just RETURN). Each RETURN will store the editied
line and the whole screen will be reprinted.
\ *** Block No. 1, Hexblock 1
\ primitivst Editor PRIMED cas 10nov05
Vocabulary Editor
| : !line ( adr count line# -- )
scr @ block swap c/l * + dup c/l bl fill
swap cmove update ;
: new ( n -- )
l/s 1+ swap
?DO cr I .
pad c/l expect span @ 0= IF leave THEN
pad span @ I !line cr scr @ list LOOP ;
' scr | Alias scr'
.( Simple Editor loaded ) cr
\ *** Block No. 2, Hexblock 2
\ PRIMED Demo-Screen cas 10nov05
This text was created by: "2 LIST 4 NEW" and then entering
this text
The headerline (Line 0) was added later after leaving "NEW"
with an empty line (just RETURN) and a new editing command
"0 NEW".
Ulrich Hoffmann
\ *** Block No. 3, Hexblock 3
\ *** Block No. 4, Hexblock 4
\ *** Block No. 5, Hexblock 5
\ *** Block No. 6, Hexblock 6

0
8086/msdos/see.fb → 8086/msdos/src/see.fb
View File

2318
8086/msdos/src/see.fth Normal file
View File

File diff suppressed because it is too large Load Diff

0
8086/msdos/serial.fb → 8086/msdos/src/serial.fb
View File

418
8086/msdos/src/serial.fth Normal file
View File

@ -0,0 +1,418 @@
\ *** Block No. 0, Hexblock 0
\ Serial interface for IBM-PC using 8250 chip cas 11nov05
INCLUDE SERIAL.FB will load code for COM1,
2 LOADFROM SERIAL.FB for COM2
Bytes recieved will be buffered in a 128 Byte deep Queue
by an interrupt Routine.
The DTR Line will be used to signal that new bytes can be
recieved.
The Sender will recognize CTS, a full Handshake is implemented
Xon/Xoff Protocoll using ^S/^Q is _not_ implemented.
Sender: TX? ( -- f ) TX ( -- char )
Empfänger: RX? ( -- f ) RX ( char -- )
\ *** Block No. 1, Hexblock 1
\ Driver for IBM-PC Serial card using 8250 cas 11nov05
Onlyforth \needs Assembler 2 loadfrom asm.fb
cr .( COM1: )
| $C 4 * Constant SINT@ \ absolute loc. of serial interrupt
$3F8 >label Portadr
| $10 Constant I_level \ 8259 priority
2 7 +thru
\ *** Block No. 2, Hexblock 2
\ Driver for IBM-PC Serial card using 8250 cas 11nov05
Onlyforth \needs Assembler 2 loadfrom asm.fb
cr .( COM2: )
| $B 4 * Constant SINT@ \ absolute loc. of serial interrupt
$2F8 >label Portadr
| 8 Constant I_level \ 8259 priority
1 6 +thru
\ *** Block No. 3, Hexblock 3
\ Driver for IBM-PC Serial card using 8250 ks 11 mai 88
\ 3 .( 38.4 kbaud )
\ &6 .( 19.2 kbaud )
&12 .( 9.6 kbaud )
\ &24 .( 4.8 kbaud )
\ &96 .( 1200 baud )
>label baud
$20 >label I_ctrl $21 >label I_mask \ 8259 addresses
Create Queue 0 , $80 allot
\ 0 1 2 130 byte address
\ | len | out |<-- 128 byte Queue -->|
\ len ::= number of characters queued
\ out ::= relativ address of next output character
\ (len+out)mod(128) ::= relative address of first empty byte
\ *** Block No. 4, Hexblock 4
\ transmit to 8250 ks 11 dez 87
Code tx? ( -- f ) D push Portadr 5 + # D mov
D in D D xor $1020 # A and $1020 # A cmp
0= ?[ D dec ]? Next end-code
Code tx ( c -- ) D- A- xchg Portadr # D mov
D byte out D pop Next end-code
Code -dtr D push Portadr 4 + # D mov
D byte in $1E # A- and D byte out D pop Next
end-code
Code +dtr D push Portadr 4 + # D mov
D byte in 1 # A- or D byte out D pop Next
end-code
\ *** Block No. 5, Hexblock 5
\ receive queue and interrupt service routine ks 11 dez 87
Label S_INT D push I push A push
Portadr # D mov D byte in A- D+ mov
Queue # I mov C: seg I ) A mov A- D- mov D- inc
C: seg D- I ) mov A+ A- add $7F # A and A I add
C: seg D+ 2 I D) mov $68 # D- cmp CS not
?[ Portadr 4 + # D mov
D byte in $1E # A- and D byte out ]? \ -DTR
$20 # A- mov I_ctrl #) byte out \ EOI for 8259
A pop I pop D pop iret
end-code
\ *** Block No. 6, Hexblock 6
\ rx? rx ks 30 dez 87
Code rx? ( -- f ) D push D D xor
Queue #) D- mov D- D- or 0=
?[ [[ D push Portadr 4 + # D mov \ +DTR
D byte in 9 # A- or D byte out D pop
swap ]? Next end-code
Code rx ( -- 8b ) I W mov Queue # I mov
D push D D xor cli lods A- A- or 0= not
?[ A+ C- mov A- dec A+ inc $7F # A+ and
A -2 I D) mov D- C+ mov C I add I ) D- mov
]? sti W I mov $18 # A- cmp CS not ?] Next
end-code
\ *** Block No. 7, Hexblock 7
\ Serial initialization ks 25 apr 86
| Code S_init D push D: push A A xor A D: mov C: A mov
SINT@ # W mov S_INT # W ) mov A 2 W D) mov D: pop
Portadr 3 + # D mov $80 # A- mov D byte out \ DLAB = 1
2 # D sub baud # A mov A- A+ xchg D byte out
D dec A- A+ xchg D byte out \ baudrate
3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT
2 # D sub 1 # A- mov D byte out \ +rxINT
I_mask #) byte in I_level Forth not Assembler # A- and
I_mask #) byte out D pop Next
end-code
\ *** Block No. 8, Hexblock 8
\ init bye ks 11 dez 87
\needs init : init ;
: init init Queue off S_init ; init
: bye 0 [ Portadr 1+ ] Literal pc! \ -rxINT
0 [ Portadr 4 + ] Literal pc! \ -dtr/-rts/-out2
I_mask pc@ I_level or I_mask pc! bye ;
\ *** Block No. 9, Hexblock 9
\ dumb terminal via 8250 ks 11 dez 87
Variable Fkeys Fkeys on
| : ?rx ( -- ) pause rx? 0=exit rx
Fkeys @ 0= IF emit ?cr exit THEN
#LF case? IF cr exit THEN
#CR case? IF Row 0 at exit THEN
#BS case? IF del exit THEN emit ;
| : ?tx ( c -- ) BEGIN ?rx tx? UNTIL tx ;
: dumb BEGIN BEGIN ?rx key? UNTIL key
$1B case? IF -dtr exit THEN ?tx REPEAT ;
\ *** Block No. 10, Hexblock a
\ *** Block No. 11, Hexblock b
\ *** Block No. 12, Hexblock c
\ *** Block No. 13, Hexblock d
\ *** Block No. 14, Hexblock e
\ *** Block No. 15, Hexblock f
\ *** Block No. 16, Hexblock 10
\ *** Block No. 17, Hexblock 11
\ *** Block No. 18, Hexblock 12
\ *** Block No. 19, Hexblock 13
\ *** Block No. 20, Hexblock 14
\ *** Block No. 21, Hexblock 15

0
8086/msdos/stream.fb → 8086/msdos/src/stream.fb
View File

209
8086/msdos/src/stream.fth Normal file
View File

@ -0,0 +1,209 @@
\ *** Block No. 0, Hexblock 0
\ cas 11nov05
The word STREAM>BLK convert a sequiential file with CR lineend
into a screenfile with 64 Chars per line.
Example:
FORTH.TXT is a Forth-Sourceode in a sequiential file
MAKEFILE FORTH.FB will create an empty screenfile
FROM FORTH.TXT will define the inputfile
STREAM>BLK will convert FORTH.TXT into FORTH.FB
\ *** Block No. 1, Hexblock 1
\ ks 06 jul 88
Onlyforth Dos also
| : in ( -- fcb ) fromfile @ ;
| : out ( -- fcb ) isfile @ ;
| : padd ( cnt -- ) dup IF c/l mod ?dup 0=exit THEN
c/l swap ?DO BL out fputc LOOP ;
| : skipctrl ( -- char )
BEGIN in fgetc dup #cr = ?exit
dup 0 BL uwithin 0=exit drop REPEAT ;
2 3 thru
Onlyforth
\ *** Block No. 2, Hexblock 2
\ ks 06 jul 88
| : lastline? ( -- f ) false 0 skipctrl
BEGIN -1 case? IF ?dup IF padd THEN 0= exit THEN
#cr case? 0= WHILE out fputc 1+ in fgetc REPEAT
padd ;
: stream>blk open out freset
out f.size 2@ out fseek \ append to end of file
BEGIN lastline? stop? or UNTIL close out fclose ;
\ *** Block No. 3, Hexblock 3
\ absolute blocks in file eintragen ks 11 aug 87
| : >stream ( blk -- )
fromfile @ (block b/blk bounds
DO ds@ I C/L -trailing out lfputs
#cr out fputc #lf out fputc C/L +LOOP ;
: blk>stream ( from.blk to.blk -- ) emptyfile
1+ swap DO I >stream LOOP close ;
\ *** Block No. 4, Hexblock 4
\ *** Block No. 5, Hexblock 5
\ *** Block No. 6, Hexblock 6
\ *** Block No. 7, Hexblock 7
\ *** Block No. 8, Hexblock 8
\ *** Block No. 9, Hexblock 9
\ *** Block No. 10, Hexblock a

0
8086/msdos/system.cfg → 8086/msdos/src/system.cfg
View File

0
8086/msdos/tasker.fb → 8086/msdos/src/tasker.fb
View File

95
8086/msdos/src/tasker.fth Normal file
View File

@ -0,0 +1,95 @@
\ *** Block No. 0, Hexblock 0
\ ks 22 dez 87
The multitasker is a simple yet powerful round robin scheme
with explicit task switching. This has the major advantage
that the system switches tasks only in known states.
Hence the difficulties in synchronizing tasks and locking
critical portions of code are greatly minimized or simply
do not exist at all.
\ *** Block No. 1, Hexblock 1
\ Multitasker loadscreen ks 03 apr 88
Onlyforth \needs Assembler 2 loadfrom asm.scr
Code stop $E990 # U ) mov ' pause @ # jmp end-code
: singletask [ ' noop @ ] Literal ['] pause ! ;
: multitask [ ' pause @ ] Literal ['] pause ! ;
1 3 +thru .( Multitasker geladen) cr
\ *** Block No. 2, Hexblock 2
\ pass activate ks 1 jun 87
: pass ( n0 ... nr-1 Taddr r -- )
BEGIN [ rot ]
swap $E9CD over ! \ awake Task
r> -rot \ Stack: IP r addr
8 + >r \ s0 of Task
r@ 2+ @ swap \ Stack: IP r0 r
2+ 2* \ bytes on Taskstack incl. r0 & IP
r@ @ over - \ new SP
dup r> 2- ! \ into Ssave
swap bounds ?DO I ! 2 +LOOP ; restrict
: activate ( Taddr -- ) 0 \ [ ' pass >body ] Literal >r ;
[ -rot ] REPEAT ; restrict
\ *** Block No. 3, Hexblock 3
( Building a Task ks 8 may 84 )
| : taskerror ( string -- ) standardi/o singletask
." Task error: " count type multitask stop ;
: sleep ( addr -- ) $90 swap c! ;
: wake ( addr -- ) $CD swap c! ;
: rendezvous ( semaphoraddr -- )
dup unlock pause lock ;
\ *** Block No. 4, Hexblock 4
\ Task ks 1 jun 87
: Task ( rlen slen -- ) clear
0 Constant here 2- >r \ addr of task constant
here -rot \ here for Task dp
even allot even \ allot dictionary area
here r> ! \ set task constant addr
up@ here $100 cmove \ init user area
here $E990 , \ JMP opcode
up@ 2+ dup dup @ + here - ,
2dup - 2- swap ! \ link task
0 , dup 2- dup , , \ ssave and s0
2dup + , \ here + rlen = r0
rot , \ dp
under + dp ! 0 , \ allot rstack
['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ;

0
8086/msdos/timer.fb → 8086/msdos/src/timer.fb
View File

95
8086/msdos/src/timer.fth Normal file
View File

@ -0,0 +1,95 @@
\ *** Block No. 0, Hexblock 0
\ ks 22 dez 87
The timer utilizes the memory cell at $46C that is incremented
by an interrupt. A couple of words allow this timer to be
used for time delays.
time-of-day and date are accessed via MS-DOS calls.
\ *** Block No. 1, Hexblock 1
\ BIMomat BIOS Timer ks 03 apr 88
Onlyforth \needs Assembler 2 loadfrom asm.scr
$46C >label Counter
\ 1193180 / 65536 = 18,206 Hz
1 2 +thru .( Timer geladen) cr
\ *** Block No. 2, Hexblock 2
\ BIMomat BIOS Timer ks 22 dez 87
Code ticks ( -- n ) D push D: C mov A A xor
A D: mov Counter #) D mov C D: mov Next end-code
: timeout? ( ticks -- ticks f ) pause dup ticks - 0< ;
: till ( n -- ) BEGIN timeout? UNTIL drop ;
: time ( n -- time ) ticks + ;
: wait ( n -- ) time till ;
: seconds ( sec -- ticks ) &18206 &1000 */ ;
: minutes ( min -- ticks ) &1092 * ;
\ *** Block No. 3, Hexblock 3
\ MS-DOS time and date ks 22 dez 87
Code date@ ( -- dd mm yy )
D push $2A # A+ mov $21 int A A xor D+ A- xchg
D push A push C D mov &1900 # D sub Next
end-code
Code time@ ( -- ss mm hh )
D push $2C # A+ mov $21 int D+ D- mov 0 # D+ mov
D push D+ D- mov C+ D- xchg C push Next
end-code
\ *** Block No. 4, Hexblock 4

0
8086/msdos/tools.fb → 8086/msdos/src/tools.fb
View File

247
8086/msdos/src/tools.fth Normal file
View File

@ -0,0 +1,247 @@
\ *** Block No. 0, Hexblock 0
\ ks 22 dez 87
Some simple tools for debugging.
A state-of-the-art, interactive single step tracer
and a couple of tools for decompiling and dumping
\ *** Block No. 1, Hexblock 1
\ Programming-Tools word set cas 19july2020
Onlyforth \needs Assembler 2 loadfrom asm.fb
Vocabulary Tools Tools also definitions
1 11 +thru Onlyforth .( Tools loaded ) cr
\ *** Block No. 2, Hexblock 2
\ trace - next ks 11 jun 87
| Variable nest? nest? off
Label tracenext 0 # nest? #) byte cmp 0=
?[ $5555 # I cmp here 2- >label (ip >=
?[ [[ swap lods A W xchg W ) jmp ]?
$5555 # I cmp here 2- >label ip) CS ?]
][ 0 # nest? #) byte mov
]? $5555 # W mov here 2- >label >tracing W ) jmp
end-code
| (ip Constant <ip | ip) Constant ip>
| : (debug ( addr -- ) dup <ip !
BEGIN 1+ dup @ ['] unnest = UNTIL 2+ ip> ! ;
\ *** Block No. 3, Hexblock 3
\ install Tracer ks 11 jun 87
Label (do-trace next-link # W mov D push
$E9 # A- mov tracenext 1+ # C mov
[[ W ) W mov W W or 0= not
?[[ A- -4 W D) mov C D mov W D sub
D -3 W D) mov ]]? D pop ret end-code
Code do-trace (do-trace # call Next end-code
' end-trace Alias end-trace
| Code (step (do-trace # call
R ) I mov R inc R inc lods A W xchg W ) jmp
| Create: nextstep (step ;
\ *** Block No. 4, Hexblock 4
\ tracer display ks 20 sep 88
| Variable nest# nest# off
| Variable 'ip 'ip off
| Create: -nest r> ip> ! r> <ip ! -1 nest# +! ;
| : oneline .status space
BEGIN query interpret tib #tib @ + 1- c@ BL =
WHILE prompt &36 tab REPEAT
-$20 allot r0 @ rp! r> r0 ! r> dup #tib !
rp@ over tib swap cmove rp@ + rp!
r> Is parser r> adr 'quit ! r> >in !
r> blk ! r> state ! r> output ! r> input ! ;
\ *** Block No. 5, Hexblock 5
\ tracer display ks 16 sep 88
| : tracing end-trace nest? @
IF r> <ip @ >r ip> @ >r -nest >r >r
1 nest# +! r@ 2- (debug nest? off THEN r@ 'ip !
nextstep >r input @ >r output @ >r state @ >r
blk @ >r >in @ >r adr 'quit @ >r adr parser @ >r
tib #tib @ rp@ over - under rp! cmove #tib @ >r
r0 @ >r rp@ r0 ! standardi/o
cr nest# @ spaces 'ip @ dup 5 u.r @ dup 5 u.r
2 spaces >name .name &30 nest# @ + tab .s
$20 allot ['] oneline Is 'quit quit ;
' tracing >tracing !
\ *** Block No. 6, Hexblock 6
\ test traceability ks 07 dez 87
| : traceable ( cfa -- cfa' ) recursive dup @
[ ' : @ ] Literal case? ?exit
[ ' key @ ] Literal case? IF >body c@ Input @ +
@ traceable exit THEN
[ ' type @ ] Literal case? IF >body c@ Output @ +
@ traceable exit THEN
[ ' r/w @ ] Literal case? IF >body @ traceable exit THEN
c@ $E9 = IF @ 1+ exit THEN \ Does> word
>name .name ." can't be DEBUGged" quit ;
\ *** Block No. 7, Hexblock 7
\ user words for tracing ks 16 sep 88
| : do_debug ( addr -- )
traceable (debug nest? off nest# off do-trace ;
: nest \ trace next high-level word executed
'ip @ @ traceable drop nest? on ;
: unnest \ ends tracing of actual word
<ip on ip> off ; unnest \ clears trap range
: endloop \ stop tracing loop
'ip @ <ip ! ; \ use when at end of loop
: debug ' do_debug ;
: trace ' dup >r do_debug r> execute end-trace unnest ;
\ *** Block No. 8, Hexblock 8
\ tools for decompiling, interactive use ks 04 jul 87
| : ?: ( addr -- addr ) dup 5 u.r ." :" ;
| : @? ( addr -- addr ) dup @ 6 u.r ;
| : c? ( addr -- addr ) dup c@ 3 .r ;
| : end $28 tab ;
: s ( addr1 -- addr2 )
?: 3 spaces c? 2 spaces count 2dup type + even end ;
: n ( addr1 -- addr2 )
?: @? 2 spaces dup @ >name .name 2+ end ;
: d ( addr1 n -- addr2 ) 2dup swap ?: 3 spaces
swap 0 DO c? 1+ LOOP 2 spaces -rot type end ;
: l ( addr1 -- addr2 ) ?: 6 spaces @? 2+ end ;
: c ( addr1 -- addr2 ) 1 d end ;
: b ( addr1 -- addr2 ) ?: @? dup @ over + 6 u.r 2+ end ;
\ *** Block No. 9, Hexblock 9
\ often times ks 29 jun 87
Onlyforth
: often stop? ?exit >in off ;
| Variable #times #times off
: times ( n -- ) ?dup
IF #times @ 2+ u< stop? or
IF #times off exit THEN 1 #times +!
ELSE stop? ?exit
THEN >in off ;
\ *** Block No. 10, Hexblock a
\ dump ks 04 jul 87
: dump ( addr n -- ) base push hex
bounds ?DO cr I $10 [ Tools ] d [ Forth ] drop
stop? IF LEAVE THEN $10 +LOOP ;
| : ld ( seg:addr -- )
over 4 u.r ." :" dup 0 <# # # # # #> type
3 spaces ds@ pad $10 lmove pad $10 bounds
DO I c@ 3 u.r LOOP 2 spaces pad $10 type ;
: ldump ( seg:addr quan -- ) base push hex
0 DO cr 2dup ld $10 + stop? IF LEAVE THEN
$10 +LOOP 2drop ;
\ *** Block No. 11, Hexblock b
\ N>R NR> cr
: N>R ( i * n +n -- ) ( R: -- j * x +n )
\ Transfer N items and count to the return stack.
DUP BEGIN DUP WHILE
ROT R> SWAP >R >R
1-
REPEAT DROP R> SWAP >R >R ;
: NR> ( -- i * x +n ) ( R: j * x +n -- )
\ Pull N items and count off the return stack.
R> R> SWAP >R DUP
BEGIN DUP WHILE
R> R> SWAP >R -ROT
1-
REPEAT DROP ;
\ *** Block No. 12, Hexblock c
\ ?
: ? ( a-addr -- )
\ Display the value stored at a-addr.
@ . ;

2027
8086/msdos/src/vf86core.fth Normal file
View File

File diff suppressed because it is too large Load Diff

665
8086/msdos/src/vf86dos.fth Normal file
View File

@ -0,0 +1,665 @@
\ *** Block No. 112, Hexblock 70
\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86
Code lc@ ( seg:addr -- 8b ) D: pop D W mov
W ) D- mov 0 # D+ mov C: A mov A D: mov Next
end-code
Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov
A- W ) mov C: A mov A D: mov D pop Next end-code
Code l@ ( seg:addr -- 16b ) D: pop D W mov
W ) D mov C: A mov A D: mov Next end-code
Code l! ( 16b seg:addr -- ) D: pop A pop D W mov
A W ) mov C: A mov A D: mov D pop Next end-code
\ *** Block No. 113, Hexblock 71
\ ltype lmove special 8088 operators ks 11 dez 87
: ltype ( seg:addr len -- )
0 ?DO 2dup I + lc@ emit LOOP 2drop ;
Code lmove ( from.seg:addr to.seg:addr quan -- )
A I xchg D C mov W pop E: pop
I pop D: pop I W cmp CS
?[ rep byte movs
][ C dec C W add C I add C inc
std rep byte movs cld
]? A I xchg C: A mov A E: mov
A D: mov D pop Next end-code
\ *** Block No. 114, Hexblock 72
\ BDOS keyboard input ks 16 sep 88
\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P
| Variable newkey newkey off
Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or
0= ?[ $7 # A+ mov $21 int A- D- mov ]?
0 # D+ mov D+ newkey 1+ #) mov Next
end-code
Code (key? ( -- f ) D push newkey #) D mov D+ D+ or
0= ?[ -1 # D- mov 6 # A+ mov $21 int 0=
?[ 0 # D+ mov
][ -1 # A+ mov A newkey #) mov -1 # D+ mov
]? ]? D+ D- mov Next
end-code
\ *** Block No. 115, Hexblock 73
\ empty-keys (key ks 16 sep 88
Code empty-keys $C00 # A mov $21 int
0 # newkey 1+ #) byte mov Next end-code
: (key ( -- 16b ) BEGIN pause (key? UNTIL
(key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ;
\ *** Block No. 116, Hexblock 74
\ BIOS keyboard input ks 16 sep 88
\ Code (key@ ( -- 8b ) D push A+ A+ xor $16 int
\ A- D- xchg 0 # D+ mov Next end-code
\ Code (key? ( -- f ) D push 1 # A+ mov D D xor
\ $16 int 0= not ?[ D dec ]? Next end-code
\ Code empty-keys $C00 # A mov $21 int Next end-code
\ : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ;
\ mit diesen Keytreibern sind die Funktionstasten nicht
\ mehr durch ANSI.SYS Sequenzen vorbelegt.
\ *** Block No. 117, Hexblock 75
\ (decode expect ks 16 sep 88
7 Constant #bel 8 Constant #bs
9 Constant #tab $A Constant #lf
$D Constant #cr
: (decode ( addr pos1 key -- addr pos2 )
#bs case? IF dup 0=exit del 1- exit THEN
#cr case? IF dup span ! space exit THEN
>r 2dup + r@ swap c! r> emit 1+ ;
: (expect ( addr len1 -- ) span ! 0
BEGIN dup span @ u< WHILE key decode REPEAT 2drop ;
Input: keyboard [ here input ! ]
(key (key? (decode (expect [ drop
\ *** Block No. 118, Hexblock 76
\ MSDOS character output ks 29 jun 87
Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]?
6 # A+ mov $21 int D pop ' pause # W mov W ) jmp
end-code
&80 Constant c/row &25 Constant c/col
: (emit ( char -- ) dup bl u< IF $80 or THEN charout ;
: (cr #cr charout #lf charout ;
: (del #bs charout bl charout #bs charout ;
: (at 2drop ;
: (at? 0 0 ;
: (page c/col 0 DO cr LOOP ;
\ *** Block No. 119, Hexblock 77
\ MSDOS character output ks 7 may 85
: bell #bel charout ;
: tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ;
Output: display [ here output ! ]
(emit (cr tipp (del (page (at (at? [ drop
\ *** Block No. 120, Hexblock 78
\ MSDOS printer I/O Port access ks 09 aug 87
Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next
end-code
Code pc@ ( port -- 8b )
D byte in A- D- mov D+ D+ xor Next
end-code
Code pc! ( 8b port -- )
A pop D byte out D pop Next
end-code
\ *** Block No. 121, Hexblock 79
\ zero terminated strings ks 09 aug 87
: counted ( asciz -- addr len )
dup -1 0 scan drop over - ;
: >asciz ( string addr -- asciz ) 2dup >r -
IF count r@ place r@ THEN 0 r> count + c! 1+ ;
: asciz ( -- asciz ) name here >asciz ;
\ *** Block No. 122, Hexblock 7a
\ Disk capacities ks 08 aug 88
Vocabulary Dos Dos also definitions
6 Constant #drives
Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 ,
| Code ?capacity ( +n -- cap ) D shl capacities # W mov
D W add W ) D mov Next end-code
\ *** Block No. 123, Hexblock 7b
\ MS-dos disk handlers direct access ks 31 jul 87
| Code block@ ( addr blk drv -- ff )
D- A- mov D pop C pop R push U push
I push C R mov 2 # C mov D shl $25 int
Label end-r/w I pop I pop U pop R pop 0 # D mov
CS ?[ D+ A+ mov A error# #) mov D dec ]? Next
end-code
| Code block! ( addr blk drv -- ff ) D- A- mov D pop
C pop R push U push I push C R mov 2 # C mov
D shl $26 int end-r/w # jmp
end-code
\ *** Block No. 124, Hexblock 7c
\ MS-dos disk handlers direct access ks cas 18jul20
| : ?drive ( +n -- +n ) dup #drives u< ?exit
Error" beyond drive capacity" ;
: /drive ( blk1 -- blk2 drive ) 0 swap #drives 0
DO dup I ?capacity under u< IF drop LEAVE THEN
- swap 1+ swap LOOP swap ;
: blk/drv ( -- capacity ) drv ?capacity ;
Forth definitions
: >drive ( blk1 +n -- blk2 ) ?drive
0 swap drv 2dup u> dup >r 0= IF swap THEN
?DO I ?capacity + LOOP r> IF negate THEN - ;
\ *** Block No. 125, Hexblock 7d
\ MS-DOS file access ks 18 mär 88
Dos definitions
| Variable fcb fcb off \ last fcb accessed
| Variable prevfile \ previous active file
&30 Constant fnamelen \ default length in FCB
Create filename &62 allot \ max 60 + count + null
Variable attribut 7 attribut ! \ read-only, hidden, system
\ *** Block No. 126, Hexblock 7e
\ MS-DOS disk errors ks cas 18jul20
| : .error# ." error # " base push decimal error# @ . ;
| : .ferrors error# @ &18 case? IF 2 THEN
1 case? Abort" file exists"
2 case? Abort" file not found"
3 case? Abort" path not found"
4 case? Abort" too many open files"
5 case? Abort" no access"
9 case? Abort" beyond end of file"
&15 case? Abort" illegal drive"
&16 case? Abort" current directory"
&17 case? Abort" wrong drive"
drop ." Disk" .error# abort ;
\ *** Block No. 127, Hexblock 7f
\ MS-DOS disk errors ks cas 18jul20
: (diskerror ( *f -- ) ?dup 0=exit
fcb @ IF error# ! .ferrors exit THEN
input push output push standardi/o 1-
IF ." read" ELSE ." write" THEN
.error# ." retry? (y/n)"
key cr capital Ascii Y = not Abort" aborted" ;
' (diskerror Is ?diskerror
\ *** Block No. 128, Hexblock 80
\ ~open ~creat ~close ks 04 aug 87
Code ~open ( asciz mode -- handle ff / err# )
A D xchg $3D # A+ mov
Label >open D pop $21 int A D xchg
CS not ?[ D push 0 # D mov ]? Next
end-code
Code ~creat ( asciz attribut -- handle ff / err# )
D C mov $3C # A+ mov >open ]] end-code
Code ~close ( handle -- ) D R xchg
$3E # A+ mov $21 int R D xchg D pop Next
end-code
\ *** Block No. 129, Hexblock 81
\ ~first ~unlink ~select ~disk? ks 04 aug 87
Code ~first ( asciz attr -- err# )
D C mov D pop $4E # A+ mov
[[ $21 int 0 # D mov CS ?[ A D xchg ]? Next
end-code
Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code
Code ~select ( n -- )
$E # A+ mov $21 int D pop Next end-code
Code ~disk? ( -- n ) D push $19 # A+ mov
$21 int A- D- mov 0 # D+ mov Next
end-code
\ *** Block No. 130, Hexblock 82
\ ~next ~dir ks 04 aug 87
Code ~next ( -- err# ) D push $4F # A+ mov
$21 int 0 # D mov CS ?[ A D xchg ]? Next
end-code
Code ~dir ( addr drive -- err# ) I W mov
I pop $47 # A+ mov $21 int W I mov
0 # D mov CS ?[ A D xchg ]? Next
end-code
\ *** Block No. 131, Hexblock 83
\ MS-DOS file control Block cas 19jun20
\ | : Fcbytes ( n1 len -- n2 ) Create over c, +
\ Does> ( fcbaddr -- fcbfield ) c@ + ;
| : Fcbytes Create over c, + Does> c@ + ;
\ first field for file-link
2 1 Fcbytes f.no \ must be first field
2 Fcbytes f.handle
2 Fcbytes f.date
2 Fcbytes f.time
4 Fcbytes f.size
fnamelen Fcbytes f.name Constant b/fcb
b/fcb Host ' tb/fcb >body !
Target Forth also Dos also definitions
\ *** Block No. 132, Hexblock 84
\ (.file fname fname! ks 10 okt 87
: fname! ( string fcb -- ) f.name >r count
dup fnamelen < not Abort" file name too long" r> place ;
| : filebuffer? ( fcb -- fcb bufaddr / fcb ff )
prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ;
| : flushfile ( fcb -- )
BEGIN filebuffer? ?dup
WHILE dup backup emptybuf REPEAT drop ;
: fclose ( fcb -- ) ?dup 0=exit
dup f.handle @ ?dup 0= IF drop exit THEN
over flushfile ~close f.handle off ;
\ *** Block No. 133, Hexblock 85
\ (.file fname fname! ks 18 mär 88
| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ;
: (fsearch ( string -- asciz *f )
filename >asciz dup attribut @ ~first ;
Defer fsearch ( string -- asciz *f )
' (fsearch Is fsearch
\ graceful behaviour if file does not exist
| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] =
IF hide file-link @ @ file-link ! prevfile @ setfiles
last @ 4 - dp ! last off filename count here place
THEN ?diskerror ;
\ *** Block No. 134, Hexblock 86
\ freset fseek ks 19 mär 88
: freset ( fcb -- ) ?dup 0=exit
dup f.handle @ ?dup IF ~close THEN dup >r
f.name fsearch ?notfound getsize r@ f.size 2!
[ $80 &22 + ] Literal @ r@ f.time !
[ $80 &24 + ] Literal @ r@ f.date !
2 ~open ?diskerror r> f.handle ! ;
Code fseek ( dfaddr fcb -- )
D W mov u' f.handle W D) W mov W W or 0=
?[ ;c: dup freset fseek ; Assembler ]? R W xchg
C pop D pop $4200 # A mov $21 int W R mov
CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ;
\ *** Block No. 135, Hexblock 87
\ lfgets fgetc file@ ks 07 jul 88
\ Code ~read ( seg:addr quan handle -- #read ) D W mov
Assembler [[ W R xchg C pop D pop
D: pop $3F # A+ mov $21 int C: C mov C D: mov
W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ;
Code lfgets ( seg:addr quan fcb -- #read )
D W mov u' f.handle W D) W mov ]] end-code
true Constant eof
: fgetc ( fcb -- 8b / eof )
>r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ;
: file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ;
\ *** Block No. 136, Hexblock 88
\ lfputs fputc file! ks 24 jul 87
| Code ~write ( seg:addr quan handle -- ) D W mov
[[ W R xchg C pop D pop
D: pop $40 # A+ mov $21 int W R mov A D xchg
C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]?
C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ;
Code lfputs ( seg:addr quan fcb -- )
D W mov u' f.handle W D) W mov ]] end-code
: fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ;
: file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ;
\ *** Block No. 137, Hexblock 89
\ /block *block ks 02 okt 87
Code /block ( d -- rest blk ) A D xchg C pop
C D mov A shr D rcr A shr D rcr D+ D- mov
A- D+ xchg $3FF # C and C push Next
end-code
\ : /block ( d -- rest blk ) b/blk um/mod ;
Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg
A+ sal D rcl A+ sal D rcl A push Next
end-code
\ : *block ( blk -- d ) b/blk um* ;
\ *** Block No. 138, Hexblock 8a
\ fblock@ fblock! ks 19 mär 88
Dos definitions
| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ;
| : fblock ( addr blk fcb -- seg:addr quan fcb )
fcb ! ?beyond dup *block fcb @ fseek ds@ -rot
fcb @ f.size 2@ /block rot - ?beyond
IF drop b/blk THEN fcb @ ;
: fblock@ ( addr blk fcb -- ) fblock lfgets drop ;
: fblock! ( addr blk fcb -- ) fblock lfputs ;
\ *** Block No. 139, Hexblock 8b
\ (r/w flush ks 18 mär 88
Forth definitions
: (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over
IF IF fblock@ false exit THEN fblock! false exit
THEN >r drop /drive ?drive
r> IF block@ exit THEN block! ;
' (r/w Is r/w
| : setfiles ( fcb -- ) isfile@ prevfile !
dup isfile ! fromfile ! ;
: direct 0 setfiles ;
\ *** Block No. 140, Hexblock 8c
\ File >file ks 23 mär 88
: File Create file-link @ here file-link ! ,
here [ b/fcb 2 - ] Literal dup allot erase
file-link @ dup @ f.no c@ 1+ over f.no c!
last @ count $1F and rot f.name place
Does> setfiles ;
File kernel.scr ' kernel.scr @ Constant [fcb]
Dos definitions
: .file ( fcb -- )
?dup IF body> >name .name exit THEN ." direct" ;
\ *** Block No. 141, Hexblock 8d
\ .file pushfile close open ks 12 mai 88
Forth definitions
: file? isfile@ .file ;
: pushfile r> isfile push fromfile push >r ; restrict
: close isfile@ fclose ;
: open isfile@ freset ;
: assign isfile@ dup fclose name swap fname! open ;
\ *** Block No. 142, Hexblock 8e
\ use from loadfrom include ks 18 mär 88
: use >in @ name find
0= IF swap >in ! File last' THEN nip
dup @ [fcb] = over ['] direct = or
0= Abort" not a file" execute open ;
: from isfile push use ;
: loadfrom ( n -- ) pushfile use load close ;
: include 1 loadfrom ;
\ *** Block No. 143, Hexblock 8f
\ drive drv capacity drivenames ks 18 mär 88
: drive ( n -- ) isfile@ IF ~select exit THEN
?drive offset off 0 ?DO I ?capacity offset +! LOOP ;
: drv ( -- n )
isfile@ IF ~disk? exit THEN offset @ /drive nip ;
: capacity ( -- n ) isfile@ ?dup
IF dup f.handle @ 0= IF dup freset THEN
f.size 2@ /block swap 0<> - exit THEN blk/drv ;
| : Drv: Create c, Does> c@ drive ;
0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D:
4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H:
\ *** Block No. 144, Hexblock 90
\ lfsave savefile savesystem ks 10 okt 87
: lfsave ( seg:addr quan string -- )
filename >asciz 0 ~creat ?diskerror
dup >r ~write r> ~close ;
: savefile ( addr len -- ) ds@ -rot
name nullstring? Abort" needs name" lfsave ;
: savesystem save flush $100 here savefile ;
\ *** Block No. 145, Hexblock 91
\ viewing ks 19 mär 88
Dos definitions
| $400 Constant viewoffset
: (makeview ( -- n )
blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup
IF viewoffset * + $8000 or exit THEN 0= ;
' (makeview Is makeview
: @view ( acf -- blk fno ) >name 4 - @ dup 0<
IF $7FFF and viewoffset u/mod exit THEN
?dup 0= Error" eingetippt" 0 ;
: >file ( fno -- fcb ) dup 0=exit file-link
BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ;
\ *** Block No. 146, Hexblock 92
\ forget FCB's ks 23 okt 88
Forth definitions
| : 'file ( -- scr ) r> scr push isfile push >r
[ Dos ] ' @view >file isfile ! ;
: view 'file list ;
: help 'file capacity 2/ + list ;
| : remove? ( dic symb addr -- dic symb addr f )
2 pick over 1+ u< ;
| : remove-files ( dic symb -- dic symb ) file-link
BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT
file-link remove
isfile@ remove? nip IF file-link @ isfile ! THEN
fromfile @ remove? nip 0=exit isfile@ fromfile ! ;

58
8086/msdos/src/vf86info.txt Normal file
View File

@ -0,0 +1,58 @@
\ *** Block No. 0, Hexblock 0
\^@ #### volksFORTH #### cas 18jul20
VolksForth has been developed by
K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck
Ulli Hoffmann, Philip Zembrod, Carsten Strotmann
6502 version by B.Pennemann and K.Schleisiek
Port to C64 "ultraFORTH" by G. Rehfeld
Port to 68000 and Atari ST by D.Weineck and B.Pennemann
Port to 8080 and CP/M by U.Hoffmann jul 86
Port to C16 "ultraFORTH" by C.Vogt
Port to 8088/86 and MS-DOS by K.Schleisiek dez 87
\ *** Block No. 2, Hexblock 2
\\ Die Nutzung der 8088/86 Register ks 27 oct 86
Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt
Dabei ist die Zuordnung zu den Intel Namen folgendermassen:
A <=> AX A- <=> AL A+ <=> AH
C <=> CX C- <=> CL C+ <=> CH
Register A und C sind zur allgemeinen Benutzung frei
D <=> DX D- <=> DL D+ <=> DH
das oberste Element des (Daten)-Stacks.
R <=> BX R- <=> RL R+ <=> RH
der Return_stack_pointer
\ *** Block No. 3, Hexblock 3
\\ Die Nutzung der 8088/86 Register ks 27 oct 86
U <=> BP User_area_pointer
S <=> SP Daten_stack_pointer
I <=> SI Instruction_pointer
W <=> DI Word_pointer, im allgemeinen zur Benutzung frei.
D: <=> DS E: <=> ES S: <=> SS C: <=> CS
Alle Segmentregister werden beim booten auf den Wert des
Codesegments C: gesetzt und muessen, wenn sie "verstellt"
werden, wieder auf C: zurueckgesetzt werden.

0
8086/msdos/volks4th.sys → 8086/msdos/src/volks4th.sys
View File

2
8086/msdos/tests/golden/prelim.golden
View File

@ -25,7 +25,7 @@ Pass #16: testing 2*
Pass #17: testing AND
Pass #18: testing AND
Pass #19: testing AND
PASS exists Pass #20: testing ?F~ ?~~ Pass Error
Pass #20: testing ?F~ ?~~ Pass Error
Pass #21: testing ?~
Pass #22: testing EMIT
Pass #23: testing S"

41
8086/msdos/tests/golden/volks4th-prelim.golden Normal file
View File

@ -0,0 +1,41 @@
ANS-SHIM.FTH
PRELIM.FTH
CR CR SOURCE TYPE ( Preliminary test ) CR
SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR
( The next line of output should be blank to test CR ) SOURCE TYPE CR CR
( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR
( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR
( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR
( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR
( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR
( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC
( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC
( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC
( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC
( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC
Pass #11: testing WORD COUNT .MSG
Pass #12: testing = returns all 1's for true
Pass #13: testing = returns 0 for false
Pass #14: testing -1 interpreted correctly
Pass #15: testing 2*
Pass #16: testing 2*
Pass #17: testing AND
Pass #18: testing AND
Pass #19: testing AND
PASS exists Pass #20: testing ?F~ ?~~ Pass Error
Pass #21: testing ?~
Pass #22: testing EMIT
Pass #23: testing S"
Results:
Pass messages #1 to #23 should be displayed above
and no error messages
0 tests failed out of 57 additional tests
--- End of Preliminary Tests ---

3
8086/msdos/tests/incltest.fth
View File

@ -1,6 +1,7 @@
\needs (type include extend.fb include multi.vid include dos.fb
include log2file.fb
logopen incltest.log
logopen output.log
.( hello, world) cr
: test-hello ." hello, world, from test-hello" cr ;

2
8086/msdos/tests/log2file.fb
View File

File diff suppressed because one or more lines are too long

72
8086/msdos/tests/log2file.fth
View File

@ -20,7 +20,13 @@
\ *** Block No. 1, Hexblock 1
\ load screen phz 16jan22
\ load screen phz 25feb22
Code m+! ( 16b addr -- )
D W mov W inc W inc A pop A W ) add
CS ?[ W dec W dec W ) inc ]?
D pop Next end-code
: (blk blk @ 0= IF ascii ) parse 2drop THEN ;
@ -31,42 +37,74 @@
\ *** Block No. 2, Hexblock 2
\ log-type log-emit log-cr alsologtofile phz 04jan22
\ log-type log-emit log-cr phz 25feb22
context @ dos also context !
\ vocabulary log dos also log definitions
file logfile
variable logfcb
variable logpos 0 ,
: log-type 2dup (type ds@ -rot logfcb @ lfputs ;
: log-type ( addr count -- ) dup logpos m+!
2dup (type ds@ -rot logfcb @ lfputs ;
: log-emit dup (emit logfcb @ fputc ;
: log-cr (cr #cr logfcb @ fputc #lf logfcb @ fputc ;
Output: alsologtofile
log-emit log-cr log-type (del (page (at (at? ;
: log-emit ( char -- ) 1 logpos m+!
dup (emit logfcb @ fputc ;
: log-cr ( -- ) 2 logpos m+!
(cr #cr logfcb @ fputc #lf logfcb @ fputc ;
\ *** Block No. 3, Hexblock 3
\ logopen logclose phz 11jan22
\ alsologtofile logopen logclose logreopen phz 25feb22
Output: alsologtofile
log-emit log-cr log-type (del (page (at (at? ;
: logopen ( -- )
isfile push
isfile push logpos dup 2+ off off
logfile make isfile@ dup freset logfcb !
alsologtofile ;
: logclose ( -- ) display logfcb @ fclose ;
: logreopen ( -- )
logfcb @ freset logpos 2@ logfcb @ fseek
alsologtofile ;
\ *** Block No. 4, Hexblock 4
\ phz 25feb22
\ *** Block No. 5, Hexblock 5

78
8086/msdos/tests/logapp.fth Normal file
View File

@ -0,0 +1,78 @@
\ Experimental code and test for text logs that can be closed
\ and reopened for appending.
\ Already integrated into log2file.fb/.fth
\ Yet to be done: A more permanent test for m+!
\ and an extension of logtest.fb/.fth to also cover the reopen feature.
\ Code +! ( 16b addr -- )
\ D W mov A pop A W ) add D pop Next end-code
Code m+! ( 16b addr -- )
D W mov W inc W inc A pop A W ) add
CS ?[ W dec W dec W ) inc ]?
D pop Next end-code
\ *** Block No. 2, Hexblock 2
\ log-type log-emit log-cr alsologtofile phz 04jan22
context @ dos also context !
\ vocabulary log dos also log definitions
file logfile
variable logfcb
variable logpos 0 ,
: log-type
dup logpos m+!
2dup (type ds@ -rot logfcb @ lfputs ;
: log-emit
1 logpos m+!
dup (emit logfcb @ fputc ;
: log-cr
2 logpos m+!
(cr #cr logfcb @ fputc #lf logfcb @ fputc ;
Output: alsologtofile
log-emit log-cr log-type (del (page (at (at? ;
\ *** Block No. 3, Hexblock 3
\ logopen logclose phz 11jan22
: logopen ( -- )
isfile push logpos dup 2+ off off
logfile make isfile@ dup freset logfcb !
alsologtofile ;
: logclose ( -- ) display logfcb @ fclose ;
: logreopen ( -- )
logfcb @ freset logpos 2@ logfcb @ fseek
alsologtofile ;
logopen output.log
.( logtest started) cr
logpos @ cr u. cr
.( logtest interrupted) cr
logclose
logreopen
create 2v 4 allot
hex
12345. 2v 2!
1 2v m+!
2v 2@ d. cr
1ffff. 2v 2!
1 2v m+!
2v 2@ d. cr
.( logtest done) cr
logclose

2
8086/msdos/tests/logtest.fb
View File

@ -1 +1 @@
\ logtest.fb phz 04jan22 basic tests for log2file.fb \ loadscreen phz 04jan22 include log2file.fb logopen logtest.log .( logtest done) cr logclose
\ logtest.fb phz 04jan22 basic tests for log2file.fb \ loadscreen phz 22jan22 include log2file.fb logopen output.log .( logtest done) cr logclose

4
8086/msdos/tests/logtest.fth
View File

@ -20,11 +20,11 @@
\ *** Block No. 1, Hexblock 1
\ loadscreen phz 04jan22
\ loadscreen phz 22jan22
include log2file.fb
logopen logtest.log
logopen output.log
.( logtest done) cr
logclose

1
8086/msdos/tests/preptest.fb Normal file
View File

@ -0,0 +1 @@
\ include file to bundle what test-*.fth need phz 30jan22\ on top of kernel.com \ loadscreen to prepare kernel.com for test-*.fth phz 31jan22 include multi.vid \ include asm.fb \ include extend.fb : arguments ( n -- ) depth 1- > Error" too few params" ; : blank ( addr count -- ) bl fill ; include dos.fb include include.fb include log2file.fb

38
8086/msdos/tests/preptest.fth Normal file
View File

@ -0,0 +1,38 @@
\ *** Block No. 0, Hexblock 0
\ include file to bundle what test-*.fth need phz 30jan22
\ on top of kernel.com
\ *** Block No. 1, Hexblock 1
\ loadscreen to prepare kernel.com for test-*.fth phz 31jan22
include multi.vid
\ include asm.fb
\ include extend.fb
: arguments ( n -- )
depth 1- > Error" too few params" ;
: blank ( addr count -- ) bl fill ;
include dos.fb
include include.fb
include log2file.fb

2
8086/msdos/tests/test-min.fth
View File

@ -1,6 +1,6 @@
include log2file.fth
logopen test.log
logopen output.log
include ans-shim.fth
: \vf [compile] \ ; immediate

14
8086/msdos/tests/test-std.fth
View File

@ -1,6 +1,6 @@
include log2file.fth
logopen test.log
logopen output.log
include ans-shim.fth
: \vf [compile] \ ; immediate
@ -9,16 +9,14 @@ include prelimtest.fth
include tester.fth
\ 1 verbose !
include core.fr
include coreplustest.fth
include coreplus.fth
include utilities.fth
include errorreport.fth
include util.fth
include errorrep.fth
include coreexttest.fth
include doubletest.fth
include coreext.fth
include double.fth
REPORT-ERRORS
logclose
dos s0:notdone

1
8086/msdos/tests/testprep.fb Normal file
View File

@ -0,0 +1 @@
\ include file to bundle what test-*.fth need phz 30jan22\ on top of kernel.com \ loadscreen to prepare kernel.com for test-*.fth phz 30jan22 include extend.fb include multi.vid include dos.fb include include.fb include log2file.fb

38
8086/msdos/tests/testprep.fth Normal file
View File

@ -0,0 +1,38 @@
\ *** Block No. 0, Hexblock 0
\ include file to bundle what test-*.fth need phz 30jan22
\ on top of kernel.com
\ *** Block No. 1, Hexblock 1
\ loadscreen to prepare kernel.com for test-*.fth phz 30jan22
include extend.fb
include multi.vid
include dos.fb
include include.fb
include log2file.fb

BIN
8086/msdos/v4th.com Normal file
View File

Binary file not shown.

BIN
8086/msdos/v4thfile.com
View File

Binary file not shown.

11
README.ORG
View File

@ -11,9 +11,14 @@ resources.
Some modern Forth Systems were influenced by or were derived from
VolksForth (GNU-Forth, bigForth).
The current Version of VolksForth is 3.81. Version 3.9.x will be
interim versions on the way to sync all VolksForth targets and move
towards compliance with the 2012 Forth standard.
On most platforms the current version of VolksForth is 3.8x.
Versions 3.9.x are interim versions towards compliance with the
2012 Forth standard, and at the same time towards a unification
(as far as feasible) of the sources of the different platforms.
Also included in 3.9.x versions is the transition from block files
to stream files as primary source format, and an introduction of
make-based build and test automation.
So far the 6502/C64 VolksForth (C64/Plus4/X16) is on a 3.9.x version.
Version 3.8.x is based on the Forth 83 standard, Version 4.00 will be
based on the current 2012 Standard (https://forth-standard.org).