6502
/
VolksForth
mirror of https://github.com/forth-ev/VolksForth.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into x16-r41 

# Conflicts:
#	6502/C64/src/vf-cbm-file.fth
This commit is contained in:
Philip Zembrod 2022-08-29 22:21:27 +02:00
parent 313b87d58d fa97a04376
commit d6d38e13a4
186 changed files with 26669 additions and 458 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -2,3 +2,5 @@
*.log
/.DS_Store
*~
/tools/blkpack
/tools/blkunpack

14
6502/C64/Makefile
View File

@ -175,31 +175,31 @@ emulator/sdcard.img: emulator/sdcard.sfdisk
test-v4thblk-c64.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double block report-blk)
cat $? > $@
cat $^ > $@
test-v4th-c64.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double report-noblk)
cat $? > $@
cat $^ > $@
test-v4thblk-c16+.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double block report-blk)
cat $? > $@
cat $^ > $@
test-v4th-c16+.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double report-noblk)
cat $? > $@
cat $^ > $@
test-v4thblk-c16-.golden: $(patsubst %, tests/golden/%.golden, \
prelim core)
cat $? > $@
cat $^ > $@
test-v4th-c16-.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double report-noblk)
cat $? > $@
cat $^ > $@
test-v4th-x16.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double report-noblk)
cat $? > $@
cat $^ > $@
# Rules for building Forth binaries on top of the plain vanilla
# c64-volksforth83.

9
6502/C64/src/vf-cbm-file.fth
View File

@ -14,7 +14,10 @@
create fload-dev 8 ,
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
i/o-status? IF 1 exit THEN -1 ;
@ -25,7 +28,7 @@
fload-dev @ fload-2nd @ busin
i/o-status?abort
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
dup 0<
IF drop ELSE I + tib - #tib ! UNLOOP
@ -33,7 +36,7 @@
LOOP /tib #tib !
." warning: line exceeds max " /tib .
cr ." extra chars ignored" cr
BEGIN bus@ eol? 1+ UNTIL
BEGIN bus@ eolf? 1+ UNTIL
i/o-status? busoff ;

2
6502/C64/tests/logtofile.fth
View File

@ -24,4 +24,4 @@ Output: alsologtofile
alsologtofile ;
: logclose
log-dev-2nd@ busclose display ;
display log-dev-2nd@ busclose ;

2
6502/py65/6502f83.fb
View File

File diff suppressed because one or more lines are too long

16
6502/py65/6502f83.fth
View File

@ -20,7 +20,7 @@ ende 123
\ *** Block No. 1, Hexblock 1
\ volksFORTH Loadscreen for py65 target cas 15juli2020
\ volksFORTH Loadscreen for py65 target cas 02aug2020
forth definitions
: (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE
@ -58,7 +58,7 @@ HERE DUP ORIGIN!
\ *** 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
@ -67,7 +67,7 @@ HERE DUP ORIGIN!
0D6 ALLOT
\ 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
\ MANIPULATE SYSTEM POINTERS 29JAN85BP)
\ MANIPULATE SYSTEM POINTERS 29JAN85BP) cas 02aug2020
CODE SP@ ( -- ADDR)
SP LDA N STA SP 1+ LDA N 1+ STA
@ -628,12 +628,12 @@ CODE U< ( U1 U2 -- FLAG)
\ *** Block No. 33, Hexblock 21
\ COMPARISION WORDS 24DEC83KS)
\ COMPARISION WORDS 24DEC83KS) cas 02aug2020
| : 0< 8000 AND 0<> ;
: > ( N1 N2 -- FLAG) SWAP < ;
: 0> ( N -- FLAG) NEGATE 0< ;
: 0> ( N -- FLAG) DUP 0< SWAP 0= OR NOT ;
: 0<> ( N -- FLAG) 0= NOT ;
: U> ( U1 U2 -- FLAG) SWAP U< ;
: = ( N1 N2 -- FLAG) - 0= ;
@ -2300,7 +2300,7 @@ HOST TARGET
\ *** Block No. 121, Hexblock 79
\ 'COLD 07JUN85BP) cas 15juli2020
\ 'COLD 07JUN85BP) cas 02aug2020
| : INIT-VOCABULARYS VOC-LINK @
BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ;
@ -2309,7 +2309,7 @@ HOST TARGET
DEFER 'COLD ' NOOP IS 'COLD
| : (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
| : (RESTART ['] (QUIT IS 'QUIT

BIN
6502/py65/vfpy65.bin
View File

Binary file not shown.

1
8080/AmstradCPC/AMSDOS.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/ASS8080.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/ASSTRAN.SCR Normal file
View 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
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/COPY.SCR Normal file
View 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
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/DOUBLE.SCR Normal file
View 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
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/FILEINT.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/GRAFDEMO.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/GRAFIK.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/HASHCASH.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/INSTALL.SCR Normal file
View File

File diff suppressed because one or more lines are too long

BIN
8080/AmstradCPC/KERNEL.COM Normal file
View File

Binary file not shown.

1
8080/AmstradCPC/MATHE.SCR Normal file
View 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
View 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
View 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
View 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
View File

File diff suppressed because one or more lines are too long

129
8080/AmstradCPC/README-german.org Normal file
View 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
View 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
View 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
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/SIMPFILE.SCR Normal file
View 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
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/STARTUP.SCR Normal file
View 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
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/TERMINAL.SCR Normal file
View 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
View 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
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/TURTDEMO.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/TURTLE.SCR Normal file
View File

File diff suppressed because one or more lines are too long

1
8080/AmstradCPC/VDOS62KX.SCR Normal file
View File

File diff suppressed because one or more lines are too long

BIN
8080/AmstradCPC/VOLKS4TH.COM Normal file
View File

Binary file not shown.

1
8080/AmstradCPC/XINOUT.SCR Normal file
View File

File diff suppressed because one or more lines are too long

53
8080/AmstradCPC/disks/makedisks.sh Executable file
View 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
View 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.

2
8080/CPM/startup.fb
View File

@ -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

BIN
8080/CPM/volks4th.com
View File

Binary file not shown.

237
8086/msdos/Makefile Normal file
View 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
View File

File diff suppressed because one or more lines are too long

30
8086/msdos/emulator/run-in-dosbox.sh Executable file
View 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
View File

Binary file not shown.

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

Binary file not shown.

BIN
8086/msdos/kernel.org → 8086/msdos/o4th.com
View File

Binary file not shown.

80
8086/msdos/readme.org
View File

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

397
8086/msdos/src/86asm.fth Normal file
View 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

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

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

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

@ -0,0 +1,437 @@
\ *** Block No. 0, Hexblock 0
\ 8086 Assembler cas 10nov05
This 8086 Assembler was written by Klaus Schleisiek.
Assembler Definitions are created with the definig word
CODE and closed with the word END-CODE.
The 8086 Registers naming and usage in volksFORTH
Intel vForth Used for 8bit-Register
AX A free A+ A-
DX D topmost Stackitem D+ D-
CX C free C+ C-
BX R Returnstack Pointer R+ R-
BP U User Pointer
SP S Stack Pointer
SI I Instruction Pointer
DI W Word Pointer, mostly free
\ *** Block No. 1, Hexblock 1
\ 8086 Assembler loadscreen cas 10nov05
Onlyforth
| : u2/ ( 16b -- 15b ) 2/ $7FFF and ;
| : 8* ( 15b -- 16b ) 2* 2* 2* ;
| : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ;
Vocabulary Assembler
Assembler also definitions
3 &21 thru clear .( Assembler loaded ) cr
\ *** Block No. 2, Hexblock 2
\ conditional Assembler compiler cas 10nov05
here
: temp-assembler ( addr -- ) hide last off dp !
" ASSEMBLER" find nip ?exit here $1800 + sp@ u>
IF display cr ." Assembler won't fit" abort THEN
here sp@ $1800 - dp ! 1 load dp ! ;
temp-assembler \\
: blocks ( n -- addr / ff )
first @ >r dup 0 ?DO freebuffer LOOP
[ b/blk negate ] Literal * first @ + r@ u> r> and ;
\ *** Block No. 3, Hexblock 3
\ Code generating primitives cas 10nov05
Variable >codes \ points at table of execution vectors
| Create nrc ] c, , here ! c! [
: nonrelocate nrc >codes ! ; nonrelocate
| : >exec ( n -- n+2 ) Create dup c, 2+
Does> c@ >codes @ + perform ;
0 | >exec >c, | >exec >, | >exec >here
| >exec >! | >exec >c! drop
\ *** Block No. 4, Hexblock 4
\ 8086 Registers cas 10nov05
0 Constant A 1 Constant C 2 Constant D 3 Constant R
4 Constant S 5 Constant U 6 Constant I 7 Constant W
' I Alias SI ' W Alias DI ' R Alias BX
8 Constant A- 9 Constant C- $A Constant D- $B Constant R-
$C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+
' R- Alias B- ' R+ Alias B+
$100 Constant E: $101 Constant C:
$102 Constant S: $103 Constant D:
| Variable isize ( specifies Size by prefix)
| : Size: ( n -- ) Create c, Does> c@ isize ! ;
0 Size: byte 1 Size: word word 2 Size: far
\ *** Block No. 5, Hexblock 5
\ 8086 Assembler System variables cas 10nov05
| Variable direction \ 0 reg>EA, -1 EA>reg
| Variable size \ 1 word, 0 byte, -1 undefined
| Variable displaced \ 1 direct, 0 nothing, -1 displaced
| Variable displacement
| : setsize isize @ size ! ;
| : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ;
| : wexit rdrop word ;
| : moderr word true Abort" invalid" ;
| : ?moderr ( f -- ) 0=exit moderr ;
| : ?word size @ 1- ?moderr ;
| : far? ( -- f ) size @ 2 = ;
\ *** Block No. 6, Hexblock 6
\ 8086 addressing modes cas 10nov05
| Create (EA 7 c, 0 c, 6 c, 4 c, 5 c,
| : () ( 8b1 -- 8b2 )
3 - dup 4 u> over 1 = or ?moderr (EA + c@ ;
-1 Constant # $C6 Constant #) -1 Constant C*
: ) ( u1 -- u2 )
() 6 case? IF 0 $86 exit THEN $C0 or ;
: I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ;
: D) ( n u1 -- n u2 )
() over long? IF $40 ELSE $80 THEN or ;
: DI) ( n u1 u2 -- n u3 )
I) over long? IF $80 ELSE $40 THEN xor ;
\ *** Block No. 7, Hexblock 7
\ 8086 Registers and addressing modes cas 10nov05
| : displaced? ( [n] u1 -- [n] u1 f )
dup #) = IF 1 exit THEN
dup $C0 and dup $40 = swap $80 = or ;
| : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit
displaced @ ?moderr displaced ! swap displacement ! ;
| : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit
size off $FF07 and ;
| : mmode? ( 9b - 9b f) dup $C0 and ;
| : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ;
\ *** Block No. 8, Hexblock 8
\ 8086 decoding addressing modes cas 10nov05
| : 2address ( [n] source [displ] dest -- 15b / [n] 16b )
size on displaced off dup # = ?moderr mmode?
IF displace False ELSE rmode True THEN direction !
>r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit
THEN direction @
IF r> 8* >r mmode? IF displace
ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN
ELSE rmode 8*
THEN r> or $C0 xor ;
| : 1address ( [displ] 9b -- 9b )
# case? ?moderr size on displaced off direction off
mmode? IF displace setsize ELSE rmode THEN $C0 xor ;
\ *** Block No. 9, Hexblock 9
\ 8086 assembler cas 10nov05
| : immediate? ( u -- u f ) dup 0< ;
| : nonimmediate ( u -- u ) immediate? ?moderr ;
| : r/m 7 and ;
| : reg $38 and ;
| : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ;
| : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and
IF dup $100 and IF dup r/m 8* swap reg 8/
or $C0 or direction off
THEN True exit
THEN False ;
\ *** Block No. 10, Hexblock a
\ 8086 Registers and addressing modes cas 10nov05
| : w, size @ or >c, ;
| : dw, size @ or direction @ IF 2 xor THEN >c, ;
| : ?word, ( u1 f -- ) IF >, exit THEN >c, ;
| : direct, displaced @ 0=exit
displacement @ dup long? displaced @ 1+ or ?word, ;
| : r/m, >c, direct, ;
| : data, size @ ?word, ;
\ *** Block No. 11, Hexblock b
\ 8086 Arithmetic instructions cas 10nov05
| : Arith: ( code -- ) Create ,
Does> @ >r 2address immediate?
IF rmode? IF ?akku IF r> size @
IF 5 or >c, >, wexit THEN
4 or >c, >c, wexit THEN THEN
r@ or $80 size @ or r> 0<
IF size @ IF 2 pick long? 0= IF 2 or size off THEN
THEN THEN >c, >c, direct, data, wexit
THEN r> dw, r/m, wexit ;
$8000 Arith: add $0008 Arith: or
$8010 Arith: adc $8018 Arith: sbb
$0020 Arith: and $8028 Arith: sub
$0030 Arith: xor $8038 Arith: cmp
\ *** Block No. 12, Hexblock c
\ 8086 move push pop cas 10nov05
: mov [ Forth ] 2address immediate?
IF rmode? IF r/m $B0 or size @ IF 8 or THEN
>c, data, wexit
THEN $C6 w, r/m, data, wexit
THEN 6 case? IF $A2 dw, direct, wexit THEN
smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit
THEN $88 dw, r/m, wexit ;
| : pupo [ Forth ] >r 1address ?word
smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN
rmode? IF r/m $50 or r> or >c, wexit THEN
r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ;
: push 0 pupo ; : pop 8 pupo ;
\ *** Block No. 13, Hexblock d
\ 8086 inc & dec , effective addresses cas 10nov05
| : inc/dec [ Forth ] >r 1address rmode?
IF size @ IF r/m $40 or r> or >c, wexit THEN
THEN $FE w, r> or r/m, wexit ;
: dec 8 inc/dec ; : inc 0 inc/dec ;
| : EA: ( code -- ) Create c, [ Forth ]
Does> >r 2address nonimmediate
rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ;
$C4 EA: les $8D EA: lea $C5 EA: lds
\ *** Block No. 14, Hexblock e
\ 8086 xchg segment prefix cas 10nov05
: xchg [ Forth ] 2address nonimmediate rmode?
IF size @ IF dup r/m 0=
IF 8/ true ELSE dup $38 and 0= THEN
IF r/m $90 or >c, wexit THEN
THEN THEN $86 w, r/m, wexit ;
| : 1addr: ( code -- ) Create c, [ Forth ]
Does> c@ >r 1address $F6 w, r> or r/m, wexit ;
$10 1addr: com $18 1addr: neg
$20 1addr: mul $28 1addr: imul
$38 1addr: idiv $30 1addr: div
: seg ( 8b -) [ Forth ]
$100 xor dup $FFFC and ?moderr 8* $26 or >c, ;
\ *** Block No. 15, Hexblock f
\ 8086 test not neg mul imul div idiv cas 10nov05
: test [ Forth ] 2address immediate?
IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN
$F6 w, r/m, data, wexit
THEN $84 w, r/m, wexit ;
| : in/out [ Forth ] >r 1address setsize
$C2 case? IF $EC r> or w, wexit THEN
6 - ?moderr $E4 r> or w, displacement @ >c, wexit ;
: out 2 in/out ; : in 0 in/out ;
: int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ;
\ *** Block No. 16, Hexblock 10
\ 8086 shifts and string instructions cas 10nov05
| : Shifts: ( code -- ) Create c, [ Forth ]
Does> c@ >r C* case? >r 1address
r> direction ! $D0 dw, r> or r/m, wexit ;
$00 Shifts: rol $08 Shifts: ror
$10 Shifts: rcl $18 Shifts: rcr
$20 Shifts: shl $28 Shifts: shr
$38 Shifts: sar ' shl Alias sal
| : Str: ( code -- ) Create c,
Does> c@ setsize w, wexit ;
$A6 Str: cmps $AC Str: lods $A4 Str: movs
$AE Str: scas $AA Str: stos
\ *** Block No. 17, Hexblock 11
\ implied 8086 instructions cas 10nov05
: Byte: ( code -- ) Create c, Does> c@ >c, ;
: Word: ( code -- ) Create , Does> @ >, ;
$37 Byte: aaa $AD5 Word: aad $AD4 Word: aam
$3F Byte: aas $98 Byte: cbw $F8 Byte: clc
$FC Byte: cld $FA Byte: cli $F5 Byte: cmc
$99 Byte: cwd $27 Byte: daa $2F Byte: das
$F4 Byte: hlt $CE Byte: into $CF Byte: iret
$9F Byte: lahf $F0 Byte: lock $90 Byte: nop
$9D Byte: popf $9C Byte: pushf $9E Byte: sahf
$F9 Byte: stc $FD Byte: std $FB Byte: sti
$9B Byte: wait $D7 Byte: xlat
$C3 Byte: ret $CB Byte: lret
$F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep
\ *** Block No. 18, Hexblock 12
\ 8086 jmp call conditions cas 10nov05
| : jmp/call >r setsize # case? [ Forth ]
IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit
THEN >here 2+ - r>
IF dup long? 0= IF $EB >c, >c, wexit THEN $E9
ELSE $E8 THEN >c, 1- >, wexit
THEN 1address $FF >c, $10 or r> +
far? IF 8 or THEN r/m, wexit ;
: call 0 jmp/call ; : jmp $10 jmp/call ;
$71 Constant OS $73 Constant CS
$75 Constant 0= $77 Constant >=
$79 Constant 0< $7B Constant PE
$7D Constant < $7F Constant <=
$E2 Constant C0= $E0 Constant ?C0=
: not 1 [ Forth ] xor ;
\ *** Block No. 19, Hexblock 13
\ 8086 conditional branching cas 10nov05
: +ret $C2 >c, >, ;
: +lret $CA >c, >, ;
| : ?range dup long? abort" out of range" ;
: ?[ >, >here 1- ;
: ]? >here over 1+ - ?range swap >c! ;
: ][ $EB ?[ swap ]? ;
: ?[[ ?[ swap ;
: [[ >here ;
: ?] >c, >here 1+ - ?range >c, ;
: ]] $EB ?] ;
: ]]? ]] ]? ;
\ *** Block No. 20, Hexblock 14
\ Next user' end-code ;c: cas 10nov05
: Next lods A W xchg W ) jmp
>here next-link @ >, next-link ! ;
: u' ' >body c@ ;
Forth definitions
\needs end-code : end-code toss also ;
Assembler definitions
: ;c: recover # call last off end-code 0 ] ;
\ *** Block No. 21, Hexblock 15
\ 8086 Assembler, Forth words cas 10nov05
Onlyforth
: Assembler Assembler [ Assembler ] wexit ;
: ;code 0 ?pairs compile (;code
reveal [compile] [ Assembler ; immediate
: Code Create [ Assembler ] >here dup 2- >! Assembler ;
: >label ( addr -- )
here | Create immediate swap , 4 hallot
here 4 - heap 4 cmove heap last @ (name> ! dp !
Does> ( -- addr ) @ state @ 0=exit [compile] Literal ;
: Label [ Assembler ] >here >label Assembler ;
\ *** Block No. 22, Hexblock 16

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -0,0 +1,342 @@
\ *** Block No. 0, Hexblock 0
\ 28 jun 88
DOS loads higher level file functions which go beyond
including a screen file. Calls to MS-DOS are implemented
and used for directory manipulation. These functions may
not work for versions before MS-DOS 3.0.
\ *** Block No. 1, Hexblock 1
\ MS-DOS file handli cas 09jun20
Onlyforth \needs Assembler 2 loadfrom asm.fb
: fswap isfile@ fromfile @ isfile ! fromfile ! ;
$80 Constant dta
| : COMSPEC ( -- string ) [ dos ]
$2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove
filename counted &60 min filename place filename ;
1 &12 +thru .( MS-DOS functions loaed ) cr
Onlyforth
\ *** Block No. 2, Hexblock 2
\ moving blocks ks 04 okt 87
| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ;
: used? ( blk -- f )
block count b/blk 1- swap skip nip 0<> ;
| : (copy ( from to -- )
full? IF save-buffers THEN isfile@ fromfile @ -
IF dup used? Abort" target block not empty" THEN
dup isfile@ core? IF prev @ emptybuf THEN
isfile@ 0= IF offset @ + THEN
isfile@ rot fromfile @ (block 6 - 2! update ;
\ *** Block No. 3, Hexblock 3
\ moving blocks ks 04 okt 87
| : blkmove ( from to quan -- ) 3 arguments save-buffers
>r over r@ + over u> >r 2dup u< r> and
IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP
ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP
THEN save-buffers 2drop ;
: copy ( from to -- ) 1 blkmove ;
: convey ( blk1 blk2 to.blk -- )
3 arguments >r 2dup swap - >r
fswap dup capacity 1- > isfile@ 0<> and
fswap r> r@ + capacity 1- > isfile@ 0<> and or >r
1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ;
\ *** Block No. 4, Hexblock 4
\ MORE extending forth files ks 10 okt 87
Dos also definitions
| : addblock ( blk -- ) dup buffer dup b/blk blank
isfile@ f.size dup 2@ b/blk 0 d+ rot 2!
swap isfile@ fblock! ;
Forth definitions
: more ( n -- ) 1 arguments isfile@
IF capacity swap bounds ?DO I addblock LOOP close exit
THEN drop ;
\ *** Block No. 5, Hexblock 5
\ file eof? create dta-addressing ks 03 apr 88
Dos definitions
: ftime ( -- mm hh )
isfile@ f.time @ $20 u/mod nip $40 u/mod ;
: fdate ( -- dd mm yy )
isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
: .when base push decimal
fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r
ftime 3 .r ." :" 2 .r ;
\ *** Block No. 6, Hexblock 6
\ ks 20mar88
: (.fcb ( fcb -- )
dup .file ?dup 0=exit pushfile
isfile ! &13 tab ." is"
isfile@ f.handle @ 2 .r
isfile@ f.size 2@ 7 d.r .when
space isfile@ f.name count type ;
Forth definitions
: files file-link
BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ;
: ?file isfile@ (.fcb ;
\ *** Block No. 7, Hexblock 7
\ dir make makefile ks 25 okt 87
Forth definitions
: killfile close
isfile@ f.name filename >asciz ~unlink drop ;
: emptyfile isfile@ 0=exit
isfile@ f.name filename >asciz 0 ~creat ?diskerror
isfile@ f.handle ! isfile@ f.size 4 erase ;
: make close name isfile@ fname! emptyfile ;
: makefile File last @ name> execute emptyfile ;
\ *** Block No. 8, Hexblock 8
\ getpath ks 10 okt 87
Dos definitions
| &40 Constant pathlen
| Create pathes 0 c, pathlen allot
| : (setpath ( string -- ) count
dup pathlen u> Abort" path too long" pathes place ;
| : getpath ( +n -- string / ff )
>r 0 pathes count r> 0
DO rot drop Ascii ; skip stash Ascii ; scan LOOP
drop over - ?dup
IF here place here dup count + 1- c@
?" :\" ?exit Ascii \ here append exit
THEN 0= ;
\ *** Block No. 9, Hexblock 9
\ pathsearch .path path ks 09 okt 87
: pathsearch ( string -- asciz *f ) dup >r
(fsearch dup 0= IF rdrop exit THEN 2drop 0 0
BEGIN drop 1+ dup getpath ?dup 0=
IF drop r> filename >asciz 2 exit THEN
r@ count 2 pick attach (fsearch
0= UNTIL nip rdrop false ;
' pathsearch Is fsearch
Forth definitions
: .path pathes count type ;
: path name nullstring? IF .path exit THEN (setpath ;
\ *** Block No. 10, Hexblock a
\ call another executable file ks 04 aug 87
Dos definitions
| Create cpb 0 , \ inherit parent environment
dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 ,
| Code ~exec ( asciz -- *f )
I push R push U push S ssave #) mov cpb # R mov
$4B00 # A mov $21 int C: D mov D D: mov D S: mov
D E: mov ssave #) S mov CS not
?[ A A xor A push $2F # A+ mov $21 int E: A mov
A D: mov C: A mov A E: mov R I mov dta # W mov
$40 # C mov rep movs A D: mov A pop
]? A W xchg dta # D mov $1A # A+ mov $21 int
W D mov U pop R pop I pop Next
end-code
\ *** Block No. 11, Hexblock b
\ calling MS-DOS thru forth interpreter ks 19 mr 88
| : execute? ( extension -- *f )
count filename count Ascii . scan drop swap
2dup 1+ erase move filename 1+ ~exec ;
: fcall ( string -- ) count filename place ds@ cpb 4+ !
" .EXE" execute? dup IF drop " .COM" execute? THEN
?diskerror ;
: fdos ( string -- )
dta $80 erase " /c " count dta place count dta attach
status push status off .status COMSPEC fcall curat? at ;
\ *** Block No. 12, Hexblock c
\ einige MS-DOS Funktionen msdos call ks 10 okt 87
: dos: Create ," Does> count here place
Ascii " parse here attach here fdos ;
Forth definitions
dos: dir dir "
dos: ren ren "
dos: md md "
dos: cd cd "
dos: rd rd "
dos: fcopy copy "
dos: delete del "
dos: ftype type "
\ *** Block No. 13, Hexblock d
\ msdos call ks 23 okt 88
: msdos savevideo status push status off .status
flush dta off COMSPEC fcall restorevideo ;
: call name source >in @ /string c/l umin
dta place dta dta >asciz drop [compile] \
status push status off .status fcall curat? at ;
\ *** Block No. 14, Hexblock e
\ time date ks 19 mr 88
Dos definitions
: ftime ( -- mm hh )
open isfile@ f.time @ $20 u/mod nip $40 u/mod ;
: fdate ( -- dd mm yy )
open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
\ *** Block No. 15, Hexblock f
\ ~lseek position? ks 10 okt 87
Dos definitions
Code ~lseek ( d handle method -- d' )
R W mov D A mov R pop C pop D pop
$42 # A+ mov $21 int W R mov CS not
?[ A push Next ]? A D xchg ;c: ?diskerror ;
Forth definitions
: position? ( -- dfaddr )
isfile@ f.handle @ 0= Abort" file not open"
0 0 isfile@ f.handle @ 1 ~lseek ;
\ *** Block No. 16, Hexblock 10
\ *** Block No. 17, Hexblock 11

255
8086/msdos/src/dos2.fth Normal file
View 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
View 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

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

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

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

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

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

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

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

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

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

@ -0,0 +1,209 @@
\ *** Block No. 0, Hexblock 0
\ ks 11 mai 88
Dieses File enthält Definitionen, die zum Laden der weiteren
System- und Applikationsfiles benötigt werden.
Unter anderem finden sich hier auch MS-DOS spezifische
Befehle wie zum Beispiel das Allokieren von Speicher-
platz ausserhalb des auf 64k begrenzten Forthsystems
und einige Routinen, die das Arbeiten mit dem Video-
Display erleichtern sowie einige Operatoren zur String-
manipulation.
\ *** Block No. 1, Hexblock 1
\ loadscreen for often used words ks cas 25sep16
Onlyforth \needs Assembler 2 loadfrom asm.fb
' save-buffers Alias sav
' name &12 + Constant 'name
' page Alias cls
1 8 +thru .( Systemerweiterung geladen) cr
\ *** Block No. 2, Hexblock 2
\ Postkernel words ks 22 dez 87
: blank ( addr quan -- ) bl fill ;
Code stash ( u1 u2 -- u1 u1 u2 )
S W mov W ) push Next end-code
\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ;
: >expect ( addr len -- ) stash expect span @ over place ;
: .field ( addr len quan -- )
over - >r type r> 0 max spaces ;
: tab ( n -- ) col - 0 max spaces ;
\ *** Block No. 3, Hexblock 3
\ postkernel ks 08 mär 89
\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT
\needs end-code : end-code toss also ;
: u? ( addr -- ) @ u. ;
: adr ' >body state @ 0=exit [compile] Literal ; immediate
: Abort( ( f -- ) IF [compile] .( true abort" !" THEN
[compile] ( ;
: arguments ( n -- )
depth 1- > Error" zu wenige Parameter" ;
\ *** Block No. 4, Hexblock 4
\ MS-DOS memory management
Code lallocate ( pages -- seg ff / rest err# )
R push D R mov $48 # A+ mov $21 int CS
?[ A D xchg A pop R push A R xchg
][ R pop A push 0 # D mov ]? Next end-code
Code lfree ( seg -- err# )
E: push D E: mov $49 # A+ mov $21 int CS
?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code
\ *** Block No. 5, Hexblock 5
\ postkernel ks 03 aug 87
c/row c/col * 2* Constant c/dis \ characters per display
Code video@ ( -- seg ) D push R D mov $F # A+ mov
$10 int R D xchg 0 # D- mov 7 # A- cmp
0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next
end-code
: savevideo ( -- seg / ff )
[ c/dis b/seg /mod swap 0<> - ] Literal lallocate
IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ;
: restorevideo ( seg -- ) ?dup 0=exit
dup 0 video@ 0 c/dis lmove lfree drop ;
\ *** Block No. 6, Hexblock 6
\ string operators append attach ks 21 jun 87
| : .stringoverflow true Abort" String zu lang" ;
Code append ( char addr -- )
D W mov D pop W ) A- mov 1 # A- add CS
?[ ;c: .stringoverflow ; Assembler ]?
A- W ) mov 0 # A+ mov A W add
D- W ) mov D pop Next end-code
Code attach ( addr len addr1 -- ) D W mov C pop
I D mov I pop W ) A- mov A- A+ mov C- A+ add CS
?[ ;c: .stringoverflow ; Assembler ]?
A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc
rep byte movs D I mov D pop Next end-code
\ *** Block No. 7, Hexblock 7
\\ string operators append attach detract ks 21 jun 87
: append ( char addr -- )
under count + c! dup c@ 1+ swap c! ;
: attach ( addr len addr.to -- )
>r under r@ count + swap move r@ c@ + r> c! ;
: detract ( addr -- char )
dup c@ 1- dup 0> and over c!
count >r dup count -rot swap r> cmove ;
\ *** Block No. 8, Hexblock 8
\ ?" string operator ks 09 feb 88
\ : (?" ( 8b -- index ) "lit under count rot
\ scan IF swap - exit THEN 2drop false ;
| Create months ," janfebmäraprmaijunjulaugsepoktnovdez"
: >months ( n -- addr len ) 3 * 2- months + 3 ;
| Code (?" ( 8b -- index )
A D xchg I ) C- mov 0 # C+ mov C I add
I W mov I inc std 0<>rep byte scas cld
0= ?[ C inc ]? C D mov Next
end-code
: ?" compile (?" ," align ; immediate restrict
\ *** Block No. 9, Hexblock 9
\ Conditional compilation ks 12 dez 88
| Defer cond
: .THEN ; immediate
: .ELSE ( -- ) 0
BEGIN name nullstring? IF drop exit THEN
find IF cond -1 case? ?exit ELSE drop THEN
REPEAT ; immediate
: .IF ( f -- ) ?exit [compile] .ELSE ; immediate
| : (cond ( n cfa -- n' )
['] .THEN case? IF 1- exit THEN
['] .ELSE case? IF dup 0= + exit THEN
['] .IF = 0=exit 1+ ; ' (cond is cond
\ *** Block No. 10, Hexblock a

182
8086/msdos/src/extend2.fth Normal file
View 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

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

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

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

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

1
8086/msdos/src/include.fb Normal file
View File

File diff suppressed because one or more lines are too long

152
8086/msdos/src/include.fth Normal file
View 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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

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

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

File diff suppressed because one or more lines are too long

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

File diff suppressed because it is too large Load Diff

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

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

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

@ -0,0 +1,380 @@
\ *** Block No. 0, Hexblock 0
\\ Terminalprogramm mit Blockinterface ( 08.03.91/KK )
Autor: Klaus Kohl, 30.01.89 aus FG-FORTH des RTX entnommen
Beschreibung:
Kleines Beispiel zur Implementation eines Fileinterfaces über
die serielle Schnittstelle (Achtung: immer 8 Datenbits)
Die Schnittstellenbefehle stammen aus dem PC-volksFORTH 3.81
von Klaus Schleisiek. Sie wurden weitgehend unverändert über-
nommen, sind aber auf 4KByte-Puffer erweitert.
File: SERIAL.SCR
Umstellung des Ports durch Ausmaskierung der entsprechenden
Zeilen in Screen 2 (momentan COM1 aktiviert).
\ *** Block No. 1, Hexblock 1
\ LOADSCREEN cas 28jun20
Onlyforth \ Suchreihenfolge: FORTH FORTH ONLY
\needs Assembler 2 loadfrom asm.fb \ Assembler nachladen
FROM source.img ( File for SAVESYSTEM )
$20 >label I_ctrl \ 8259-Register
$21 >label I_mask \ 8259-Mask
&02 &11 THRU ( SIO-Terminalroutines )
&12 &17 THRU ( extended command words )
&18 LOAD ( Terminalprogram )
\ *** Block No. 2, Hexblock 2
\ Addresses and Constants cas 28jun20
| $C 4 * Constant SINT@ \ SIO-Interuptvector COM 1/3
\ $B 4 * Constant SINT@ \ SIO-Interuptvector COM 2/4
| $10 Constant I_level \ 8259-Interuptlevel COM 1/3
\ $08 Constant I_level \ 8259-Interuptlevel COM 2/4
( Port address)
| $3F8 >label Portadr \ Portaddress COM1:
\ $2F8 >label Portadr \ Portaddress COM2:
\ $3E8 >label Portadr \ Portaddress COM3:
\ $2E8 >label Portadr \ Portaddress COM4:
( Selection of Baud rate )
\ &96 >label baud .( 1200 Baud )
\ &48 >label baud .( 2400 Baud )
| &12 >label baud .( 9600 Baud )
\ &02 >label baud .( 57600 Baud )
\ *** Block No. 3, Hexblock 3
\ Queue and required commands cas 28jun20
( Dataqueue with 128 bytes and two pointer for IRQ service )
( Queue+0: Number of saved characters )
( Queue+1: offset to next char to be send )
Create Queue 0 , 0 , $1000 allot
\ send byte to port address ( b adr -- )
\needs pc! Code pc! A pop D byte out D pop Next
\ Read Byte from port address ( adr -- b )
\needs pc@ Code pc@ D byte in A- D- mov D+ D+ xor Next
\ *** Block No. 4, Hexblock 4
\ tx? = Request status for sending char cas 28jun20
( test if a char cn be send )
Code tx? ( -- f ) \ f=-1, ready to send
D push \ TOS to datastack (TOS=Top Of Stack)
Portadr 5 + # D mov \ move status address into D reg
D in \ get port into register A
D D xor \ set D register to 0
$1020 # A and \ mask % 0001 0000 0010 0000
$1020 # A cmp \ tes if these bits are set
0= ?[ D dec ]? \ char output permitted ?
Next \ compiling "Next" wurg macro
end-code
\ *** Block No. 5, Hexblock 5
\ (tx tx = transmit cas 28jun20
( unconditional send byte directly to 8250-Port )
Code (tx ( char -- )
D- A- xchg \ load char into AL-register
Portadr # D mov \ load port address in D-register
D byte out \ transmit AL
D pop \ load next stack value into D-register
Next \ compiling "Next"
end-code
( wait until last char has been send )
: tx ( char -- )
BEGIN tx? UNTIL \ wait until SIO ready
(tx ; \ now write to port
\ *** Block No. 6, Hexblock 6
\ -DTR +DTR = Data Terminal Ready on/off cas 28jun20
( DTR-Line to +12 V = logical zero )
Code -DTR ( -- )
D push \ save TOS
Portadr 4 + # D mov \ get Address of Port Controllregister
D byte in \ move content to AL register
$1C # A- and \ DTR and RTS to 0 = +12 V
D byte out \ write AL back into port register
D pop \ restore TOS
Next \ next FORTH words
end-code
( set DTR and RTS back to 1 = -12 V )
Code +DTR ( -- )
D push Portadr 4 + # D mov
D byte in 3 # A- or D byte out
D pop Next end-code
\ *** Block No. 7, Hexblock 7
\ receive queue and interrupt service routine ( 21.02.89/KK )
| Label S_INT
D push I push A push
Queue # I mov C: seg I ) A mov
A D mov A inc $FFF # A and C: seg A I ) mov D I ADD
Portadr # D mov D byte in C: seg A- 4 I D) mov
$20 # A- mov I_ctrl #) byte out \ EOI for 8259
A pop I pop D pop iret
end-code
\ *** Block No. 8, Hexblock 8
\ rx? = request status for reading from Queue cas 28jun20
| Code rx? ( -- f ) D push
Queue #) D mov Queue 2+ #) D XOR
Next end-code
\\ Query if a char can be read from the queue
Code rx? ( -- f ) ( f<>0, if char ready )
D push \ TOS to datastack
D D xor \ D-register to 0
Queue #) D- mov \ get number if DL and
D- D- or \ test for 0
0= ?[ [[ D push \ if queue empty
Portadr 4 + # D mov \ activate S8 again
D byte in $B # A- or D byte out \ without changing
D pop \ D register
swap ]? Next end-code
\ *** Block No. 9, Hexblock 9
\ (rx rx = receive char from queue cas 28jun20
( get char from queue, adjust pointer )
Code (rx ( -- char )
D push I push
Queue 2+ # I mov C: seg I ) A mov
A D mov A inc $FFF # A and C: seg A I ) mov D I ADD
C: seg 2 I D) A- mov 0 # A+ mov A D mov
I pop Next end-code
( get char, wait for char available )
: rx ( -- char )
BEGIN rx? UNTIL (rx ;
\ *** Block No. 10, Hexblock a
\ S_init = initialize serial interface cas 28jun20
| Code S_init ( -- )
D push D: push \ save TOS and DS register
A A xor A D: mov C: A mov \ 0 -> DS ; CS -> A
SINT@ # W mov S_INT # W ) mov \ set IRQ vector
A 2 W D) mov D: pop \ and restore DS register
Portadr 3 + # D mov
$80 # A- mov D byte out \ enable Baud-rate register
2 # D sub baud # A mov A- A+ xchg D byte out \ set the
D dec A- A+ xchg D byte out \ BAUD rate
3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT
2 # D sub 1 # A- mov D byte out \ enable RX IRQ
I_mask #) byte in
I_level Forth not Assembler # A- and \ activate 8259
I_mask #) byte out
D pop Next end-code
\ *** Block No. 11, Hexblock b
\ init -init = Initialization / Reset cas 28jun20
\needs init | : init ;
( clear queue pointer and initialize port and interrupt )
: init ( -- )
init Queue off Queue 2+ off S_init ;
( block IRQ, disable RTS and DTR )
: -init ( -- )
0 [ Portadr 1+ ] Literal pc! \ disable 8259 IRQ
0 [ Portadr 4 + ] Literal pc! \ -RTS/-rts/-out2
I_mask pc@ I_level or I_mask pc! ; \ block 8259
\ *** Block No. 12, Hexblock c
\ rxto rxwto = receive char with timeout cas 28jun20
| &1000 Constant Timeout \ exit after 1000 iterations
( get a char )
| : rxto ( -- char 0 | f ) ( f=-1 signals error )
Timeout \ number iterations
BEGIN rx? IF drop (rx 0 exit THEN \ char available?
1- DUP 0= \ Timeout ?
UNTIL DROP -1 ;
( get a word, Highbyte first )
| : rxwto ( -- n 0 | f )
rxto ?dup ?exit \ exit when Timeout in 1st byte
&256 * rxto \ move to highbyte, get lowbyte
if drop -1 else OR 0 then ; \ Timeout -> error flag
\ *** Block No. 13, Hexblock d
\ info. blk>sio sio>blk = Forth Block I/O cas 28jun20
: info. ." Block: " dup . cr ;
: blk>sio ( b -- f ) ( Block to target machine )
dup capacity u<
if cr ." HOST -> TA -" info. block 0 tx
&1024 0 DO dup c@ tx 1+ LOOP drop
else drop 9 tx
then 0 ;
: sio>blk ( b -- f ) ( Block from Target )
dup capacity u<
if cr ." TA -> HOST -" info. flush block 0 tx
&1024 0 do rxto if drop &1234 leave
else over c! 1+ then loop &1234 =
if empty-buffers -1 else update flush 0 then
else drop 9 tx 0 then ;
\ *** Block No. 14, Hexblock e
\ Extension for img>file cas 28jun20
VARIABLE TSEG TSEG OFF ( Segment-Address of Target-RAM )
: TINIT ( len -- )
0 B/SEG UM/MOD SWAP IF 1+ THEN ( number of blocks )
LALLOCATE ABORT" No RAM" ( reserve )
TSEG ! ; ( save address )
: TFREE ( -- ) ( release memory )
TSEG @ LFREE ABORT" RAM allocated" ;
: TC! ( c addr -- ) ( write byte )
TSEG @ SWAP LC! ;
: <TMOVE ( taddr addr n -- ) ( data from target )
>R >R TSEG @ SWAP DS@ R> R> LMOVE ;
\ *** Block No. 15, Hexblock f
\ Terminal part for SAVESYSTEM cas 28jun20
: img>file ( len -- f ) ( save image file )
DUP TINIT DUP 0 0 tx
?DO rxto ABORT" Savesystem-Error" I TC! LOOP
PUSHFILE SOURCE.IMG
CAPACITY 1- 0 DO I BLOCK &1024 -1 FILL UPDATE LOOP
0 $400 UM/MOD DUP 0
?DO I $400 * I BLOCK $400 <TMOVE UPDATE LOOP
SWAP ?DUP
IF OVER DUP $400 * SWAP BLOCK ROT <TMOVE UPDATE THEN
DROP FLUSH CLOSE
TFREE 0 ;
\ *** Block No. 16, Hexblock 10
\ tbu = command interpreter cas 28jun20
( command interpreter for escape codes )
| : tbu ( -- f ) ( Terminal block transmission )
rxto ?dup ?exit \ get code
1 case? if rxwto ?dup ?exit blk>sio exit then \ Transmit
2 case? if rxwto ?dup ?exit sio>blk exit then \ Receive
3 case? if rxwto ?dup ?exit img>file exit then \ ROM
4 case? if rxwto ?dup ?exit drop page 0 exit then \ PAGE
5 case? if rxto ?dup ?exit rxto ?dup if nip exit then
swap at 0 exit then \ AT
$1B case? if $1B tx 0 exit then \ ESCAPE
drop -1 ; \ error unknown command
\ *** Block No. 17, Hexblock 11
\ ?rx = char from terminal cas 28jun20
( receive and interpret char )
| : ?rx ( -- )
pause rx? 0=exit (rx \ return if no char wainting
dup $20 u< \ is control char?
if
$1B case? if tbu abort" Command-Error" exit THEN \ ESCAPE
#LF case? IF cr exit THEN \ CRLF
#CR case? IF Row 0 at exit THEN \ only CR
#BS case? IF del exit THEN \ Backspace
drop \ better ignore these
else
Col &78 u> if cr then \ next line?
emit \ directly emit char
then ;
\ *** Block No. 18, Hexblock 12
\ T - Main Terminal command cas 28jun20
( send char if possible )
| : ?tx ( c -- )
BEGIN ?rx tx? UNTIL \ receive unil SIO is free
tx ; \ then transmit
( Terminal Interpreter Loop )
| : (T ( -- )
BEGIN BEGIN ?rx key? UNTIL \ receive until key pressed
key $1B case? IF -DTR exit THEN ?tx \ exit on ESC
REPEAT ;
( Main program, en-/disables interrupt )
: T ( -- )
CR ." TA-Terminal (Exit with ESC)" CR
INIT (T -INIT
CR ." VolksForth " ;
\ *** Block No. 19, Hexblock 13

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

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

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

File diff suppressed because one or more lines are too long

192
8086/msdos/src/multivid.fth Normal file
View 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

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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

Some files were not shown because too many files have changed in this diff Show More