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

CPM Source files

Browse Source
This commit is contained in:
Carsten Strotmann 2020-06-20 18:59:14 +02:00
parent f7e90c3fb4
commit 3dd6197fbf
25 changed files with 6341 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

306
sources/cpm/ASS8080.FB.src Normal file
View File

@ -0,0 +1,306 @@
Screen 0 not modified
0 \ VolksForth 8080 Assembler UH 09Mar86
1
2 Ideen lieferten:
3 John Cassady
4 Mike Perry
5 Klaus Schleisiek
6 Bernd Pennemann
7 Dietrich Weineck
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ VolksForth 8080 Assembler Load Screen UH 03Jun86
1 Onlyforth Assembler also definitions hex
2
3 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr
4
5 OnlyForth
6
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ Vektorisierte Erzeugung UH 03Jun86
1 Variable >codes
2
3 | Create nrc ] c, , c@ here allot ! c! [
4
5 : nonrelocate ( -- ) nrc >codes ! ; nonrelocate
6
7 | : >exec ( n -- n+2 )
8 Create dup c, 2+ does> c@ >codes @ + perform ;
9
10 0 | >exec >c, | >exec >, | >exec >c@ | >exec >here
11 | >exec >allot | >exec >! | >exec >c!
12 drop
13
14
15
Screen 3 not modified
0 \ Register und Definierende Worte UH 09Mar86
1
2 7 Constant A
3 0 Constant B 1 Constant C 2 Constant D 3 Constant E
4 0 Constant I 1 Constant I' 2 Constant W 3 Constant W'
5 0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L
6 6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S
7
8 | : 1MI Create >c, does> C@ >c, ;
9 | : 2MI Create >c, does> C@ + >c, ;
10 | : 3MI Create >c, does> C@ swap 8 * + >c, ;
11 | : 4MI Create >c, does> C@ >c, >c, ;
12 | : 5MI Create >c, does> C@ >c, >, ;
13
14
15
Screen 4 not modified
0 \ Mnemonics UH 09Mar86
1 00 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc
2 0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg
3 C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc
4 2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl
5 E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa
6 80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana
7 A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr
8 03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push
9 C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in
10 C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani
11 EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call
12 2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp
13 C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo
14 EA 5MI jpe F2 5MI jp FA 5MI jm
15
Screen 5 not modified
0 \ Spezial Mnemonics und Spruenge UH 09Mar86
1 DA Constant C0= D2 Constant C0<> D2 Constant CS
2 C2 Constant 0= CA Constant 0<> E2 Constant PE
3 F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ;
4
5 : mov 8 * 40 + + >c, ;
6 : mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ;
7
8 : [[ ( -- addr ) >here ; \ BEGIN
9 : ?] ( addr opcode -- ) >c, >, ; \ UNTIL
10 : ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF
11 : ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE
12 : ]? ( addr -- ) >here swap >! ; \ THEN
13 : ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE
14 : ]] ( addr -- ) jmp ; \ AGAIN
15 : ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT
Screen 6 not modified
0 \ Macros UH 14May86
1 : end-code context 2- @ context ! ;
2
3 : ;c: 0 recover call end-code ] ;
4
5 : Next >next jmp ;
6
7 : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high )
8 H dcx 1+ M mov ( low ) RP shld ;
9
10 : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx
11 M swap mov ( high ) H inx RP shld ;
12 \ rpush und rpop gehen nicht mit HL
13
14 : mvx ( src dest -- )
15 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ;
Screen 7 not modified
0 \ Definierende Worte UH 06Aug86
1 Forth definitions
2 : Code ( -- ) Create here dup 2- ! Assembler ;
3
4 : ;Code ( -- ) 0 ?pairs
5 compile [ ' does> >body 2+ @ , ]
6 reveal [compile] [ Assembler ; immediate
7
8 : >label ( adr -- )
9 here | Create swap , 4 hallot >here 4 - heap 4 cmove
10 heap last @ (name> ! dp !
11 does> ( -- adr ) @ State @ IF [compile] Literal THEN ;
12
13 : Label [ Assembler ] >here >label Assembler ;
14
15
Screen 8 not modified
0 UH 14May86
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0 % VolksForth 8080 Assembler Shadow-Screens UH 09Mar86
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 10 not modified
0 % VolksForth 8080 Assembler UH 03Jun86
1
2 Der 8080 Assembler wurde von John Cassady, in den Forth
3 Dimensions veroeffentlicht und von Mike Perry im F83
4 implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat
5 und auch Befehle zur strukturierten Assemblerprogrammierung.
6 Um ein Wort in Assembler zu definieren wird das definierende
7 Wort Code benutzt, es kann, muss aber nicht mit end-code beendet
8 werden. Wie der Assembler arbeitet ist ein interessantes
9 Beispiel fuer die Maechtigkeit von Create does>.
10 Am Anfang werden die Befehle in Klassen eingeteilt und fuer
11 jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic
12 des Befehls spaeter interpretiert wird, kompiliert er den
13 entsprechenden Opcode.
14
15
Screen 11 not modified
0 % Vektorisierte Erzeugung UH 09Mar86
1 Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren.
2
3 Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler
4
5 Schaltet Assembler in den In-Line Modus.
6
7 Definierendes Wort fuer Erzeugungs-Operator-Namen.
8
9
10 Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden
11 aktuellen Erzeugungsoperator aus.
12
13 Mit diesen Erweiterungen kann der Assembler auch fuer den
14 Target-Compiler benutzt werden.
15
Screen 12 not modified
0 % Register und Definierende Worte UH 09Mar86
1
2 Die 8080 Register werden definiert. Es sind einfach Konstanten
3 die Information fuer die Mnemonics hinterlassen.
4 Einige Register der Forth-Maschine:
5 IP ist BC, W ist DE
6
7
8 Definierende Worte fuer die Mnemonics.
9 Fast alle 8080 Befehle fallen in diese 5 Klassen.
10
11
12
13
14
15
Screen 13 not modified
0 % Mnemonics UH 09Mar86
1 Die 8080 Mnemonics werden definiert.
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 14 not modified
0 % Spezial Mnemonics und Spruenge UH 09Mar86
1 Vergleiche des 8080
2
3 not folgt einem Vergleich, wenn er invertiert werden soll.
4
5 die Mnemonics, die sich nicht in die Klassen MI1 bis MI5
6 einteilen lassen.
7
8 Die strukturierten Assembler-Anweisungen.
9 Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungen
10 zu den strukturierten Anweisungen in Forth entstehen.
11 Es findet keine Absicherung der Kontrollstrukturen statt, sodass
12 sie auch beliebig missbraucht, werden koennen.
13 Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig.
14
15
Screen 15 not modified
0 % Macros UH 17May86
1 end-code beendet eine Code-Definition
2
3 ;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten.
4
5 Next Assembliert einen Sprung zum Adress-Interpretierer.
6
7 rpush Das angegebene Register wird auf den Return-Stack gelegt.
8
9
10 rpop Das angegebene Register wird vom Return-Stack genommen.
11
12 rpush und rpop benutzen das HL Register.
13
14 mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register
15 Bewegt Registerpaare HL BC DE
Screen 16 not modified
0 % Definierende Worte UH 17May86
1 Code leitet eine Code-Definition ein.
2
3 ;code ist das Low-Level-Aequivalent von does>
4
5
6 >label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert
7
8
9
10
11 Label erzeugt ein Label auf dem Heap, mit dem Wert von here
12
13
14
15
Screen 17 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

34
sources/cpm/ASSTRAN.FB.src Normal file
View File

@ -0,0 +1,34 @@
Screen 0 not modified
0 \\ Transinient Assembler 11Nov86
1
2 Dieses File enthaelt Befehle, die den Assembler vollstaendig in
3 den Heap laden, so dass er schliesslich mit clear wieder
4 vergessen werden kann.
5
6 Dadurch ist es nicht notwendig in einer Anwendung den ganzen
7 Assembler im Speicher lassen zu muessen, nur weil einige
8 primitive Worte in Assembler geschrieben sind.
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Internal Assembler UH 22Oct86
1
2 Onlyforth
3
4 here
5 $C00 hallot heap dp ! include ass8080.scr
6 dp !
7
8
9
10
11
12
13
14
15

34
sources/cpm/COPY.FB.src Normal file
View File

@ -0,0 +1,34 @@
Screen 0 not modified
0 \ Copy und Convey 19Nov87
1
2 Dieses File enthaelt Definitionen, die urspruenglich im Kern
3 enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern
4 klein zu halten.
5
6 copy kopiert einen Screen
7
8 convey kopiert einen Bereich von Screens
9
10
11
12
13
14
15
Screen 1 not modified
0 \ moving blocks 20Oct86 19Nov87
1 | : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ;
2 | : fromblock ( blk -- adr ) fromfile @ (block ;
3 | : (copy ( from to -- )
4 dup isfile@ core? IF prev @ emptybuf THEN
5 full? IF save-buffers THEN
6 offset @ + isfile@ rot fromblock 6 - 2! update ;
7 | : blkmove ( from to quan --) save-buffers >r
8 over r@ + over u> >r 2dup u< r> and
9 IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP
10 ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN
11 save-buffers 2drop ;
12
13 : copy ( from to --) 1 blkmove ;
14 : convey ( [blk1 blk2] [to.blk --)
15 swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ;

306
sources/cpm/DISASS.FB.src Normal file
View File

@ -0,0 +1,306 @@
Screen 0 not modified
0 \\ Z80-Disassembler 08Nov86
1
2 Dieses File enthaelt einen Z80-Disassembler, der assemblierten
3 Code in Standard Zilog-Z80 Mnemonics umsetzt.
4
5 Benutzung:
6
7 TOOLS ALSO \ Schalte Disassembler-Vokabular an
8
9 addr DIS \ Disassembliere ab Adresse addr
10
11 xxxx displace ! \ Beruecksichte bei allen Adressen einen
12 \ Versatz von xxxx.
13 \ Wird gebraucht, wenn ein Assemblerstueck
14 \ nicht an dem Platz disassembliert wird,
15 \ an dem es ablaeuft.
Screen 1 not modified
0 \ Z80-Disassembler Load Screen 08Nov86
1
2 Onlyforth Tools also definitions hex
3
4 ' Forth | Alias F: immediate
5 ' Tools | Alias T: immediate
6
7 1 $10 +THRU cr .( Disassembler geladen. ) cr
8
9 OnlyForth
10
11
12 \\ Fragen Anregungen & Kritik an:
13 U. Hoffmann
14 Harmsstrasse 71
15 2300 Kiel 1
Screen 2 not modified
0 \ Speicherzugriff und Ausgabe 07Jul86
1 internal
2 \needs Case: : Case: Create: Does> swap 2* + perform ;
3
4 Variable index Variable address Variable offset
5 Variable oldoutput
6 external Variable displace displace off internal
7
8 ' pad Alias str1 ( -- addr )
9 : str2 ( -- addr ) str1 $40 + ;
10
11 : byte ( -- b ) address @ displace @ + c@ ;
12 : word ( -- w ) address @ displace @ + @ ;
13
14 : .byte ( byte -- ) 0 <# # #s #> type ;
15 : .word ( addr -- ) 0 <# # # # #s #> type ;
Screen 3 not modified
0 \ neue Bytes lesen Byte-Fraktionen 07Jul86
1
2 : next-byte output push oldoutput @ output !
3 byte .byte space 1 address +! ;
4
5 : next-word next-byte next-byte ;
6
7 : f ( -- b ) byte $40 / ;
8 : g ( -- b ) byte 8 / 7 and ;
9 : h ( -- b ) byte 7 and ;
10 : j ( -- b ) g 2/ ;
11 : k ( -- b ) g 1 and ;
12
13 \\ 76543210
14 ffggghhh
15 jjk
Screen 4 not modified
0 \ Select" 08Nov86
1
2 : scan/ ( limit start -- limit start' ) over swap
3 DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ;
4
5 : select ( n addr len -- addr' len' )
6 bounds rot
7 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN
8 LOOP under scan/ nip over - ;
9
10 : (select" ( n -- ) "lit count select type ;
11
12 : select" ( -- ) compile (select" ," ; immediate
13
14 : append ( c str -- )
15 under count + c! dup c@ 1+ swap c! ;
Screen 5 not modified
0 \ StringOutput 07Jul86
1
2 Variable $
3
4 : $emit ( c -- ) $ @ append pause ;
5
6 : $type ( adr len -- ) 0 ?DO count $emit LOOP drop ;
7
8 : $cr ( -- ) $ @ off ;
9
10 : $at? ( -- row col ) 0 $ @ c@ ;
11
12 Output: $output
13 $emit $cr $type noop $cr 2drop $at? ;
14
15
Screen 6 not modified
0 \ Register 07Jul86
1
2 : reg ( n -- ) dup 5 = IF index @ negate index ! THEN
3 select" B/C/D/E/H/L/$/A" ;
4
5 : double-reg ( n -- ) select" BC/DE/%/SP" ;
6
7 : double-reg2 ( n -- ) select" BC/DE/%/AF" ;
8
9 : num ( n -- ) select" 0/1/2/3/4/5/6/7" ;
10
11 : cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ;
12
13 : arith ( n -- )
14 select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ;
15
Screen 7 not modified
0 \ no-prefix Einteilung der Befehle in Klassen 07Jul86
1
2 : 00xxx000
3 g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN
4 select" nop/ex AF,AF'/djnz ?/jr ?" ;
5
6 : 00xxx001
7 k IF ." add %," j double-reg exit THEN
8 ." ld " j double-reg ." ,&" ;
9
10 : 00xxx010 ." ld " g
11 select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)"
12 ;
13
14 : 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ;
15
Screen 8 not modified
0 \ no-prefix 07Jul86
1
2 : 00xxx100 ." inc " g reg ;
3
4 : 00xxx101 ." dec " g reg ;
5
6 : 00xxx110 ." ld " g reg ." ,#" ;
7
8 : 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ;
9
10 : 01xxxxxx ." ld " g reg ." ," h reg ;
11
12 : 10xxxxxx g arith h reg ;
13
14
15
Screen 9 not modified
0 \ no-prefix 07Jul86
1
2 : 11xxx000 ." ret " g cond ;
3
4 : 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN
5 ." pop " j double-reg2 ;
6
7 : 11xxx010 ." JP " g cond ." ,&" ;
8
9 : 11xxx011 g
10 select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ;
11
12 : 11xxx100 ." call " g cond ;
13 : 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ;
14 : 11xxx110 g arith ." #" ;
15 : 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ;
Screen 10 not modified
0 \ no-prefix 07Jul86
1
2 Case: 00xxxhhh
3 00xxx000 00xxx001 00xxx010 00xxx011
4 00xxx100 00xxx101 00xxx110 00xxx111 ;
5
6 Case: 11xxxhhh
7 11xxx000 11xxx001 11xxx010 11xxx011
8 11xxx100 11xxx101 11xxx110 11xxx111 ;
9
10 : 00xxxxxx h 00xxxhhh ;
11 : 11xxxxxx h 11xxxhhh ;
12
13 Case: ffxxxxxx
14 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ;
15
Screen 11 not modified
0 \ no-prefix 07Jul86
1
2 : get-offset index @ 0> IF byte offset ! next-byte THEN ;
3
4 : no-prefix f ffxxxxxx next-byte get-offset ;
5
6
7
8
9
10
11
12
13
14
15
Screen 12 not modified
0 \ CB-Prefix 07Jul86
1
2 : CB-00xxxxxx
3 g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ;
4
5 : CB-01xxxxxx ." bit " g num ." ," h reg ;
6
7 : CB-10xxxxxx ." res " g num ." ," h reg ;
8
9 : CB-11xxxxxx ." set " g num ." ," h reg ;
10
11 case: singlebit
12 CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ;
13
14 : CB-prefix get-offset f singlebit next-byte ;
15
Screen 13 not modified
0 \ ED-Prefix 30Sep86
1 : ED-01xxx000 ." in (C)," g reg ;
2 : ED-01xxx001 ." out (C)," g reg ;
3 : ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN
4 ." HL," j double-reg ;
5 : ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN
6 ." (&)," j double-reg ;
7 : ED-01xxx100 ." neg" ;
8 : ED-01xxx101 k IF ." reti" exit THEN ." retn" ;
9 : ED-01xxx110 g select" im 0/-/im 1/im 2" ;
10 : ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ;
11 : ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ;
12 Case: ED-01xxxhhh
13 ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011
14 ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ;
15 : ED-01xxxxxx h ED-01xxxhhh ;
Screen 14 not modified
0 \ ED-Prefix 07Jul86
1
2 Case: extended
3 noop ED-01xxxxxx ED-10xxxxxx noop ;
4
5 : ED-prefix get-offset f extended next-byte ;
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \ Disassassemblieren eines einzelnen Befehls 30Sep86
1
2 : index-register ( n -- ) index ! next-byte ;
3
4 : get-instruction ( -- )
5 index off str1 $ ! cr
6 byte $DD = IF 1 index-register ELSE
7 byte $FD = IF 2 index-register THEN THEN
8 byte $76 case? IF next-byte ." halt" exit THEN
9 $CB case? IF next-byte CB-prefix exit THEN
10 $ED case? IF next-byte ED-prefix exit THEN
11 drop no-prefix ;
12
13
14
15
Screen 16 not modified
0 \ Adressierungsarten ausgeben 07Jul86 27Nov87
1 : .index-register ( -- ) index @ abs select" HL/IX/IY" ;
2
3 : offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ;
4 : +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ;
5
6 : .offset ( -- ) offset @ offset-sign
7 extend under dabs <# # #s rot +- #> type ;
8 : .index-register-offset
9 index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ;
10
11 : .inline-byte ( -- ) byte .byte next-byte ;
12 : .inline-word ( -- ) word .word next-word ;
13
14 : .displace ( -- )
15 byte offset-sign address @ + 1+ .word next-byte ;
Screen 17 not modified
0 \ Hauptebene: dis 07Jul86
1 : .char ( c -- )
2 Ascii % case? IF .index-register exit THEN
3 Ascii $ case? IF .index-register-offset exit THEN
4 Ascii # case? IF .inline-byte exit THEN
5 Ascii & case? IF .inline-word exit THEN
6 Ascii ? case? IF .displace exit THEN emit ;
7
8 : instruction ( -- ) cr address @ .word 2 spaces
9 output @ oldoutput ! $output get-instruction
10 str2 $ ! cr str1 count 0 ?DO count .char LOOP drop
11 oldoutput @ output ! $20 col - 0 max spaces str2 count type ;
12
13 external
14 : dis ( addr -- ) address !
15 BEGIN instruction stop? UNTIL ;

51
sources/cpm/DOUBLE.FB.src Normal file
View File

@ -0,0 +1,51 @@
Screen 0 not modified
0 \\ Double words 11Nov86
1
2 Dieses File enthaelt Worte fuer 32-Bit Objekte.
3
4 Im Kern bereits enthalten sind:
5
6 2@ 2! 2dup 2drop 2swap dnegate d+
7
8 Hier werden definiert:
9
10 2Variable 2Constant 2over d*
11
12
13
14
15
Screen 1 not modified
0 \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86
1
2 : 2Variable Variable 2 allot ;
3 : 2Constant Create , , does> 2@ ;
4
5 Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi
6 SP dad M D mov H dcx M E mov D push
7 H dcx M D mov H dcx M E mov D push Next end-code
8 --> \\
9 Code 2@ ( addr -- 32b ) H pop H push
10 H inx H inx M E mov H inx M D mov H pop D push
11 M E mov H inx M D mov D push Next end-code
12
13 Code 2! ( 32b addr -- ) H pop
14 D pop E M mov H inx D M mov H inx
15 D pop E M mov H inx D M mov Next end-code
Screen 2 not modified
0 \ d* d- 29Jun86
1
2 : d* ( d1 d2 -- d1*d2 )
3 rot 2over rot um* 2swap um* d+ 2swap um* d+ ;
4
5 : d- ( d1 d2 -- d1-d2 ) dnegate d+ ;
6
7
8
9
10
11
12
13
14
15

544
sources/cpm/EDITOR.FB.src Normal file
View File

@ -0,0 +1,544 @@
Screen 0 not modified
0 \ Full-Screen Editor UH 02Nov86
1
2 Dieses File enthaelt den Full-Screen Editor fuer die CP/M -
3 volksFORTH-Version.
4
5 Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion
6 sowie Unterstuetzung des Shadow-Screen-Konzepts, der view-
7 Funktion und des sichtbaren Laden von Screens (showload).
8
9 Durch die integrierte Tastaturtabelle (keytable) laesst sich die
10 Kommandobelegung der Tasten auf einfache Art und Weise aendern.
11
12 Anregungen, Kritik und Verbesserungsvorschlaege bitte an:
13 U. Hoffmann
14 Harmsstrasse 71
15 2300 Kiel
Screen 1 not modified
0 \ Load Screen for the Editor UH 03Nov86 UH 27Nov87
1
2 Onlyforth cr
3
4 1 $1E +thru
5
6 Onlyforth
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ String primitves 27Nov87
1
2 : delete ( buffer size count -- )
3 over umin dup >r - 2dup over r@ + -rot cmove
4 + r> bl fill ;
5
6 : insert ( string length buffer size -- )
7 rot over umin dup >r -
8 over dup r@ + rot cmove> r> cmove ;
9
10 : replace ( string length buffer size -- ) rot umin cmove ;
11
12
13
14
15
Screen 3 not modified
0 \ usefull definitions and Editor vocabulary UH 27Nov87
1
2 : blank ( addr len -- ) bl fill ;
3
4 : ?enough ( n --) depth 1- > abort" Not enough Parameters" ;
5
6 : ?abort( ( f -- )
7 IF [compile] .( true abort" !" THEN [compile] ( ;
8
9 Vocabulary Editor
10
11 ' Forth | Alias F: immediate
12 ' Editor | Alias E: immediate
13
14 Editor also definitions
15
Screen 4 not modified
0 \ move cursor with position-checking 23Nov86
1
2 | : c ( n --) \ checks the cursor position
3 r# @ + dup 0 b/blk uwithin not
4 Abort" There is a border!" r# ! ;
5
6 \\
7
8 : c ( n --) \ goes thru the screens
9 r# @ + dup b/blk 1- > IF 1 scr +! THEN
10 dup 0< IF -1 scr +! THEN b/blk mod r# ! ;
11
12 : c ( n --) \ moves cyclic thru the screen
13 r# @ + b/blk mod r# ! ;
14
15
Screen 5 not modified
0 \ calculate addresses UH 31Oct86
1
2 | Code *line ( l -- adr )
3 H pop H dad H dad H dad
4 H dad H dad H dad Hpush jmp end-code
5
6 | Code /line ( n -- c l )
7 H pop L A mov $3F ani A E mov 0 D mvi
8 L A mov ral A L mov H A mov ral A H mov
9 L A mov ral A L mov H A mov ral A H mov
10 L A mov ral 3 ani H L mov A H mov
11 dpush jmp end-code
12
13 \\
14 | : *line ( l -- adr ) c/l * ;
15 | : /line ( n -- c l ) c/l /mod ;
Screen 6 not modified
0 \ calculate addresses UH 01Nov86
1
2 | : top ( -- ) r# off ;
3 | : cursor ( -- n ) r# @ ;
4 | : 'start ( -- adr ) scr @ block ;
5 | : 'end ( -- adr ) 'start b/blk + ;
6 | : 'cursor ( -- adr ) 'start cursor + ;
7 | : position ( -- c l ) cursor /line ;
8 | : line# ( -- l ) position nip ;
9 | : col# ( -- c ) position drop ;
10 | : 'line ( -- adr ) 'start line# *line + ;
11 | : 'line-end ( -- adr ) 'line c/l + 1- ;
12 | : #after ( -- n ) c/l col# - ;
13 | : #remaining ( -- n ) b/blk cursor - ;
14 | : #end ( -- n ) b/blk line# *line - ;
15
Screen 7 not modified
0 \ move cursor directed UH 01Nov86
1
2 | : curup c/l negate c ;
3 | : curdown c/l c ;
4 | : curleft -1 c ;
5 | : curright 1 c ;
6
7 | : +tab \ 1/4 line forth
8 cursor $10 / 1+ $10 * cursor - c ;
9
10 | : -tab \ 1/8 line back
11 cursor 8 mod negate dup 0= 8 * + c ;
12
13 | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ;
14 | : <cr> #after c ;
15
Screen 8 not modified
0 \ show border UH 27Nov87
1 &15 | Constant dx 1 | Constant dy
2
3 | : horizontal ( row -- row' )
4 dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ;
5
6 | : vertical ( row -- row' )
7 l/s 0 DO dup dx 1- at Ascii | emit
8 row dx c/l + at Ascii | emit 1+ LOOP ;
9
10 | : border dy 1- horizontal vertical horizontal drop ;
11
12 | : edit-at ( -- ) position swap dy dx d+ at ;
13
14 Forth definitions
15 : updated? ( -- f) scr @ block 2- @ 0< ;
Screen 9 not modified
0 \ display screen UH 02Nov86 UH 27Nouho
1 Editor definitions | Variable isfile' | Variable imode
2
3 | : .updated ( -- ) 7 0 at
4 updated? IF 4 spaces ELSE ." not " THEN ." updated" ;
5
6 | : redisplay ( line# -- )
7 dup dy + dx at *line 'start + c/l type ;
8
9 | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ;
10 | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file
11 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at
12 imode @ IF ." insert " exit THEN ." overwrite" ;
13
14 | : .screen l/s 0 DO I redisplay LOOP ;
15 | : .all .title .screen ;
Screen 10 not modified
0 \ check errors UH 02Nov86
1
2 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip
3 Abort" You would lose a line" ;
4
5 | : ?fit ( n -- ) 'line c/l -trailing nip + c/l >
6 IF line# redisplay
7 true Abort" You would lose a char" THEN ;
8
9 | : ?end 1 ?fit ;
10
11
12
13
14
15
Screen 11 not modified
0 \ programmer's id UH 02Nov86
1
2 $12 | Constant id-len
3 Create id id-len allot id id-len erase
4
5 | : stamp ( -- )
6 id 1+ count 'start c/l + over - swap cmove ;
7
8 | : ?stamp ( -- ) updated? IF stamp THEN ;
9
10 | : get-id ( -- )
11 id c@ ?exit id on
12 cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at
13 id id-len 2 /string expect rvsoff span @ id 1+ c! ;
14
15
Screen 12 not modified
0 \ update screen-display UH 02Dec86
1
2 | : emptybuf prev @ 2+ dup on 4+ off ;
3
4 | : undo emptybuf .all ;
5
6 | : modified updated? ?exit update .updated ;
7
8 | : linemodified modified line# redisplay ;
9
10 | : screenmodified modified
11 l/s line# ?DO I redisplay LOOP ;
12
13 | : .modified ( -- ) dy l/s + 4+ 0 at scr @ .
14 updated? not IF ." un" THEN ." modified" ?stamp ;
15
Screen 13 not modified
0 \ leave editor UH 02Dec86 UH 23Feb88
1 | Variable (pad (pad off
2 | : memtop ( -- adr) sp@ $100 - ;
3
4 | Create char 1 allot
5
6 ( | Variable imode ) imode off
7 | : setimode imode on .title ;
8 | : clrimode imode off .title ;
9 | : flipimode ( -- ) imode @ 0= imode ! .title ;
10
11 | : done ( -- )
12 ['] (quit is 'quit ['] (error errorhandler ! quit ;
13
14 | : update-exit ( -- ) .modified done ;
15 | : flushed-exit ( -- ) .modified save-buffers done ;
Screen 14 not modified
0 \ handle lines UH 01Nov86
1
2 | : (clear-line 'line c/l blank ;
3 | : clear-line (clear-line linemodified ;
4
5 | : clear> 'cursor #after blank linemodified ;
6
7 | : delete-line 'line #end c/l delete screenmodified ;
8
9 | : backline curup delete-line ;
10
11 | : (insert-line
12 ?bottom 'line c/l over #end insert (clear-line ;
13
14 | : insert-line (insert-line screenmodified ;
15
Screen 15 not modified
0 \ handle characters UH 01Nov86
1
2 | : delete-char 'cursor #after 1 delete linemodified ;
3
4 | : backspace curleft delete-char ;
5
6 | : (insert-char ?end 'cursor 1 over #after insert ;
7
8
9 | : insert-char (insert-char bl 'cursor c! linemodified ;
10
11 | : putchar ( --) char c@
12 imode @ IF (insert-char THEN
13 'cursor c! linemodified curright ;
14
15
Screen 16 not modified
0 \ stack lines UH 31Oct86
1
2 | Create lines 4 allot \ { 2+pointer | 2base }
3 | : 'lines ( -- adr) lines 2@ + ;
4
5 | : @line 'lines memtop u> Abort" line buffer full"
6 'line 'lines c/l cmove c/l lines +! ;
7
8 | : copyline @line curdown ;
9 | : line>buf @line delete-line ;
10
11 | : !line c/l negate lines +! 'lines 'line c/l cmove ;
12
13 | : buf>line lines @ 0= Abort" line buffer empty"
14 ?bottom (insert-line !line screenmodified ;
15
Screen 17 not modified
0 \ stack characters UH 01Nov86
1
2 | Create chars 4 allot \ { 2+pointer | 2base }
3 | : 'chars ( -- adr) chars 2@ + ;
4
5 | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full"
6 'cursor c@ 'chars c! 1 chars +! ;
7
8 | : copychar @char curright ;
9 | : char>buf @char delete-char ;
10
11 | : !char -1 chars +! 'chars c@ 'cursor c! ;
12
13 | : buf>char chars @ 0= Abort" char buffer empty"
14 ?end (insert-char !char linemodified ;
15
Screen 18 not modified
0 \ switch screens UH 03Nov86 UH 27Nov87
1
2 | Variable r#' r#' off
3 | Variable scr' scr' off
4 ( | Variable isfile' ) isfile@ isfile' !
5
6 | : associate \ switch to alternate screen
7 isfile' @ isfile@ isfile' ! isfile !
8 scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ;
9
10 | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ;
11 | : n ?stamp 1 scr +! .all ;
12 | : b ?stamp -1 scr +! .all ;
13 | : a ?stamp associate .all ;
14
15
Screen 19 not modified
0 \ shadow screens UH 03Nov86
1
2 Variable shadow shadow off
3
4 | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ;
5
6 | : >shadow ?stamp \ switch to shadow screen
7 (shadow dup scr @ u> not IF negate THEN scr +! .all ;
8
9
10
11
12
13
14
15
Screen 20 not modified
0 \ load and show screens UH 06Mar88
1
2 ' name >body &10 + | Constant 'name
3
4 | : showoff ['] exit 'name ! curoff rvsoff ;
5
6 | : show ( -- ) blk @ 0= IF showoff exit THEN
7 >in @ 1- r# ! curoff edit-at curon
8 stop? IF showoff true Abort" Break! " THEN
9 blk @ scr @ -
10 IF blk @ scr ! rvsoff curoff .all rvson curon THEN ;
11
12 | : showload ( -- ) ?stamp save-buffers
13 ['] show 'name ! curon rvson
14 ['] .status >body push ['] noop is .status
15 scr @ scr push scr off r# push r# @ (load showoff ;
Screen 21 not modified
0 \ find strings UH 01Nov86
1
2 | Variable insert-buffer
3 | Variable find-buffer
4 | : 'insert ( -- addr ) insert-buffer @ ;
5 | : 'find ( -- addr ) find-buffer @ ;
6
7 | : .buf ( addr -- ) count type ." |" &80 col - spaces ;
8
9 | : get ( addr -- ) >r at? r@ .buf
10 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN
11 at r> .buf ;
12
13 | : get-buffers dy l/s + 2+ dx 1- 2dup at
14 ." find: |" 'find get swap 1+ swap 2- at
15 ." ? replace: |" 'insert get ;
Screen 22 not modified
0 \ search for string UH 02Nov86 UH 27Nov87
1
2 | : skip ( addr -- addr' ) 'find c@ + ;
3
4 | : find? ( -- addr T | F )
5 'find count 'cursor #remaining "search ;
6
7 | : "find ( -- r# scr )
8 find? IF skip 'start - scr @ exit THEN ?stamp
9 capacity scr @ 1+
10 ?DO 'find count
11 I dup 5 5 at 4 .r block b/blk "search
12 IF skip I block - I endloop exit THEN
13 stop? Abort" Break! "
14 LOOP true Abort" not found!" ;
15
Screen 23 not modified
0 \ replace strings UH 03Nov86 UH 27Nov87
1 | : replace? ( -- f ) dy l/s + 3+ dx 3 - at
2 key dup #cr = IF line# redisplay true Abort" Break!" THEN
3 capital Ascii R = ;
4
5 | : "mark ( -- ) r# push
6 'find count dup negate c edit-at rvson type rvsoff ;
7
8 | : (replace 'insert c@ 'find c@ - ?fit
9 'find c@ negate c 'cursor #after 'find c@ delete
10 'insert count 'cursor #after insert
11 'insert c@ c modified ;
12
13 | : "replace get-buffers
14 BEGIN "find dup scr @ - swap scr ! IF .all THEN r# !
15 "mark replace? IF (replace THEN line# redisplay REPEAT ;
Screen 24 not modified
0 \ Control-Characters 'normal' CP/M uho 08May2005
1
2 Forth definitions
3
4 : Ctrl ( -- c )
5 name 1+ c@ $1F and state @ IF [compile] Literal THEN ;
6 immediate
7
8 $7F Constant #del
9
10 Editor definitions
11
12 \ | : flipimode imode @ 0= imode ! ;
13
14
15
Screen 25 not modified
0 \ Try a Screen-Editor 'normal' CP/M UH 29Nov86
1
2 Create keytable
3 Ctrl E c, Ctrl S c, Ctrl X c, Ctrl D c,
4 Ctrl I c, Ctrl J c, Ctrl O c, Ctrl K c,
5 Ctrl P c, Ctrl L c,
6 Ctrl H c, Ctrl H c, #del c, Ctrl G c,
7 Ctrl T c, Ctrl Y c, Ctrl N c,
8 Ctrl V c, Ctrl Z c,
9 #cr c, Ctrl F c, Ctrl A c,
10 Ctrl \ c, Ctrl U c,
11 Ctrl Q c, #esc c, Ctrl W c,
12 Ctrl C c, Ctrl R c, Ctrl ] c, Ctrl B c,
13
14
15 here keytable - Constant #keys
Screen 26 not modified
0 \ Try a screen Editor UH 29Nov86
1
2 Create: actiontable
3 curup curleft curdown curright
4 line>buf char>buf buf>line buf>char
5 copyline copychar
6 backspace backspace backspace delete-char
7 insert-char delete-line insert-line
8 flipimode ( clear-line ) clear>
9 <cr> +tab -tab
10 ( top >""end ) "replace undo
11 update-exit flushed-exit ( showload ) >shadow
12 n b a mark ;
13
14
15 here actiontable - 2/ 1- #keys - ?abort( # of actions)
Screen 27 not modified
0 \ find keys UH 01Nov86
1
2 | Code findkey ( key -- addr/default )
3 H pop L A mov keytable H lxi #keys $100 * D lxi
4 [[ M cmp 0=
5 ?[ actiontable H lxi 0 D mvi D dad D dad
6 M E mov H inx M D mov D push next ]?
7 H inx E inr D dcr 0= ?]
8 ' putchar H lxi hpush jmp
9 end-code
10
11 \\
12 | : findkey ( key -- adr/default )
13 #keys 0 DO dup keytable F: I + c@ =
14 IF drop E: actiontable F: I 2* + @ endloop exit THEN
15 LOOP drop ['] putchar ;
Screen 28 not modified
0 \ allocate buffers UH 01Nov86
1
2 c/l 2* | Constant cstack-size
3
4 | : nextbuf ( adr -- adr' ) cstack-size + ;
5
6 | : ?clearbuffer pad (pad @ = ?exit
7 pad dup (pad !
8 nextbuf dup find-buffer ! 'find off
9 nextbuf dup insert-buffer ! 'insert off
10 nextbuf dup 0 chars 2!
11 nextbuf 0 lines 2! ;
12
13
14
15
Screen 29 not modified
0 \ enter and exit the editor, editor's loop UH 02Nov86
1 | Variable jingle jingle on | : bell 07 con! jingle off ;
2
3 | : clear-error
4 jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ;
5
6 | : fullquit BEGIN ?clearbuffer edit-at key dup char c!
7 findkey execute clear-error REPEAT ;
8
9 | : fullerror ( string --) jingle @ IF bell THEN
10 dy l/s + 1+ dx $16 + at rvson count type rvsoff
11 &80 col - spaces scr @ capacity 1- min 0 max scr !
12 .title quit ;
13
14 | : install ( -- )
15 ['] fullquit Is 'quit ['] fullerror errorhandler ! ;
Screen 30 not modified
0 \ enter and exit the Editor UH 02Nov86
1
2 Forth definitions
3
4 : v ( -- ) E: 'start drop get-id install ?clearbuffer
5 page curoff border .all quit ;
6
7 : l ( scr -- ) 1 ?enough scr ! E: top F: v ;
8
9
10
11
12
13
14
15
Screen 31 not modified
0 \ savesystem uho 09May2uho
1
2 : savesystem \ save image
3 E: id off (pad off savesystem ;
4
5 | : >find ?clearbuffer >in push
6 bl word count 'find 1+ place
7 bl 'find 1+ dup >r count dup >r + c!
8 r> 2+ 'find c! bl r> c! ;
9 | : %view ( -- ) >find ' >name 4- @ (view
10 ?dup 0= Abort" hand made" scr !
11 E: top curdown find? 0=
12 IF ." From Scr # " scr @ u. true Abort" wrong file" THEN
13 skip 'start - 1- r# ! ;
14 : view ( -- ) %view scr @ list ;
15 : fix ( -- ) %view v ;

544
sources/cpm/FILEINT.FB.src Normal file
View File

@ -0,0 +1,544 @@
Screen 0 not modified
0 \ CP/M 2.2 File-Interface (3.80a) UH 05Oct87
1
2 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M.
3 Damit ist Zugriff auf normale CP/M-Files moeglich.
4 Wenn ein File mit USE benutzt wird, beziehen sich alle Worte,
5 die mit dem Massenspeicher arbeiten, auf dieses File.
6
7 Benutzung:
8 USE <name> \ benutze ein schon existierendes File
9 FILE <name> \ erzeuge ein Forthfile mit dem Namen <name>.
10 MAKE <name> \ Erzeuge ein File mit <name> und ordne
11 \ es dem aktuellen Forthfile zu.
12 MAKEFILE <name> \ Erzeuge ein File mit CP/M und FORTH-Namen
13 <name>.
14 INCLUDE <name> \ Lade File mit Forthnamen <name> ab Screen 1
15 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M)
Screen 1 not modified
0 \ CP/M 2.2 File-Interface load-Screen UH 18Feb88
1 OnlyForth
2
3 2 load \ view numbers for this file
4 3 4 thru \ DOS File Functions
5 5 $11 thru \ Forth File Functions
6 $12 $16 thru \ User Interface
7
8 File source.scr \ Define already existing Files
9 File fileint.scr File startup.scr
10
11 ' (makeview Is makeview
12 ' remove-files Is custom-remove
13 ' file-r/w Is r/w
14 ' noop Is drvinit
15 \ include startup.scr \ load Standard System
Screen 2 not modified
0 \ Build correct view-numbers for this file UUH 19Nov87
1
2 | : fileintview ( -- ) $400 blk @ + ;
3
4 ' fileintview Is makeview
5
6
7
8
9
10
11
12
13
14
15
Screen 3 not modified
0 \ File Control Blocks UH 18Feb88
1 Dos definitions also
2 | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ;
3 &11 Constant filenamelen
4 0 2 | Fcbyte nextfile immediate
5 1 Fcbyte drive ' drive | Alias >dosfcb
6 filenamelen 3 - Fcbyte filename
7 3 Fcbyte extension
8 &21 + \ ex, s1, s2, rc, d0, ... dn, cr
9 2 Fcbyte record \ r0, r1
10 1+ \ r2
11 2 Fcbyte opened
12 2 Fcbyte fileno
13 2 Fcbyte filesize \ in 128-Byte-Records
14 4 Fcbyte position
15 Constant b/fcb
Screen 4 not modified
0 \ dos primitives UH 10Oct87
1
2 ' 2- | Alias body> ' 2- | Alias dosfcb>
3
4 : drive! ( drv -- ) $0E bdos ;
5 : search0 ( dosfcb -- dir ) $11 bdosa ;
6 : searchnext ( dosfcb -- dir ) $12 bdosa ;
7 : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ;
8 : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ;
9 : createfile ( dosfcb -- f ) $16 bdosa dos-error? ;
10 : size ( dos -- size ) dup $23 bdos dosfcb> record @ ;
11 : drive@ ( -- drv ) 0 $19 bdosa ;
12 : killfile ( dosfcb -- ) $13 bdos ;
13
14
15
Screen 5 not modified
0 \ File sizes UH 05Oct87
1
2 : (capacity ( fcb -- n ) \ filecapacity in blocks
3 filesize @ rec/blk u/mod swap 0= ?exit 1+ ;
4
5 : in-range ( block fcb -- )
6 (capacity u< not Abort" beyond capacity!" ;
7
8 Forth definitions
9
10 : capacity ( -- n ) isfile@ (capacity ;
11
12 Dos definitions
13
14
15
Screen 6 not modified
0 \ (open UH 18Feb88
1
2 : (open ( fcb -- )
3 dup opened @ IF drop exit THEN dup position 0. rot 2!
4 dup >dosfcb openfile Abort" not found!" dup opened on
5 dup >dosfcb size swap filesize ! ;
6
7 : (make ( fcb -- )
8 dup >dosfcb killfile
9 dup >dosfcb createfile Abort" directory full!"
10 dup position 0. rot 2!
11 dup filesize off opened on offset off ;
12
13 : file-r/w ( buffer block fcb f -- f )
14 over 0= Abort" no Direct Disk IO supported! "
15 >r dup (open 2dup in-range r> (r/w ;
Screen 7 not modified
0 \ Print Filenames UH 10Oct87
1
2 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN
3 fcb dosfcb> case? IF ." DEFAULT" exit THEN
4 body> >name .name ;
5
6 : .drive ( fcb -- ) drive c@ ?dup 0=exit
7 [ Ascii A 1- ] Literal + emit Ascii : emit ;
8
9 : .dosfile ( fcb -- ) dup filename 8 -trailing type
10 Ascii . emit extension 3 type ;
11
12
13
14
15
Screen 8 not modified
0 \ Print Filenames UH 10Oct87
1
2 : tab ( -- ) col &59 > IF cr exit THEN
3 &20 col &20 mod - 0 max spaces ;
4
5 : .fcb ( fcb -- ) dup fileno @ 3 u.r tab
6 dup .file tab dup .drive dup .dosfile
7 tab dup opened @ IF ." opened" ELSE ." closed" THEN
8 3 spaces base push decimal (capacity 3 u.r ." kB" ;
9
10
11
12
13
14
15
Screen 9 not modified
0 \ Filenames UH 05Oct87
1
2 : !name ( addr len fcb -- )
3 dup >r filename filenamelen bl fill
4 over 1+ c@ Ascii : =
5 IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r>
6 ELSE 0 THEN r@ drive c! r> dup filename 2swap
7 filenamelen 1+ min bounds
8 ?DO I c@ Ascii . =
9 IF drop dup extension ELSE I c@ over c! 1+ THEN
10 LOOP 2drop ;
11
12 : !fcb ( fcb -- ) dup opened off name count rot !name ;
13
14
15
Screen 10 not modified
0 \ Print Directory UH 18Nov87
1
2 | Create dirbuf b/rec allot dirbuf b/rec erase
3 | Create fcb0 b/fcb allot fcb0 b/fcb erase
4
5 | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ;
6 | : (expand ( addr len -- ) false -rot bounds
7 ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ;
8 | : expand ( fcb -- ) \ expand * to ???
9 dup filename 8 (expand extension 3 (expand ;
10
11 : (dir ( addr len -- )
12 fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0
13 BEGIN dup dos-error? not
14 WHILE $20 * dirbuf + dosfcb> tab .dosfile
15 fcb0 >dosfcb searchnext stop? UNTIL drop ;
Screen 11 not modified
0 \ File List UH 10Oct87
1
2 User file-link file-link off
3
4 | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ;
5
6
7 Forth definitions
8
9 : forthfiles ( -- )
10 file-link @
11 BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ;
12
13 Dos definitions
14
15
Screen 12 not modified
0 \ Close a file UH 10Oct87
1
2 ' save-buffers >body $0C + @ | Alias backup
3
4 | : filebuffer? ( fcb -- fcb bufaddr/flag )
5 prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ;
6
7 | : flushfile ( fcb -- ) \ flush file buffers
8 BEGIN filebuffer? ?dup WHILE
9 dup backup emptybuf REPEAT drop ;
10
11 : (close ( fcb -- ) \ close file in fcb
12 dup flushfile
13 dup opened dup @ 0= IF 2drop exit THEN off
14 >dosfcb closefile Abort" not found!" ;
15
Screen 13 not modified
0 \ Create fcbs UH 10Oct87
1
2 : !files ( fcb -- ) dup isfile ! fromfile ! ;
3
4 ' r@ | Alias newfcb
5
6 Forth definitions
7
8 : File ( -- )
9 Create here >r b/fcb allot newfcb b/fcb erase
10 last @ count $1F and newfcb !name
11 #file newfcb fileno !
12 file-link @ newfcb nextfile ! r> file-link !
13 Does> !files ;
14
15 : direct 0 !files ;
Screen 14 not modified
0 \ flush buffers & misc. UH 10Oct87 UH 28Nov87
1 Dos definitions
2
3 : save-files ( -- ) file-link BEGIN @ ?dup WHILE
4 dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ;
5
6 ' save-files Is save-dos-buffers
7
8 \ : close-files ( -- ) file-link
9 \ BEGIN @ ?dup WHILE dup (close REPEAT ;
10
11 Forth definitions
12
13 : file? isfile@ .file ; \ print current file
14
15 : list ( n -- ) 3 spaces file? list ;
Screen 15 not modified
0 \ words for viewing UH 10Oct87
1
2 Forth definitions
3
4 | $200 Constant viewoffset \ max. %512 kB files
5
6 : (makeview ( -- n ) \ calc. view filed for a name
7 blk @ dup 0= ?exit
8 loadfile @ ?dup IF fileno @ viewoffset * + THEN ;
9
10 : (view ( blk -- blk' ) \ select file and leave block
11 dup 0=exit
12 viewoffset u/mod file-link
13 BEGIN @ dup WHILE 2dup fileno @ = UNTIL
14 !files drop ; \ not found: direct access
15
Screen 16 not modified
0 \ FORGETing files UH 10Oct87
1
2 | : remove? ( dic symb addr -- dic symb addr f )
3 dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ;
4
5
6 | : remove-files ( dic symb -- dic symb ) \ flush files !
7 isfile@ remove? nip IF direct THEN
8 fromfile @ remove? nip IF fromfile off THEN
9 file-link
10 BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT
11 file-link remove ;
12
13
14
15
Screen 17 not modified
0 \ print a list of all buffers UH 20Oct86
1
2 : .buffers
3 prev BEGIN @ ?dup WHILE stop? abort" stopped"
4 cr dup u. dup 2+ @ dup 1+
5 IF ." Block: " over 4+ @ 5 .r
6 ." File : " [ Dos ] .file
7 dup 6 + @ 0< IF ." updated" THEN
8 ELSE ." Buffer empty" drop THEN REPEAT ;
9
10
11
12
13
14
15
Screen 18 not modified
0 \ File Interface User words UH 11Oct87
1
2 | : same ( addr -- ) >in ! ;
3 : open isfile@ (open offset off ;
4 : close isfile@ (close ;
5 : assign close isfile@ !fcb open ;
6 : make isfile@ dup !fcb (make ;
7
8 | : isfile? ( addr -- addr f ) \ is adr a fcb?
9 file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ;
10
11 : use >in @ name find \ create a fcb if not present
12 IF isfile? IF execute drop exit THEN THEN drop
13 dup same File same ' execute open ;
14
15
Screen 19 not modified
0 \ File Interface User words UH 25May88
1
2 : makefile >in @ File dup same ' execute same make ;
3 : emptyfile isfile@ >dosfcb createfile ;
4
5 : from isfile push use ;
6 : loadfrom ( n -- )
7 isfile push fromfile push use load close ;
8 : include 1 loadfrom ;
9
10 : eof ( -- f ) isfile@ dup filesize @ swap record @ = ;
11
12 : files " *.*" count (dir ;
13 : files" Ascii " word count 2dup upper (dir ;
14
15 ' files Alias dir ' files" Alias dir"
Screen 20 not modified
0 \ extend Files UH 20Nov87
1
2 | : >fileend isfile@ >dosfcb size drop ;
3
4 | : addblock ( n -- ) \ add block n to file
5 dup buffer under b/blk bl fill
6 isfile@ rec/blk over filesize +! false file-r/w
7 IF close Abort" disk full!" THEN ;
8
9 : more ( n -- ) open >fileend
10 capacity swap bounds ?DO I addblock LOOP close
11 open close ;
12
13 : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ;
14 0 Drive: a: Drive: b: Drive: c: Drive: d:
15 5 + Drive: j: drop
Screen 21 not modified
0 \ save memory-image as disk-file UH 29Nov86
1
2 Forth definitions
3
4 : savefile ( from count -- ) \ filename
5 isfile push makefile bounds
6 ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!"
7 b/rec +LOOP close ;
8
9
10
11
12
13
14
15
Screen 22 not modified
0 \ Status UH 10OCt87
1
2
3 : .blk ( -- ) blk @ ?dup 0=exit
4 dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ;
5
6 ' .blk Is .status
7
8
9
10
11
12
13
14
15
Screen 23 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 24 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 25 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 26 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 27 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 28 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 29 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 30 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 31 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

85
sources/cpm/HASHCASH.FB.src Normal file
View File

@ -0,0 +1,85 @@
Screen 0 not modified
0 \ HashCash Suchalgorithmus UH 11Nov86
1
2 Ein Algorithmus, der die Dictionarysuche beschleunigt:
3 Zuerst wird uebr das gesucht Wort gehasht und in in einer
4 Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normal
5 gesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchen
6 herunter.
7
8 Hinzu kommen die Worte:
9 cash, hash-thread, erase-cash, 'cash, und found?
10
11 Im Kernal neudefiniert oder gepatched werden muessen:
12 (find, hide, reveal, forget-words
13
14 (find und (forget benutzen jejweils die alten Worte. Sie muessen
15 umbenannt oder in die neuen Worte eingebettet werden.
Screen 1 not modified
0 \ Hash Cash fuer volksFORTH UH 11Nov86
1
2 Create cash $200 allot
3
4 ' Forth >body Constant hash-thread
5 : erase-cash ( -- ) cash $200 erase ; erase-cash
6
7 1 3 +thru
8
9 patch (find
10 ( patch forget-words ) ' forget-words \ forget-words
11 dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen
12 dup ' (forget >body $12 + ! \ Adresse, sodass das automa-
13 dup ' empty >body 8 + ! \ tische Patchen nicht klappt.
14 ' save >body 4+ !
15 patch hide patch reveal forget (patch save
Screen 2 not modified
0 \ 'cash found? hfind UH 23Oct86
1
2 : 'cash ( nfa -- 'cash )
3 count $1F and under bounds
4 ?DO I c@ + LOOP $FF and 2* cash + ;
5
6 : found? ( str nfa -- f )
7 count rot count rot over = IF swap -text 0= exit THEN
8 drop 2drop false ;
9
10 : (find ( str thread -- str false | nfa true )
11 dup hash-thread - IF (find exit THEN
12 drop dup 'cash @ 2dup found? IF nip true exit THEN
13 drop hash-thread (find dup 0= ?exit over dup 'cash ! ;
14
15
Screen 3 not modified
0 \ Kernal changes UH 23Oct86
1
2 ' hide >body @ | Alias last?
3
4 : hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ;
5
6 : reveal last? IF dup dup 'cash ! 2- current @ ! THEN ;
7
8 ' clear >body 6 + @ | Alias forget-words
9
10 | : forget-words erase-cash forget-words ;
11
12 : .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ;
13
14
15
Screen 4 not modified
0 \ patching UH 23Oct86
1
2 : (patch ( new old -- )
3 ['] cash 0 DO
4 i @ over = IF cr I u. over I ! THEN LOOP 2drop ;
5
6 : patch \ name
7 >in @ ' swap >in ! dup >name 2- context push context ! '
8 (patch ;
9
10
11
12
13
14
15

85
sources/cpm/INSTALL.FB.src Normal file
View File

@ -0,0 +1,85 @@
Screen 0 not modified
0 \\ Install Editor
1
2 Dieses File enthaelt einen Installer fuer den Editor.
3
4 Es werden nacheinander die Tasten erfragt, die einen bestimmten
5 Befehl ausloesen sollen.
6
7 Damit ist es moeglich, die Tastatur an die individuellen
8 Beduerfnisse anzupassen.
9
10
11
12
13
14
15
Screen 1 not modified
0 \ install Editor UH 17Nov86
1
2 Onlyforth Editor also save warning on
3
4 : tab &20 col &20 mod - spaces ;
5 : .key ( c -- )
6 dup $7E > IF ." $" u. exit THEN
7 dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ;
8
9 : install \ install editor's keyboard
10 page ." Entsprechende Tasten druecken. (Blank uebernimmt.)"
11 #keys 0 ?DO cr I 2* actiontable + @ >name .name
12 tab ." : " I keytable + dup c@ .key tab ." -> "
13 key dup bl = IF drop dup c@ THEN dup .key swap c!
14 LOOP ;
15 -->
Screen 2 not modified
0 \ define action-names UH 29Nov86
1 : :a ( addr -- adr' ) dup @ Alias 2+ ;
2 actiontable
3 :a up :a left :a down :a right
4 :a push-line :a push-char :a pull-line :a pull-char
5 :a copy-line :a copy-char
6 :a backspace :a backspace :a backspace :a delete-char
7 :a insert-char :a delete-line :a insert-line
8 :a flipimode ( :a erase-line) :a clear-to-right
9 :a new-line :a +tab :a -tab
10 ( :a home :a to-end ) :a search :a undo
11 :a update-exit :a flushed-exit ( :a showload ):a shadow-screen
12 :a next-Screen :a back-Screen :a alter-Screen :a mark-screen
13 drop
14
15 warning off install empty
Screen 3 not modified
0 UH 17Nov86
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 4 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

34
sources/cpm/PORT8080.FB.src Normal file
View File

@ -0,0 +1,34 @@
Screen 0 not modified
0 \ 8080-Portzugriff UH 11Nov86
1
2 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit
3 Adressen anzusprechen.
4
5 Der Code ist leider selbstmodifizierend, da beim 8080 die
6 Portadresse im Code ausdruecklich angegeben werden muss.
7
8 Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen,
9 kann auch das File portz80.scr benutzt werden, indem die
10 Z80-IO-Befehle (16Bit-Adressen) benutzt werden.
11
12
13
14
15
Screen 1 not modified
0 \ 8080-Portzugriff pc@, pc! 15Jul86
1
2 ' 0 | Alias patch
3
4 Code pc@ ( addr -- c )
5 H pop L A mov here 4 + sta patch in
6 0 H mvi A L mov Hpush jmp end-code
7
8 Code pc! ( c addr -- )
9 H pop L A Mov here 6 + sta H pop L A mov patch out
10 Next end-code
11
12
13
14
15

51
sources/cpm/PORTZ80.FB.src Normal file
View File

@ -0,0 +1,51 @@
Screen 0 not modified
0 \ Z80-Portzugriff UH 05Nov86
1
2 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit
3 Adressen anzusprechen.
4
5 Einige Komputer, so die der Schneider Serie dekodieren ihre
6 Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit
7 Adressen angesprochen werden muessen.
8 Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen.
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86
1
2 Assembler definitions
3
4 | : Z80-io ( base -- ) \ define special Z80-io instruction
5 Create c,
6 Does> ( reg -- ) $ED c, c@ swap 8 * + c, ;
7
8 $40 Z80-io (c)in
9 $41 Z80-io (c)out
10
11 Forth definitions
12
13 -->
14
15
Screen 2 not modified
0 \ store and fetch values with 16-bit port-adresses UH 05Nov86
1
2 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr
3 H pop IP push H B mvx L (c)in 0 H mvi
4 IP pop hpush jmp
5 end-code
6
7 Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr
8 H pop D pop IP push H B mvx E (c)out
9 IP pop Next
10 end-code
11
12
13
14
15

51
sources/cpm/PRIMED.FB.src Normal file
View File

@ -0,0 +1,51 @@
Screen 0 not modified
0 \\ Primitivst Editor zur Installation UH 17Nov86
1
2 Da zur Installationszeit der Full-Screen Editor noch nicht
3 funtionsfaehig ist, muessen die zu aendernden Screens auf eine
4 andere Weise ge{nder werden: mit dem primitivst Editor PRIMED,
5 der nur ein Benutzer wort enthaelt:
6
7 Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen,
8 dann mit "ll NEW" den Screen aendern. Es koennen immer nur
9 ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher
10 Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe
11 einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW.
12 Nach jeder Eingabe von RETURN wird die eingegebene Zeile in
13 den Screen uebernommen, und der ganze Screen zur Kontrolle
14 nocheinmal ausgegeben.
15
Screen 1 not modified
0 \ primitivst Editor PRIMED UH 17Nov86
1
2 | : !line ( adr count line# -- )
3 scr @ block swap c/l * + dup c/l bl fill
4 swap cmove update ;
5
6 : new ( n -- )
7 l/s 1+ swap
8 ?DO cr I .
9 pad c/l expect span @ 0= IF leave THEN
10 pad span @ I !line cr scr @ list LOOP ;
11
12
13
14
15
Screen 2 not modified
0 \ PRIMED Demo-Screen
1
2
3
4 Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender
5 Eingabe dieses Textes
6 Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new
7 durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit
8 "0 NEW" erzeugt.
9 Ulrich Hoffmann
10
11
12
13
14
15

272
sources/cpm/PRINTER.FB.src Normal file
View File

@ -0,0 +1,272 @@
Screen 0 not modified
0 \\ Printer Interface 08Nov86
1
2 Dieses File enthaelt das Printer Interface zwischen volksFORTH
3 und dem Drucker.
4
5 Damit ist es moeglich Source-Texte auf bequeme Art und Weise
6 in uebersichtlicher Form auszudrucken (6 auf eine Seite).
7
8 In Verbindung mit dem Multitasker ist es moeglich, auch Texte im
9 Hintergrund drucken zu lassen und trotztdem weiterzuarbeiten.
10
11
12
13
14
15
Screen 1 not modified
0 \ Printer Interface Epson RX80 18Aug86
1 \ angepasst auf M 130i 07dec85we
2
3 Onlyforth
4
5 Variable shadow capacity 2/ shadow ! \ s. Editor
6
7 Vocabulary Printer Printer definitions also
8 | Variable printsem printsem off
9
10 01 +load 04 0C +thru \ M 130i - Printer
11 \ 01 03 +thru 06 0C +thru \ Fujitsu - Printer
12
13 Onlyforth
14
15
Screen 2 not modified
0 \ Printer p! and controls UH 02Nov87
1
2 | : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ;
3
4 : p! ( n --) BEGIN pause
5 stop? IF printsem unlock true abort" stopped! " THEN
6 ready? UNTIL [ Dos ] 5 bios ;
7
8 | : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ;
9
10 07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET
11 1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF
12 0F | ctrl: (+17cpi 12 | ctrl: (-17cpi
13
14
15
Screen 3 not modified
0 \ Printer Escapes 24dec85
1
2 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ;
3
4 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10"
5 Ascii 2 esc: 1/6" Ascii T esc: suoff
6 Ascii N esc: +jump Ascii O esc: -jump
7 Ascii G esc: +dark Ascii H esc: -dark
8 \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive
9
10
11 | : ESC2 ( 8b0 8b1 --) ESC p! p! ;
12
13 | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ;
14 | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ;
15
Screen 4 not modified
0 \ Printer Escapes 29jan86
1
2 Ascii W on: +wide Ascii W off: -wide
3 Ascii - on: +under Ascii - off: -under
4 Ascii S on: sub Ascii S off: super
5 Ascii P on: (10cpi Ascii P off: (12cpi
6
7 : 10cpi (-17cpi (10cpi ;
8 : 12cpi (-17cpi (12cpi ;
9 : 17cpi (10cpi (+17cpi ;
10
11 : lines ( #.of.lines --) Ascii C ESC2 ;
12 : "long ( inches --) 0 lines p! ;
13 : american 0 Ascii R ESC2 ;
14 : german 2 Ascii R ESC2 ;
15 : normal 12cpi american suoff 1/6" 0C "long RET ;
Screen 5 not modified
0 \ Printer Escapes 16Jul86
1
2 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ;
3
4 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10"
5 Ascii 2 esc: 1/6" Ascii T esc: suoff
6 Ascii N esc: +jump Ascii O esc: -jump
7 Ascii G esc: +dark Ascii H esc: -dark
8 Ascii 4 esc: +cursive Ascii 5 esc: -cursive
9 Ascii M esc: 12cpi Ascii P | esc: (-12cpi
10
11 : 10cpi (-12cpi (-17cpi ;
12 : 17cpi (-12cpi (+17cpi ;
13
14 ' 10cpi Alias pica ' 12cpi Alias elite
15
Screen 6 not modified
0 \ Printer Escapes 16Jul86
1
2 | : ESC2 ( 8b0 8b1 --) ESC p! p! ;
3
4 | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ;
5 | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ;
6
7 Ascii W on: +wide Ascii W off: -wide
8 Ascii - on: +under Ascii - off: -under
9 Ascii S on: sub Ascii S off: super
10 Ascii p on: +prop Ascii p off: -prop
11 : lines ( #.of.lines --) Ascii C ESC2 ;
12 : "long ( inches --) 0 lines p! ;
13 : american 0 Ascii R ESC2 ;
14 : german 2 Ascii R ESC2 ;
15 : normal 12cpi american suoff 1/6" 0C "long RET ;
Screen 7 not modified
0 \ Printer Output 04Jul86
1
2 : prinit ; \ initializing Printer
3
4 | Variable pcol pcol off | Variable prow prow off
5 | : pemit ( 8b --) p! 1 pcol +! ;
6 | : pcr ( --) RET LF 1 prow +! pcol off ;
7 | : pdel ( --) DEL pcol @ 1- 0 max pcol ! ;
8 | : ppage ( --) FF prow off pcol off ;
9 | : pat ( row col --) over prow @ < IF ppage THEN
10 swap prow @ - 0 ?DO pcr LOOP
11 dup pcol @ < IF RET pcol off THEN pcol @ - spaces ;
12 | : pat? ( -- row col) prow @ pcol @ ;
13 | : ptype ( adr len --)
14 dup pcol +! bounds ?DO I c@ p! LOOP ;
15
Screen 8 not modified
0 \ Printer output 28Jun86
1
2 | Output: >printer pemit pcr ptype pdel ppage pat pat? ;
3
4 Forth definitions
5
6 : print >printer normal ;
7
8 : printable? ( char -- f) bl Ascii ~ uwithin ;
9
10
11
12
13
14
15
Screen 9 not modified
0 \ Variables and Setup 23Oct86
1
2 Printer definitions
3
4 $00 | Constant logo | Variable pageno
5 | Create scr#s $0E allot \ enough room for 6 screens
6
7 | : header ( -- )
8 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r
9 $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV "
10 5 spaces file? -dark 1 pageno +! 17cpi ;
11
12
13
14
15
Screen 10 not modified
0 \ Print 2 screens across on a page 03dec85
1
2 | : text? ( scr# -- f) block dup c@ printable?
3 IF b/blk -trailing nip 0= THEN 0= ;
4
5 | : pr ( scr# --) dup capacity 1- u> IF drop logo THEN
6 1 scr#s +! scr#s dup @ 2* + ! ;
7
8 | : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r
9 pad $101 bl fill swap block r@ + pad c/l cmove
10 block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ;
11
12 | : 2scr ( scr#1 scr#2 --) cr cr $1E spaces
13 +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark
14 cr l/s 0 DO 2dup I 2pr LOOP 2drop ;
15
Screen 11 not modified
0 \ Printer 6 screens on a page 03dec85
1
2 | : pr-start ( --) scr#s off 1 pageno ! ;
3
4 | : pagepr ( --) header scr#s off scr#s 2+
5 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ;
6
7 | : shadowpr ( --) header scr#s off scr#s 2+
8 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ;
9
10 | : pr-flush ( -- f) scr#s @ dup \ any screens left over?
11 IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN
12 0<> ;
13
14
15
Screen 12 not modified
0 \ Printer 6 screens on a page 23Nov86
1 Forth definitions
2
3 : pthru ( first last --)
4 printsem lock output push print pr-start 1+ swap
5 ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN
6 LOOP pr-flush IF pagepr THEN printsem unlock ;
7
8 : document ( first last --)
9 isfile@ IF capacity 2/ shadow ! THEN
10 printsem lock output push print pr-start 1+ swap
11 ?DO I text? IF I pr I shadow @ + pr THEN
12 scr#s @ 6 = IF shadowpr THEN LOOP
13 pr-flush IF shadowpr THEN printsem unlock ;
14
15 : listing ( --) 0 capacity 2/ 1- document ;
Screen 13 not modified
0 \ Printerspool 03Nov86
1
2 \needs Task \\
3
4 | Input: noinput 0 false drop 2drop ;
5
6
7 $100 $200 noinput Task spooler
8
9 keyboard
10
11 : spool ( from to -- )
12 isfile@ spooler 3 pass isfile ! pthru stop ;
13
14
15
Screen 14 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

51
sources/cpm/RELOCATE.FB.src Normal file
View File

@ -0,0 +1,51 @@
Screen 0 not modified
0 \\ Relocate System 11Nov86
1
2 Dieses File enthaelt das Utility-Wort BUFFERS.
3 Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen,
4 die volksFORTH benutzt. Voreingestellt sind 4 Buffer.
5
6 Benutzung: nn BUFFERS
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Relocate a system 16Jul86
1
2 | : relocate-tasks ( mainup -- ) up@ dup
3 BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ;
4
5 | : relocate ( stacklen rstacklen -- )
6 2dup + b/buf + 2+ limit origin -
7 u> abort" kills all buffers"
8 over pad $100 + origin - u< abort" cuts the dictionary"
9 dup udp @ $40 +
10 u< abort" a ticket to the moon with no return ..."
11 flush empty over + origin +
12 origin $0A + ! \ r0
13 origin + dup relocate-tasks \ multitasking link
14 6 - origin 8 + ! \ s0
15 cold ; -->
Screen 2 not modified
0 \ bytes.more buffers 29Jun86
1
2 | : bytes.more ( n+- -- )
3 up@ origin - + r0 @ up@ - relocate ;
4
5 : buffers ( +n -- )
6 b/buf * 4+ limit r0 @ - swap - bytes.more ;
7
8
9
10
11
12
13
14
15

34
sources/cpm/SAVESYS.FB.src Normal file
View File

@ -0,0 +1,34 @@
Screen 0 not modified
0 \\ savesystem 11Nov86
1
2 Dieses File enthaelt das Utility-Wort SAVESYSTEM.
3
4 Mit ihm kann man das gesamte System als File auf Disk schreiben.
5
6 Achtung:
7 Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM
8 der Heap geloescht!
9
10 Benutzung: SAVESYSTEM <filename>
11
12
13
14
15
Screen 1 not modified
0 \ savsystem 05Nov86
1
2 : savesystem \ filename
3 save $100 here over - savefile ;
4
5
6 \\ Einfaches savesystem 18Aug86
7
8 | : message ( -- )
9 base push decimal
10 cr ." ready for SAVE " here 1- $100 / u.
11 ." VOLKS4TH.COM" cr ;
12
13 : savesystem ( -- ) save message bye ;
14
15

408
sources/cpm/SEE.FB.src Normal file
View File

@ -0,0 +1,408 @@
Screen 0 not modified
0 \ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86
1
2 Dieses File enthaelt einen Decompiler, der bereits kompilierte
3 Worte wieder in Sourcetextform bringt.
4 Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL
5 und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang
6 erkannt und umgeformt.
7 Ein Decompiler kann aber keine (Stack-) Kommentare wieder
8 herzaubern, die Benutzung der Screens und dann view, wird
9 daher staerkstens empfohlen.
10
11 Denn: Es ist immernoch ein Fehler drin!
12 Und um den zu korrigieren, ist der Sourcetext dem Objektkode
13 doch vorzuziehen.
14
15 Benutzung: see <name>
Screen 1 not modified
0 \ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86
1
2 Onlyforth Tools also definitions
3
4 1 13 +thru
5
6 \\
7 Produces compilable Forth source from normal compiled Forth.
8
9 These source blocks are based on the works of
10
11 Henry Laxen, Mike Perry and Wil Baden
12
13 volksFORTH version: U. Hoffmann
14
15
Screen 2 not modified
0 \ detacting does> 01Jul86
1
2 internal
3
4 ' does> 4+ @ Alias (;code
5 ' Forth @ 1+ @ Constant (dodoes>
6
7 : does? ( IP - f )
8 dup c@ $CD ( call ) = swap
9 1+ @ (dodoes> = and ;
10
11
12
13
14
15
Screen 3 not modified
0 \ indentation. 04Jul86
1 Variable #spaces #spaces off
2
3 : +in ( -- ) 3 #spaces +! ;
4
5 : -in ( -- ) -3 #spaces +! ;
6
7 : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ;
8
9 : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ;
10
11
12
13
14
15
Screen 4 not modified
0 \ case defining words 01Jul86
1
2 : Case: ( -- )
3 Create: Does> swap 2* + perform ;
4
5 : Associative: ( n -- )
6 Constant Does> ( n - index )
7 dup @ -rot dup @ 0
8 DO 2+ 2dup @ =
9 IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ;
10
11
12
13
14
15
Screen 5 not modified
0 \ branching 04Jul86
1
2 Variable #branches Variable #branch
3
4 : branch-type ( n -- a ) 6 * pad + ;
5 : branch-from ( n -- a ) branch-type 2+ ;
6 : branch-to ( n -- a ) branch-type 4+ ;
7
8 : branched ( adr type -- ) \ Make entry in branch-table.
9 #branches @ branch-type ! dup #branches @ branch-from !
10 2+ dup @ + #branches @ branch-to ! 1 #branches +! ;
11
12 \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... }
13
14
15
Screen 6 not modified
0 \ branching 01Jul86
1
2 : branch-back ( adr type -- )
3 \ : make entry in branch-table & reclassify branch-type.)
4 over swap branched
5 2+ dup dup @ + swap 2+ ( loop-start,-end.)
6 0 #branches @ 1-
7 ?DO
8 over I branch-from @ u> IF LEAVE THEN
9 dup I branch-to @ = IF ['] while I branch-type ! THEN
10 -1 +LOOP 2drop ;
11
12
13
14
15
Screen 7 not modified
0 \ branching 01Jul86
1 : forward? ( ip -- f ) 2+ @ 0> ;
2
3 : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward?
4 IF ['] if branched exit THEN ['] until branch-back ;
5
6 : branch+ ( ip -- ip' ) dup 4+ swap dup forward?
7 IF ['] else branched exit THEN ['] repeat branch-back ;
8
9 : (loop)+ ( ip -- ip' )
10 dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ;
11
12 : string+ ( ip -- ip' ) 2+ count + even ;
13
14 : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ;
15
Screen 8 not modified
0 \ classify each word 25Aug86
1 Forth
2
3 &15 Associative: execution-class
4 ] clit lit ?branch branch
5 (do (." (abort" (;code
6 (" (?do (loop
7 (+loop unnest (is compile [
8
9 Case: execution-class+
10 3+ 4+ ?branch+ branch+
11 2+ string+ string+ (;code+
12 string+ 2+ 4+
13 4+ 0= 4+ 4+ 2+ ;
14
15 Tools
Screen 9 not modified
0 \ first pass 01Jul86
1
2 : pass1 ( cfa -- ) #branches off >body
3 BEGIN dup @ execution-class execution-class+
4 dup 0= stop? or
5 UNTIL drop ;
6
7
8
9
10
11
12
13
14
15
Screen 10 not modified
0 \ identify branch destinations. 04Jul86
1 : thru.branchtable ( -- limit start ) #branches @ 0 ;
2 : ?.then ( ip -- ) thru.branchtable
3 ?DO I branch-to @ over =
4 IF I branch-from @ over u<
5 IF I branch-type @ dup ['] else = swap ['] if = or
6 IF -in ." THEN " ind-cr LEAVE THEN THEN THEN
7 LOOP ;
8 : ?.begin ( ip -- ) thru.branchtable
9 ?DO I branch-to @ over =
10 IF I branch-from @ over u< not
11 IF I branch-type @ dup
12 ['] repeat = swap ['] until = or
13 IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN
14 LOOP ;
15 ( put "BEGIN" and "THEN" where used.)
Screen 11 not modified
0 \ decompile each type of word 01Jul86
1
2 : .word ( ip -- ip' ) dup @ >name .name 2+ ;
3
4 : .(word ( ip -- ip' ) dup @ >name
5 ?dup 0= IF ." ??? " ELSE
6 count $1f and swap 1+ swap 1- type space THEN 2+ ;
7 : .inline ( val16b -- )
8 dup >name ?dup IF ." ['] " .name drop exit THEN . ;
9
10 : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ;
11 : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ;
12 : .string ( ip -- ip' )
13 .(word count 2dup type Ascii " emit space + even ?.then ;
14
15 : .unnest ( ip -- 0 ) ." ; " 0= ;
Screen 12 not modified
0 \ decompile each type of word 01Jul86
1
2 : .default ( ip -- ip' ) dup @ >name ?dup IF
3 c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ;
4
5 : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ;
6
7 : .compile ( ip -- ip' ) .word .word ?.then ;
8
9
10
11
12
13
14
15
Screen 13 not modified
0 \ decompiling conditionals 04Jul86
1
2 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ;
3 : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ;
4 : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ;
5 : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ;
6 : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ;
7
8 5 Associative: branch-class
9 ' if , ' while , ' else , ' repeat , ' until ,
10 Case: .branch-class
11 .if .else .else .repeat .repeat ;
12
13 : .branch ( ip -- ip' )
14 #branch @ branch-type @ 1 #branch +!
15 dup >name swap branch-class .branch-class ;
Screen 14 not modified
0 \ decompile Does> ;code 04Jul86
1
2 : .(;code ( IP - IP' f)
3 2+ dup does?
4 IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ;
5
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \ classify word's output 01Jul86
1
2 Case: .execution-class
3 .clit .lit .branch .branch
4 .do .string .string .(;code
5 .string .do .loop
6 .loop .unnest .['] .compile
7 .default ;
8
9
10
11
12
13
14
15
Screen 16 not modified
0 \ decompile colon-definitions 04Jul86
1
2 : pass2 ( cfa -- ) #branch off >body
3 BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class
4 dup 0= stop? or
5 UNTIL drop ;
6
7 : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ;
8
9 : .immediate ( cfa - ) >name c@ dup
10 ?ind-cr 40 and IF ." IMMEDIATE " THEN
11 ?ind-cr 80 and IF ." RESTRICT" THEN ;
12
13 : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ;
14
15
Screen 17 not modified
0 \ display category of word 01Jul86
1 external Defer (see internal
2
3 : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ;
4
5 : .user-variable ( cfa - ) ." USER " dup >name dup .name
6 3 spaces swap execute @ u. .name ." ! " ;
7
8 : .defer ( cfa - )
9 ." deferred " dup >name .name ." Is " >body @ (see ;
10
11 : .other ( cfa - ) dup >name .name
12 dup @ over >body = IF drop ." is Code " exit THEN
13 dup @ does? IF .does> exit THEN
14 drop ." is unknown " ;
15
Screen 18 not modified
0 \ decompiling variables and constants 01Jul86
1
2 : .constant ( cfa - )
3 dup >body @ u. ." CONSTANT " >name .name ;
4
5 : .variable ( cfa - ) ." VARIABLE "
6 dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ;
7
8
9
10
11
12
13
14
15
Screen 19 not modified
0 \ classify a word UH 25Jan88
1
2 5 Associative: definition-class
3 ' quit @ , ' 0 @ , ' scr @ , ' base @ ,
4 ' 'cold @ ,
5
6 Case: .definition-class
7 .: .constant .variable .user-variable
8 .defer .other ;
9
10
11
12
13
14
15
Screen 20 not modified
0 \ Top level of Decompiler 04Jul86
1
2 external
3
4 : ((see ( cfa -)
5 #spaces off cr
6 dup dup @
7 definition-class .definition-class .immediate ;
8
9 ' ((see Is (see
10
11 Forth definitions
12 : see ' (see ;
13
14
15
Screen 21 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 22 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 23 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

68
sources/cpm/SIMPFILE.FB.src Normal file
View File

@ -0,0 +1,68 @@
Screen 0 not modified
0 \\ Simple Files 11Nov86
1
2 Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es
3 trotzdem wuenschenswert eine Art File-Struktur zu besitzen.
4 Dieses File enthaelt eine einfache Implementation eines
5 Filesystems. Der/die Programmierer/in muss selbst die Direktory
6 auf dem laufenden halten: in ihr sind die Start-Bloecke des
7 entsprechenden Diskettenteils gespeichert.
8 Sogar eine Hierarchie von Direktories laesst sich so relisieren.
9
10 Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch
11 von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64).
12
13
14
15
Screen 1 not modified
0 \ simple files 12feb86
1
2 \needs search .( search missing) \\
3
4 | Variable (dir : dir (dir @ ; : root 0 (dir ! ; root
5
6 | : read" ( -- n)
7 Ascii " word count dup >r dir block b/blk search
8 0= abort" not found" r> + >in push >in !
9 bl dir block b/blk (word number drop ;
10
11 : load" read" dir + load ; : dir" read" (dir +! ;
12 : list" read" dir + list ;
13
14 \ 1 +load \ Only if file" is needed
15
Screen 2 not modified
0 \ simple files 01feb86
1
2 | : snap ( n0 -- n1) $20 / 3 max $20 * ;
3 : file" ( n --)
4 Ascii " word count 2dup dir block b/blk search
5 IF + nip
6 ELSE drop dir block b/blk -trailing nip snap $20 +
7 dup b/blk 1- > abort" directory full"
8 2dup + >r dir block + swap cmove r>
9 THEN snap $18 + >r
10 dir - extend under dabs <# # # # #
11 base @ $0A = IF Ascii & ELSE Ascii $ THEN hold
12 rot 0< IF Ascii - ELSE bl THEN hold #>
13 r> dir block + swap cmove update ;
14
15
Screen 3 not modified
0 \ dir load" 11feb86
1
2 \needs search .( search missing) \\
3
4 0 Constant dir
5
6 : load" ( -- )
7 Ascii " word count dup >r dir block b/blk search
8 0= abort" not found" r> +
9 >in @ blk @ rot >in ! dir blk !
10 bl word number drop -rot blk ! >in ! load ;
11
12
13
14
15

2176
sources/cpm/SOURCE.FB.src Normal file
View File

File diff suppressed because it is too large Load Diff

34
sources/cpm/STARTUP.FB.src Normal file
View File

@ -0,0 +1,34 @@
Screen 0 not modified
0 \\ Startup: Load Standard System UH 11Nov86
1
2 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM
3 ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM
4 als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann.
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87
1 include ass8080.fb i
2 nclude xinout.fb \ Erweiterte Ein- u. Ausgabe in
3 clude terminal.fb save \ Terminal inc
4 lude copy.fb cr .( copy und convey geladen.) cr incl
5 ude savesys.fb cr .( Savesystem geladen.) cr inclu
6 de editor.fb cr .( Editor geladen.) cr includ
7 e tools.fb cr .( Tools geladen.) cr include
8 see.fb cr .( Decompiler geladen.) cr include
9 tasker.fb cr .( Multitasker geladen.) cr include p
10 rinter.fb cr .( Printer Interface geladen.) cr include re
11 locate.fb cr .( Relocating geladen. ) cr
12 .( May the
13 volksFORTH be with you ...) cr decimal caps on
14 editor.fb
15 scr off r# off savesystem volks4th.com \

578
sources/cpm/TARGET.FB.src Normal file
View File

@ -0,0 +1,578 @@
Screen 0 not modified
0 \ 05Jul86
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Target compiler loadscr UH 07Jun86
1 \ Idea and first Implementation by ks/bp
2 \ Implemented on 6502 by ks/bp
3 \ ultraFORTH83-Version by bp/we
4 \ Atari 520 ST - Version by we
5 \ CP/M 2.2 Version by UH
6
7 Onlyforth hex Assembler nonrelocate
8 Vocabulary Ttools
9 Vocabulary Defining
10 1 10 +thru \ Target compiler
11 11 13 +thru \ Target Tools
12 14 16 +thru \ Redefinitions
13 save 17 20 +thru \ Predefinitions
14
15 Onlyforth
Screen 2 not modified
0 \ Target header pointers UH 26Mar88
1
2 Create lastname $20 allot
3 Variable tdp : there tdp @ ;
4 Variable displace
5 Variable image
6 Variable ?thead ?thead off
7 Variable tlast tlast off
8 Variable glast' glast' off
9 Variable tdoes>
10 Variable >in:
11 Variable tvoc tvoc off
12 Variable tvoc-link tvoc-link off
13 0 | Constant <forw>
14 0 | Constant <res>
15 | : Is> ( cfa -- ) [compile] Does> here 3 - swap >body ! 0 ] ;
Screen 3 not modified
0 \ Image and byteorder UH 26Mar88
1
2 Code c+! ( 8b addr -- )
3 H pop D pop E A mov M add A M mov Next end-code
4
5 Code /block ( addr -- +n blk )
6 H pop L E mov H A mov 3 ani A D mov
7 H A mov $FC ani rrc rrc A L mov 0 H mvi dpush jmp
8 end-code
9
10 : >image ( addr1 - addr2 )
11 displace @ ( - /block image @ + block ) + ;
12
13 : >heap ( from quan - ) dup hallot heap swap cmove ;
14 \\ : c+! ( 8b addr -- ) dup c@ rot + swap c! ;
15 : /block ( addr -- +n blk ) b/blk /mod ;
Screen 4 not modified
0 \ Ghost-creating UH 26Mar88
1
2 | : (make.ghost ( str -- cfa.ghost ) dp push
3 count dup 1 $1F uwithin not Abort" invalid Ghostname"
4 here 2+ place
5 here state @ \ address of link field
6 IF context @ ELSE current THEN @ under @ , \ link
7 1 here c+! here c@ allot bl c, \ name
8 here over - swap \ offset to codefield
9 <forw> , 0 , 0 , \ code and parameter field
10 here over - >heap \ move to heap
11 heap rot ! \ link
12 heap + ; \ codefield address
13
14 | : Make.Ghost ( -- cfa.ghost ) name (make.ghost ;
15
Screen 5 not modified
0 \ ghost words UH 28Apr88
1
2 : gfind ( string - cfa tf / string ff )
3 >r bl r@ count + c! 1 r@ c+! r@ find -1 r> c+! ;
4
5 : (ghost ( string -- cfa ) gfind ?exit (make.ghost ;
6
7 : ghost ( -- cfa ) name (ghost ;
8
9 : gdoes> ( cfa.ghost - cfa.does ) dp push
10 4+ dup @ IF @ exit THEN \ defined
11 here <forw> , 0 , 4 >heap \ forward-chain
12 heap dup rot ! ; \ forward-link
13
14
15
Screen 6 not modified
0 \ ghost utilities 2UH 26Mar88
1
2 : g' ( -- cfa.ghost ) name gfind 0= abort" ?" ;
3
4 | : .ghost-type ( cfa.ghost -- ) @
5 <forw> case? IF ." forward" exit THEN
6 <res> - Abort" type unknown" ." resolved " ;
7
8 | : .does-type ( cfa.does -- ) @
9 <forw> case? IF ." forward-define" exit THEN
10 <res> - Abort" does-type unknown" ." resolved-define" ;
11
12 : '. ( -- ) g' dup .ghost-type dup 2+ @ 5 u.r
13 4+ @ ?dup 0=exit dup .does-type 2+ @ 5 u.r ;
14
15 ' ' Alias h'
Screen 7 not modified
0 \ .unresolved UH 26Mar88
1
2 | : forward? ( cfa -- f ) dup @ <forw> = swap 2+ @ and ;
3 | : ghost? ( nfa -- f ) count $1F and + 1- c@ bl = ;
4
5 | : unresolved? ( addr - f ) 2+
6 dup ghost? not IF drop false exit THEN
7 name> dup forward? IF drop true exit THEN
8 4+ @ forward? ;
9
10 | : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE
11 dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ;
12
13 : .unresolved ( -- ) voc-link @
14 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
15
Screen 8 not modified
0 \ Extending Vocabularys for Target-Compilation 2UH 26Mar88
1
2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
3
4 Vocabulary Transient tvoc off
5
6 Root definitions
7
8 : T Transient ; immediate
9 : H Forth ; immediate
10
11 OnlyForth
12
13
14
15
Screen 9 not modified
0 \ Transient primitives UH 26Mar88
1
2 Code byte> ( 8bl 8bh -- 16b )
3 D pop H pop E H mov hpush jmp end-code
4 Code >byte ( 16b -- 8bh 8bl )
5 H pop H E mov 0 H mvi H D mov dpush jmp end-code
6
7 Transient definitions
8 : c@ ( addr -- 8b ) H >image c@ ;
9 : c! ( 8b addr -- ) H >image c! ( update ) ;
10 : @ ( addr -- n ) dup T c@ H swap 1+ T c@ H byte> ;
11 : ! ( n addr -- ) >r >byte r@ T c! H r> 1+ T c! H ;
12 : cmove ( from.mem to.target quan -)
13 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
14 : on ( addr -- ) true swap T ! H ;
15 : off ( addr -- ) false swap T ! H ;
Screen 10 not modified
0 \ Transient primitives UH 26Mar88
1
2 : here ( -- taddr ) there ;
3 : allot ( n -- ) Tdp +! ;
4 : c, ( c -- ) T here c! 1 allot H ;
5 : , ( n -- ) T here ! 2 allot H ;
6
7 : ," ( -- ) Ascii " parse
8 dup T c, under here swap cmove allot H ;
9
10 : fill ( addr len c -- )
11 -rot bounds ?DO dup I T c! H LOOP drop ;
12
13 : erase ( addr len -- ) 0 T fill H ;
14 : blank ( addr len -- ) bl T fill H ;
15 : here! ( addr -- ) H tdp ! ;
Screen 11 not modified
0 \ Resolving UH 26Mar88
1
2 Forth definitions
3
4 : resolve ( cfa.ghost cfa.target -- )
5 2dup swap >body dup @ >r ! over @ <res> =
6 IF drop >name space .name ." exists" ?cr rdrop exit THEN
7 r> swap >r <res> rot ! ?dup 0= IF rdrop exit THEN
8 BEGIN dup T @ H 2dup = abort" resolve loop"
9 r@ rot T ! H ?dup 0= UNTIL rdrop ;
10
11 : resdoes> ( cfa.ghost cfa.target -- )
12 swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
13
14 ' <forw> Is> ( -- ) dup @ there rot ! T , H ; \ forward link
15 ' <res> Is> ( -- ) @ T , H ; \ compile target.cfa
Screen 12 not modified
0 \ move-threads UH 26Mar88
1
2 : move-threads Tvoc @ Tvoc-link @
3 BEGIN over ?dup
4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
5 error" some undef. Target-Vocs left" drop ;
6
7 | : tlatest ( - addr) Current @ 6 + ;
8
9
10 : save-target \ filename
11 $100 dup >image there rot - savefile ;
12
13
14
15
Screen 13 not modified
0 \ compiling names into targ. UH 26Mar88
1
2 | : viewfield ( -- n ) H blk @ $200 + ; \ in File #1
3
4 : (theader ( -- ) ?thead @ IF 1 ?thead +! exit THEN
5 >in push
6 name dup c@ 1 $20 uwithin not abort" invalid Targetname"
7 viewfield T ,
8 H there tlatest @ T , H tlatest ! \ link
9 there dup tlast !
10 over c@ 1+ dup T allot cmove H ;
11
12 : Theader ( -- ) tlast off
13 (theader Ghost dup glast' ! there resolve ;
14
15
Screen 14 not modified
0 \ prebuild defining words bp2UH 26Mar88
1
2 | : executable? ( adr - adr f ) dup ;
3 | : tpfa, there , ;
4
5 | : (prebuild ( cfa.adr -- ) >in push Create here 2- ! ;
6
7 : prebuild ( adr 0.from.: - 0 ) 0 ?pairs
8 executable? dup >r
9 IF [compile] Literal compile (prebuild ELSE drop THEN
10 compile Theader Ghost gdoes> ,
11 r> IF compile tpfa, THEN 0 ; immediate restrict
12
13
14
15
Screen 15 not modified
0 \ code portion of def.words bp2UH 26Mar88
1
2 : dummy 0 ;
3
4 : DO> ( - adr.of.jmp.dodoes> 0 )
5 [compile] Does> here 3 - compile @ 0 ] ;
6
7
8
9
10
11
12
13
14
15
Screen 16 not modified
0 \ The Target-Assembler UH 26Mar88
1
2
3 Forth definitions
4 | Create relocate ] T c, , c@ here allot ! c! H [
5
6 Transient definitions
7
8 : Assembler H [ Assembler ] relocate >codes ! Assembler ;
9 : >label ( 16b -) H >in @ name gfind rot >in !
10 IF over resolve dup THEN drop Constant ;
11 : Label H there T >label Assembler H ;
12 : Code H Theader there 2+ T , Assembler H ;
13
14
15
Screen 17 not modified
0 \ immed. restr. ' \ compile bp2UH 26Mar88
1
2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
3 : >mark ( - addr) H there T 0 , H ;
4 : >resolve ( addr -) H there over - swap T ! H ;
5 : <mark ( - addr) H there ;
6 : <resolve ( addr -) H there - T , H ;
7 : immediate H Tlast @ ?dup 0=exit dup T c@ $40 or swap c! H ;
8 : restrict H Tlast @ ?dup 0=exit dup T c@ $80 or swap c! H ;
9 : ' ( <name> - cfa) H g' dup @ <res> - abort" ?" 2+ @ ;
10 : | H ?thead @ ?exit ?thead on ;
11 : compile H Ghost , ; immediate restrict
12
13
14
15
Screen 18 not modified
0 \ Target tools UH 26Mar88
1 Onlyforth Ttools also definitions
2
3 | : ttype ( adr n -) bounds ?DO I T c@ H dup
4 bl > IF emit ELSE drop ascii . emit THEN LOOP ;
5
6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
7 ELSE ." ??? " THEN space ?cr ;
8
9 | : nfa? ( cfa lfa - nfa / cfa ff)
10 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ =
11 IF 2+ nip exit THEN T @ H REPEAT ;
12
13 : >name ( cfa - nfa / ff)
14 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
15 IF nip exit THEN swap REPEAT nip ;
Screen 19 not modified
0 \ Ttools for decompiling ks29jun85we
1
2 | : ?: dup 4 u.r ." :" ;
3 | : @? dup T @ H 6 u.r ;
4 | : c? dup T c@ H 3 .r ;
5
6 : s ( adr - adr+) ?: space c? 3 spaces
7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
8
9 : n ( adr - adr+2) ?: @? 2 spaces
10 dup T @ H [ Ttools ] >name .name H 2+ ;
11
12 : d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP
13 2 spaces -rot ttype ;
14
15
Screen 20 not modified
0 \ Tools for decompiling bp204dec85we
1
2 : l ( adr - adr+2) ?: 5 spaces @? 2+ ;
3
4 : c ( adr - adr+1) 1 d ;
5
6 : b ( adr - adr+1) ?: @? dup T @ H over + 5 u.r 2+ ;
7
8 : dump ( adr n -) bounds ?DO cr I 10 d drop stop?
9 IF LEAVE THEN 10 +LOOP ;
10
11 : view T ' H [ Ttools ] >name ?dup
12 IF 4 - T @ H list THEN ;
13
14
15
Screen 21 not modified
0 \ reinterpretation def.-words UH 26Mar88
1
2 Onlyforth
3
4 : redefinition ( -- ) tdoes> @ 0=exit
5 >in push [ ' parser >body ] Literal push
6 state push context push
7 >in: @ >in ! name [ ' Transient 2+ ] Literal (find nip ?exit
8 cr ." Redefinition: " here .name
9 >in: @ >in ! : Defining interpret tdoes> off ;
10
11
12
13
14
15
Screen 22 not modified
0 \ Create..does> structure 27Apr86
1
2 | : (;tcode Tlast @ dup T c@ + 1+ ! H rdrop ;
3
4 | : changecfa compile lit tdoes> @ , compile (;tcode ;
5
6 Defining definitions
7
8 : ;code 0 ?pairs changecfa reveal rdrop rdrop ;
9 immediate restrict
10
11 Defining ' ;code Alias does> immediate restrict
12
13 : ; [compile] ; rdrop rdrop ; immediate restrict
14
15
Screen 23 not modified
0 \ redefinition conditionals bp27jun85we
1
2 ' DO Alias DO immediate restrict
3 ' ?DO Alias ?DO immediate restrict
4 ' LOOP Alias LOOP immediate restrict
5 ' IF Alias IF immediate restrict
6 ' THEN Alias THEN immediate restrict
7 ' ELSE Alias ELSE immediate restrict
8 ' BEGIN Alias BEGIN immediate restrict
9 ' UNTIL Alias UNTIL immediate restrict
10 ' WHILE Alias WHILE immediate restrict
11 ' REPEAT Alias REPEAT immediate restrict
12
13
14
15
Screen 24 not modified
0 \ clear Liter. Ascii ['] ." UH 26Mar88
1
2 Onlyforth Transient definitions
3
4 : clear True abort" There are ghosts" ;
5 : Literal ( n -) H dup $FF00 and IF T compile lit , H exit THEN
6 T compile clit c, H ; immediate
7 : Ascii H bl word 1+ c@
8 state @ 0=exit T [compile] Literal H ; immediate
9 : ['] T ' [compile] Literal H ; immediate restrict
10 : " T compile (" ," H ; immediate restrict
11 : ." T compile (." ," H ; immediate restrict
12
13 : even H ; immediate \ machen nichts beim 8080
14 : align H ; immediate
15 : halign H ; immediate
Screen 25 not modified
0 \ Target compilation ] [ bp0UH 26Mar88
1
2 Forth definitions
3
4 : tcompile ( str -- ) count lastname place
5 lastname find ?dup
6 IF 0> IF execute exit THEN drop lastname THEN
7 gfind IF execute exit THEN
8 number? ?dup
9 IF 0> IF swap T [compile] Literal THEN
10 [compile] Literal H exit THEN
11 (ghost execute ;
12
13 Transient definitions
14 : ] H State on ['] tcompile is parser ;
15
Screen 26 not modified
0 \ Target conditionals bp27jun85we
1
2 : IF T compile ?branch >mark H 1 ; immediate restrict
3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict
4 : ELSE T 1 ?pairs compile branch >mark swap >resolve
5 H -1 ; immediate restrict
6 : BEGIN T <mark H 2 ; immediate restrict
7 : WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
8 immediate restrict
9 | : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
10 WHILE drop T >resolve H REPEAT ;
11 : UNTIL T compile ?branch (repeat H ; immediate restrict
12 : REPEAT T compile branch (repeat H ; immediate restrict
13
14
15
Screen 27 not modified
0 \ Target conditionals bp27jun85we
1
2 : DO T compile (do >mark H 3 ; immediate restrict
3 : ?DO T compile (?do >mark H 3 ; immediate restrict
4 : LOOP T 3 ?pairs compile (loop compile endloop
5 >resolve H ; immediate restrict
6 : +LOOP T 3 ?pairs compile (+loop compile endloop
7 >resolve H ; immediate restrict
8
9
10
11
12
13
14
15
Screen 28 not modified
0 \ predefinitions bp27jun85we
1
2 : abort" T compile (abort" ," H ; immediate
3 : error" T compile (err" ," H ; immediate
4
5 Forth definitions
6
7 Variable torigin
8 Variable tudp 0 tudp !
9
10 : >user T c@ H torigin @ + ;
11
12
13
14
15
Screen 29 not modified
0 \ Datatypes bp2UH 07Nov87
1
2 Transient definitions
3 : origin! H torigin ! ;
4 : user' ( - 8b) T ' 2 + c@ H ;
5 : uallot ( n -) H tudp @ swap tudp +! ;
6
7 DO> >user ;
8 : User prebuild User 2 T uallot c, ;
9
10 DO> ;
11 : Create prebuild (create ;
12
13 DO> T @ H ;
14 : Constant prebuild Constant T , ;
15 : Variable Create 2 T allot ;
Screen 30 not modified
0 \ Datatypes UH 07Nov87
1
2 dummy
3 : Vocabulary
4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
5 here H tvoc-link @ T , H tvoc-link ! ;
6
7
8 dummy
9 : (create prebuild (create ;
10
11
12
13
14
15
Screen 31 not modified
0 \ target defining words 27Apr86
1
2 Do> ;
3 : Defer prebuild Defer 2 T allot ;
4 : Is T ' H >body State @ IF T compile (is , H
5 ELSE T ! H THEN ; immediate
6 | : dodoes> T compile (;code H Glast' @
7 there resdoes> there tdoes> ! ;
8
9 : ;code 0 T ?pairs dodoes> Assembler H [compile] [
10 redefinition ; immediate restrict
11 : does> T dodoes> $CD c,
12 compile (dodoes> H ; immediate restrict
13
14
15
Screen 32 not modified
0 \ : Alias ; bUH 07Jun86
1
2 dummy
3 : : H tdoes> off >in @ >in: ! T prebuild :
4 H current @ context ! T ] H 0 ;
5
6 : Create: Create H current @ context ! T ] H 0 ;
7
8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve
9 tlast @ T c@ H 20 or tlast @ T c! , H ;
10
11 : ; T 0 ?pairs compile unnest [compile] [ H redefinition ;
12 immediate restrict
13
14
15
Screen 33 not modified
0 \ predefinitions UH 26Mar88
1
2 : compile T compile compile H ; immediate restrict
3 : Host H Onlyforth Ttools also ;
4 : Compiler T Host H Transient also definitions ;
5 : [compile] H ghost execute ; immediate restrict
6 \ : Onlypatch H there 3 - 0 tdoes> ! 0 ;
7
8 Onlyforth
9 : Target Onlyforth Transient also definitions ;
10
11 Transient definitions
12 Ghost c, drop
13
14
15

119
sources/cpm/TASKER.FB.src Normal file
View File

@ -0,0 +1,119 @@
Screen 0 not modified
0 \\ Multitasker 11Nov86
1
2 Dieses File enthaelt den Multitasker des volksFORTHs.
3 Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt
4 die Kontrolle ueber den Prozessor solange, bis sie sie
5 ausdruecklich abgibt.
6 Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet
7 auf den Massenspeicher und auf den Drucker zugreifen.
8
9 In Verbindung mit dem Printer-Interface ist es moeglich
10 Files im Hintergrund auszudrucken. (SPOOL)
11
12
13
14
15
Screen 1 not modified
0 \ Multitasker Loadscreen 27Jun86 20Nov87
1
2 Onlyforth
3
4 \needs multitask 1 +load
5
6 02 05 +thru \ Tasker
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ stop singletask multitask 28Aug86 20Nov87
1
2 Code stop UP lhld 0 ( nop ) M mvi
3 Label taskpause
4 IP push RP lhld H push UP lhld 6 D lxi D dad xchg
5 H L mov SP dad xchg E M mov H inx D M mov
6 UP lhld H inx pchl
7 end-code
8
9 : singletask [ ' pause @ ] Literal ['] pause ! ;
10
11 : multitask [ taskpause ] Literal ['] pause ! ;
12
13
14
15
Screen 3 not modified
0 \ pass activate 28Aug86
1
2 : pass ( n0 ... nr-1 Taddr r -- )
3 BEGIN [ rot ( Trick !! ) ]
4 swap $F7 over c! \ awake Task ( rst 6 )
5 r> -rot \ Stack: IP r addr
6 8 + >r \ s0 of Task
7 r@ 2+ @ swap \ Stack: IP r0 r
8 2+ 2* \ bytes on Taskstack incl. r0 & IP
9 r@ @ over - \ new SP
10 dup r> 2- ! \ into Ssave
11 swap bounds ?DO I ! 2 +LOOP ; restrict
12
13 : activate ( Taddr -- )
14 0 [ -rot ( Trick !! ) ] REPEAT ; restrict
15
Screen 4 not modified
0 \ sleep wake taskerror 28Aug86 20Nov87
1
2 : sleep ( Taddr -- ) $00 ( nop ) swap c! ;
3 : wake ( Taddr -- ) $F7 ( rst 6 ) swap c! ;
4
5 | : taskerror ( string -- )
6 standardi/o singletask ." Task error : " count type
7 multitask stop ;
8
9
10
11
12
13
14
15
Screen 5 not modified
0 \ Task 20Nov87
1
2 : Task ( rlen slen -- )
3 0 Constant here 2- >r \ addr of task constant
4 here -rot \ here for Task dp
5 even allot even \ allot dictionary area
6 here r@ ! \ set task constant addr
7 up@ here $100 cmove \ init user area
8 here dup $C300 , \ nop-jmp opcode to sleep task
9 up@ 2+ dup @ , ! \ link task
10 r> , \ spare used for pointer to header
11 dup 6 - dup , , \ ssave and s0
12 2dup + , \ here + rlen = r0
13 rot , \ dp
14 under + dp ! 0 , \ allot rstack
15 ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ;
Screen 6 not modified
0 \ rendezvous 's tasks 27Jun86 20Nov87
1
2 : rendezvous ( semaphoraddr -- ) dup unlock pause lock ;
3
4 | : statesmart state @ IF [compile] Literal THEN ;
5
6 : 's ( Taddr -- adr.of.tasks.userarea )
7 ' >body c@ + statesmart ; immediate
8
9 : tasks ( -- ) ." Main " cr up@ dup 2+ @
10 BEGIN 2dup - WHILE dup 4+ @ body> >name .name
11 dup c@ 0= ( nop ) IF ." sleeping" THEN cr
12 2+ @ REPEAT 2drop ;
13
14
15

34
sources/cpm/TERMINAL.FB.src Normal file
View File

@ -0,0 +1,34 @@
Screen 0 not modified
0 \\ Terminal-Anpassung UH 08OCt87
1
2 In diesem File wird volksFORTH an das benutzte Terminal
3 angepasst. Ueber folgende Faehigkeiten muss das Terminal
4 verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt
5 werden koennen:
6
7 curon, curoff \ Ein- bzw. Ausschalten des Cursors
8 rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellung
9 dark \ Loeschen des Bildschirms
10 locate \ Positionieren des Cursors auf eine
11 \ bestimmte Position auf dem Bildschirm
12
13 In der Version 3.80a nicht mehr in der Terminal-Anpassung:
14
15 curleft, currite \ Cursor nach links bzw. rechts bewegen
Screen 1 not modified
0 \ Anpassung fuer ANSI-Terminal uho 09May2005
1 | : ccon!! ( addr len -- ) bounds ?DO I C@ con! LOOP ;
2 | : con!! ( addr -- ) count ccon!! ;
3 | : ## ( n -- ) base push decimal 0 <# #S #> ccon!! ;
4 | : csi ( -- ) #esc con! Ascii [ con! ;
5 | : ANSIcuron ( -- ) csi " ?25h" con!! ;
6 | : ANSIcuroff ( -- ) csi " ?25l" con!! ;
7 | : ANSIrvson ( -- ) csi " 7m" con!! ;
8 | : ANSIrvsoff ( -- ) csi " 0m" con!! ;
9 | : ANSIdark ( -- ) csi " 2J" con!! csi " ;H" con!! ;
10 | : ANSIlocate ( row col -- )
11 csi swap 1+ ## ascii ; con! 1+ ## ascii H con! ;
12
13 Terminal: ANSI
14 noop noop ANSIrvson ANSIrvsoff ANSIdark ANSIlocate ;
15 ANSI page rvson .( ANSI Terminal installiert. ) rvsoff cr cr

34
sources/cpm/TIMES.FB.src Normal file
View File

@ -0,0 +1,34 @@
Screen 0 not modified
0 \\ Times Often: interactive loops 11Nov86
1
2 Dieses File enthaelt die Definitionen der beiden Utility-Worte
3 TIMES, OFTEN, die interaktiv benutzt werden koennen, was
4 normalerweise mit BEGIN WHILE ... nicht moeglich ist.
5
6 Benutzung: nur interaktiv!
7
8 a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal,
9 \ oder bis eine Taste gedrueckt wird, oder
10 \ bis ein Fehler auftritt,
11
12 a b ... often \ Wiederhole die Befehlsfolge "a b ..."
13 \ so oft, bis eine Taste gedrueckt wird, oder
14 \ bis ein Fehler auftritt.
15
Screen 1 not modified
0 \ Times, Often 02feb86
1
2 also Forth definitions
3
4 : often stop? ?exit >in off ;
5
6 | Variable #times #times off
7
8 : times ( n --)
9 ?dup IF #times @ 2+ u< stop? or
10 IF #times off exit THEN 1 #times +!
11 ELSE stop? ?exit THEN >in off ;
12
13 toss definitions
14
15

272
sources/cpm/TOOLS.FB.src Normal file
View File

@ -0,0 +1,272 @@
Screen 0 not modified
0 \\ Tools 11Nov86
1 Dieses File enthaelt die wichtigsten Werkzeuge zur Programm-
2 entwicklung: - den einfachen Decompiler
3 - der DUMP-Befehl
4 - den Tracer
5
6 Der einfache Decompiler wird benutzt, um neue Defining-Words
7 zu ueberpruefen. Der automatische Decompiler kann ja dafuer
8 nicht benutzt werden, da ihm diese Strukturen unbekannt sind.
9 (Benutzung: addr und dann, je nach Art: S N D L C oder B)
10
11 DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP)
12
13 Der Tracer erlaubt Einzelschrittausfuehrung von Worten.
14 Er ist unentbehrliches Hilfsmittel bei der Fehlersuche.
15 (Benutzung: DEBUG <name> und END-TRACE)
Screen 1 not modified
0 \ Loadscreen for simple decompiler and tracer 11Nov86
1
2 Onlyforth Vocabulary Tools Tools also definitions
3
4 01 05 +thru
5 06 +load \ Tracer
6
7 Onlyforth
8
9 : internal \ start headerless definitions
10 1 ?head ! ;
11
12 : external \ end headerless definitions
13 ?head off ;
14
15
Screen 2 not modified
0 \ Tools for decompiling 22feb86
1
2 | : ?: dup 4 u.r ." :" ;
3 | : @? dup @ 6 u.r ;
4 | : c? dup c@ 3 .r ;
5
6 : s ( adr - adr+ )
7 ?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ;
8
9 : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ;
10 : d ( adr n - adr+n)
11 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ;
12
13
14
15
Screen 3 not modified
0 \ Tools for decompiling 22feb86
1
2 : l ( adr - adr+2 ) ?: 5 spaces @? 2+ ;
3 : c ( adr - adr+1) 1 d ;
4 : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ;
5
6
7
8 \\
9 : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE
10 THEN 10 +LOOP ;
11
12
13
14
15
Screen 4 not modified
0 \ General Dump Utility - Output UH 07Jun86
1
2 | : .2 ( n -- ) 0 <# # # #> type space ;
3 | : .6 ( d -- ) <# # # # # # # #> type ;
4 | : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ;
5 | : emit. ( char -- )
6 $7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ;
7 | : dln ( addr --- )
8 cr dup 6 u.r 2 spaces 8 2dup d.2 space
9 over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ;
10 | : ?.n ( n1 n2 -- n1 )
11 2dup = IF ." \/" drop ELSE 2 .r THEN space ;
12 | : ?.a ( n1 n2 -- n1 )
13 2dup = IF ." V" drop ELSE 1 .r THEN ;
14
15
Screen 5 not modified
0 \ .head UH 03Jun86
1
2
3 | : .head ( addr len -- addr' len' )
4 swap dup -$10 and swap $0F and cr 8 spaces
5 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP
6 space $10 0 DO I ?.a LOOP rot + ;
7
8
9
10
11
12
13
14
15
Screen 6 not modified
0 \ Dump and Fill Memory Utility UH 25Aug86
1
2 Forth definitions
3
4 : dump ( addr len -- )
5 base push hex .head
6 bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ;
7
8 Tools definitions
9
10 : du ( addr -- addr+$40 ) dup $40 dump $40 + ;
11
12 : dl ( line# -- ) c/l * scr @ block + c/l dump ;
13
14 Forth definitions
15
Screen 7 not modified
0 \ Trace Loadscreen 29Jun86
1
2 Onlyforth \needs Tools Vocabulary Tools
3 Tools also definitions
4
5 1 8 +thru
6
7 Onlyforth
8
9 \ clear
10
11 \ don't forget END-TRACE after using DEBUG
12
13
14
15
Screen 8 not modified
0 \ Variables do-trace UH 04Nov86
1
2 | Variable Wsave \ Variable for saving W
3 | Variable <ip \ start of trace trap range
4 | Variable ip> \ end of trace trap range
5 | Variable 'ip \ holds IP (preincrement!)
6 | Variable nest? \ True if NEST shall be performed
7 | Variable newnext \ Address of new Next for tracing
8 | Variable #spaces \ for indenting nested trace
9 | Variable tracing \ true if trace mode active
10
11
12
13
14
15
Screen 9 not modified
0 \ install Tracer UH 18Nov87
1
2 Tools definitions
3
4 | Code do-trace \ patch Next to new definition
5 $C3 A mvi ( jmp ) >next sta
6 newnext lhld >next 1+ shld Next
7 end-code
8
9
10
11
12
13
14
15
Screen 10 not modified
0 \ throw status on Return-Stack 29Jun86
1
2 | Create: npull
3 rp@ count 2dup + even rp! r> swap cmove ;
4
5 : npush ( addr len --) r> -rot over >r
6 rp@ over 1+ - even dup rp! place npull >r >r ;
7
8 | : oneline .status space query interpret -&82 allot
9 rdrop ( delete quit from tracenext ) ;
10
11
12
13
14
15
Screen 11 not modified
0 \ reenter tracer 04Nov86
1
2 | Code (step
3 true H lxi tracing shld IP rpop Wsave lhld H W mvx
4 Label fnext
5 xchg
6 M E mov H inx M D mov xchg pchl
7 end-code
8
9 | Create: nextstep (step ;
10
11 | : (debug ( addr --) \ start tracing at addr
12 dup <ip !
13 BEGIN 1+ dup @ ['] unnest = UNTIL 2+ ip> ! ;
14
15
Screen 12 not modified
0 \ check trace conditions 04Nov86
1
2 Label tracenext tracenext newnext !
3 IP ldax IP inx A L mov IP ldax IP inx A H mov
4 xchg tracing lhld H A mov L ora fnext jz
5 nest? 1+ lda A ana
6 0= ?[
7 <IP lhld H inx
8 IP A mov H cmp fnext jc
9 0= ?[ IP' A mov L cmp fnext jc ]?
10 IP> lhld
11 H A mov IP cmp fnext jc
12 0= ?[ L A mov IP' cmp fnext jc ]?
13 ][ A xra nest? 1+ sta ]? \ low byte still set
14 \ one trace condition satisfied
15 W H mvx Wsave shld false H lxi tracing shld
Screen 13 not modified
0 \ tracer display UH 25Jan88
1
2 ;c: nest? @
3 IF nest? off r> ip> push <ip push dup 2- (debug
4 #spaces push 1 #spaces +! >r THEN
5 r@ nextstep >r input push output push standardi/o
6 cr #spaces @ spaces
7 dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces
8 >name .name $1C col - 0 max spaces .s
9 state push blk push >in push ['] 'quit >body push
10 [ ' parser >body ] Literal push
11 span push #tib push tib #tib @ npush r0 push
12 rp@ r0 ! &82 allot ['] oneline Is 'quit quit ;
13
14
15
Screen 14 not modified
0 \ DEBUG with errorchecking 28Nov86
1
2 | : traceable ( cfa -- cfa' )
3 recursive dup @
4 ['] : @ case? ?exit
5 ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN
6 ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN
7 ['] r/w @ case? IF >body traceable exit THEN
8 dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN
9 drop >name .name ." can't be DEBUGged" quit ;
10
11 also Forth definitions
12
13 : debug ( -- ) \ reads a word
14 ' traceable (debug Tools
15 nest? off #spaces off tracing on do-trace ;
Screen 15 not modified
0 \ misc. words for tracing 28Nov86
1 Tools definitions
2
3 : nest \ trace next high-level word executed
4 'ip @ 2- @ traceable drop nest? on ;
5
6 : unnest \ ends tracing of actual word
7 <ip on ip> off ; \ clears trap range
8
9 : endloop \ stop tracing loop
10 'ip @ <ip ! ; \ use when at end of loop
11
12 Forth definitions
13
14 : trace' ( -- ) \ reads a word
15 context push debug <ip perform end-trace ;

136
sources/cpm/XINOUT.FB.src Normal file
View File

@ -0,0 +1,136 @@
Screen 0 not modified
0 \ Erweiterte I/O-Funktionen 3.80a UH 08Oct87
1
2 Dieses File enthaelt Definitionen, die eine erweiterte Bild-
3 schirmdarstellung ermoeglichen:
4
5 - Installation eines Terminals mit Hilfe des Wortes
6 "Terminal:"
7
8 - Editieren von Eingabezeilen
9
10 In der Version 3.80a sind diese Teile aus dem Kern genommen
11 worden, um diesen einfacher zu gestalten.
12
13
14
15
Screen 1 not modified
0 \ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87
1
2
3 1 3 +thru \ Erweiterte Ausgabe
4
5 4 6 +thru \ Erweiterte Eingabe
6
7
8 ' curon Is postlude
9
10
11
12
13
14
15
Screen 2 not modified
0 \ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87
1 | Variable terminal
2
3 : Term: ( off -- off' ) Create dup c, 2+
4 Does> c@ terminal @ + perform ;
5
6 : Terminal: Create: Does> terminal ! ;
7
8 0 Term: curon Term: curoff
9 Term: rvson Term: rvsoff
10 Term: dark Term: locate drop
11
12 : curleft ( -- ) at? 1- at ;
13 : currite ( -- ) at? 1+ at ;
14
15 Terminal: dumb noop noop noop noop noop 2drop ; dumb
Screen 3 not modified
0 \ Erweiterte Ausgabe: UH 06Mar88
1
2 &80 Constant c/row &24 Constant c/col
3
4 | Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col
5
6 : (at ( row col -- ) c/row 1- min swap c/col 1- min swap
7 2dup 'at 2! locate ;
8 : (at? ( -- row col ) 'at 2@ ;
9
10 : (page ( -- ) 0 0 'at 2! dark ;
11
12 : (type ( addr len -- ) dup 'col +!
13 0 ?DO count (emit LOOP drop ;
14
15 : (emit ( c -- ) 1 'col +! (emit ;
Screen 4 not modified
0 \ Erweiterte Ausgabe: UH 04Mar88
1
2 : (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ;
3 : (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ;
4
5 ' (emit ' display 2+ !
6 ' (cr ' display 4 + !
7 ' (type ' display 6 + !
8 ' (del ' display 8 + !
9 ' (page ' display &10 + !
10 ' (at ' display &12 + !
11 ' (at? ' display &14 + !
12
13
14
15
Screen 5 not modified
0 \ Erweiterte Eingabe UH 08OCt87
1 | Variable maxchars | Variable oldspan oldspan off
2
3 | : redisplay ( addr pos -- )
4 at? 2swap under + span @ rot - type space at ;
5 | : del ( addr pos1 -- ) dup >r + dup 1+ swap
6 span @ r> - 1- cmove -1 span +! ;
7 | : ins ( addr pos1 -- ) dup >r + dup dup 1+
8 span @ r> - cmove> bl swap c! 1 span +! ;
9
10 | : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ;
11 | : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ;
12 | : (back ( a p1 -- a p2 ) 1- curleft (del ;
13 | : (recall ( a p1 -- a p2 ) ?dup ?exit
14 oldspan @ span ! 0 2dup redisplay ;
15
Screen 6 not modified
0 \ Tastenbelegung fuer Zeilen-Editor CP/M UH 18Mar88
1 : (decode ( addr pos1 key -- addr pos2 )
2 4 case? IF dup span @ < 0=exit currite 1+ exit THEN
3 &19 case? IF dup 0=exit curleft 1- exit THEN
4 &22 case? IF dup span @ = ?exit (ins exit THEN
5 #bs case? IF dup 0=exit (back exit THEN
6 #del case? IF dup 0=exit (back exit THEN
7 7 case? IF span @ 2dup < and 0=exit (del exit THEN
8 $1B case? IF (recall exit THEN
9 #cr case? IF span @ dup maxchars ! oldspan !
10 dup at? rot span @ - - at space exit THEN
11 dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ;
12
13 : (expect ( addr len -- ) maxchars ! span off 0
14 BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ;
15
Screen 7 not modified
0 \ Patch UH 08Oct87
1
2 : (key ( -- char )
3 curon BEGIN pause (key? UNTIL curoff getkey ;
4
5 ' (key ' keyboard 2+ !
6 ' (decode ' keyboard 6 + !
7 ' (expect ' keyboard 8 + !
8
9
10
11
12
13
14
15