mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-14 00:29:45 +00:00
Merge branch 'master' into x16-r41
# Conflicts: # 6502/C64/src/vf-cbm-file.fth
This commit is contained in:
commit
d6d38e13a4
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -2,3 +2,5 @@
|
||||||
*.log
|
*.log
|
||||||
/.DS_Store
|
/.DS_Store
|
||||||
*~
|
*~
|
||||||
|
/tools/blkpack
|
||||||
|
/tools/blkunpack
|
||||||
|
|
|
@ -175,31 +175,31 @@ emulator/sdcard.img: emulator/sdcard.sfdisk
|
||||||
|
|
||||||
test-v4thblk-c64.golden: $(patsubst %, tests/golden/%.golden, \
|
test-v4thblk-c64.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core coreext double block report-blk)
|
prelim core coreext double block report-blk)
|
||||||
cat $? > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test-v4th-c64.golden: $(patsubst %, tests/golden/%.golden, \
|
test-v4th-c64.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core coreext double report-noblk)
|
prelim core coreext double report-noblk)
|
||||||
cat $? > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test-v4thblk-c16+.golden: $(patsubst %, tests/golden/%.golden, \
|
test-v4thblk-c16+.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core coreext double block report-blk)
|
prelim core coreext double block report-blk)
|
||||||
cat $? > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test-v4th-c16+.golden: $(patsubst %, tests/golden/%.golden, \
|
test-v4th-c16+.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core coreext double report-noblk)
|
prelim core coreext double report-noblk)
|
||||||
cat $? > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test-v4thblk-c16-.golden: $(patsubst %, tests/golden/%.golden, \
|
test-v4thblk-c16-.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core)
|
prelim core)
|
||||||
cat $? > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test-v4th-c16-.golden: $(patsubst %, tests/golden/%.golden, \
|
test-v4th-c16-.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core coreext double report-noblk)
|
prelim core coreext double report-noblk)
|
||||||
cat $? > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test-v4th-x16.golden: $(patsubst %, tests/golden/%.golden, \
|
test-v4th-x16.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core coreext double report-noblk)
|
prelim core coreext double report-noblk)
|
||||||
cat $? > $@
|
cat $^ > $@
|
||||||
|
|
||||||
# Rules for building Forth binaries on top of the plain vanilla
|
# Rules for building Forth binaries on top of the plain vanilla
|
||||||
# c64-volksforth83.
|
# c64-volksforth83.
|
||||||
|
|
|
@ -14,7 +14,10 @@
|
||||||
create fload-dev 8 ,
|
create fload-dev 8 ,
|
||||||
create fload-2nd f ,
|
create fload-2nd f ,
|
||||||
|
|
||||||
| : eol? ( c -- f )
|
| : eolf? ( c -- f )
|
||||||
|
\ f=-1: not yet eol; store c and continue
|
||||||
|
\ f=0: eol but not yet eof; return line and flag continue
|
||||||
|
\ f=1: not eol but eof; store c, return line and flag eof
|
||||||
dup 0= swap #cr = or IF 0 exit THEN
|
dup 0= swap #cr = or IF 0 exit THEN
|
||||||
i/o-status? IF 1 exit THEN -1 ;
|
i/o-status? IF 1 exit THEN -1 ;
|
||||||
|
|
||||||
|
@ -25,7 +28,7 @@
|
||||||
fload-dev @ fload-2nd @ busin
|
fload-dev @ fload-2nd @ busin
|
||||||
i/o-status?abort
|
i/o-status?abort
|
||||||
tib /tib bounds
|
tib /tib bounds
|
||||||
DO bus@ i/o-status?abort dup eol? under
|
DO bus@ i/o-status?abort dup eolf? under
|
||||||
IF I c! ELSE drop THEN
|
IF I c! ELSE drop THEN
|
||||||
dup 0<
|
dup 0<
|
||||||
IF drop ELSE I + tib - #tib ! UNLOOP
|
IF drop ELSE I + tib - #tib ! UNLOOP
|
||||||
|
@ -33,7 +36,7 @@
|
||||||
LOOP /tib #tib !
|
LOOP /tib #tib !
|
||||||
." warning: line exceeds max " /tib .
|
." warning: line exceeds max " /tib .
|
||||||
cr ." extra chars ignored" cr
|
cr ." extra chars ignored" cr
|
||||||
BEGIN bus@ eol? 1+ UNTIL
|
BEGIN bus@ eolf? 1+ UNTIL
|
||||||
i/o-status? busoff ;
|
i/o-status? busoff ;
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -24,4 +24,4 @@ Output: alsologtofile
|
||||||
alsologtofile ;
|
alsologtofile ;
|
||||||
|
|
||||||
: logclose
|
: logclose
|
||||||
log-dev-2nd@ busclose display ;
|
display log-dev-2nd@ busclose ;
|
||||||
|
|
File diff suppressed because one or more lines are too long
|
@ -20,7 +20,7 @@ ende 123
|
||||||
|
|
||||||
\ *** Block No. 1, Hexblock 1
|
\ *** Block No. 1, Hexblock 1
|
||||||
|
|
||||||
\ volksFORTH Loadscreen for py65 target cas 15juli2020
|
\ volksFORTH Loadscreen for py65 target cas 02aug2020
|
||||||
forth definitions
|
forth definitions
|
||||||
: (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE
|
: (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE
|
||||||
|
|
||||||
|
@ -58,7 +58,7 @@ HERE DUP ORIGIN!
|
||||||
|
|
||||||
\ *** Block No. 3, Hexblock 3
|
\ *** Block No. 3, Hexblock 3
|
||||||
|
|
||||||
\ Coldstartvalues and user variables cas 15juli2020
|
\ Coldstartvalues and user variables cas 02aug2020
|
||||||
\
|
\
|
||||||
|
|
||||||
0 JMP 0 JSR HERE 2- >LABEL >WAKE
|
0 JMP 0 JSR HERE 2- >LABEL >WAKE
|
||||||
|
@ -67,7 +67,7 @@ HERE DUP ORIGIN!
|
||||||
0D6 ALLOT
|
0D6 ALLOT
|
||||||
|
|
||||||
\ Bootlabel
|
\ Bootlabel
|
||||||
," VOLKSFORTH-83 3.8 py65 15july2020 CS"
|
," VolksForth-83 3.8.1 py65 02aug2020 CS"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -172,7 +172,7 @@ USER UDP \ POINTS TO NEXT FREE ADDR IN USER
|
||||||
|
|
||||||
\ *** Block No. 9, Hexblock 9
|
\ *** Block No. 9, Hexblock 9
|
||||||
|
|
||||||
\ MANIPULATE SYSTEM POINTERS 29JAN85BP)
|
\ MANIPULATE SYSTEM POINTERS 29JAN85BP) cas 02aug2020
|
||||||
|
|
||||||
CODE SP@ ( -- ADDR)
|
CODE SP@ ( -- ADDR)
|
||||||
SP LDA N STA SP 1+ LDA N 1+ STA
|
SP LDA N STA SP 1+ LDA N 1+ STA
|
||||||
|
@ -628,12 +628,12 @@ CODE U< ( U1 U2 -- FLAG)
|
||||||
|
|
||||||
\ *** Block No. 33, Hexblock 21
|
\ *** Block No. 33, Hexblock 21
|
||||||
|
|
||||||
\ COMPARISION WORDS 24DEC83KS)
|
\ COMPARISION WORDS 24DEC83KS) cas 02aug2020
|
||||||
|
|
||||||
| : 0< 8000 AND 0<> ;
|
| : 0< 8000 AND 0<> ;
|
||||||
|
|
||||||
: > ( N1 N2 -- FLAG) SWAP < ;
|
: > ( N1 N2 -- FLAG) SWAP < ;
|
||||||
: 0> ( N -- FLAG) NEGATE 0< ;
|
: 0> ( N -- FLAG) DUP 0< SWAP 0= OR NOT ;
|
||||||
: 0<> ( N -- FLAG) 0= NOT ;
|
: 0<> ( N -- FLAG) 0= NOT ;
|
||||||
: U> ( U1 U2 -- FLAG) SWAP U< ;
|
: U> ( U1 U2 -- FLAG) SWAP U< ;
|
||||||
: = ( N1 N2 -- FLAG) - 0= ;
|
: = ( N1 N2 -- FLAG) - 0= ;
|
||||||
|
@ -2300,7 +2300,7 @@ HOST TARGET
|
||||||
|
|
||||||
\ *** Block No. 121, Hexblock 79
|
\ *** Block No. 121, Hexblock 79
|
||||||
|
|
||||||
\ 'COLD 07JUN85BP) cas 15juli2020
|
\ 'COLD 07JUN85BP) cas 02aug2020
|
||||||
| : INIT-VOCABULARYS VOC-LINK @
|
| : INIT-VOCABULARYS VOC-LINK @
|
||||||
BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ;
|
BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ;
|
||||||
|
|
||||||
|
@ -2309,7 +2309,7 @@ HOST TARGET
|
||||||
DEFER 'COLD ' NOOP IS 'COLD
|
DEFER 'COLD ' NOOP IS 'COLD
|
||||||
|
|
||||||
| : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH
|
| : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH
|
||||||
." volksFORTH-83 3.8 py65 202007" CR RESTART ; -2 ALLOT
|
." volksFORTH-83 3.8.1 py65 202008" CR RESTART ; -2 ALLOT
|
||||||
|
|
||||||
DEFER 'RESTART ' NOOP IS 'RESTART
|
DEFER 'RESTART ' NOOP IS 'RESTART
|
||||||
| : (RESTART ['] (QUIT IS 'QUIT
|
| : (RESTART ['] (QUIT IS 'QUIT
|
||||||
|
|
Binary file not shown.
1
8080/AmstradCPC/AMSDOS.SCR
Normal file
1
8080/AmstradCPC/AMSDOS.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/ASS8080.SCR
Normal file
1
8080/AmstradCPC/ASS8080.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/ASSTRAN.SCR
Normal file
1
8080/AmstradCPC/ASSTRAN.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Transinient Assembler 11Nov86 Dieses File enthaelt Befehle, die den Assembler vollstaendig in den Heap laden, so dass er schliesslich mit clear wieder vergessen werden kann. Dadurch ist es nicht notwendig in einer Anwendung den ganzen Assembler im Speicher lassen zu muessen, nur weil einige primitive Worte in Assembler geschrieben sind. \ Internal Assembler UH 22Oct86 Onlyforth here $C00 hallot heap dp ! include ass8080.scr dp !
|
1
8080/AmstradCPC/ATARI.SCR
Normal file
1
8080/AmstradCPC/ATARI.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/COPY.SCR
Normal file
1
8080/AmstradCPC/COPY.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\ Copy und Convey 19Nov87 Dieses File enthaelt Definitionen, die urspruenglich im Kern enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern klein zu halten. copy kopiert einen Screen convey kopiert einen Bereich von Screens \ moving blocks 20Oct86 19Nov87| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; | : fromblock ( blk -- adr ) fromfile @ (block ; | : (copy ( from to -- ) dup isfile@ core? IF prev @ emptybuf THEN full? IF save-buffers THEN offset @ + isfile@ rot fromblock 6 - 2! update ; | : blkmove ( from to quan --) 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 --) swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ;
|
1
8080/AmstradCPC/DISASS.SCR
Normal file
1
8080/AmstradCPC/DISASS.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/DOUBLE.SCR
Normal file
1
8080/AmstradCPC/DOUBLE.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Double words 11Nov86 Dieses File enthaelt Worte fuer 32-Bit Objekte. Im Kern bereits enthalten sind: 2@ 2! 2dup 2drop 2swap dnegate d+ Hier werden definiert: 2Variable 2Constant 2over d* \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86 : 2Variable Variable 2 allot ; : 2Constant Create , , does> 2@ ; Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi SP dad M D mov H dcx M E mov D push H dcx M D mov H dcx M E mov D push Next end-code --> \\ Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ d* d- 29Jun86 : d* ( d1 d2 -- d1*d2 ) rot 2over rot um* 2swap um* d+ 2swap um* d+ ; : d- ( d1 d2 -- d1-d2 ) dnegate d+ ;
|
1
8080/AmstradCPC/EDITOR.SCR
Normal file
1
8080/AmstradCPC/EDITOR.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/FILEINT.SCR
Normal file
1
8080/AmstradCPC/FILEINT.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/GRAFDEMO.SCR
Normal file
1
8080/AmstradCPC/GRAFDEMO.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/GRAFIK.SCR
Normal file
1
8080/AmstradCPC/GRAFIK.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/HASHCASH.SCR
Normal file
1
8080/AmstradCPC/HASHCASH.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/INSTALL.SCR
Normal file
1
8080/AmstradCPC/INSTALL.SCR
Normal file
File diff suppressed because one or more lines are too long
BIN
8080/AmstradCPC/KERNEL.COM
Normal file
BIN
8080/AmstradCPC/KERNEL.COM
Normal file
Binary file not shown.
1
8080/AmstradCPC/MATHE.SCR
Normal file
1
8080/AmstradCPC/MATHE.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\ Mathematics calculating sin & cos nach FD IV 1 6UH 03Dec86 Dieses File enthaelt Definitionen zur Berechnung von Integer-Sinus und -Cosinus. Sie werden z.B. von der Turtle-Grafik benutzt. \ Mathematics calculating sin & cos nach FD IV 1 6 05Sep86 Create sintab decimal 0000 , 0175 , 0349 , 0523 , 0698 , 0872 , 1045 , 1219 , 1392 , 1564 , 1736 , 1908 , 2079 , 2250 , 2419 , 2588 , 2756 , 2924 , 3090 , 3256 , 3420 , 3584 , 3746 , 3907 , 4067 , 4226 , 4384 , 4540 , 4695 , 4848 , 5000 , 5150 , 5299 , 5446 , 5592 , 5736 , 5878 , 6018 , 6157 , 6293 , 6428 , 6561 , 6691 , 6820 , 6947 , 7071 , 7193 , 7314 , 7431 , 7547 , 7660 , 7771 , 7880 , 7986 , 8090 , 8192 , 8290 , 8387 , 8480 , 8572 , 8660 , 8746 , 8829 , 8910 , 8988 , 9063 , 9135 , 9205 , 9272 , 9336 , 9397 , 9455 , 9511 , 9563 , 9613 , 9659 , 9703 , 9744 , 9781 , 9816 , 9848 , 9877 , 9903 , 9925 , 9945 , 9962 , 9976 , 9986 , 9994 , 9998 , 10000 , : sintable ( deg -- sine*10000 ) 2* sintab + @ ; --> \ sin 05Sep86 : s180 ( deg -- sine*10000 ) dup 90 > IF 180 swap - ( reflect ) THEN sintable ; : sin ( deg -- sine*10000 ) 360 mod dup 180 > IF 180 - s180 negate exit THEN s180 ; : cos ( deg -- cosine*10000 ) 90 + sin ; hex
|
1
8080/AmstradCPC/PORT8080.SCR
Normal file
1
8080/AmstradCPC/PORT8080.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\ 8080-Portzugriff UH 11Nov86 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit Adressen anzusprechen. Der Code ist leider selbstmodifizierend, da beim 8080 die Portadresse im Code ausdruecklich angegeben werden muss. Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen, kann auch das File portz80.scr benutzt werden, indem die Z80-IO-Befehle (16Bit-Adressen) benutzt werden. \ 8080-Portzugriff pc@, pc! 15Jul86 ' 0 | Alias patch Code pc@ ( addr -- c ) H pop L A mov here 4 + sta patch in 0 H mvi A L mov Hpush jmp end-code Code pc! ( c addr -- ) H pop L A Mov here 6 + sta H pop L A mov patch out Next end-code
|
1
8080/AmstradCPC/PORTZ80.SCR
Normal file
1
8080/AmstradCPC/PORTZ80.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\ Z80-Portzugriff UH 05Nov86 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit Adressen anzusprechen. Einige Komputer, so die der Schneider Serie dekodieren ihre Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit Adressen angesprochen werden muessen. Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen. \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86 Assembler definitions | : Z80-io ( base -- ) \ define special Z80-io instruction Create c, Does> ( reg -- ) $ED c, c@ swap 8 * + c, ; $40 Z80-io (c)in $41 Z80-io (c)out Forth definitions --> \ store and fetch values with 16-bit port-adresses UH 05Nov86 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr H pop IP push H B mvx L (c)in 0 H mvi IP pop hpush jmp end-code Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr H pop D pop IP push H B mvx E (c)out IP pop Next end-code
|
1
8080/AmstradCPC/PRIMED.SCR
Normal file
1
8080/AmstradCPC/PRIMED.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Primitivst Editor zur Installation UH 17Nov86 Da zur Installationszeit der Full-Screen Editor noch nicht funtionsfaehig ist, muessen die zu aendernden Screens auf eine andere Weise ge{nder werden: mit dem primitivst Editor PRIMED, der nur ein Benutzer wort enthaelt: Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen, dann mit "ll NEW" den Screen aendern. Es koennen immer nur ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW. Nach jeder Eingabe von RETURN wird die eingegebene Zeile in den Screen uebernommen, und der ganze Screen zur Kontrolle nocheinmal ausgegeben. \ primitivst Editor PRIMED UH 17Nov86 | : !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 ; \ PRIMED Demo-Screen Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender Eingabe dieses Textes Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit "0 NEW" erzeugt. Ulrich Hoffmann
|
1
8080/AmstradCPC/PRINTER.SCR
Normal file
1
8080/AmstradCPC/PRINTER.SCR
Normal file
File diff suppressed because one or more lines are too long
129
8080/AmstradCPC/README-german.org
Normal file
129
8080/AmstradCPC/README-german.org
Normal file
|
@ -0,0 +1,129 @@
|
||||||
|
Änderungen im CP/M-volksFORTH von Version 3.80 zu Version 3.80a UH 04Mär88
|
||||||
|
=============================================================================
|
||||||
|
|
||||||
|
Die Unverträlichkeit des ursprünglichen CP/M-volksFORTHs mit CP/M+ und die
|
||||||
|
damit verbundene Vielzahl von unterschiedlichen Versionen hat eine allgmeine
|
||||||
|
Überarbeitung des CP/M-volksFORTHs notwendig gemacht.
|
||||||
|
|
||||||
|
Bei dieser Gelegenheit wurden gleich einige Fehler beseitigt und einige
|
||||||
|
neue Funktionen eingeführt.
|
||||||
|
|
||||||
|
1. Änderungen im Kern (SOURCE.SCR)
|
||||||
|
|
||||||
|
- Die Terminal-Ein- und Ausgabe wurde auf ein Mindestmaß begrenzt,
|
||||||
|
sodaß auch unmittelbar mit dem Kern gearbeitet werden kann. Es
|
||||||
|
gibt keinen Zeileneditor für die Eingabezeile mehr, dieser wurde
|
||||||
|
zusammen mit der "Terminal:" Funktion in die Datei XINOUT.SCR
|
||||||
|
ausgelagert.
|
||||||
|
|
||||||
|
- Der Kern enthält kein Fileinterface mehr, sondern arbeitet nur
|
||||||
|
in dem File, welches bei Aufruf in der Kommandozeile mit
|
||||||
|
angegeben wird (default-file). Typischerweise wird mit diesem
|
||||||
|
Mechanismus zuerst das File-Interface geladen.
|
||||||
|
|
||||||
|
- Direkter Diskettenzugriff wird im Kern nicht mehr unterstützt,
|
||||||
|
da er unter CP/M+ nicht problemlos zu implementieren ist.
|
||||||
|
Außerdem kann in Ermangelung eines CP/M+ Systems der Code hier
|
||||||
|
nicht getestet werden. Diskettenzugriff findet nur noch über das
|
||||||
|
BDOS statt.
|
||||||
|
|
||||||
|
- Zahlreiche Funktionen des Kerns wurden neu überarbeitet und in
|
||||||
|
Code geschrieben, als wichtige neue Funktion des Kerns ist
|
||||||
|
"search" hinzugekommen, das eine schnelle Suche mit
|
||||||
|
Berücksichtigung der Groß/Klein- schreibung ermöglicht.
|
||||||
|
|
||||||
|
- Die Funktion CAPITALIZE ist durch die ähnliche Funktion UPPER
|
||||||
|
ersetzt worden. Das EXIT in NAME verschiebt sich dadurch.
|
||||||
|
|
||||||
|
- Der Kern gibt beim Verlassen eine Größenangabe in (256
|
||||||
|
Byte)-Seiten aus. Diese Angabe kann direkt benutzt werden, um
|
||||||
|
mit dem CP/M =SAVE= Kommando das System auf Diskette zu schreiben.
|
||||||
|
(Forth: =SAVE= nicht vergessen! )
|
||||||
|
|
||||||
|
- SAVE-BUFFERS ist um ein defered Wort SAVE-DOS-BUFFERS erweitert
|
||||||
|
worden. Damit sollte der lästige CP/M+ Fehler ausgeschaltet
|
||||||
|
sein.
|
||||||
|
|
||||||
|
- Das defered Wort POSTLUDE regelt die letzte Handlung des Systems
|
||||||
|
vor dem CP/M Warmstart (Cursor anschalten, Bildschirm löschen
|
||||||
|
oder Systemgröße ausgeben...)
|
||||||
|
|
||||||
|
- Die Kommandozeile des Aufrufs wird in den TIB kopiert und kann
|
||||||
|
dort interpretiert werden. Das Öffnen des default-Files löscht
|
||||||
|
allerdings den TIB wieder, sodaß diese Funktion erst ausgenutzt
|
||||||
|
werden kann, wenn das Fileinterface geladen ist. (DRVINIT öffnet
|
||||||
|
nicht mehr das default-File.)
|
||||||
|
|
||||||
|
- Die Interpret-Loop wurde überarbeitet und um das Wort PROMPT
|
||||||
|
erweitert. Das Sonderwort >INTERPRET ist weggefallen. Seine
|
||||||
|
Funktion übernimmt jetzt das (normale) defered Wort PARSER.
|
||||||
|
|
||||||
|
- Die Kontrollstruktur-Anweisungen (IF, WHILE ... ) sind jetzt
|
||||||
|
auch inter- aktiv verwendbar.
|
||||||
|
|
||||||
|
- Diverse kleinere Änderungen haben stattgefunden.
|
||||||
|
|
||||||
|
|
||||||
|
2. Änderungen im Editor (Dateien =EDITOR.SCR=, =STRING.SCR=)
|
||||||
|
|
||||||
|
- Das Markieren der Screens wurde korrigiert und geschieht jetzt
|
||||||
|
auch beim Suchen/Ersetzen und bei =showload= richtig.
|
||||||
|
|
||||||
|
- =VIEW= wurde geändert und sucht nun nach dem in Blanks
|
||||||
|
eingerahmten Wort.
|
||||||
|
|
||||||
|
- Es wird nun zusätzlich das Associative File angezeigt.
|
||||||
|
|
||||||
|
- Beim Suchen/Ersetzen wird die Screennummer hochgezählt, um eine
|
||||||
|
Kontrolle über das Suchen zu geben.
|
||||||
|
|
||||||
|
- Die Textsuche ist nun schon im Kern definiert, die elementaren
|
||||||
|
Stringfunktionen sind mit in das EDITOR.SCR genommen worden.
|
||||||
|
STRING.SCR ist daher entfallen.
|
||||||
|
|
||||||
|
3. Änderungen im Multi-Tasker (TASKER.SCR)
|
||||||
|
|
||||||
|
- Das Wort TASK wurde geändert: Die Konstante ist nun vor der Task
|
||||||
|
definiert. Man kann also nun mit FORGET <taskname> tatsächlich
|
||||||
|
die Task vergessen.
|
||||||
|
|
||||||
|
- Der PAUSE/WAKE/STOP-Mechanismus wurde geändert. In der Benutzung
|
||||||
|
ergibt sich daraus keine Änderung.
|
||||||
|
|
||||||
|
4. Änderungen im Fileinterface (FILEINT.SCR)
|
||||||
|
|
||||||
|
- Das Fileinterface wurde überarbeitet und einige Fehler
|
||||||
|
beseitigt. Die Namen zahlreicher Worte haben sich geändert, sind
|
||||||
|
dadurch aber systematischer geworden. Die Funktionen sind im
|
||||||
|
Wesentlichen gleich geblieben.
|
||||||
|
|
||||||
|
|
||||||
|
5. Terminal-Installation (Zusatz zu Anpassung von VolksForth an den Computer)
|
||||||
|
|
||||||
|
- Da der Kern kein Fileinterface mehr enthält, muß dies noch vor
|
||||||
|
dem Primitivst-Editor geladen werden. Es ergibt sich also die
|
||||||
|
Kommandosequenz:
|
||||||
|
#+begin_example
|
||||||
|
A> kernel fileint.scr
|
||||||
|
1 load
|
||||||
|
use primed.scr 1 load
|
||||||
|
use terminal.scr
|
||||||
|
#+end_example
|
||||||
|
|
||||||
|
6. Erstellen eines Standard-Systems
|
||||||
|
|
||||||
|
- Mit folgender Kommandosequenz wird aus =KERNEL.COM= das File
|
||||||
|
=VOLKS4TH.COM= gemacht:
|
||||||
|
#+begin_example
|
||||||
|
A> kernel fileint.scr
|
||||||
|
1 load
|
||||||
|
include startup.scr
|
||||||
|
#+end_example
|
||||||
|
|
||||||
|
7. Neue Dateien auf der Diskette
|
||||||
|
|
||||||
|
- READ.ME diese Datei
|
||||||
|
- XINOUT.SCR Terminalfunktionen und Zeileneditor für Eingabe
|
||||||
|
- COPY.SCR Die Funktionen COPY und CONVEY (früher im Kern).
|
||||||
|
|
||||||
|
- STRING.SCR Entfällt, da in EDITOR.SCR und SOURCE.SCR integriert.
|
1
8080/AmstradCPC/RELOCATE.SCR
Normal file
1
8080/AmstradCPC/RELOCATE.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Relocate System 11Nov86 Dieses File enthaelt das Utility-Wort BUFFERS. Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen, die volksFORTH benutzt. Voreingestellt sind 4 Buffer. Benutzung: nn BUFFERS \ Relocate a system 16Jul86 | : relocate-tasks ( mainup -- ) up@ dup BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ; | : relocate ( stacklen rstacklen -- ) 2dup + b/buf + 2+ limit origin - u> abort" kills all buffers" over pad $100 + origin - u< abort" cuts the dictionary" dup udp @ $40 + u< abort" a ticket to the moon with no return ..." flush empty over + origin + origin $0A + ! \ r0 origin + dup relocate-tasks \ multitasking link 6 - origin 8 + ! \ s0 cold ; --> \ bytes.more buffers 29Jun86 | : bytes.more ( n+- -- ) up@ origin - + r0 @ up@ - relocate ; : buffers ( +n -- ) b/buf * 4+ limit r0 @ - swap - bytes.more ;
|
1
8080/AmstradCPC/SAVESYS.SCR
Normal file
1
8080/AmstradCPC/SAVESYS.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ savesystem 11Nov86 Dieses File enthaelt das Utility-Wort SAVESYSTEM. Mit ihm kann man das gesamte System als File auf Disk schreiben. Achtung: Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM der Heap geloescht! Benutzung: SAVESYSTEM <filename> \ savsystem 05Nov86 : savesystem \ filename save $100 here over - savefile ; \\ Einfaches savesystem 18Aug86 | : message ( -- ) base push decimal cr ." ready for SAVE " here 1- $100 / u. ." VOLKS4TH.COM" cr ; : savesystem ( -- ) save message bye ;
|
1
8080/AmstradCPC/SEE.SCR
Normal file
1
8080/AmstradCPC/SEE.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/SIMPFILE.SCR
Normal file
1
8080/AmstradCPC/SIMPFILE.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Simple Files 11Nov86 Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es trotzdem wuenschenswert eine Art File-Struktur zu besitzen. Dieses File enthaelt eine einfache Implementation eines Filesystems. Der/die Programmierer/in muss selbst die Direktory auf dem laufenden halten: in ihr sind die Start-Bloecke des entsprechenden Diskettenteils gespeichert. Sogar eine Hierarchie von Direktories laesst sich so relisieren. Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64). \ simple files 12feb86 \needs search .( search missing) \\ | Variable (dir : dir (dir @ ; : root 0 (dir ! ; root | : read" ( -- n) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in push >in ! bl dir block b/blk (word number drop ; : load" read" dir + load ; : dir" read" (dir +! ; : list" read" dir + list ; \ 1 +load \ Only if file" is needed \ simple files 01feb86 | : snap ( n0 -- n1) $20 / 3 max $20 * ; : file" ( n --) Ascii " word count 2dup dir block b/blk search IF + nip ELSE drop dir block b/blk -trailing nip snap $20 + dup b/blk 1- > abort" directory full" 2dup + >r dir block + swap cmove r> THEN snap $18 + >r dir - extend under dabs <# # # # # base @ $0A = IF Ascii & ELSE Ascii $ THEN hold rot 0< IF Ascii - ELSE bl THEN hold #> r> dir block + swap cmove update ; \ dir load" 11feb86 \needs search .( search missing) \\ 0 Constant dir : load" ( -- ) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in @ blk @ rot >in ! dir blk ! bl word number drop -rot blk ! >in ! load ;
|
1
8080/AmstradCPC/SOURCE.SCR
Normal file
1
8080/AmstradCPC/SOURCE.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/STARTUP.SCR
Normal file
1
8080/AmstradCPC/STARTUP.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth ( 10.02.89/KK ) include ass8080.scr include xinout.scr \ Erweiterte Ein- u. Ausgabe include terminal.scr save \ Terminal include copy.scr cr .( copy und convey geladen.) cr include savesys.scr cr .( Savesystem geladen.) cr include editor.scr cr .( Editor geladen.) cr include tools.scr cr .( Tools geladen.) cr include see.scr cr .( Decompiler geladen.) cr include tasker.scr cr .( Multitasker geladen.) cr include printer.scr cr .( Printer Interface geladen.) cr include relocate.scr cr .( Relocating geladen. ) cr .( May the volksFORTH be with you ...) cr decimal caps on editor.scr scr off r# off ( savesystem volks4th.com ) \ UH 22Oct86
|
1
8080/AmstradCPC/TASKER.SCR
Normal file
1
8080/AmstradCPC/TASKER.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/TERMINAL.SCR
Normal file
1
8080/AmstradCPC/TERMINAL.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Terminal-Anpassung 11Nov86 In diesem File wird volksFORTH an das benutzte Terminal angepasst. Ueber folgende Faehigkeiten muss das Terminal verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt werden koennen: curon, curoff \ Ein- bzw. Ausschalten des Cursors curleft, currite \ Cursor nach links bzw. rechts bewegen rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellungdark \ Loeschen des Bildschirms locate \ Positionieren des Cursors auf eine \ bestimmte Position auf dem Bildschirm \ Schneider CPC464-Terminal Anpassung UH 18Mar87 | : CPCcuron ( -- ) 3 con! ; | : CPCcuroff ( -- ) 2 con! ; | Variable reverse reverse off | : CPCrvson ( -- ) reverse @ ?exit reverse on $18 con! ; | : CPCrvsoff ( -- ) reverse @ 0= ?exit reverse off $18 con! ; | : CPCdark ( -- ) $0C con! ; | : CPClocate ( row col -- ) $1F con! 1+ con! &24 min 1+ con! ; Terminal: schneider CPCcuron CPCcuroff CPCrvson CPCrvsoff CPCdark CPClocate ; schneider page .( CPC-464 Terminal installiert. ) cr cr
|
1
8080/AmstradCPC/TIMES.SCR
Normal file
1
8080/AmstradCPC/TIMES.SCR
Normal file
|
@ -0,0 +1 @@
|
||||||
|
\\ Times Often: interactive loops 11Nov86 Dieses File enthaelt die Definitionen der beiden Utility-Worte TIMES, OFTEN, die interaktiv benutzt werden koennen, was normalerweise mit BEGIN WHILE ... nicht moeglich ist. Benutzung: nur interaktiv! a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal, \ oder bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt, a b ... often \ Wiederhole die Befehlsfolge "a b ..." \ so oft, bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt. \ Times, Often 02feb86 also Forth definitions : 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 ; toss definitions
|
1
8080/AmstradCPC/TOOLS.SCR
Normal file
1
8080/AmstradCPC/TOOLS.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/TURTDEMO.SCR
Normal file
1
8080/AmstradCPC/TURTDEMO.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/TURTLE.SCR
Normal file
1
8080/AmstradCPC/TURTLE.SCR
Normal file
File diff suppressed because one or more lines are too long
1
8080/AmstradCPC/VDOS62KX.SCR
Normal file
1
8080/AmstradCPC/VDOS62KX.SCR
Normal file
File diff suppressed because one or more lines are too long
BIN
8080/AmstradCPC/VOLKS4TH.COM
Normal file
BIN
8080/AmstradCPC/VOLKS4TH.COM
Normal file
Binary file not shown.
1
8080/AmstradCPC/XINOUT.SCR
Normal file
1
8080/AmstradCPC/XINOUT.SCR
Normal file
File diff suppressed because one or more lines are too long
53
8080/AmstradCPC/disks/makedisks.sh
Executable file
53
8080/AmstradCPC/disks/makedisks.sh
Executable file
|
@ -0,0 +1,53 @@
|
||||||
|
#!/bin/sh
|
||||||
|
echo "Creating base.dsk ..."
|
||||||
|
iDSK base.dsk -n
|
||||||
|
iDSK base.dsk -i ../AMDDOS.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../ATARI.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../DOUBLE.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../GRAFDEMO.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../GRAFIK.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../INSTALL.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../MATHE.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../TERMINAL.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../TURTDEMO.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../TURTLE.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../VDOS62KX.SCR -t 2
|
||||||
|
iDSK base.dsk -i ../VOLKS4TH.COM -t 2
|
||||||
|
echo "base.dsk created!"
|
||||||
|
|
||||||
|
echo "Creating kernel.dsk ..."
|
||||||
|
iDSK kernel.dsk -n
|
||||||
|
iDSK kernel.dsk -i ../ASS8080.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../ASSTRAN.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../DISASS.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../FILEINT.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../HASHCASH.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../KERNEL.COM -t 2
|
||||||
|
iDSK kernel.dsk -i ../PORT8080.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../PORTZ80.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../PRIMED.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../SIMPFILE.SCR -t 2
|
||||||
|
iDSK kernel.dsk -i ../TIMES.SCR -t 2
|
||||||
|
echo "kernel.dsk created!"
|
||||||
|
|
||||||
|
echo "Creating tools.dsk ..."
|
||||||
|
iDSK tools.dsk -n
|
||||||
|
iDSK tools.dsk -i ../ASS8080.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../COPY.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../EDITOR.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../PRINTER.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../RELOCATE.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../SAVESYS.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../SEE.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../STARTUP.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../TASKER.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../TERMINAL.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../TOOLS.SCR -t 2
|
||||||
|
iDSK tools.dsk -i ../XINOUT.SCR -t 2
|
||||||
|
echo "tools.dsk created!"
|
||||||
|
|
||||||
|
echo "Creating source.dsk ..."
|
||||||
|
iDSK source.dsk -n
|
||||||
|
iDSK source.dsk -i ../SOURCE.SCR -t 2
|
||||||
|
echo "source.dsk created!"
|
||||||
|
|
8
8080/AmstradCPC/disks/readme.org
Normal file
8
8080/AmstradCPC/disks/readme.org
Normal file
|
@ -0,0 +1,8 @@
|
||||||
|
* Creating Disk Images for Amstrad/Schneider CPC
|
||||||
|
|
||||||
|
The script =makedisks.sh= will create disk images to use in Amstrad CPC
|
||||||
|
Emulator or modern disk emulator systems for the Amstrad CPC system.
|
||||||
|
|
||||||
|
The script requires =iDSK= (https://github.com/cpcsdk/idsk) to be
|
||||||
|
installed.
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr include see.fb cr .( Decompiler loaded) cr include tasker.fb cr .( Multitasker loaded) cr include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86
|
\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O \ include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr \ include see.fb cr .( Decompiler loaded) cr \ include tasker.fb cr .( Multitasker loaded) cr \ include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86
|
Binary file not shown.
237
8086/msdos/Makefile
Normal file
237
8086/msdos/Makefile
Normal file
|
@ -0,0 +1,237 @@
|
||||||
|
|
||||||
|
fbfiles = $(wildcard src/*.fb tests/*.fb)
|
||||||
|
fthfiles = $(patsubst %.fb, %.fth, $(fbfiles))
|
||||||
|
|
||||||
|
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-std.result test-blk.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/v4th.fth src/vf86core.fth \
|
||||||
|
src/vf86dos.fth src/vf86file.fth src/vf86end.fth
|
||||||
|
rm -f v4th.com V4TH.COM OUTPUT.LOG
|
||||||
|
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \
|
||||||
|
metafile.com "include v4th.fth"
|
||||||
|
dos2unix -n OUTPUT.LOG v4th.log
|
||||||
|
mv V4TH.COM v4th.com
|
||||||
|
grep -F 'unresolved:' v4th.log
|
||||||
|
grep -F 'new kernel written as v4th.com' v4th.log
|
||||||
|
grep -i 'unresolved:.*[^ ]' v4th.log && exit 1 || true
|
||||||
|
|
||||||
|
v4thblk.com: metafile.com src/meta.fb src/v4thblk.fth src/vf86core.fth \
|
||||||
|
src/vf86dos.fth src/vf86file.fth src/vf86bufs.fth src/vf86end.fth
|
||||||
|
rm -f v4thblk.com V4THBLK.COM OUTPUT.LOG
|
||||||
|
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \
|
||||||
|
metafile.com "include v4thblk.fth"
|
||||||
|
dos2unix -n OUTPUT.LOG v4thblk.log
|
||||||
|
mv V4THBLK.COM v4thblk.com
|
||||||
|
grep -F 'unresolved:' v4thblk.log
|
||||||
|
grep -F 'new kernel written as v4thblk.com' v4thblk.log
|
||||||
|
grep -i 'unresolved:.*[^ ]' v4thblk.log && exit 1 || true
|
||||||
|
|
||||||
|
# o4th for old volks4th - the new v4th is built with precompiled
|
||||||
|
# metacompiler metafile.com and mk-v4th.fth which writes a compile log.
|
||||||
|
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
|
||||||
|
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
|
||||||
|
rm -f OUTPUT.LOG
|
||||||
|
FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include logtest.fb"
|
||||||
|
dos2unix -n OUTPUT.LOG $@
|
||||||
|
|
||||||
|
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 $@
|
||||||
|
|
||||||
|
prepsrcs = asm.fb extend.fb multi.vid dos.fb include.fb
|
||||||
|
|
||||||
|
prepfths = asm.fb extend.fb multi.vid dos.fb include.fb 86asm.fth \
|
||||||
|
t86asm.fth extend2.fth multivid.fth dos2.fth dos3.fth
|
||||||
|
|
||||||
|
incltest.log: \
|
||||||
|
$(patsubst %, dosfiles/%, v4thblk.com $(prepsrcs) log2file.fb \
|
||||||
|
incltest.fth)
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh \
|
||||||
|
v4thblk.com "include incltest.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG $@
|
||||||
|
|
||||||
|
test-std.log: \
|
||||||
|
$(patsubst %, dosfiles/%, v4th.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \
|
||||||
|
"include logprep.fth include test-std.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG $@
|
||||||
|
|
||||||
|
test-blk.log: \
|
||||||
|
$(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \
|
||||||
|
"include logprep.fth include test-blk.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG $@
|
||||||
|
|
||||||
|
forthblkdos: v4thblk.dos v4thblk.forth
|
||||||
|
|
||||||
|
forthdos: forthblkdos v4thfile.dos v4thfile.forth v4th0.dos v4th0.forth
|
||||||
|
|
||||||
|
v4th0.dos: \
|
||||||
|
$(patsubst %, dosfiles/%, v4th.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \
|
||||||
|
"include logprep.fth include vocdos.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG output.log
|
||||||
|
tr " " "\n" <output.log | sort >$@
|
||||||
|
|
||||||
|
v4th0.forth: \
|
||||||
|
$(patsubst %, dosfiles/%, v4th.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \
|
||||||
|
"include logprep.fth include vocforth.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG output.log
|
||||||
|
tr " " "\n" <output.log | sort >$@
|
||||||
|
|
||||||
|
v4thblk.dos: \
|
||||||
|
$(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \
|
||||||
|
"include logprep.fth include vocdos.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG output.log
|
||||||
|
tr " " "\n" <output.log | sort >$@
|
||||||
|
|
||||||
|
v4thblk.forth: \
|
||||||
|
$(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \
|
||||||
|
"include logprep.fth include vocforth.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG output.log
|
||||||
|
tr " " "\n" <output.log | sort >$@
|
||||||
|
|
||||||
|
v4thfile.dos: \
|
||||||
|
$(patsubst %, dosfiles/%, v4thfile.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4thfile.com \
|
||||||
|
"include log2file.fth include vocdos.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG output.log
|
||||||
|
tr " " "\n" <output.log | sort >$@
|
||||||
|
|
||||||
|
v4thfile.forth: \
|
||||||
|
$(patsubst %, dosfiles/%, v4thfile.com $(prepfths)) \
|
||||||
|
$(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*))
|
||||||
|
rm -f dosfiles/OUTPUT.LOG
|
||||||
|
(cd dosfiles && ../emulator/run-in-dosbox.sh v4thfile.com \
|
||||||
|
"include log2file.fth include vocforth.fth")
|
||||||
|
dos2unix -n dosfiles/OUTPUT.LOG output.log
|
||||||
|
tr " " "\n" <output.log | sort >$@
|
||||||
|
|
||||||
|
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)
|
||||||
|
cat $^ > $@
|
||||||
|
|
||||||
|
test-std.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
|
prelim core coreplus coreext doubltst report-noblk)
|
||||||
|
cat $^ > $@
|
||||||
|
|
||||||
|
test-blk.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
|
prelim core coreplus coreext doubltst block report-blk)
|
||||||
|
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 $< $@
|
||||||
|
|
||||||
|
tests/%.fth: tests/%.fb ../../tools/fb2fth.py
|
||||||
|
../../tools/fb2fth.py $< $@
|
||||||
|
|
||||||
|
# Collective rule for converting uppercase *.FB to lowercase *.fth.
|
||||||
|
# Because make doesn't provide case changing pattern matching,
|
||||||
|
# file-by-file dependencies as with the src/%.fth and tests/%.fth
|
||||||
|
# rules doesn't seem feasible here, hence the one collective rule.
|
||||||
|
|
||||||
|
.ONESHELL:
|
||||||
|
$(fthfiles_caseconverted): $(fbfiles_uppercase)
|
||||||
|
set -x
|
||||||
|
for fb in $^
|
||||||
|
do
|
||||||
|
echo fb: $$fb
|
||||||
|
fth=$$(../../tools/echo-tolower.py $$fb | sed -e 's/fb$$/fth/')
|
||||||
|
../../tools/fb2fth.py $$fb $$fth
|
||||||
|
done
|
1
8086/msdos/emu2-4th.sys
Normal file
1
8086/msdos/emu2-4th.sys
Normal file
File diff suppressed because one or more lines are too long
30
8086/msdos/emulator/run-in-dosbox.sh
Executable file
30
8086/msdos/emulator/run-in-dosbox.sh
Executable file
|
@ -0,0 +1,30 @@
|
||||||
|
#!/bin/bash
|
||||||
|
|
||||||
|
set -e
|
||||||
|
|
||||||
|
forth="$1"
|
||||||
|
forthcmd="$2"
|
||||||
|
exit=""
|
||||||
|
bye=""
|
||||||
|
if [ -n "${forthcmd}" ]; then
|
||||||
|
logname="output.log"
|
||||||
|
doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')"
|
||||||
|
rm -f "${logname}" "${doslogname}"
|
||||||
|
if [ -z "${KEEPEMU}" ]; then
|
||||||
|
exit="-c exit"
|
||||||
|
bye="bye"
|
||||||
|
fi
|
||||||
|
fi
|
||||||
|
|
||||||
|
auto_c=""
|
||||||
|
autocmd=""
|
||||||
|
pathcmd=""
|
||||||
|
if [ -n "${forth}" ]; then
|
||||||
|
auto_c="-c"
|
||||||
|
if [ -n "${FORTHPATH}" ]; then
|
||||||
|
pathcmd="path ${FORTHPATH}"
|
||||||
|
fi
|
||||||
|
autocmd="${forth} ${pathcmd} ${forthcmd} ${bye}"
|
||||||
|
fi
|
||||||
|
|
||||||
|
dosbox -c "mount f ." -c "f:" "${auto_c}" "${autocmd}" $exit
|
BIN
8086/msdos/krnlbios.fb
Normal file
BIN
8086/msdos/krnlbios.fb
Normal file
Binary file not shown.
BIN
8086/msdos/metafile.com
Normal file
BIN
8086/msdos/metafile.com
Normal file
Binary file not shown.
Binary file not shown.
|
@ -1,15 +1,82 @@
|
||||||
#+TITLE: VolksForth MS-DOS README
|
#+TITLE: VolksForth MS-DOS README
|
||||||
#+AUTHOR: Carsten Strotmann
|
#+AUTHOR: Carsten Strotmann, Philip Zembrod
|
||||||
#+DATE: <2020-06-19 Fri>
|
#+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. v4th.com does not have the block
|
||||||
|
words and the buffer mechanism anymore. The only way to load code from
|
||||||
|
files is via =include filename.fth=.
|
||||||
|
|
||||||
|
=make v4thblk.com=
|
||||||
|
builds the new minimal VolksForth kernel v4thblk.com
|
||||||
|
from .fth sources using metafile.com. v4thblk.com contains the block
|
||||||
|
words and the buffer mechanism and can load and include both .fth
|
||||||
|
stream sources and .fb block sources.
|
||||||
|
|
||||||
|
=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-std.result=
|
||||||
|
runs v4th.com through the standard set of unit tests, without the block
|
||||||
|
tests, of course
|
||||||
|
|
||||||
|
=make test-blk.result=
|
||||||
|
runs v4thblk.com through full set of unit tests, including the block
|
||||||
|
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=,
|
After making changes the the Forth kernel source in =kernel.fb=,
|
||||||
restart =volksforth.com= to have a clean system and compile a new
|
restart =volksforth.com= to have a clean system and compile a new
|
||||||
"minimal" kernel with =include kernel.fb=. This will create a new
|
"minimal" kernel with =include kernel.fb=. This will create a new
|
||||||
=FORTH.COM= executable.
|
=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
|
Execute =forth.com include minimal.sys= to generate the file
|
||||||
=minimal.com= which contains a minimal VolksForth system with the
|
=minimal.com= which contains a minimal VolksForth system with the
|
||||||
|
@ -19,11 +86,12 @@
|
||||||
This system can be used to edit the file =volksforth.sys= or other
|
This system can be used to edit the file =volksforth.sys= or other
|
||||||
Forth source block files needed to create a full VolksForth system.
|
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
|
Execute =forth.com include volks4th.sys= to create a new fully
|
||||||
equipped VolksForth executable =volks4th.com=.
|
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
|
EMU2 is a nice PC Emulator that can run MS-DOS console applications
|
||||||
as Linux/MacOS/Windows console applications. EMU2 can be found at
|
as Linux/MacOS/Windows console applications. EMU2 can be found at
|
||||||
|
|
397
8086/msdos/src/86asm.fth
Normal file
397
8086/msdos/src/86asm.fth
Normal file
|
@ -0,0 +1,397 @@
|
||||||
|
|
||||||
|
\ *** Block No. 0, Hexblock 0
|
||||||
|
|
||||||
|
\ 8086 Assembler cas 10nov05
|
||||||
|
\ This 8086 Assembler was written by Klaus Schleisiek.
|
||||||
|
\ Assembler Definitions are created with the definig word
|
||||||
|
\ CODE and closed with the word END-CODE.
|
||||||
|
|
||||||
|
\ The 8086 Registers naming and usage in volksFORTH
|
||||||
|
|
||||||
|
\ Intel vForth Used for 8bit-Register
|
||||||
|
\ AX A free A+ A-
|
||||||
|
\ DX D topmost Stackitem D+ D-
|
||||||
|
\ CX C free C+ C-
|
||||||
|
\ BX R Returnstack Pointer R+ R-
|
||||||
|
\ BP U User Pointer
|
||||||
|
\ SP S Stack Pointer
|
||||||
|
\ SI I Instruction Pointer
|
||||||
|
\ DI W Word Pointer, mostly free
|
||||||
|
|
||||||
|
\ *** Block No. 1, Hexblock 1
|
||||||
|
|
||||||
|
\ 8086 Assembler loadscreen cas 10nov05
|
||||||
|
Onlyforth
|
||||||
|
|
||||||
|
| : u2/ ( 16b -- 15b ) 2/ $7FFF and ;
|
||||||
|
| : 8* ( 15b -- 16b ) 2* 2* 2* ;
|
||||||
|
| : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ;
|
||||||
|
|
||||||
|
Vocabulary Assembler
|
||||||
|
Assembler also definitions
|
||||||
|
|
||||||
|
\ 3 &21 thru clear .( Assembler loaded ) cr
|
||||||
|
|
||||||
|
\ *** Block No. 3, Hexblock 3
|
||||||
|
|
||||||
|
\ Code generating primitives cas 10nov05
|
||||||
|
|
||||||
|
Variable >codes \ points at table of execution vectors
|
||||||
|
|
||||||
|
| Create nrc ] c, , here ! c! [
|
||||||
|
|
||||||
|
: nonrelocate nrc >codes ! ; nonrelocate
|
||||||
|
|
||||||
|
| : >exec ( n -- n+2 ) Create dup c, 2+
|
||||||
|
Does> c@ >codes @ + perform ;
|
||||||
|
|
||||||
|
0 | >exec >c, | >exec >, | >exec >here
|
||||||
|
| >exec >! | >exec >c! drop
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 4, Hexblock 4
|
||||||
|
|
||||||
|
\ 8086 Registers cas 10nov05
|
||||||
|
|
||||||
|
0 Constant A 1 Constant C 2 Constant D 3 Constant R
|
||||||
|
4 Constant S 5 Constant U 6 Constant I 7 Constant W
|
||||||
|
' I Alias SI ' W Alias DI ' R Alias BX
|
||||||
|
|
||||||
|
8 Constant A- 9 Constant C- $A Constant D- $B Constant R-
|
||||||
|
$C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+
|
||||||
|
' R- Alias B- ' R+ Alias B+
|
||||||
|
|
||||||
|
$100 Constant E: $101 Constant C:
|
||||||
|
$102 Constant S: $103 Constant D:
|
||||||
|
|
||||||
|
| Variable isize ( specifies Size by prefix)
|
||||||
|
| : Size: ( n -- ) Create c, Does> c@ isize ! ;
|
||||||
|
0 Size: byte 1 Size: word word 2 Size: far
|
||||||
|
|
||||||
|
\ *** Block No. 5, Hexblock 5
|
||||||
|
|
||||||
|
\ 8086 Assembler System variables cas 10nov05
|
||||||
|
|
||||||
|
| Variable direction \ 0 reg>EA, -1 EA>reg
|
||||||
|
| Variable size \ 1 word, 0 byte, -1 undefined
|
||||||
|
| Variable displaced \ 1 direct, 0 nothing, -1 displaced
|
||||||
|
| Variable displacement
|
||||||
|
|
||||||
|
| : setsize isize @ size ! ;
|
||||||
|
| : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ;
|
||||||
|
| : wexit rdrop word ;
|
||||||
|
| : moderr word true Abort" invalid" ;
|
||||||
|
| : ?moderr ( f -- ) 0=exit moderr ;
|
||||||
|
| : ?word size @ 1- ?moderr ;
|
||||||
|
| : far? ( -- f ) size @ 2 = ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 6, Hexblock 6
|
||||||
|
|
||||||
|
\ 8086 addressing modes cas 10nov05
|
||||||
|
|
||||||
|
| Create (EA 7 c, 0 c, 6 c, 4 c, 5 c,
|
||||||
|
| : () ( 8b1 -- 8b2 )
|
||||||
|
3 - dup 4 u> over 1 = or ?moderr (EA + c@ ;
|
||||||
|
|
||||||
|
-1 Constant # $C6 Constant #) -1 Constant C*
|
||||||
|
|
||||||
|
: ) ( u1 -- u2 )
|
||||||
|
() 6 case? IF 0 $86 exit THEN $C0 or ;
|
||||||
|
: I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ;
|
||||||
|
|
||||||
|
: D) ( n u1 -- n u2 )
|
||||||
|
() over long? IF $40 ELSE $80 THEN or ;
|
||||||
|
: DI) ( n u1 u2 -- n u3 )
|
||||||
|
I) over long? IF $80 ELSE $40 THEN xor ;
|
||||||
|
|
||||||
|
\ *** Block No. 7, Hexblock 7
|
||||||
|
|
||||||
|
\ 8086 Registers and addressing modes cas 10nov05
|
||||||
|
|
||||||
|
| : displaced? ( [n] u1 -- [n] u1 f )
|
||||||
|
dup #) = IF 1 exit THEN
|
||||||
|
dup $C0 and dup $40 = swap $80 = or ;
|
||||||
|
|
||||||
|
| : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit
|
||||||
|
displaced @ ?moderr displaced ! swap displacement ! ;
|
||||||
|
|
||||||
|
| : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit
|
||||||
|
size off $FF07 and ;
|
||||||
|
|
||||||
|
| : mmode? ( 9b - 9b f) dup $C0 and ;
|
||||||
|
|
||||||
|
| : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 8, Hexblock 8
|
||||||
|
|
||||||
|
\ 8086 decoding addressing modes cas 10nov05
|
||||||
|
|
||||||
|
| : 2address ( [n] source [displ] dest -- 15b / [n] 16b )
|
||||||
|
size on displaced off dup # = ?moderr mmode?
|
||||||
|
IF displace False ELSE rmode True THEN direction !
|
||||||
|
>r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit
|
||||||
|
THEN direction @
|
||||||
|
IF r> 8* >r mmode? IF displace
|
||||||
|
ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN
|
||||||
|
ELSE rmode 8*
|
||||||
|
THEN r> or $C0 xor ;
|
||||||
|
|
||||||
|
| : 1address ( [displ] 9b -- 9b )
|
||||||
|
# case? ?moderr size on displaced off direction off
|
||||||
|
mmode? IF displace setsize ELSE rmode THEN $C0 xor ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 9, Hexblock 9
|
||||||
|
|
||||||
|
\ 8086 assembler cas 10nov05
|
||||||
|
| : immediate? ( u -- u f ) dup 0< ;
|
||||||
|
|
||||||
|
| : nonimmediate ( u -- u ) immediate? ?moderr ;
|
||||||
|
|
||||||
|
| : r/m 7 and ;
|
||||||
|
|
||||||
|
| : reg $38 and ;
|
||||||
|
|
||||||
|
| : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ;
|
||||||
|
|
||||||
|
| : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and
|
||||||
|
IF dup $100 and IF dup r/m 8* swap reg 8/
|
||||||
|
or $C0 or direction off
|
||||||
|
THEN True exit
|
||||||
|
THEN False ;
|
||||||
|
|
||||||
|
\ *** Block No. 10, Hexblock a
|
||||||
|
|
||||||
|
\ 8086 Registers and addressing modes cas 10nov05
|
||||||
|
|
||||||
|
| : w, size @ or >c, ;
|
||||||
|
|
||||||
|
| : dw, size @ or direction @ IF 2 xor THEN >c, ;
|
||||||
|
|
||||||
|
| : ?word, ( u1 f -- ) IF >, exit THEN >c, ;
|
||||||
|
|
||||||
|
| : direct, displaced @ 0=exit
|
||||||
|
displacement @ dup long? displaced @ 1+ or ?word, ;
|
||||||
|
|
||||||
|
| : r/m, >c, direct, ;
|
||||||
|
|
||||||
|
| : data, size @ ?word, ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 11, Hexblock b
|
||||||
|
|
||||||
|
\ 8086 Arithmetic instructions cas 10nov05
|
||||||
|
|
||||||
|
| : Arith: ( code -- ) Create ,
|
||||||
|
Does> @ >r 2address immediate?
|
||||||
|
IF rmode? IF ?akku IF r> size @
|
||||||
|
IF 5 or >c, >, wexit THEN
|
||||||
|
4 or >c, >c, wexit THEN THEN
|
||||||
|
r@ or $80 size @ or r> 0<
|
||||||
|
IF size @ IF 2 pick long? 0= IF 2 or size off THEN
|
||||||
|
THEN THEN >c, >c, direct, data, wexit
|
||||||
|
THEN r> dw, r/m, wexit ;
|
||||||
|
|
||||||
|
$8000 Arith: add $0008 Arith: or
|
||||||
|
$8010 Arith: adc $8018 Arith: sbb
|
||||||
|
$0020 Arith: and $8028 Arith: sub
|
||||||
|
$0030 Arith: xor $8038 Arith: cmp
|
||||||
|
|
||||||
|
\ *** Block No. 12, Hexblock c
|
||||||
|
|
||||||
|
\ 8086 move push pop cas 10nov05
|
||||||
|
|
||||||
|
: mov [ Forth ] 2address immediate?
|
||||||
|
IF rmode? IF r/m $B0 or size @ IF 8 or THEN
|
||||||
|
>c, data, wexit
|
||||||
|
THEN $C6 w, r/m, data, wexit
|
||||||
|
THEN 6 case? IF $A2 dw, direct, wexit THEN
|
||||||
|
smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit
|
||||||
|
THEN $88 dw, r/m, wexit ;
|
||||||
|
|
||||||
|
| : pupo [ Forth ] >r 1address ?word
|
||||||
|
smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN
|
||||||
|
rmode? IF r/m $50 or r> or >c, wexit THEN
|
||||||
|
r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ;
|
||||||
|
|
||||||
|
: push 0 pupo ; : pop 8 pupo ;
|
||||||
|
|
||||||
|
\ *** Block No. 13, Hexblock d
|
||||||
|
|
||||||
|
\ 8086 inc & dec , effective addresses cas 10nov05
|
||||||
|
|
||||||
|
| : inc/dec [ Forth ] >r 1address rmode?
|
||||||
|
IF size @ IF r/m $40 or r> or >c, wexit THEN
|
||||||
|
THEN $FE w, r> or r/m, wexit ;
|
||||||
|
|
||||||
|
: dec 8 inc/dec ; : inc 0 inc/dec ;
|
||||||
|
|
||||||
|
| : EA: ( code -- ) Create c, [ Forth ]
|
||||||
|
Does> >r 2address nonimmediate
|
||||||
|
rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ;
|
||||||
|
|
||||||
|
$C4 EA: les $8D EA: lea $C5 EA: lds
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 14, Hexblock e
|
||||||
|
|
||||||
|
\ 8086 xchg segment prefix cas 10nov05
|
||||||
|
: xchg [ Forth ] 2address nonimmediate rmode?
|
||||||
|
IF size @ IF dup r/m 0=
|
||||||
|
IF 8/ true ELSE dup $38 and 0= THEN
|
||||||
|
IF r/m $90 or >c, wexit THEN
|
||||||
|
THEN THEN $86 w, r/m, wexit ;
|
||||||
|
|
||||||
|
| : 1addr: ( code -- ) Create c, [ Forth ]
|
||||||
|
Does> c@ >r 1address $F6 w, r> or r/m, wexit ;
|
||||||
|
|
||||||
|
$10 1addr: com $18 1addr: neg
|
||||||
|
$20 1addr: mul $28 1addr: imul
|
||||||
|
$38 1addr: idiv $30 1addr: div
|
||||||
|
|
||||||
|
: seg ( 8b -) [ Forth ]
|
||||||
|
$100 xor dup $FFFC and ?moderr 8* $26 or >c, ;
|
||||||
|
|
||||||
|
\ *** Block No. 15, Hexblock f
|
||||||
|
|
||||||
|
\ 8086 test not neg mul imul div idiv cas 10nov05
|
||||||
|
|
||||||
|
: test [ Forth ] 2address immediate?
|
||||||
|
IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN
|
||||||
|
$F6 w, r/m, data, wexit
|
||||||
|
THEN $84 w, r/m, wexit ;
|
||||||
|
|
||||||
|
| : in/out [ Forth ] >r 1address setsize
|
||||||
|
$C2 case? IF $EC r> or w, wexit THEN
|
||||||
|
6 - ?moderr $E4 r> or w, displacement @ >c, wexit ;
|
||||||
|
|
||||||
|
: out 2 in/out ; : in 0 in/out ;
|
||||||
|
|
||||||
|
: int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 16, Hexblock 10
|
||||||
|
|
||||||
|
\ 8086 shifts and string instructions cas 10nov05
|
||||||
|
|
||||||
|
| : Shifts: ( code -- ) Create c, [ Forth ]
|
||||||
|
Does> c@ >r C* case? >r 1address
|
||||||
|
r> direction ! $D0 dw, r> or r/m, wexit ;
|
||||||
|
|
||||||
|
$00 Shifts: rol $08 Shifts: ror
|
||||||
|
$10 Shifts: rcl $18 Shifts: rcr
|
||||||
|
$20 Shifts: shl $28 Shifts: shr
|
||||||
|
$38 Shifts: sar ' shl Alias sal
|
||||||
|
|
||||||
|
| : Str: ( code -- ) Create c,
|
||||||
|
Does> c@ setsize w, wexit ;
|
||||||
|
|
||||||
|
$A6 Str: cmps $AC Str: lods $A4 Str: movs
|
||||||
|
$AE Str: scas $AA Str: stos
|
||||||
|
|
||||||
|
\ *** Block No. 17, Hexblock 11
|
||||||
|
|
||||||
|
\ implied 8086 instructions cas 10nov05
|
||||||
|
|
||||||
|
: Byte: ( code -- ) Create c, Does> c@ >c, ;
|
||||||
|
: Word: ( code -- ) Create , Does> @ >, ;
|
||||||
|
|
||||||
|
$37 Byte: aaa $AD5 Word: aad $AD4 Word: aam
|
||||||
|
$3F Byte: aas $98 Byte: cbw $F8 Byte: clc
|
||||||
|
$FC Byte: cld $FA Byte: cli $F5 Byte: cmc
|
||||||
|
$99 Byte: cwd $27 Byte: daa $2F Byte: das
|
||||||
|
$F4 Byte: hlt $CE Byte: into $CF Byte: iret
|
||||||
|
$9F Byte: lahf $F0 Byte: lock $90 Byte: nop
|
||||||
|
$9D Byte: popf $9C Byte: pushf $9E Byte: sahf
|
||||||
|
$F9 Byte: stc $FD Byte: std $FB Byte: sti
|
||||||
|
$9B Byte: wait $D7 Byte: xlat
|
||||||
|
$C3 Byte: ret $CB Byte: lret
|
||||||
|
$F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep
|
||||||
|
|
||||||
|
\ *** Block No. 18, Hexblock 12
|
||||||
|
|
||||||
|
\ 8086 jmp call conditions cas 10nov05
|
||||||
|
| : jmp/call >r setsize # case? [ Forth ]
|
||||||
|
IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit
|
||||||
|
THEN >here 2+ - r>
|
||||||
|
IF dup long? 0= IF $EB >c, >c, wexit THEN $E9
|
||||||
|
ELSE $E8 THEN >c, 1- >, wexit
|
||||||
|
THEN 1address $FF >c, $10 or r> +
|
||||||
|
far? IF 8 or THEN r/m, wexit ;
|
||||||
|
: call 0 jmp/call ; : jmp $10 jmp/call ;
|
||||||
|
|
||||||
|
$71 Constant OS $73 Constant CS
|
||||||
|
$75 Constant 0= $77 Constant >=
|
||||||
|
$79 Constant 0< $7B Constant PE
|
||||||
|
$7D Constant < $7F Constant <=
|
||||||
|
$E2 Constant C0= $E0 Constant ?C0=
|
||||||
|
: not 1 [ Forth ] xor ;
|
||||||
|
|
||||||
|
\ *** Block No. 19, Hexblock 13
|
||||||
|
|
||||||
|
\ 8086 conditional branching cas 10nov05
|
||||||
|
|
||||||
|
: +ret $C2 >c, >, ;
|
||||||
|
: +lret $CA >c, >, ;
|
||||||
|
|
||||||
|
| : ?range dup long? abort" out of range" ;
|
||||||
|
|
||||||
|
: ?[ >, >here 1- ;
|
||||||
|
: ]? >here over 1+ - ?range swap >c! ;
|
||||||
|
: ][ $EB ?[ swap ]? ;
|
||||||
|
: ?[[ ?[ swap ;
|
||||||
|
: [[ >here ;
|
||||||
|
: ?] >c, >here 1+ - ?range >c, ;
|
||||||
|
: ]] $EB ?] ;
|
||||||
|
: ]]? ]] ]? ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 20, Hexblock 14
|
||||||
|
|
||||||
|
\ Next user' end-code ;c: cas 10nov05
|
||||||
|
|
||||||
|
: Next lods A W xchg W ) jmp
|
||||||
|
>here next-link @ >, next-link ! ;
|
||||||
|
|
||||||
|
: u' ' >body c@ ;
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
\needs end-code : end-code toss also ;
|
||||||
|
|
||||||
|
Assembler definitions
|
||||||
|
|
||||||
|
: ;c: recover # call last off end-code 0 ] ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 21, Hexblock 15
|
||||||
|
|
||||||
|
\ 8086 Assembler, Forth words cas 10nov05
|
||||||
|
Onlyforth
|
||||||
|
|
||||||
|
: Assembler Assembler [ Assembler ] wexit ;
|
||||||
|
|
||||||
|
: ;code 0 ?pairs compile (;code
|
||||||
|
reveal [compile] [ Assembler ; immediate
|
||||||
|
|
||||||
|
: Code Create [ Assembler ] >here dup 2- >! Assembler ;
|
||||||
|
|
||||||
|
: >label ( addr -- )
|
||||||
|
here | Create immediate swap , 4 hallot
|
||||||
|
here 4 - heap 4 cmove heap last @ (name> ! dp !
|
||||||
|
Does> ( -- addr ) @ state @ 0=exit [compile] Literal ;
|
||||||
|
|
||||||
|
: Label [ Assembler ] >here >label Assembler ;
|
||||||
|
|
||||||
|
|
||||||
|
clear .( Assembler loaded ) cr
|
437
8086/msdos/src/asm.fth
Normal file
437
8086/msdos/src/asm.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
57
8086/msdos/src/blocking.fth
Normal file
57
8086/msdos/src/blocking.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
152
8086/msdos/src/ced.fth
Normal file
152
8086/msdos/src/ced.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
836
8086/msdos/src/disasm.fth
Normal file
836
8086/msdos/src/disasm.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
342
8086/msdos/src/dos.fth
Normal file
342
8086/msdos/src/dos.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
255
8086/msdos/src/dos2.fth
Normal file
255
8086/msdos/src/dos2.fth
Normal file
|
@ -0,0 +1,255 @@
|
||||||
|
|
||||||
|
\ *** Block No. 0, Hexblock 0
|
||||||
|
|
||||||
|
\ 28 jun 88
|
||||||
|
|
||||||
|
\ This file is a pure .fth-version of dos.fb.
|
||||||
|
|
||||||
|
\ DOS loads higher level file functions which go beyond
|
||||||
|
\ including a screen file. Calls to MS-DOS are implemented
|
||||||
|
\ and used for directory manipulation. These functions may
|
||||||
|
\ not work for versions before MS-DOS 3.0.
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 1, Hexblock 1
|
||||||
|
|
||||||
|
\ MS-DOS file handli cas 09jun20
|
||||||
|
Onlyforth \needs Assembler 2 loadfrom asm.fb
|
||||||
|
|
||||||
|
: fswap isfile@ fromfile @ isfile ! fromfile ! ;
|
||||||
|
|
||||||
|
$80 Constant dta
|
||||||
|
|
||||||
|
| : COMSPEC ( -- string ) [ dos ]
|
||||||
|
$2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove
|
||||||
|
filename counted &60 min filename place filename ;
|
||||||
|
|
||||||
|
\ 1 &12 +thru .( MS-DOS functions loaed ) cr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 2, Hexblock 2
|
||||||
|
|
||||||
|
\ moving blocks ks 04 okt 87
|
||||||
|
|
||||||
|
| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ;
|
||||||
|
|
||||||
|
: used? ( blk -- f )
|
||||||
|
block count b/blk 1- swap skip nip 0<> ;
|
||||||
|
|
||||||
|
| : (copy ( from to -- )
|
||||||
|
full? IF save-buffers THEN isfile@ fromfile @ -
|
||||||
|
IF dup used? Abort" target block not empty" THEN
|
||||||
|
dup isfile@ core? IF prev @ emptybuf THEN
|
||||||
|
isfile@ 0= IF offset @ + THEN
|
||||||
|
isfile@ rot fromfile @ (block 6 - 2! update ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 3, Hexblock 3
|
||||||
|
|
||||||
|
\ moving blocks ks 04 okt 87
|
||||||
|
|
||||||
|
| : blkmove ( from to quan -- ) 3 arguments save-buffers
|
||||||
|
>r over r@ + over u> >r 2dup u< r> and
|
||||||
|
IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP
|
||||||
|
ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP
|
||||||
|
THEN save-buffers 2drop ;
|
||||||
|
|
||||||
|
: copy ( from to -- ) 1 blkmove ;
|
||||||
|
|
||||||
|
: convey ( blk1 blk2 to.blk -- )
|
||||||
|
3 arguments >r 2dup swap - >r
|
||||||
|
fswap dup capacity 1- > isfile@ 0<> and
|
||||||
|
fswap r> r@ + capacity 1- > isfile@ 0<> and or >r
|
||||||
|
1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 4, Hexblock 4
|
||||||
|
|
||||||
|
\ MORE extending forth files ks 10 okt 87
|
||||||
|
Dos also definitions
|
||||||
|
|
||||||
|
| : addblock ( blk -- ) dup buffer dup b/blk blank
|
||||||
|
isfile@ f.size dup 2@ b/blk 0 d+ rot 2!
|
||||||
|
swap isfile@ fblock! ;
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
: more ( n -- ) 1 arguments isfile@
|
||||||
|
IF capacity swap bounds ?DO I addblock LOOP close exit
|
||||||
|
THEN drop ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 5, Hexblock 5
|
||||||
|
|
||||||
|
\ file eof? create dta-addressing ks 03 apr 88
|
||||||
|
Dos definitions
|
||||||
|
|
||||||
|
: ftime ( -- mm hh )
|
||||||
|
isfile@ f.time @ $20 u/mod nip $40 u/mod ;
|
||||||
|
|
||||||
|
: fdate ( -- dd mm yy )
|
||||||
|
isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
|
||||||
|
|
||||||
|
: .when base push decimal
|
||||||
|
fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r
|
||||||
|
ftime 3 .r ." :" 2 .r ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 6, Hexblock 6
|
||||||
|
|
||||||
|
\ ks 20mar88
|
||||||
|
|
||||||
|
: (.fcb ( fcb -- )
|
||||||
|
dup .file ?dup 0=exit pushfile
|
||||||
|
isfile ! &13 tab ." is"
|
||||||
|
isfile@ f.handle @ 2 .r
|
||||||
|
isfile@ f.size 2@ 7 d.r .when
|
||||||
|
space isfile@ f.name count type ;
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
: files file-link
|
||||||
|
BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ;
|
||||||
|
|
||||||
|
: ?file isfile@ (.fcb ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 7, Hexblock 7
|
||||||
|
|
||||||
|
\ dir make makefile ks 25 okt 87
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
: killfile close
|
||||||
|
isfile@ f.name filename >asciz ~unlink drop ;
|
||||||
|
|
||||||
|
: emptyfile isfile@ 0=exit
|
||||||
|
isfile@ f.name filename >asciz 0 ~creat ?diskerror
|
||||||
|
isfile@ f.handle ! isfile@ f.size 4 erase ;
|
||||||
|
|
||||||
|
: make close name isfile@ fname! emptyfile ;
|
||||||
|
|
||||||
|
: makefile File last @ name> execute emptyfile ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 8, Hexblock 8
|
||||||
|
|
||||||
|
\ getpath ks 10 okt 87
|
||||||
|
Dos definitions
|
||||||
|
|
||||||
|
| &40 Constant pathlen
|
||||||
|
| Create pathes 0 c, pathlen allot
|
||||||
|
|
||||||
|
| : (setpath ( string -- ) count
|
||||||
|
dup pathlen u> Abort" path too long" pathes place ;
|
||||||
|
|
||||||
|
| : getpath ( +n -- string / ff )
|
||||||
|
>r 0 pathes count r> 0
|
||||||
|
DO rot drop Ascii ; skip stash Ascii ; scan LOOP
|
||||||
|
drop over - ?dup
|
||||||
|
IF here place here dup count + 1- c@
|
||||||
|
?" :\" ?exit Ascii \ here append exit
|
||||||
|
THEN 0= ;
|
||||||
|
|
||||||
|
\ *** Block No. 9, Hexblock 9
|
||||||
|
|
||||||
|
\ pathsearch .path path ks 09 okt 87
|
||||||
|
|
||||||
|
: pathsearch ( string -- asciz *f ) dup >r
|
||||||
|
(fsearch dup 0= IF rdrop exit THEN 2drop 0 0
|
||||||
|
BEGIN drop 1+ dup getpath ?dup 0=
|
||||||
|
IF drop r> filename >asciz 2 exit THEN
|
||||||
|
r@ count 2 pick attach (fsearch
|
||||||
|
0= UNTIL nip rdrop false ;
|
||||||
|
|
||||||
|
' pathsearch Is fsearch
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
: .path pathes count type ;
|
||||||
|
|
||||||
|
: path name nullstring? IF .path exit THEN (setpath ;
|
||||||
|
|
||||||
|
\ *** Block No. 10, Hexblock a
|
||||||
|
|
||||||
|
\ call another executable file ks 04 aug 87
|
||||||
|
Dos definitions
|
||||||
|
|
||||||
|
| Create cpb 0 , \ inherit parent environment
|
||||||
|
dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 ,
|
||||||
|
|
||||||
|
| Code ~exec ( asciz -- *f )
|
||||||
|
I push R push U push S ssave #) mov cpb # R mov
|
||||||
|
$4B00 # A mov $21 int C: D mov D D: mov D S: mov
|
||||||
|
D E: mov ssave #) S mov CS not
|
||||||
|
?[ A A xor A push $2F # A+ mov $21 int E: A mov
|
||||||
|
A D: mov C: A mov A E: mov R I mov dta # W mov
|
||||||
|
$40 # C mov rep movs A D: mov A pop
|
||||||
|
]? A W xchg dta # D mov $1A # A+ mov $21 int
|
||||||
|
W D mov U pop R pop I pop Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
\ *** Block No. 11, Hexblock b
|
||||||
|
|
||||||
|
\ calling MS-DOS thru forth interpreter ks 19 mr 88
|
||||||
|
|
||||||
|
| : execute? ( extension -- *f )
|
||||||
|
count filename count Ascii . scan drop swap
|
||||||
|
2dup 1+ erase move filename 1+ ~exec ;
|
||||||
|
|
||||||
|
: fcall ( string -- ) count filename place ds@ cpb 4+ !
|
||||||
|
" .EXE" execute? dup IF drop " .COM" execute? THEN
|
||||||
|
?diskerror ;
|
||||||
|
|
||||||
|
: fdos ( string -- )
|
||||||
|
dta $80 erase " /c " count dta place count dta attach
|
||||||
|
status push status off .status COMSPEC fcall curat? at ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 12, Hexblock c
|
||||||
|
|
||||||
|
\ einige MS-DOS Funktionen msdos call ks 10 okt 87
|
||||||
|
|
||||||
|
: dos: Create ," Does> count here place
|
||||||
|
Ascii " parse here attach here fdos ;
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
dos: dir dir "
|
||||||
|
dos: ren ren "
|
||||||
|
dos: md md "
|
||||||
|
dos: cd cd "
|
||||||
|
dos: rd rd "
|
||||||
|
dos: fcopy copy "
|
||||||
|
dos: delete del "
|
||||||
|
dos: ftype type "
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 13, Hexblock d
|
||||||
|
|
||||||
|
\ msdos call ks 23 okt 88
|
||||||
|
|
||||||
|
: msdos savevideo status push status off .status
|
||||||
|
flush dta off COMSPEC fcall restorevideo ;
|
||||||
|
|
||||||
|
: call name source >in @ /string c/l umin
|
||||||
|
dta place dta dta >asciz drop [compile] \
|
||||||
|
status push status off .status fcall curat? at ;
|
||||||
|
|
||||||
|
|
||||||
|
.( MS-DOS functions loaed ) cr
|
||||||
|
|
||||||
|
Onlyforth
|
195
8086/msdos/src/dos3.fth
Normal file
195
8086/msdos/src/dos3.fth
Normal file
|
@ -0,0 +1,195 @@
|
||||||
|
|
||||||
|
\ *** Block No. 0, Hexblock 0
|
||||||
|
|
||||||
|
\ 28 jun 88
|
||||||
|
|
||||||
|
\ This file is an .fth-version of dos.fb without the block-related
|
||||||
|
\ words.
|
||||||
|
|
||||||
|
\ DOS loads higher level file functions which go beyond
|
||||||
|
\ including a screen file. Calls to MS-DOS are implemented
|
||||||
|
\ and used for directory manipulation. These functions may
|
||||||
|
\ not work for versions before MS-DOS 3.0.
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 1, Hexblock 1
|
||||||
|
|
||||||
|
\ MS-DOS file handli cas 09jun20
|
||||||
|
Onlyforth \needs Assembler 2 loadfrom asm.fb
|
||||||
|
|
||||||
|
: fswap isfile@ fromfile @ isfile ! fromfile ! ;
|
||||||
|
|
||||||
|
$80 Constant dta
|
||||||
|
|
||||||
|
| : COMSPEC ( -- string ) [ dos ]
|
||||||
|
$2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove
|
||||||
|
filename counted &60 min filename place filename ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 5, Hexblock 5
|
||||||
|
|
||||||
|
\ file eof? create dta-addressing ks 03 apr 88
|
||||||
|
Dos also definitions
|
||||||
|
|
||||||
|
: ftime ( -- mm hh )
|
||||||
|
isfile@ f.time @ $20 u/mod nip $40 u/mod ;
|
||||||
|
|
||||||
|
: fdate ( -- dd mm yy )
|
||||||
|
isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
|
||||||
|
|
||||||
|
: .when base push decimal
|
||||||
|
fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r
|
||||||
|
ftime 3 .r ." :" 2 .r ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 6, Hexblock 6
|
||||||
|
|
||||||
|
\ ks 20mar88
|
||||||
|
|
||||||
|
: (.fcb ( fcb -- )
|
||||||
|
dup .file ?dup 0=exit pushfile
|
||||||
|
isfile ! &13 tab ." is"
|
||||||
|
isfile@ f.handle @ 2 .r
|
||||||
|
isfile@ f.size 2@ 7 d.r .when
|
||||||
|
space isfile@ f.name count type ;
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
: files file-link
|
||||||
|
BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ;
|
||||||
|
|
||||||
|
: ?file isfile@ (.fcb ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 7, Hexblock 7
|
||||||
|
|
||||||
|
\ dir make makefile ks 25 okt 87
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
: killfile close
|
||||||
|
isfile@ f.name filename >asciz ~unlink drop ;
|
||||||
|
|
||||||
|
: emptyfile isfile@ 0=exit
|
||||||
|
isfile@ f.name filename >asciz 0 ~creat ?diskerror
|
||||||
|
isfile@ f.handle ! isfile@ f.size 4 erase ;
|
||||||
|
|
||||||
|
: make close name isfile@ fname! emptyfile ;
|
||||||
|
|
||||||
|
: makefile File last @ name> execute emptyfile ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 8, Hexblock 8
|
||||||
|
|
||||||
|
\ getpath ks 10 okt 87
|
||||||
|
Dos definitions
|
||||||
|
|
||||||
|
| &40 Constant pathlen
|
||||||
|
| Create pathes 0 c, pathlen allot
|
||||||
|
|
||||||
|
| : (setpath ( string -- ) count
|
||||||
|
dup pathlen u> Abort" path too long" pathes place ;
|
||||||
|
|
||||||
|
| : getpath ( +n -- string / ff )
|
||||||
|
>r 0 pathes count r> 0
|
||||||
|
DO rot drop Ascii ; skip stash Ascii ; scan LOOP
|
||||||
|
drop over - ?dup
|
||||||
|
IF here place here dup count + 1- c@
|
||||||
|
?" :\" ?exit Ascii \ here append exit
|
||||||
|
THEN 0= ;
|
||||||
|
|
||||||
|
\ *** Block No. 9, Hexblock 9
|
||||||
|
|
||||||
|
\ pathsearch .path path ks 09 okt 87
|
||||||
|
|
||||||
|
: pathsearch ( string -- asciz *f ) dup >r
|
||||||
|
(fsearch dup 0= IF rdrop exit THEN 2drop 0 0
|
||||||
|
BEGIN drop 1+ dup getpath ?dup 0=
|
||||||
|
IF drop r> filename >asciz 2 exit THEN
|
||||||
|
r@ count 2 pick attach (fsearch
|
||||||
|
0= UNTIL nip rdrop false ;
|
||||||
|
|
||||||
|
' pathsearch Is fsearch
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
: .path pathes count type ;
|
||||||
|
|
||||||
|
: path name nullstring? IF .path exit THEN (setpath ;
|
||||||
|
|
||||||
|
\ *** Block No. 10, Hexblock a
|
||||||
|
|
||||||
|
\ call another executable file ks 04 aug 87
|
||||||
|
Dos definitions
|
||||||
|
|
||||||
|
| Create cpb 0 , \ inherit parent environment
|
||||||
|
dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 ,
|
||||||
|
|
||||||
|
| Code ~exec ( asciz -- *f )
|
||||||
|
I push R push U push S ssave #) mov cpb # R mov
|
||||||
|
$4B00 # A mov $21 int C: D mov D D: mov D S: mov
|
||||||
|
D E: mov ssave #) S mov CS not
|
||||||
|
?[ A A xor A push $2F # A+ mov $21 int E: A mov
|
||||||
|
A D: mov C: A mov A E: mov R I mov dta # W mov
|
||||||
|
$40 # C mov rep movs A D: mov A pop
|
||||||
|
]? A W xchg dta # D mov $1A # A+ mov $21 int
|
||||||
|
W D mov U pop R pop I pop Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
\ *** Block No. 11, Hexblock b
|
||||||
|
|
||||||
|
\ calling MS-DOS thru forth interpreter ks 19 mr 88
|
||||||
|
|
||||||
|
| : execute? ( extension -- *f )
|
||||||
|
count filename count Ascii . scan drop swap
|
||||||
|
2dup 1+ erase move filename 1+ ~exec ;
|
||||||
|
|
||||||
|
: fcall ( string -- ) count filename place ds@ cpb 4+ !
|
||||||
|
" .EXE" execute? dup IF drop " .COM" execute? THEN
|
||||||
|
?diskerror ;
|
||||||
|
|
||||||
|
: fdos ( string -- )
|
||||||
|
dta $80 erase " /c " count dta place count dta attach
|
||||||
|
status push status off .status COMSPEC fcall curat? at ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 12, Hexblock c
|
||||||
|
|
||||||
|
\ einige MS-DOS Funktionen msdos call ks 10 okt 87
|
||||||
|
|
||||||
|
: dos: Create ," Does> count here place
|
||||||
|
Ascii " parse here attach here fdos ;
|
||||||
|
|
||||||
|
Forth definitions
|
||||||
|
|
||||||
|
dos: dir dir "
|
||||||
|
dos: ren ren "
|
||||||
|
dos: md md "
|
||||||
|
dos: cd cd "
|
||||||
|
dos: rd rd "
|
||||||
|
dos: fcopy copy "
|
||||||
|
dos: delete del "
|
||||||
|
dos: ftype type "
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 13, Hexblock d
|
||||||
|
|
||||||
|
\ msdos call ks 23 okt 88
|
||||||
|
|
||||||
|
: msdos savevideo status push status off .status
|
||||||
|
flush dta off COMSPEC fcall restorevideo ;
|
||||||
|
|
||||||
|
: call name source >in @ /string c/l umin
|
||||||
|
dta place dta dta >asciz drop [compile] \
|
||||||
|
status push status off .status fcall curat? at ;
|
||||||
|
|
||||||
|
|
||||||
|
.( MS-DOS functions loaed ) cr
|
||||||
|
|
||||||
|
Onlyforth
|
95
8086/msdos/src/double.fth
Normal file
95
8086/msdos/src/double.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
798
8086/msdos/src/editor.fth
Normal file
798
8086/msdos/src/editor.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
209
8086/msdos/src/extend.fth
Normal file
209
8086/msdos/src/extend.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
182
8086/msdos/src/extend2.fth
Normal file
182
8086/msdos/src/extend2.fth
Normal file
|
@ -0,0 +1,182 @@
|
||||||
|
|
||||||
|
\ *** Block No. 0, Hexblock 0
|
||||||
|
|
||||||
|
\ ks 11 mai 88
|
||||||
|
|
||||||
|
\ This file is a pure .fth-version of extend.fb.
|
||||||
|
\ It contains definitions needed for several further system
|
||||||
|
\ and application files.
|
||||||
|
|
||||||
|
\ Among others there are MSDOS specific commands such as allocating
|
||||||
|
\ memory outside the Forth core 64k memory segment, some routines
|
||||||
|
\ that make using the video display easier, and some string
|
||||||
|
\ manipulation words.
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 1, Hexblock 1
|
||||||
|
|
||||||
|
\ loadscreen for often used words ks cas 25sep16
|
||||||
|
|
||||||
|
Onlyforth \needs Assembler include t86asm.fth
|
||||||
|
|
||||||
|
' save-buffers Alias sav
|
||||||
|
|
||||||
|
' name &12 + Constant 'name
|
||||||
|
|
||||||
|
' page Alias cls
|
||||||
|
|
||||||
|
\ 1 8 +thru
|
||||||
|
|
||||||
|
\ *** Block No. 2, Hexblock 2
|
||||||
|
|
||||||
|
\ Postkernel words ks 22 dez 87
|
||||||
|
|
||||||
|
: blank ( addr quan -- ) bl fill ;
|
||||||
|
|
||||||
|
Code stash ( u1 u2 -- u1 u1 u2 )
|
||||||
|
S W mov W ) push Next end-code
|
||||||
|
\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ;
|
||||||
|
|
||||||
|
: >expect ( addr len -- ) stash expect span @ over place ;
|
||||||
|
|
||||||
|
: .field ( addr len quan -- )
|
||||||
|
over - >r type r> 0 max spaces ;
|
||||||
|
|
||||||
|
: tab ( n -- ) col - 0 max spaces ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 3, Hexblock 3
|
||||||
|
|
||||||
|
\ postkernel ks 08 mär 89
|
||||||
|
\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT
|
||||||
|
|
||||||
|
\needs end-code : end-code toss also ;
|
||||||
|
|
||||||
|
: u? ( addr -- ) @ u. ;
|
||||||
|
|
||||||
|
: adr ' >body state @ 0=exit [compile] Literal ; immediate
|
||||||
|
|
||||||
|
: Abort( ( f -- ) IF [compile] .( true abort" !" THEN
|
||||||
|
[compile] ( ;
|
||||||
|
|
||||||
|
: arguments ( n -- )
|
||||||
|
depth 1- > Error" zu wenige Parameter" ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 4, Hexblock 4
|
||||||
|
|
||||||
|
\ MS-DOS memory management
|
||||||
|
|
||||||
|
Code lallocate ( pages -- seg ff / rest err# )
|
||||||
|
R push D R mov $48 # A+ mov $21 int CS
|
||||||
|
?[ A D xchg A pop R push A R xchg
|
||||||
|
][ R pop A push 0 # D mov ]? Next end-code
|
||||||
|
|
||||||
|
Code lfree ( seg -- err# )
|
||||||
|
E: push D E: mov $49 # A+ mov $21 int CS
|
||||||
|
?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 5, Hexblock 5
|
||||||
|
|
||||||
|
\ postkernel ks 03 aug 87
|
||||||
|
|
||||||
|
c/row c/col * 2* Constant c/dis \ characters per display
|
||||||
|
|
||||||
|
Code video@ ( -- seg ) D push R D mov $F # A+ mov
|
||||||
|
$10 int R D xchg 0 # D- mov 7 # A- cmp
|
||||||
|
0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
: savevideo ( -- seg / ff )
|
||||||
|
[ c/dis b/seg /mod swap 0<> - ] Literal lallocate
|
||||||
|
IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ;
|
||||||
|
|
||||||
|
: restorevideo ( seg -- ) ?dup 0=exit
|
||||||
|
dup 0 video@ 0 c/dis lmove lfree drop ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 6, Hexblock 6
|
||||||
|
|
||||||
|
\ string operators append attach ks 21 jun 87
|
||||||
|
|
||||||
|
| : .stringoverflow true Abort" String zu lang" ;
|
||||||
|
|
||||||
|
Code append ( char addr -- )
|
||||||
|
D W mov D pop W ) A- mov 1 # A- add CS
|
||||||
|
?[ ;c: .stringoverflow ; Assembler ]?
|
||||||
|
A- W ) mov 0 # A+ mov A W add
|
||||||
|
D- W ) mov D pop Next end-code
|
||||||
|
|
||||||
|
Code attach ( addr len addr1 -- ) D W mov C pop
|
||||||
|
I D mov I pop W ) A- mov A- A+ mov C- A+ add CS
|
||||||
|
?[ ;c: .stringoverflow ; Assembler ]?
|
||||||
|
A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc
|
||||||
|
rep byte movs D I mov D pop Next end-code
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 7, Hexblock 7
|
||||||
|
|
||||||
|
\ string operators append attach detract ks 21 jun 87
|
||||||
|
|
||||||
|
\ : append ( char addr -- )
|
||||||
|
\ under count + c! dup c@ 1+ swap c! ;
|
||||||
|
|
||||||
|
\ : attach ( addr len addr.to -- )
|
||||||
|
\ >r under r@ count + swap move r@ c@ + r> c! ;
|
||||||
|
|
||||||
|
\ : detract ( addr -- char )
|
||||||
|
\ dup c@ 1- dup 0> and over c!
|
||||||
|
\ count >r dup count -rot swap r> cmove ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 8, Hexblock 8
|
||||||
|
|
||||||
|
\ ?" string operator ks 09 feb 88
|
||||||
|
|
||||||
|
\ : (?" ( 8b -- index ) "lit under count rot
|
||||||
|
\ scan IF swap - exit THEN 2drop false ;
|
||||||
|
|
||||||
|
| Create months ," janfebmäraprmaijunjulaugsepoktnovdez"
|
||||||
|
|
||||||
|
: >months ( n -- addr len ) 3 * 2- months + 3 ;
|
||||||
|
|
||||||
|
| Code (?" ( 8b -- index )
|
||||||
|
A D xchg I ) C- mov 0 # C+ mov C I add
|
||||||
|
I W mov I inc std 0<>rep byte scas cld
|
||||||
|
0= ?[ C inc ]? C D mov Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
: ?" compile (?" ," align ; immediate restrict
|
||||||
|
|
||||||
|
\ *** Block No. 9, Hexblock 9
|
||||||
|
|
||||||
|
\ Conditional compilation ks 12 dez 88
|
||||||
|
| Defer cond
|
||||||
|
|
||||||
|
: .THEN ; immediate
|
||||||
|
|
||||||
|
: .ELSE ( -- ) 0
|
||||||
|
BEGIN name nullstring? IF drop exit THEN
|
||||||
|
find IF cond -1 case? ?exit ELSE drop THEN
|
||||||
|
REPEAT ; immediate
|
||||||
|
|
||||||
|
: .IF ( f -- ) ?exit [compile] .ELSE ; immediate
|
||||||
|
|
||||||
|
| : (cond ( n cfa -- n' )
|
||||||
|
['] .THEN case? IF 1- exit THEN
|
||||||
|
['] .ELSE case? IF dup 0= + exit THEN
|
||||||
|
['] .IF = 0=exit 1+ ; ' (cond is cond
|
||||||
|
|
||||||
|
.( Systemerweiterung geladen) cr
|
646
8086/msdos/src/f83asm.fth
Normal file
646
8086/msdos/src/f83asm.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
1
8086/msdos/src/include.fb
Normal file
1
8086/msdos/src/include.fb
Normal file
File diff suppressed because one or more lines are too long
152
8086/msdos/src/include.fth
Normal file
152
8086/msdos/src/include.fth
Normal file
|
@ -0,0 +1,152 @@
|
||||||
|
|
||||||
|
\ *** Block No. 0, Hexblock 0
|
||||||
|
|
||||||
|
\ include for stream sources phz 06jan22
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 1, Hexblock 1
|
||||||
|
|
||||||
|
\ load screen phz 06feb22
|
||||||
|
|
||||||
|
1 6 +thru
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 2, Hexblock 2
|
||||||
|
|
||||||
|
\ fib /fib #fib eolf? phz 06feb22
|
||||||
|
|
||||||
|
context @ dos also context !
|
||||||
|
$50 constant /tib
|
||||||
|
variable tibeof tibeof off
|
||||||
|
|
||||||
|
: eolf? ( c -- f )
|
||||||
|
\ f=-1: not yet eol; store c and continue
|
||||||
|
\ f=0: eol but not yet eof; return line and flag continue
|
||||||
|
\ f=1: eof: return line and flag eof
|
||||||
|
tibeof off
|
||||||
|
dup #lf = IF drop 0 exit THEN
|
||||||
|
-1 = IF tibeof on 1 ELSE -1 THEN ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 3, Hexblock 3
|
||||||
|
|
||||||
|
\ 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
|
||||||
|
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 inc-fgetc eolf? 1+ UNTIL tibeof @ ;
|
||||||
|
|
||||||
|
| : 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. 5, Hexblock 5
|
||||||
|
|
||||||
|
\ save/restoretib phz 16jan22
|
||||||
|
|
||||||
|
$50 constant /stash
|
||||||
|
create stash[ /stash allot here constant ]stash
|
||||||
|
variable stash> stash[ stash> !
|
||||||
|
|
||||||
|
: savetib ( -- n )
|
||||||
|
#tib @ >in @ - dup stash> @ + ]stash u>
|
||||||
|
abort" tib stash overflow" >r
|
||||||
|
tib >in @ + stash> @ r@ cmove
|
||||||
|
r@ stash> +! r> ;
|
||||||
|
|
||||||
|
: restoretib ( n -- )
|
||||||
|
dup >r negate stash> +! stash> @ tib r@ cmove
|
||||||
|
r> #tib ! >in off ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 6, Hexblock 6
|
||||||
|
|
||||||
|
\ interpret-via-tib include phz 06feb22
|
||||||
|
|
||||||
|
: interpret-via-tib
|
||||||
|
BEGIN freadline >r .status >in off interpret
|
||||||
|
r> UNTIL ;
|
||||||
|
|
||||||
|
: 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. 7, Hexblock 7
|
||||||
|
|
||||||
|
\ \ phz 16jan22
|
||||||
|
|
||||||
|
: \ blk @ IF >in @ negate c/l mod >in +!
|
||||||
|
ELSE #tib @ >in ! THEN ; immediate
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
342
8086/msdos/src/install.fth
Normal file
342
8086/msdos/src/install.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
3040
8086/msdos/src/kernel.fth
Normal file
3040
8086/msdos/src/kernel.fth
Normal file
File diff suppressed because it is too large
Load Diff
File diff suppressed because one or more lines are too long
1007
8086/msdos/src/meta.fth
Normal file
1007
8086/msdos/src/meta.fth
Normal file
File diff suppressed because it is too large
Load Diff
380
8086/msdos/src/miniterm.fth
Normal file
380
8086/msdos/src/miniterm.fth
Normal 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
24
8086/msdos/src/mk-meta.fth
Normal 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
|
File diff suppressed because one or more lines are too long
192
8086/msdos/src/multivid.fth
Normal file
192
8086/msdos/src/multivid.fth
Normal file
|
@ -0,0 +1,192 @@
|
||||||
|
|
||||||
|
\ *** Block No. 0, Hexblock 0
|
||||||
|
|
||||||
|
\ This file is a pure .fth-version of multi.vid.
|
||||||
|
|
||||||
|
\ This display interface uses BIOS call $10 functions for a fast
|
||||||
|
\ display interface. A couple of state variables is contained
|
||||||
|
\ in a vector that is task specific such that different tasks
|
||||||
|
\ may use different windows. For simplicity windows always
|
||||||
|
\ span the whole width of the screen. They can be defined by
|
||||||
|
\ top and bottom line. This mechanism is used for a convenient
|
||||||
|
\ status display line on the bottom of the screen.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 1, Hexblock 1
|
||||||
|
|
||||||
|
\ Multitsking display interface loadscreen ks phz 31jan22
|
||||||
|
Onlyforth \needs Assembler include t86asm.fth
|
||||||
|
|
||||||
|
User area area off \ points at active window
|
||||||
|
Variable status \ to switch status on/off
|
||||||
|
| Variable cursor \ points at area with active cursor
|
||||||
|
|
||||||
|
\ 1 8 +thru .( Multitasking display driver loaded ) cr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 2, Hexblock 2
|
||||||
|
|
||||||
|
\ Multitsking display interface ks 6 sep 86
|
||||||
|
|
||||||
|
: Area: Create 0 , 0 , 7 c, Does> area ! ;
|
||||||
|
\ | col | row | top | bot | att |
|
||||||
|
|
||||||
|
Area: terminal terminal area @ cursor !
|
||||||
|
|
||||||
|
: (area Create dup c, 1+ Does> c@ area @ + ;
|
||||||
|
|
||||||
|
0 | (area ccol | (area crow | (area ctop
|
||||||
|
| (area cbot (area catt drop
|
||||||
|
|
||||||
|
: window ( topline botline -- ) cbot c! ctop c! ;
|
||||||
|
|
||||||
|
: full 0 c/col 2- window ; full
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 3, Hexblock 3
|
||||||
|
|
||||||
|
\ Multitask (type (emit ks 20 dez 87
|
||||||
|
|
||||||
|
Code (type ( addr len -- ) W pop I push R push
|
||||||
|
u' area U D) I mov U push D U mov
|
||||||
|
$F # A+ mov $10 int u' catt I D) R- mov
|
||||||
|
3 # A+ mov $10 int C push D push $E0E # C mov
|
||||||
|
1 # A+ mov $10 int I ) D mov 1 # C mov
|
||||||
|
U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int
|
||||||
|
D- inc ' c/row >body #) D- cmp 0= not
|
||||||
|
?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]?
|
||||||
|
D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]?
|
||||||
|
2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop
|
||||||
|
R pop I pop D pop ' pause #) jmp end-code
|
||||||
|
|
||||||
|
: (emit ( char -- ) sp@ 1 (type drop ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 4, Hexblock 4
|
||||||
|
|
||||||
|
\ Multitask (at (at? ks 04 aug 87
|
||||||
|
Code (at ( row col -- ) A pop A- D+ mov
|
||||||
|
u' area U D) W mov D W ) mov cursor #) W cmp 0=
|
||||||
|
?[ R push U push $F # A+ mov $10 int
|
||||||
|
2 # A+ mov $10 int U pop R pop
|
||||||
|
]? D pop Next end-code
|
||||||
|
|
||||||
|
Code (at? ( -- row col )
|
||||||
|
D push u' area U D) W mov W ) D mov
|
||||||
|
D+ A- mov 0 # A+ mov A+ D+ mov A push Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
Code curat? ( -- row col ) D push R push
|
||||||
|
$F # A+ mov $10 int 3 # A+ mov $10 int
|
||||||
|
R pop 0 # A mov D+ A- xchg A push Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
\ *** Block No. 5, Hexblock 5
|
||||||
|
|
||||||
|
\ cur! curshape setpage ks 28 jun 87
|
||||||
|
|
||||||
|
: cur! \ set cursor into current task's window
|
||||||
|
area @ cursor ! (at? (at ; cur!
|
||||||
|
|
||||||
|
Code curshape ( top bot -- ) D C mov D pop
|
||||||
|
D- C+ mov 1 # A+ mov $10 int D pop Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
Code setpage ( n -- )
|
||||||
|
$503 # A mov D- A- and $10 int D pop Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 6, Hexblock 6
|
||||||
|
|
||||||
|
\ Multitask normal invers blankline ks 01 nov 88
|
||||||
|
: normal 7 catt c! ; : invers $70 catt c! ;
|
||||||
|
: underline 1 catt c! ; : bright $F catt c! ;
|
||||||
|
|
||||||
|
Code blankline D push R push U push $F # A+ mov
|
||||||
|
$10 int u' area U D) W mov u' catt W D) R- mov
|
||||||
|
3 # A+ mov $10 int C push D push
|
||||||
|
$E0E # C mov 1 # A+ mov $10 int W ) D mov
|
||||||
|
2 # A+ mov $10 int ' c/row >body #) C mov
|
||||||
|
D- C- sub bl # A- mov 9 # A+ mov
|
||||||
|
C- C- or 0= not ?[ $10 int ]?
|
||||||
|
D pop 2 # A+ mov $10 int \ set cursor back
|
||||||
|
C pop 1 # A+ mov $10 int \ cursor visible again
|
||||||
|
U pop R pop D pop ' pause #) jmp end-code
|
||||||
|
|
||||||
|
| : lineerase ( line# -- ) 0 (at blankline ;
|
||||||
|
|
||||||
|
\ *** Block No. 7, Hexblock 7
|
||||||
|
|
||||||
|
\ Multitask (del scroll (cr (page ks 04 okt 87
|
||||||
|
|
||||||
|
: (del (at? ?dup
|
||||||
|
IF 1- 2dup (at bl (emit (at exit THEN drop ;
|
||||||
|
|
||||||
|
Code scroll D push R push U push
|
||||||
|
u' area U D) W mov u' catt W D) R+ mov
|
||||||
|
u' ctop W D) D mov D- C+ mov 0 # C- mov
|
||||||
|
' c/row >body #) D- mov D- dec $601 # A mov
|
||||||
|
$10 int U pop R pop D pop Next
|
||||||
|
end-code
|
||||||
|
|
||||||
|
: (cr (at? drop 1+ dup cbot c@ u>
|
||||||
|
IF scroll drop cbot c@ THEN lineerase ;
|
||||||
|
|
||||||
|
: (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ;
|
||||||
|
|
||||||
|
\ *** Block No. 8, Hexblock 8
|
||||||
|
|
||||||
|
\ Multitask status display ks 10 okt 87
|
||||||
|
|
||||||
|
' (emit ' display 2 + ! ' (cr ' display 4 + !
|
||||||
|
' (type ' display 6 + ! ' (del ' display 8 + !
|
||||||
|
' (page ' display &10 + !
|
||||||
|
' (at ' display &12 + ! ' (at? ' display &14 + !
|
||||||
|
|
||||||
|
: .base base @ decimal dup 2 .r base ! ;
|
||||||
|
: .sp ( n -- ) ." s" depth swap 1+ - 2 .r ;
|
||||||
|
: (.drv ( n -- ) Ascii A + emit ." : " ;
|
||||||
|
: .dr ." " drv (.drv ;
|
||||||
|
: .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN
|
||||||
|
@ 5 .r ;
|
||||||
|
: .space ." Dic" s0 @ here $100 + - 6 u.r ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 9, Hexblock 9
|
||||||
|
|
||||||
|
\ statuszeile ks ks 04 aug 87
|
||||||
|
|
||||||
|
| : fstat ( n -- ) .base .sp
|
||||||
|
.space .scr .dr file? 2 spaces order ;
|
||||||
|
|
||||||
|
| Area: statusline
|
||||||
|
statusline c/col 1- dup window page invers terminal
|
||||||
|
|
||||||
|
: (.status output @ display area @ statusline
|
||||||
|
status @ IF (at? drop 0 (at 2 fstat blankline
|
||||||
|
ELSE normal page invers
|
||||||
|
THEN area ! output ! ;
|
||||||
|
' (.status Is .status
|
||||||
|
|
||||||
|
: bye status off .status bye ;
|
||||||
|
|
||||||
|
.( Multitasking display driver loaded ) cr
|
133
8086/msdos/src/primed.fth
Normal file
133
8086/msdos/src/primed.fth
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
2318
8086/msdos/src/see.fth
Normal file
2318
8086/msdos/src/see.fth
Normal file
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user