From 3dd6197fbfb33fa81ebb1e9194be302fb10addc5 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Sat, 20 Jun 2020 18:59:14 +0200 Subject: [PATCH] CPM Source files --- sources/cpm/ASS8080.FB.src | 306 +++++ sources/cpm/ASSTRAN.FB.src | 34 + sources/cpm/COPY.FB.src | 34 + sources/cpm/DISASS.FB.src | 306 +++++ sources/cpm/DOUBLE.FB.src | 51 + sources/cpm/EDITOR.FB.src | 544 +++++++++ sources/cpm/FILEINT.FB.src | 544 +++++++++ sources/cpm/HASHCASH.FB.src | 85 ++ sources/cpm/INSTALL.FB.src | 85 ++ sources/cpm/PORT8080.FB.src | 34 + sources/cpm/PORTZ80.FB.src | 51 + sources/cpm/PRIMED.FB.src | 51 + sources/cpm/PRINTER.FB.src | 272 +++++ sources/cpm/RELOCATE.FB.src | 51 + sources/cpm/SAVESYS.FB.src | 34 + sources/cpm/SEE.FB.src | 408 +++++++ sources/cpm/SIMPFILE.FB.src | 68 ++ sources/cpm/SOURCE.FB.src | 2176 +++++++++++++++++++++++++++++++++++ sources/cpm/STARTUP.FB.src | 34 + sources/cpm/TARGET.FB.src | 578 ++++++++++ sources/cpm/TASKER.FB.src | 119 ++ sources/cpm/TERMINAL.FB.src | 34 + sources/cpm/TIMES.FB.src | 34 + sources/cpm/TOOLS.FB.src | 272 +++++ sources/cpm/XINOUT.FB.src | 136 +++ 25 files changed, 6341 insertions(+) create mode 100644 sources/cpm/ASS8080.FB.src create mode 100644 sources/cpm/ASSTRAN.FB.src create mode 100644 sources/cpm/COPY.FB.src create mode 100644 sources/cpm/DISASS.FB.src create mode 100644 sources/cpm/DOUBLE.FB.src create mode 100644 sources/cpm/EDITOR.FB.src create mode 100644 sources/cpm/FILEINT.FB.src create mode 100644 sources/cpm/HASHCASH.FB.src create mode 100644 sources/cpm/INSTALL.FB.src create mode 100644 sources/cpm/PORT8080.FB.src create mode 100644 sources/cpm/PORTZ80.FB.src create mode 100644 sources/cpm/PRIMED.FB.src create mode 100644 sources/cpm/PRINTER.FB.src create mode 100644 sources/cpm/RELOCATE.FB.src create mode 100644 sources/cpm/SAVESYS.FB.src create mode 100644 sources/cpm/SEE.FB.src create mode 100644 sources/cpm/SIMPFILE.FB.src create mode 100644 sources/cpm/SOURCE.FB.src create mode 100644 sources/cpm/STARTUP.FB.src create mode 100644 sources/cpm/TARGET.FB.src create mode 100644 sources/cpm/TASKER.FB.src create mode 100644 sources/cpm/TERMINAL.FB.src create mode 100644 sources/cpm/TIMES.FB.src create mode 100644 sources/cpm/TOOLS.FB.src create mode 100644 sources/cpm/XINOUT.FB.src diff --git a/sources/cpm/ASS8080.FB.src b/sources/cpm/ASS8080.FB.src new file mode 100644 index 0000000..58b04a8 --- /dev/null +++ b/sources/cpm/ASS8080.FB.src @@ -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 diff --git a/sources/cpm/ASSTRAN.FB.src b/sources/cpm/ASSTRAN.FB.src new file mode 100644 index 0000000..b8b05de --- /dev/null +++ b/sources/cpm/ASSTRAN.FB.src @@ -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 diff --git a/sources/cpm/COPY.FB.src b/sources/cpm/COPY.FB.src new file mode 100644 index 0000000..5f93959 --- /dev/null +++ b/sources/cpm/COPY.FB.src @@ -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 ; diff --git a/sources/cpm/DISASS.FB.src b/sources/cpm/DISASS.FB.src new file mode 100644 index 0000000..35e816f --- /dev/null +++ b/sources/cpm/DISASS.FB.src @@ -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 ; diff --git a/sources/cpm/DOUBLE.FB.src b/sources/cpm/DOUBLE.FB.src new file mode 100644 index 0000000..5ac4cbe --- /dev/null +++ b/sources/cpm/DOUBLE.FB.src @@ -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 diff --git a/sources/cpm/EDITOR.FB.src b/sources/cpm/EDITOR.FB.src new file mode 100644 index 0000000..c47895a --- /dev/null +++ b/sources/cpm/EDITOR.FB.src @@ -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 | : #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 +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 ; diff --git a/sources/cpm/FILEINT.FB.src b/sources/cpm/FILEINT.FB.src new file mode 100644 index 0000000..d1df525 --- /dev/null +++ b/sources/cpm/FILEINT.FB.src @@ -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 \ benutze ein schon existierendes File + 9 FILE \ erzeuge ein Forthfile mit dem Namen . +10 MAKE \ Erzeuge ein File mit und ordne +11 \ es dem aktuellen Forthfile zu. +12 MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen +13 . +14 INCLUDE \ Lade File mit Forthnamen 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 diff --git a/sources/cpm/HASHCASH.FB.src b/sources/cpm/HASHCASH.FB.src new file mode 100644 index 0000000..6711e24 --- /dev/null +++ b/sources/cpm/HASHCASH.FB.src @@ -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 diff --git a/sources/cpm/INSTALL.FB.src b/sources/cpm/INSTALL.FB.src new file mode 100644 index 0000000..2336603 --- /dev/null +++ b/sources/cpm/INSTALL.FB.src @@ -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 diff --git a/sources/cpm/PORT8080.FB.src b/sources/cpm/PORT8080.FB.src new file mode 100644 index 0000000..b4001bd --- /dev/null +++ b/sources/cpm/PORT8080.FB.src @@ -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 diff --git a/sources/cpm/PORTZ80.FB.src b/sources/cpm/PORTZ80.FB.src new file mode 100644 index 0000000..a867dfa --- /dev/null +++ b/sources/cpm/PORTZ80.FB.src @@ -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 diff --git a/sources/cpm/PRIMED.FB.src b/sources/cpm/PRIMED.FB.src new file mode 100644 index 0000000..5406b4a --- /dev/null +++ b/sources/cpm/PRIMED.FB.src @@ -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 diff --git a/sources/cpm/PRINTER.FB.src b/sources/cpm/PRINTER.FB.src new file mode 100644 index 0000000..cc948d3 --- /dev/null +++ b/sources/cpm/PRINTER.FB.src @@ -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 diff --git a/sources/cpm/RELOCATE.FB.src b/sources/cpm/RELOCATE.FB.src new file mode 100644 index 0000000..6bb34ba --- /dev/null +++ b/sources/cpm/RELOCATE.FB.src @@ -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 diff --git a/sources/cpm/SAVESYS.FB.src b/sources/cpm/SAVESYS.FB.src new file mode 100644 index 0000000..e4b4267 --- /dev/null +++ b/sources/cpm/SAVESYS.FB.src @@ -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 +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 diff --git a/sources/cpm/SEE.FB.src b/sources/cpm/SEE.FB.src new file mode 100644 index 0000000..f8fed64 --- /dev/null +++ b/sources/cpm/SEE.FB.src @@ -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 +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 diff --git a/sources/cpm/SIMPFILE.FB.src b/sources/cpm/SIMPFILE.FB.src new file mode 100644 index 0000000..7f1b7f8 --- /dev/null +++ b/sources/cpm/SIMPFILE.FB.src @@ -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 diff --git a/sources/cpm/SOURCE.FB.src b/sources/cpm/SOURCE.FB.src new file mode 100644 index 0000000..ed51268 --- /dev/null +++ b/sources/cpm/SOURCE.FB.src @@ -0,0 +1,2176 @@ +Screen 0 not modified + 0 \\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87 + 1 + 2 Entwicklung des volksFORTH-83 von + 3 K. Schleisiek, B. Pennemann, + 4 G. Rehfeld, D. Weineck, U. Hoffmann + 5 + 6 Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann + 7 + 8 Dieses File enthaelt den kompletten Sourcetext des Kern-Systems + 9 fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+. +10 Mit Hilfe eines Target-Compilers wird daraus das volksFORTH- +11 System erzeugt, daher finden sich an einigen Stellen Anweisungen +12 an den Target-Compiler, die fuer das Verstaendnis des Systems +13 nicht wichtig sind. +14 Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- +15 besondere die Bdos-Schnittstelle fuer Disk-IO im Kern. +Screen 1 not modified + 0 \ CP/M 2.2 volksForth Load Screen 27Nov87 + 1 + 2 Onlyforth + 3 $9000 displace ! + 4 Target definitions $100 here! + 5 + 6 + 7 1 $74 +thru \ Standard 8080-System + 8 + 9 cr .( unresolved: ) .unresolved ( ' .blk is .status ) +10 +11 save-target KERNEL.COM +12 +13 +14 +15 +Screen 2 not modified + 0 \ FORTH Preamble and ID uho 19May2005 + 1 + 2 Assembler + 3 + 4 nop 0 jmp here 2- >label >boot + 5 nop 0 jmp here 2- >label >cold + 6 nop 0 jmp here 2- >label >restart + 7 + 8 here dup origin! + 9 \ Hier beginnen die Kaltstartwerte der Benutzervariablen +10 +11 6 rst 0 jmp end-code \ for multitasker +12 +13 $100 allot +14 +15 | Create logo ," volksFORTH-83 rev. 3.80a" +Screen 3 not modified + 0 \ Assembler Labels Next Forth-Register 29Jun86 + 1 + 2 Label dpush D push Label hpush H push + 3 Label >next + 4 IP ldax IP inx A L mov IP ldax IP inx A H mov + 5 Label >next1 + 6 M E mov H inx M D mov xchg pchl + 7 end-code + 8 + 9 Variable RP +10 Variable UP +11 \ IP in BC +12 \ W in DE +13 \ SP in SP +14 Variable IPsave +15 +Screen 4 not modified + 0 \ Assembler Macros 20Oct86 + 1 Compiler Assembler also definitions Forth + 2 : Next T >next jmp [ Forth ] ; + 3 T hpush Forth Constant hpush T dpush Forth Constant dpush + 4 T >next Forth Constant >next + 5 + 6 : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) + 7 H dcx 1+ M mov ( low ) RP shld [ Forth ] ; + 8 + 9 : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx +10 M swap mov ( high ) H inx RP shld [ Forth ] ; +11 \ rpush und rpop gehen nicht mit HL +12 +13 : mvx ( src dest -- ) +14 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ; +15 Target +Screen 5 not modified + 0 \ recover ;c: noop 20Oct86 + 1 + 2 Create recover Assembler + 3 W pop IP rpush W IP mvx + 4 Next end-code + 5 + 6 Compiler Assembler also definitions Forth + 7 + 8 : ;c: 0 T recover call end-code ] [ Forth ] ; + 9 +10 Target +11 +12 | Code di di Next end-code +13 | Code ei ei Next end-code +14 +15 Code noop >next here 2- ! end-code +Screen 6 not modified + 0 \ User variables 04Oct87 + 1 + 2 Constant origin 8 uallot drop \ Multitasker + 3 \ Felder: entry link spare SPsave + 4 \ Laenge kompatibel zum 68000 und 6502 volksFORTH + 5 User s0 + 6 User r0 + 7 User dp + 8 User offset 0 offset ! + 9 User base $0A base ! +10 User output +11 User input +12 User errorhandler \ pointer for Abort" -code +13 User voc-link +14 User udp \ points to next free addr in User +15 +Screen 7 not modified + 0 \ manipulate system pointers 11Jun86 + 1 + 2 Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code + 3 + 4 Code sp! ( addr --) H pop sphl Next end-code + 5 + 6 + 7 Code up@ ( -- addr) UP lhld hpush jmp end-code + 8 + 9 Code up! ( addr --) H pop UP shld Next end-code +10 +11 +12 +13 +14 +15 +Screen 8 not modified + 0 \ manipulate returnstack 11Jun86 + 1 + 2 Code rp@ ( -- addr ) RP lhld hpush jmp end-code + 3 + 4 Code rp! ( addr -- ) H pop RP shld Next end-code + 5 + 6 + 7 Code >r ( 16b -- ) D pop D rpush Next end-code restrict + 8 + 9 Code r> ( -- 16b ) D rpop D push Next end-code restrict +10 +11 +12 +13 +14 +15 +Screen 9 not modified + 0 \ r@ rdrop exit unnest ?exit 07Oct87 + 1 Code r@ ( -- 16b ) + 2 RP lhld M E mov H inx M D mov D push Next end-code + 3 + 4 Code rdrop + 5 RP lhld H inx H inx RP shld Next end-code restrict + 6 + 7 Code exit Label >exit IP rpop Next end-code + 8 Code unnest >exit here 2- ! + 9 +10 Code ?exit ( flag -- ) +11 H pop H A mov L ora >exit jnz Next end-code +12 +13 Code 0=exit ( flag -- ) +14 H pop H A mov L ora >exit jz Next end-code +15 \ : ?exit ( flag -- ) IF rdrop THEN ; +Screen 10 not modified + 0 \ execute perform 11Jun86 18Nov87 + 1 + 2 Code execute ( cfa -- ) + 3 H pop >Next1 jmp end-code + 4 + 5 Code perform ( 'cfa -- ) + 6 H pop M A mov H inx M H mov A L mov >Next1 jmp + 7 end-code + 8 + 9 +10 \\ +11 : perform ( addr -- ) @ execute ; +12 +13 +14 +15 +Screen 11 not modified + 0 \ c@ c! ctoggle 07Oct87 + 1 + 2 Code c@ ( addr -- 8b ) + 3 H pop M L mov 0 H mvi hpush jmp end-code + 4 + 5 Code c! ( 16b addr -- ) + 6 H pop D pop E M mov Next end-code + 7 + 8 Code flip ( 16b1 -- 16b2 ) + 9 H pop H A mov L H mov A L mov Hpush jmp end-code +10 +11 Code ctoggle ( 8b addr -- ) +12 H pop D pop M A mov E xra A M mov Next end-code +13 +14 \\ +15 : ctoggle ( 8b addr --) under c@ xor swap c! ; +Screen 12 not modified + 0 \ @ ! 2@ 2! 11Jun86 18Nov87 + 1 + 2 Code @ ( addr -- 16b ) H pop Label fetch + 3 M E mov H inx M D mov D push Next end-code + 4 + 5 Code ! ( 16b addr -- ) + 6 H pop D pop E M mov H inx D M mov Next end-code + 7 + 8 Code 2@ ( addr -- 32b ) H pop H push + 9 H inx H inx M E mov H inx M D mov H pop D push +10 M E mov H inx M D mov D push Next end-code +11 +12 Code 2! ( 32b addr -- ) H pop +13 D pop E M mov H inx D M mov H inx +14 D pop E M mov H inx D M mov Next end-code +15 +Screen 13 not modified + 0 \ +! drop swap 11Jun86 18Nov87 + 1 + 2 Code +! ( 16b addr -- ) H pop + 3 Label +store D pop + 4 M A mov E add A M mov H inx + 5 M A mov D adc A M mov Next end-code + 6 + 7 \ : +! ( n addr -- ) under @ + swap ! ; + 8 + 9 +10 Code drop ( 16b -- ) H pop Next end-code +11 +12 Code swap ( 16b1 16b2 -- 16b2 16b1 ) +13 H pop xthl hpush jmp end-code +14 +15 +Screen 14 not modified + 0 \ dup ?dup 16May86 + 1 + 2 Code dup ( 16b -- 16b 16b ) + 3 H pop H push hpush jmp end-code + 4 + 5 Code ?dup ( 16b -- 16b 16b / false) + 6 H pop H A mov L ora 0<> ?[ H push ]? + 7 hpush jmp end-code + 8 + 9 \\ +10 : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; +11 +12 : dup ( 16b -- 16b 16b ) sp@ @ ; +13 +14 +15 +Screen 15 not modified + 0 \ over rot nip under 11Jun86 + 1 + 2 Code over ( 16b1 16b2 - 16b1 16b2 16b1 ) + 3 D pop H pop H push dpush jmp end-code + 4 Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) + 5 D pop H pop xthl dpush jmp end-code + 6 Code nip ( 16b1 16b2 -- 16b2) + 7 H pop D pop hpush jmp end-code + 8 Code under ( 16b1 16b2 -- 16b2 16b1 16b2) + 9 H pop D pop H push dpush jmp end-code +10 +11 \\ +12 : over >r swap r> swap ; +13 : rot >r dup r> swap ; +14 : nip swap drop ; +15 : under swap over ; +Screen 16 not modified + 0 \ -rot pick roll -roll 11Jun86 + 1 Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + 2 H pop D pop xthl H push D push Next end-code + 3 + 4 Code pick ( n -- 16b.n ) + 5 H pop H dad SP dad + 6 M E mov H inx M D mov D push Next end-code + 7 + 8 : roll ( n -- ) + 9 dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; +10 +11 : -roll ( n -- ) >r dup sp@ dup 2+ +12 dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; +13 \\ +14 : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; +15 : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; +Screen 17 not modified + 0 \ double word stack manipulation 09May86 + 1 Code 2swap ( 32b1 32b2 -- 32b2 32b1) + 2 H pop D pop xthl H push + 3 5 H lxi SP dad M A mov D M mov A D mov + 4 H dcx M A mov E M mov A E mov H pop dpush jmp + 5 end-code + 6 + 7 Code 2drop ( 32b -- ) H pop H pop Next end-code + 8 + 9 Code 2dup ( 32b -- 32b 32b) +10 H pop D pop D push H push dpush jmp end-code +11 +12 \\ +13 : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; +14 : 2drop ( 32b -- ) drop drop ; +15 : 2dup ( 32b -- 32b 32b) over over ; +Screen 18 not modified + 0 \ + and or xor not 09May86 + 1 Code + ( n1 n2 -- n3 ) + 2 H pop D pop D dad hpush jmp end-code + 3 Code or ( 16b1 16b2 -- 16b3 ) + 4 H pop D pop H A mov D ora A H mov + 5 L A mov E ora A L mov hpush jmp end-code + 6 Code and ( 16b1 16b2 -- 16b3 ) + 7 H pop D pop H A mov D ana A H mov + 8 L A mov E ana A L mov hpush jmp end-code + 9 Code xor ( 16b1 16b2 -- 16b3 ) +10 H pop D pop H A mov D xra A H mov +11 L A mov E xra A L mov hpush jmp end-code +12 Code not ( 16b1 -- 16b2 ) H pop Label >not +13 H A mov cma A H mov L A mov cma A L mov +14 hpush jmp end-code +15 +Screen 19 not modified + 0 \ - negate 16May86 + 1 + 2 Code - ( n1 n2 -- n3 ) + 3 D pop H pop + 4 L A mov E sub A L mov + 5 H A mov D sbb A H mov hpush jmp end-code + 6 + 7 Code negate ( n1 -- n2 ) + 8 H pop H dcx >not jmp end-code + 9 +10 \\ +11 : - ( n1 n2 -- n3 ) negate + ; +12 +13 +14 +15 +Screen 20 not modified + 0 \ dnegate d+ 10Mar86 18Nov87 + 1 + 2 Code dnegate ( d1 -- -d1 ) H pop + 3 Label >dnegate + 4 D pop A sub E sub A E mov 0 A mvi D sbb + 5 A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb + 6 A H mov dpush jmp end-code + 7 + 8 Code d+ ( d1 d2 -- d3) + 9 6 H lxi SP dad M E mov C M mov H inx +10 M D mov B M mov B pop H pop D dad xchg +11 H pop L A mov C adc A L mov H A mov B adc +12 A H mov B pop dpush jmp end-code +13 +14 +15 +Screen 21 not modified + 0 \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86 + 1 Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code + 2 Code 2+ ( n1 -- n2 ) + 3 H pop H inx H inx hpush jmp end-code + 4 Code 3+ ( n1 -- n2 ) + 5 H pop H inx H inx H inx hpush jmp end-code + 6 Code 4+ ( n1 -- n2 ) + 7 H pop 4 D lxi D dad hpush jmp end-code + 8 | Code 6+ ( n1 -- n2 ) + 9 H pop 6 D lxi D dad hpush jmp end-code +10 Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code +11 Code 2- ( n1 -- n2 ) +12 H pop H dcx H dcx hpush jmp end-code +13 Code 4- ( n1 -- n2 ) +14 H pop -4 D lxi D dad hpush jmp end-code +15 +Screen 22 not modified + 0 \ number Constants 07Oct87 + 1 -1 Constant true 0 Constant false + 2 + 3 0 ( -- 0 ) Constant 0 + 4 1 ( -- 1 ) Constant 1 + 5 2 ( -- 2 ) Constant 2 + 6 3 ( -- 3 ) Constant 3 + 7 4 ( -- 4 ) Constant 4 + 8 -1 ( -- -1 ) Constant -1 + 9 +10 Code on ( addr -- ) H pop $FF A mvi +11 Label set A M mov H inx A M mov Next +12 Code off ( addr -- ) H pop A xra set jmp end-code +13 +14 \ : on ( addr -- ) true swap ! ; +15 \ : off ( addr -- ) false swap ! ; +Screen 23 not modified + 0 \ words for number literals 16May86 + 1 + 2 Code lit ( -- 16b ) + 3 IP ldax A L mov IP inx IP ldax A H mov IP inx + 4 hpush jmp end-code + 5 + 6 Code clit ( -- 8b ) + 7 IP ldax A L mov 0 H mvi IP inx hpush jmp + 8 end-code + 9 +10 : Literal ( 16b -- ) +11 dup $FF00 and IF compile lit , exit THEN +12 compile clit c, ; immediate restrict +13 +14 +15 +Screen 24 not modified + 0 \ comparision words 18Nov87 + 1 Label (u< ( HL,DE -> HL u< DE c,z ) + 2 H A mov D cmp rnz L A mov E cmp ret + 3 Label (< ( HL,DE -> HL < DE c,z ) + 4 H A mov D xra (u< jp D A mov H cmp ret + 5 + 6 Label yes true H lxi hpush jmp + 7 Code u< ( u1 u2 -- flag ) D pop H pop + 8 Label uless (u< call yes jc + 9 Label no false H lxi hpush jmp +10 +11 Code < ( n1 n2 -- flag ) D pop H pop +12 Label less (< call yes jc no jmp end-code +13 +14 Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code +15 Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code +Screen 25 not modified + 0 \ comparision words 18Nov87 + 1 Code 0< ( n1 n2 -- flag ) H pop + 2 Label negative H dad yes jc no jmp end-code + 3 + 4 Code 0> ( n -- flag ) H pop H A mov A ora no jm + 5 L ora yes jnz no jmp end-code + 6 + 7 Code 0= ( n -- flag ) H pop + 8 Label zero= H A mov L ora yes jz no jmp end-code + 9 +10 Code 0<> ( n -- flag ) +11 H pop H A mov L ora yes jnz no jmp end-code +12 +13 Code = ( n1 n2 -- flag ) H pop D pop +14 L A mov E cmp no jnz +15 H A mov D cmp no jnz yes jmp end-code +Screen 26 not modified + 0 \\ comparision words high level 18Nov87 + 1 : 0< ( n1 -- flag ) 8000 and 0<> ; + 2 : > ( n1 n2 -- flag ) swap < ; + 3 : 0> ( n -- flag ) negate 0< ; + 4 : 0<> ( n -- flag ) 0= not ; + 5 : u> ( u1 u2 -- flag ) swap u< ; + 6 : = ( n1 n2 -- flag ) - 0= ; + 7 : uwithin ( u1 [low up[ -- flag ) over - -rot - u> ; + 8 | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; + 9 : min ( n1 n2 -- n3 ) 2dup > minimax ; +10 : max ( n1 n2 -- n3 ) 2dup < minimax ; +11 : umax ( u1 u2 -- u3 ) 2dup u< minimax ; +12 : umin ( u1 u2 -- u3 ) 2dup u> minimax ; +13 : extend ( n -- d ) dup 0< ; +14 : dabs ( d -- ud ) extend IF dnegate THEN ; +15 : abs ( n -- u) extend IF negate THEN ; +Screen 27 not modified + 0 \ uwthin double number comparison words 18Nov87 + 1 + 2 Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl + 3 (u< call cs ?[ H pop no jmp ]? + 4 D pop (u< call yes jc no jmp end-code + 5 + 6 Code d0= ( d -- flag ) H pop + 7 H A mov L ora H pop no jnz zero= jmp end-code + 8 + 9 : d= ( d1 d2 -- flag ) rot = -rot = and ; +10 : d< ( d1 d2 -- flag ) +11 rot 2dup = IF 2drop u< exit THEN > nip nip ; +12 +13 +14 \\ +15 : d0= ( d -- flag ) or 0= ; +Screen 28 not modified + 0 \ minimum maximum 18Nov87 + 1 + 2 Code umax ( u1 u2 -- u3 ) + 3 H pop D pop (u< call + 4 Label minimax cs ?[ xchg ]? hpush jmp end-code + 5 + 6 Code umin ( u1 u2 -- u3 ) + 7 H pop D pop (u< call cmc minimax jmp end-code + 8 + 9 Code max ( n1 n2 -- n3 ) +10 H pop D pop (< call minimax jmp end-code +11 +12 Code min ( n1 n2 -- n3 ) +13 H pop D pop (< call cmc minimax jmp end-code +14 +15 +Screen 29 not modified + 0 \ sign extension absolute values 18Nov87 + 1 + 2 Code extend ( n -- d ) H pop H push negative jmp end-code + 3 + 4 Code abs ( a -- u ) H pop H A mov A ora + 5 hpush jp H dcx >not jmp end-code + 6 + 7 Code dabs ( d -- ud ) H pop H A mov A ora + 8 hpush jp >dnegate jmp end-code + 9 +10 +11 +12 +13 +14 +15 +Screen 30 not modified + 0 \ branch ?branch 20Nov87 + 1 + 2 Code branch ( -- ) Label >branch + 3 IP H mvx M E mov H inx M D mov H dcx + 4 D dad H IP mvx Next end-code + 5 + 6 Code ?branch ( fl -- ) + 7 H pop H A mov L ora >branch jz + 8 IP inx IP inx Next end-code + 9 +10 +11 \\ +12 : branch r> dup @ + >r ; +13 +14 +15 +Screen 31 not modified + 0 \ loop primitives 11Jun86 20Nov87 + 1 + 2 Code bounds ( start count -- limit start ) + 3 H pop D pop D dad H push D push Next end-code + 4 + 5 Code endloop + 6 RP lhld 6 D lxi D dad RP shld next end-code restrict + 7 + 8 \\ dodo puts "index | limit | adr.of.DO" on return-stack + 9 : bounds ( start count -- limit start ) over + swap ; +10 +11 | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +12 +13 : (do ( limit start -- ) over - dodo ; restrict +14 : (?do ( limit start -- ) over - ?dup IF dodo THEN +15 r> dup @ + >r drop ; restrict +Screen 32 not modified + 0 \ loop primitives 20Nov87 + 1 + 2 Code (do ( limit start -- ) H pop D pop + 3 Label >do + 4 L A mov E sub A L mov + 5 H A mov D sbb A H mov + 6 H push IP inx IP inx + 7 RP lhld H dcx IP M mov H dcx IP' M mov + 8 H dcx D M mov H dcx E M mov + 9 D pop H dcx D M mov H dcx E M mov RP shld +10 Next end-code restrict +11 +12 Code (?do ( limit start -- ) H pop D pop +13 H A mov D cmp >do jnz +14 L A mov E cmp >do jnz >branch jmp +15 end-code restrict +Screen 33 not modified + 0 \ (loop (+loop 14May86 20Nov87 + 1 + 2 Code (loop + 3 RP lhld M inr 0= ?[ H inx M inr >next jz ]? + 4 Label doloop RP lhld 4 D lxi D dad + 5 M IP' mov H inx M IP mov Next + 6 end-code restrict + 7 + 8 Code (+loop + 9 RP lhld D pop +10 M A mov E add A M mov H inx +11 M A mov D adc A M mov +12 rar D xra doloop jp Next +13 end-code restrict +14 +15 +Screen 34 not modified + 0 \ loop indices 06May86 20Nov87 + 1 + 2 Code I ( -- n ) + 3 RP lhld + 4 Label >I M E mov H inx M D mov D push + 5 H inx M E mov H inx M D mov H pop D dad + 6 hpush jmp + 7 end-code + 8 + 9 Code J ( -- n ) +10 RP lhld 6 D lxi D dad >I jmp end-code +11 +12 +13 +14 +15 +Screen 35 not modified + 0 \ interpretive conditionals UH 25Jan88 + 1 + 2 | Create: remove>> r> rp! ; + 3 | : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp! + 4 swap >r remove>> >r swap >r dup >r swap cmove r> ; + 5 + 6 | Variable saved-dp 0 saved-dp ! + 7 + 8 | Variable level 0 level ! + 9 +10 | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit +11 1 level ! here saved-dp ! ] ; +12 +13 | : -level ( -- ) state @ 0= Abort" unstructured" +14 level @ 0=exit -1 level +! level @ ?exit compile unnest +15 [compile] [ saved-dp @ here over dp ! over - >>r >r ; +Screen 36 not modified + 0 \ resolve loops and branches UH 25Jan88 + 1 + 2 : >mark ( -- addr ) here 0 , ; + 3 + 4 : +>mark ( acf -- addr ) +level , >mark ; + 5 + 6 : >resolve ( addr -- ) here over - swap ! -level ; + 7 + 8 : mark 1 ; immediate + 3 : THEN abs 1 ?pairs >resolve ; immediate + 4 : ELSE 1 ?pairs ['] branch +>mark swap + 5 >resolve -1 ; immediate + 6 : BEGIN mark + 8 -2 2swap ; immediate + 9 +10 | : (reptil resolve REPEAT ; +12 +13 : REPEAT 2 ?pairs compile branch (reptil ; immediate +14 : UNTIL 2 ?pairs compile ?branch (reptil ; immediate +15 +Screen 39 not modified + 0 \ Loops UH 25Jan88 + 1 + 2 : DO ['] (do +>mark 3 ; immediate + 3 : ?DO ['] (?do +>mark 3 ; immediate + 4 : LOOP 3 ?pairs compile (loop compile endloop >resolve ; + 5 immediate + 6 : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; + 7 immediate + 8 + 9 Code LEAVE +10 RP lhld 4 D lxi D dad M E mov H inx M D mov +11 H inx RP shld xchg H dcx M D mov H dcx M E mov +12 D dad H IP mvx Next end-code restrict +13 +14 \\ Returnstack: calladr | index limit | adr of DO +15 : LEAVE endloop r> 2- dup @ + >r ; restrict +Screen 40 not modified + 0 \ um* 16May86 + 1 Label (um* 0 H lxi ( 0=Teil-Produkt ) + 2 4 C mvi ( Schleifen-Zaehler ) + 3 [[ H dad ( Schiebe HL 24 bits nach links ) + 4 ral cs ?[ D dad 0 aci ]? + 5 H dad ral cs ?[ D dad 0 aci ]? + 6 C dcr 0= ?] ret + 7 + 8 Code um* ( u1 u2 -- ud ) + 9 D pop H pop B push H B mov L A mov (um* call +10 H push A H mov B A mov H B mov (um* call +11 D pop D C mov B dad 0 aci L D mov H L mov +12 A H mov B pop dpush jmp end-code +13 +14 +15 +Screen 41 not modified + 0 \ m* * 2* 2/ 16May86 + 1 + 2 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN + 3 swap dup 0< IF negate r> not >r THEN + 4 um* r> IF dnegate THEN ; + 5 + 6 : * ( n1 n2 - prod ) um* drop ; + 7 + 8 Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code + 9 +10 Code 2/ ( n -- n/2 ) +11 H pop H A mov rlc rrc rar A H mov +12 L A mov rar A L mov hpush jmp end-code +13 \\ +14 : 2* ( n -- 2*n ) 2 * ; +15 : 2/ ( n -- n/2 ) 2 / ; +Screen 42 not modified + 0 \ um/mod 14May86 + 1 Label usl0 + 2 A E mov H A mov C sub A H mov E A mov B sbb + 3 cs ?[ H A mov C add A H mov E A mov D dcr rz + 4 Label usla + 5 H dad ral usl0 jnc + 6 A E mov H A mov C sub A H mov E A mov B sbb + 7 ]? L inr D dcr usla jnz ret + 8 Label usbad -1 H lxi B pop H push hpush jmp + 9 Code um/mod ( d1 n1 -- rem quot ) +10 IP H mvx B pop D pop xthl xchg +11 L A mov C sub H A mov B sbb usbad jnc +12 H A mov L H mov D L mov 8 D mvi D push +13 usla call D pop H push E L mov usla call +14 A D mov H E mov B pop C H mov B pop +15 D push hpush jmp end-code +Screen 43 not modified + 0 \ m/mod 16May86 + 1 + 2 : m/mod ( d n -- mod quot) + 3 dup >r abs over 0< IF under + swap THEN + 4 um/mod r@ 0< IF negate over IF swap r@ + swap 1- + 5 THEN THEN rdrop ; + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 44 not modified + 0 \ /mod / mod */mod */ u/mod ud/mod 16May86 + 1 + 2 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; + 3 + 4 : / ( n1 n2 -- quot ) /mod nip ; + 5 + 6 : mod ( n1 n2 -- rem ) /mod drop ; + 7 + 8 : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + 9 +10 : */ ( n1 n2 n3 -- quot ) */mod nip ; +11 +12 : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; +13 +14 : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r +15 um/mod r> ; +Screen 45 not modified + 0 \ cmove cmove> 16May86 18Nov87 + 1 + 2 Code cmove ( from to count -- ) IP H mvx IPsave shld + 3 B pop D pop H pop + 4 Label (cmove + 5 [[ B A mov C ora 0= not ?[[ + 6 M A mov H INX D stax D inx B dcx + 7 ]]? IPsave lhld H IP mvx Next end-code + 8 + 9 Code cmove> ( from to count -- ) IP H mvx IPsave shld +10 B pop D pop H pop +11 Label (cmove> +12 B dad H dcx xchg B dad H dcx xchg +13 [[ B A mov C ora 0= not ?[[ +14 M A mov H dcx D stax D dcx B dcx +15 ]]? IPsave lhld H IP mvx Next end-code +Screen 46 not modified + 0 \ move place count 17Oct86 18Nov87 + 1 + 2 Code move ( from to quan -- ) + 3 IP H mvx Ipsave shld B pop D pop H pop + 4 Label domove (u< call (cmove jnc (cmove> jmp end-code + 5 + 6 | Code (place ( addr len to -- len to ) IP H mvx Ipsave shld + 7 D pop B pop H pop + 8 B push D push D inx domove jmp end-code + 9 +10 : place ( addr len to -- ) (place c! ; +11 +12 Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi +13 H inx H push D push Next end-code +14 +15 +Screen 47 not modified + 0 \ fill erase 18Nov87 + 1 + 2 Code fill ( addr quan 8b -- ) + 3 IP H mvx IPsave shld D pop B pop H pop + 4 [[ B A mov C ora 0<> ?[[ + 5 E M mov H inx B dcx + 6 ]]? IPsave lhld H IP mvx Next end-code + 7 + 8 : erase ( addr quan --) 0 fill ; + 9 +10 \\ : fill ( addr quan 8b -- ) +11 swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; +12 : count ( adr -- adr+1 len ) dup 1+ swap c@ ; +13 : move ( from to quan -- ) +14 >r 2dup u< IF r> cmove> exit THEN r> cmove ; +15 : place ( addr len to --) over >r rot over 1+ r> move c! ; +Screen 48 not modified + 0 \ here allot , c, pad compile 11Jun86 18Nov87 + 1 + 2 Code here ( -- addr ) user' dp D lxi + 3 UP lhld D dad fetch jmp end-code + 4 + 5 Code allot ( n -- ) user' dp D lxi + 6 UP lhld D dad +store jmp end-code + 7 + 8 : , ( 16b -- ) here ! 2 allot ; + 9 : c, ( 8b -- ) here c! 1 allot ; +10 +11 : pad ( -- addr ) here $42 + ; +12 : compile r> dup 2+ >r @ , ; restrict +13 +14 \ : here ( -- addr ) dp @ ; +15 \ : allot ( n -- ) dp +! ; +Screen 49 not modified + 0 \ input strings 11Jun86 + 1 + 2 Variable #tib 0 #tib ! + 3 Variable >tib here >tib ! $50 allot + 4 Variable >in 0 >in ! + 5 Variable blk 0 blk ! + 6 Variable span 0 span ! + 7 + 8 : tib ( -- addr ) >tib @ ; + 9 +10 : query ( -- ) tib $50 expect span @ #tib ! >in off blk off ; +11 +12 +13 +14 +15 +Screen 50 not modified + 0 \\ scan skip /string 16May86 18Nov87 + 1 + 2 : scan ( addr0 len0 char -- addr1 len1 ) >r + 3 BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT + 4 rdrop ; + 5 + 6 : skip ( addr len del -- addr1 len1 ) >r + 7 BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT + 8 rdrop ; + 9 +10 : /string ( addr0 len0 +n - addr1 len1 ) +11 over umin rot over + -rot - ; +12 +13 +14 +15 +Screen 51 not modified + 0 \ skip scan 18Nov87 + 1 Label done H push B push IPsave lhld H IP mvx Next + 2 Code skip ( addr len del -- addr1 len1 ) + 3 IP H mvx IPsave shld D pop B pop H pop + 4 [[ B A mov C ora done jz + 5 M A mov E cmp done jnz H inx B dcx ]] end-code + 6 + 7 Code scan ( addr len chr -- addr1 len1 ) + 8 IP H mvx IPsave shld D pop B pop H pop + 9 [[ B A mov C ora done jz +10 M A mov E cmp done jz H inx B dcx ]] end-code +11 +12 Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop +13 D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl +14 L A mov E sub A L mov H A mov D sbb A H mov +15 Hpush jmp end-code +Screen 52 not modified + 0 \ capitalize ohne Umlaute !! 16May86UH 25Jan88 + 1 Variable caps 0 caps ! + 2 Label ?capital caps lda A ana rz + 3 Label (capital ( e --> A,E ) E A mov Ascii a cpi rc + 4 Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret + 5 + 6 Code capital ( char -- char') D pop + 7 (capital call D push Next end-code + 8 Code upper ( addr len -- ) D pop E D mov H pop D inr + 9 [[ D dcr >next jz M E mov (capital call E M mov H inx ]] +10 end-code +11 +12 \\ : capital ( char -- char') +13 dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit +14 [ Ascii a Ascii A - ] Literal - ; +15 : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; +Screen 53 not modified + 0 \ (word 16May86 + 1 + 2 Code (word ( char adr0 len0 -- addr ) + 3 IP H mvx IPsave shld B pop B dcx D pop + 4 >in lhld D dad xchg xthl xchg H push >in lhld + 5 C A mov L sub A L mov B A mov H sbb A H mov + 6 cs ?[ B inx C A mov >in sta B A mov >in 1+ sta + 7 D pop H pop D push + 8 ][ H inx H B mvx H pop + 9 [[ B A mov C ora 0<> +10 ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]? +11 H push +12 [[ B A mov C ora 0<> +13 ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]? +14 xchg H pop xthl +15 E A mov L sub A L mov D A mov H sbb A H mov +Screen 54 not modified + 0 \ (word Part2 16May86 + 1 + 2 B A mov C ora 0<> ?[ H inx ]? >in shld ]? + 3 H pop E A mov L sub A C mov D A mov H sbb A B mov + 4 H push user' dp D lxi UP lhld D dad + 5 M A mov H inx M H mov A L mov D pop H push + 6 C M mov H inx + 7 [[ B A mov C ora 0<> + 8 ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi + 9 IPsave lhld H IP mvx Next end-code +10 \\ +11 : (word ( char adr0 len0 -- addr ) +12 rot >r over swap >in @ /string +13 r@ skip over swap r> scan >r rot over swap - r> 0<> - +14 >in ! over - here dup >r place bl r@ count + c! r> ; +15 +Screen 55 not modified + 0 \ source word parse name 20Oct86UH 25Jan88 + 1 + 2 Variable loadfile + 3 + 4 : source ( -- addr len ) blk @ ?dup + 5 IF loadfile @ (block b/blk exit THEN tib #tib @ ; + 6 + 7 : word ( char -- addr ) source (word ; + 8 + 9 : parse ( char -- addr len ) +10 >r source >in @ /string over swap r> scan >r +11 over - dup r> 0<> - >in +! ; +12 +13 : name ( -- addr ) bl word dup count upper exit ; +14 +15 +Screen 56 not modified + 0 \ state Ascii ," "lit (" " 18Nov87 + 1 + 2 Variable state 0 state ! + 3 + 4 : Ascii ( char -- n ) + 5 bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate + 6 + 7 Code "lit RP lhld M E mov H inx M D mov H dcx + 8 D push D ldax D inx E add A M mov H inx + 9 D A mov 0 aci A M mov Next end-code +10 +11 : ," Ascii " parse here over 1+ allot place ; +12 : (" "lit ; restrict +13 : " compile (" ," align ; immediate restrict +14 +15 \ : "lit r> r> under count + even >r >r ; restrict +Screen 57 not modified + 0 \ ." ( .( \ \\ hex decimal 07Oct87 + 1 + 2 : (." "lit count type ; restrict + 3 : ." compile (." ," align ; immediate restrict + 4 + 5 : ( ascii ) parse 2drop ; immediate + 6 : .( ascii ) parse type ; immediate + 7 + 8 : \ >in @ negate c/l mod >in +! ; immediate + 9 : \\ b/blk >in ! ; immediate +10 : \needs name find nip 0=exit [compile] \ ; +11 +12 : hex $10 base ! ; +13 : decimal $0A base ! ; +14 +15 +Screen 58 not modified + 0 \ number conversion: digit? 16May86 18Nov87 + 1 + 2 Code digit? ( char -- n true : false ) + 3 user' base D lxi UP lhld D dad + 4 D pop E A mov Ascii 0 sui no jc + 5 $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc + 6 Ascii A Ascii 9 - 1- sui ]? + 7 M cmp no jnc + 8 0 H mvi A L mov H push yes jmp end-code + 9 +10 \\ +11 : digit? ( char -- digit true/ false ) dup Ascii 9 > +12 IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN +13 Ascii 0 - dup base @ u< dup ?exit nip ; +14 +15 +Screen 59 not modified + 0 \ number conversion: accumulate convert 11Jun86 + 1 + 2 | : end? ( -- flag ) >in @ 0= ; + 3 | : char ( addr0 -- addr1 char ) count -1 >in +! ; + 4 | : previous ( addr0 -- addr0 char ) 1- count ; + 5 + 6 : accumulate ( +d0 adr digit - +d1 adr ) + 7 swap >r swap base @ um* drop rot base @ um* d+ r> ; + 8 + 9 : convert ( +d1 addr0 -- +d2 addr2 ) +10 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; +11 +12 +13 +14 +15 +Screen 60 not modified + 0 \ number conversion: ?nonum punctuation? 07Oct87 + 1 + 2 | : ?nonum ( flag -- exit if true ) 0=exit + 3 rdrop 2drop drop rdrop false ; + 4 + 5 | : punctuation? ( char -- flag ) + 6 Ascii , over = swap Ascii . = or ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 61 not modified + 0 \ number conversion: fixbase? 07Oct87 + 1 + 2 | : fixbase? ( char - char false / newbase true ) capital + 3 Ascii & case? IF $0A true exit THEN + 4 Ascii $ case? IF $10 true exit THEN + 5 Ascii H case? IF $10 true exit THEN + 6 Ascii % case? IF 2 true exit THEN false ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 62 not modified + 0 \ number conversion: ?num ?dpl 07Oct87 + 1 + 2 Variable dpl -1 dpl ! + 3 + 4 | : ?num ( flag -- exit if true ) 0=exit + 5 rdrop drop r> IF dnegate THEN + 6 rot drop dpl @ 1+ ?dup ?exit drop true ; + 7 + 8 | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + 9 +10 +11 +12 +13 +14 +15 +Screen 63 not modified + 0 \ number conversion: number? number 11Jun86 + 1 + 2 : number? ( string - string false / n 0< / d 0> ) + 3 base push >in push dup count >in ! dpl on + 4 0 >r ( +sign) 0.0 rot end? ?nonum char + 5 Ascii - case? IF rdrop true >r end? ?nonum char THEN + 6 fixbase? IF base ! end? ?nonum char THEN + 7 BEGIN digit? 0= ?nonum + 8 BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL + 9 previous punctuation? 0= ?nonum dpl off end? ?num char +10 REPEAT ; +11 +12 : number ( string -- d ) +13 number? ?dup 0= Abort" ?" 0< IF extend THEN ; +14 +15 +Screen 64 not modified + 0 \ hide reveal immediate restrict 11Jun86 + 1 + 2 Variable last 0 last ! + 3 | : last? ( -- false / acf true) last @ ?dup ; + 4 : hide last? IF 2- @ current @ ! THEN ; + 5 : reveal last? IF 2- current @ ! THEN ; + 6 : Recursive reveal ; immediate restrict + 7 + 8 | : flag! ( 8b --) + 9 last? IF under c@ or over c! THEN drop ; +10 +11 : immediate $40 flag! ; +12 : restrict $80 flag! ; +13 +14 +15 +Screen 65 not modified + 0 \ clearstack hallot heap heap? 04Sep86 + 1 + 2 Code clearstack + 3 user' s0 D lxi UP lhld D dad M E mov H inx M D mov + 4 xchg sphl Next end-code + 5 + 6 : hallot ( quan -- ) + 7 s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 8 2 pick over - di move clearstack ei s0 ! ; + 9 +10 : heap ( -- addr ) s0 @ 6 + ; +11 : heap? ( addr -- flag ) heap up@ uwithin ; +12 +13 | : heapmove ( from -- from ) +14 dup here over - dup hallot +15 heap swap cmove heap over - last +! reveal ; +Screen 66 not modified + 0 \ Does> ; 11Jun86 20Nov87 + 1 + 2 Label (dodoes> + 3 IP rpush IP pop W inx W push Next end-code + 4 + 5 : (;code r> last @ name> ! ; + 6 + 7 : Does> + 8 compile (;code $CD ( 8080-Call ) c, + 9 compile (dodoes> ; immediate restrict +10 +11 +12 +13 +14 +15 +Screen 67 not modified + 0 \ ?head | alignments 20Oct86 18Nov87 + 1 + 2 Variable ?head 0 ?head ! + 3 + 4 : | ?head @ ?exit -1 ?head ! ; + 5 + 6 \ machen nichts beim 8080: + 7 : even ( addr -- addr1 ) ; immediate + 8 : align ( -- ) ; immediate + 9 : halign ( -- ) ; immediate +10 +11 Variable warning 0 warning ! +12 +13 | : exists? warning @ ?exit last @ current @ +14 (find nip 0=exit space last @ .name ." exists " ?cr ; +15 +Screen 68 not modified + 0 \ warning Create 20Oct86 18Nov87 + 1 + 2 Defer makeview ' 0 Is makeview + 3 + 4 : (create ( string -- ) align here + 5 swap count $1F and here 4+ place makeview , current @ @ , + 6 here last ! here c@ 1+ allot align exists? + 7 ?head @ IF 1 ?head +! dup , \ Pointer to Code + 8 halign heapmove $20 flag! dup dp ! + 9 THEN drop reveal 0 , +10 ;Code W inx W push Next end-code +11 +12 : Create name count 1 $20 uwithin not +13 Abort" invalid name" 1- (create ; +14 +15 +Screen 69 not modified + 0 \ nfa? 30Jun86 + 1 + 2 Code nfa? ( thread cfa -- nfa / false ) + 3 D pop H pop + 4 [[ M A mov H inx M H mov A L mov + 5 H ora Hpush jz H push H inx H inx H push D push + 6 M A mov H inx $1F ani A E mov 0 D mvi D dad + 7 D pop xthl M A mov H pop $20 ani + 8 0<> ?[ M A mov H inx M H mov A L mov ]? + 9 H A mov D cmp 0= ?[ L A mov E cmp ]? +10 H pop 0= ?] H inx H inx Hpush jmp +11 end-code +12 \\ +13 : nfa? ( thread cfa -- nfa / false) +14 >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ = +15 UNTIL 2+ rdrop ; +Screen 70 not modified + 0 \ >name name> >body .name 30Jun86 07Oct87 + 1 + 2 : >name ( cfa -- nfa / false ) voc-link + 3 BEGIN @ dup WHILE 2dup 4 - swap nfa? + 4 ?dup IF -rot 2drop exit THEN REPEAT nip ; + 5 + 6 Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani + 7 A E mov 0 D mvi D dad hpush jmp end-code + 8 \ : (name> ( nfa -- cfa ) count $1F and + ; + 9 +10 : name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ; +11 +12 : >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ; +13 +14 : .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN +15 count $1F and type ELSE ." ???" THEN space ; +Screen 71 not modified + 0 \ : ; Constant Variable 07Nov87 + 1 + 2 : Create: Create hide current @ context ! 0 ] ; + 3 + 4 : : Create: ;Code IP rpush W inx W IP mvx Next end-code + 5 + 6 : ; 0 ?pairs compile unnest [compile] [ reveal ; + 7 immediate restrict + 8 + 9 : Constant ( n -- ) Create , ;Code +10 W inx xchg M E mov H inx M D mov D push Next +11 end-code +12 +13 : Variable Create 0 , ; +14 +15 +Screen 72 not modified + 0 \ uallot User Alias Defer 11Jun86 18Nov87 + 1 : uallot ( quan -- offset ) even dup udp @ + + 2 $FF u> Abort" Userarea full" udp @ swap udp +! ; + 3 + 4 : User Create 2 uallot c, + 5 ;Code W inx W ldax A E mov 0 D mvi + 6 UP lhld D dad hpush jmp end-code + 7 + 8 : Alias ( cfa -- ) Create last @ dup c@ $20 and + 9 IF -2 allot ELSE $20 flag! THEN (name> ! ; +10 +11 | : crash true Abort" crash" ; +12 +13 : Defer Create ['] crash , +14 ;Code W inx xchg M E mov H inx M D mov +15 xchg >next1 jmp end-code +Screen 73 not modified + 0 \ vp current context also toss 11Jun86 + 1 + 2 Create vp $10 allot Variable current + 3 + 4 : context ( -- adr ) vp dup @ + 2+ ; + 5 + 6 | : thru.vocstack ( -- from to ) vp 2+ context ; + 7 \ "Only Forth also Assembler" gives + 8 \ vp: countword = 6 | Only | Forth | Assembler | + 9 +10 : also vp @ $0A > Error" Vocabulary stack full" +11 context @ 2 vp +! context ! ; +12 : toss vp @ IF -2 vp +! THEN ; +13 +14 +15 +Screen 74 not modified + 0 \ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87 + 1 + 2 : Vocabulary + 3 Create 0 , 0 , here voc-link @ , voc-link ! + 4 Does> context ! ; + 5 \ | Name | Code | Thread | Coldthread | Voc-link | + 6 + 7 Vocabulary Forth + 8 Vocabulary Root + 9 +10 : Only vp off Root also ; +11 +12 : Onlyforth Only Forth also definitions ; +13 +14 +15 +Screen 75 not modified + 0 \ definitions order words 10Oct87 20Nov87 + 1 + 2 | : init-vocabularys voc-link @ + 3 BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; + 4 + 5 : definitions context @ current ! ; + 6 + 7 | : .voc ( adr -- ) @ 2- >name .name ; + 8 + 9 : order vp 4+ context DO I .voc -2 +LOOP +10 2 spaces current .voc ; +11 +12 : words context @ +13 BEGIN @ dup stop? 0= and +14 WHILE ?cr dup 2+ .name space +15 REPEAT drop ; +Screen 76 not modified + 0 \ found -text 11Jun86 + 1 | : found ( nfa -- cfa n ) + 2 dup c@ >r (name> r@ $20 and IF @ THEN + 3 -1 r@ $80 and IF 1- THEN + 4 r> $40 and IF negate THEN ; + 5 + 6 \\ + 7 : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1r count $1F and strlen ! string ! +13 BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ = +14 IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN +15 THEN drop REPEAT string @ 1- false ; +Screen 77 not modified + 0 \ (find 11Jun86 + 1 + 2 Code (find ( str thr - str false/ NFA true ) + 3 H pop D pop IP push D ldax $1F ani A C mov D inx + 4 Label findloop + 5 M A mov H inx M H mov A L mov + 6 H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]? + 7 H push H inx H inx M A mov $1F ani C cmp + 8 0<> ?[ H pop findloop jmp ]? + 9 D push H inx C B mov B inr +10 [[ B dcr 0<> ?[[ +11 D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]? +12 H inx D inx ]]? +13 D pop H pop H inx H inx IP pop H push yes jmp +14 end-code +15 \\ HL: thread, nfa DE: string C: strlen B: counter +Screen 78 not modified + 0 \ find ' [compile] ['] nullstring? 18Nov87 + 1 + 2 : find ( string -- cfa n / string false ) + 3 context dup @ over 2- @ = IF 2- THEN + 4 BEGIN under @ (find IF nip found exit THEN + 5 over vp 2+ u> WHILE swap 2- REPEAT nip false ; + 6 + 7 : ' ( -- cfa ) name find ?exit Error" ?" ; + 8 + 9 : [compile] ' , ; immediate restrict +10 +11 : ['] ' [compile] Literal ; immediate restrict +12 +13 : nullstring? ( string -- string false / true ) +14 dup c@ 0= dup 0=exit nip ; +15 +Screen 79 not modified + 0 \ notfound 17Oct86UH 25Jan88 + 1 + 2 : no.extensions ( string -- ) + 3 state @ IF Abort" ?" THEN Error" ?" ; + 4 + 5 Defer notfound ' no.extensions Is notfound + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 80 not modified + 0 \ interpret interpreter compiler parser UH 25Jan88 + 1 Defer parser + 2 + 3 : interpret ( -- ) + 4 BEGIN ?stack name nullstring? ?exit parser REPEAT ; + 5 + 6 | : interpreter ( str -- ) find ?dup + 7 IF 1 and IF execute exit THEN Error" compile only" THEN + 8 number? ?exit notfound ; + 9 +10 ' interpreter Is parser +11 +12 | : compiler ( str -- ) find ?dup +13 IF 0> IF execute exit THEN , exit THEN +14 number? ?dup IF 0> IF swap [compile] Literal THEN +15 [compile] Literal exit THEN notfound ; +Screen 81 not modified + 0 \ [ ] UH 25Jan88 + 1 + 2 : [ ['] interpreter Is Parser state off ; immediate + 3 + 4 : ] ['] compiler Is Parser state on ; + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 82 not modified + 0 \ Is 09May86UH 25Jan88 + 1 + 2 : (is r> dup 2+ >r @ ! ; + 3 + 4 | : def? ( cfa -- ) + 5 @ [ ' notfound @ ] Literal - Abort" not deferred" ; + 6 + 7 : Is ( adr -- ) ' dup def? >body + 8 state @ IF compile (is , exit THEN ! ; immediate + 9 +10 +11 +12 +13 +14 +15 +Screen 83 not modified + 0 \ ?stack 30Jun86 + 1 | : stackfull ( -- ) depth $20 > Abort" tight stack" + 2 reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + 3 true Abort" Dictionary full" ; + 4 + 5 Code ?stack + 6 UP lhld user' dp D lxi D dad M E mov H inx M D mov + 7 0 H lxi SP dad L A mov E sub H A mov D sbb + 8 0= ?[ ;c: stackfull ; Assembler ]? H push + 9 UP lhld user' s0 D lxi D dad M E mov H inx M D mov +10 H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]? +11 >next jnc ;c: true abort" Stack empty" ; +12 \\ +13 : ?stack sp@ here - 100 u< IF stackfull THEN +14 sp@ s0 @ u> Abort" Stack empty" ; +15 +Screen 84 not modified + 0 \ .status push load 20Oct86 + 1 + 2 Defer .status ' noop Is .status + 3 + 4 | Create: pull r> r> ! ; + 5 + 6 : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; + 7 restrict + 8 + 9 : (load ( blk offset -- ) +10 isfile push loadfile push fromfile push blk push >in push +11 >in ! blk ! isfile@ loadfile ! .status interpret ; +12 +13 : load ( blk --) ?dup 0=exit 0 (load ; +14 +15 +Screen 85 not modified + 0 \ +load thru +thru --> rdepth depth 20Oct86 + 1 + 2 : +load ( offset --) blk @ + load ; + 3 + 4 : thru ( from to --) 1+ swap DO I load LOOP ; + 5 : +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; + 6 + 7 : --> 1 blk +! >in off .status ; immediate + 8 + 9 : rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; +10 : depth ( -- +n) sp@ s0 @ swap - 2/ ; +11 +12 +13 +14 +15 +Screen 86 not modified + 0 \ quit (quit abort UH 25Jan88 + 1 + 2 : (prompt ( -- ) + 3 state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; + 4 + 5 Defer prompt ' (prompt Is prompt + 6 + 7 : (quit BEGIN prompt query interpret REPEAT ; + 8 + 9 Defer 'quit ' (quit Is 'quit +10 : quit r0 @ rp! level off [compile] [ 'quit ; +11 +12 : standardi/o [ output ] Literal output 4 cmove ; +13 +14 Defer 'abort ' noop Is 'abort +15 : abort end-trace clearstack 'abort standardi/o quit ; +Screen 87 not modified + 0 \ (error Abort" Error" 20Oct86 18Nov87 + 1 + 2 Variable scr 1 scr ! Variable r# 0 r# ! + 3 + 4 : (error ( string -- ) standardi/o space here .name + 5 count type space ?cr + 6 blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + 7 ' (error errorhandler ! + 8 + 9 : (abort" "lit swap IF >r clearstack r> +10 errorhandler perform exit THEN drop ; restrict +11 +12 | : (err" "lit swap IF errorhandler perform exit THEN +13 drop ; restrict +14 : Abort" compile (abort" ," align ; immediate restrict +15 : Error" compile (err" ," align ; immediate restrict +Screen 88 not modified + 0 \ -trailing 30Jun86 18Nov87 + 1 + 2 Code -trailing ( addr n1 -- addr n2 ) + 3 D pop H pop H push + 4 D dad xchg D dcx + 5 Label -trail H A mov L ora hpush jz + 6 D ldax BL cpi hpush jnz + 7 H dcx D dcx -trail jmp end-code + 8 + 9 \\ +10 : -trailing ( addr n1 -- addr n2) +11 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; +12 +13 +14 +15 +Screen 89 not modified + 0 \ space spaces 30Jun86 + 1 + 2 $20 Constant bl + 3 + 4 : space bl emit ; + 5 : spaces ( u --) 0 ?DO space LOOP ; + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 90 not modified + 0 \ hold <# #> sign # #s 17Oct86 + 1 + 2 | : hld ( -- addr) pad 2- ; + 3 + 4 : hold ( char -- ) -1 hld +! hld @ c! ; + 5 + 6 : <# hld hld ! ; + 7 + 8 : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + 9 +10 : sign ( n -- ) 0< IF Ascii - hold THEN ; +11 +12 : # ( +d1 -- +d2) base @ ud/mod rot 9 over < +13 IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; +14 +15 : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; +Screen 91 not modified + 0 \ print numbers 24Dec83 + 1 + 2 : d.r -rot under dabs <# #s rot sign #> + 3 rot over max over - spaces type ; + 4 + 5 : .r swap extend rot d.r ; + 6 + 7 : u.r 0 swap d.r ; + 8 + 9 : d. 0 d.r space ; +10 +11 : . extend d. ; +12 +13 : u. 0 d. ; +14 +15 +Screen 92 not modified + 0 \ .s list c/l l/s 05Oct87 + 1 + 2 : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + 3 + 4 $40 Constant c/l \ Screen line length + 5 $10 Constant l/s \ lines per screen + 6 + 7 : list ( blk -- ) + 8 scr ! ." Scr " scr @ u. + 9 l/s 0 DO +10 cr I 2 .r space scr @ block I c/l * + c/l -trailing type +11 LOOP cr ; +12 +13 +14 +15 +Screen 93 not modified + 0 \ multitasker primitives 20Nov87 + 1 + 2 Code end-trace \ patch Next to its original state + 3 $0A A mvi ( IP ldax ) >next sta + 4 $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code + 5 + 6 Code pause >next here 2- ! end-code + 7 + 8 : lock ( addr -- ) dup @ up@ = IF drop exit THEN + 9 BEGIN dup @ WHILE pause REPEAT up@ swap ! ; +10 +11 : unlock ( addr -- ) dup lock off ; +12 +13 Label wake H pop H dcx UP shld +14 6 D lxi D dad M A mov H inx M H mov A L mov sphl +15 H pop RP shld IP pop Next end-code +Screen 94 not modified + 0 \ buffer mechanism 20Oct86 07Oct87 + 1 + 2 User isfile 0 isfile ! \ addr of file control block + 3 Variable fromfile 0 fromfile ! + 4 Variable prev 0 prev ! \ Listhead + 5 | Variable buffers 0 buffers ! \ Semaphor + 6 $408 Constant b/buf \ physikalische Groesse + 7 $400 Constant b/blk + 8 \\ Struktur eines Buffers: 0 : link + 9 2 : file +10 4 : blocknummer +11 6 : statusflags +12 8 : Data ... 1 Kb ... +13 Statusflag bits : 15 1 -> updated +14 file : -1 -> empty buffer, 0 -> no fcb, direct access +15 else addr of fcb ( system dependent ) +Screen 95 not modified + 0 \ search for blocks in memory 30Jun86 + 1 | Variable pred + 2 \ DE:blk BC:file HL:bufadr + 3 + 4 Label thisbuffer? ( Zero = this buffer ) + 5 H push H inx H inx M A mov C cmp 0= + 6 ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp + 7 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret + 8 + 9 Code (core? ( blk file -- adr\blk file ) +10 IP H mvx Ipsave shld +11 user' offset D lxi UP lhld D dad +12 M E mov H inx M D mov +13 B pop H pop H push B push D dad xchg +14 prev lhld +15 thisbuffer? call 0= ?[ +Screen 96 not modified + 0 \ search for blocks in memory 30Jun86 + 1 + 2 Label blockfound + 3 D pop D pop 8 D lxi D dad H push ' exit @ jmp ]? + 4 [[ pred shld + 5 M A mov H inx M H mov A L mov + 6 H ora 0= ?[ IPsave lhld H IP mvx Next ]? + 7 thisbuffer? call 0= ?] + 8 xchg pred lhld D ldax A M mov + 9 H inx D inx D ldax A M mov D dcx +10 prev lhld xchg E M mov H inx D M mov +11 H dcx prev shld +12 blockfound jmp end-code +13 +14 +15 +Screen 97 not modified + 0 \ (core? 29Jun86 + 1 \\ + 2 + 3 | : this? ( blk file bufadr -- flag ) + 4 dup 4+ @ swap 2+ @ d= ; + 5 + 6 | : (core? ( blk file -- dataaddr / blk file ) + 7 BEGIN over offset @ + over prev @ this? + 8 IF rdrop 2drop prev @ 8 + exit THEN + 9 2dup >r offset @ + >r prev @ +10 BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN +11 dup r> r> 2dup >r >r rot this? 0= +12 WHILE nip REPEAT +13 dup @ rot ! prev @ over ! prev ! rdrop rdrop +14 REPEAT ; +15 +Screen 98 not modified + 0 \ (diskerr 29Jul86 07Oct87 + 1 + 2 : (diskerr + 3 ." error! r to retry " key $FF and + 4 capital Ascii R = not Abort" aborted" ; + 5 + 6 Defer diskerr + 7 ' (diskerr Is diskerr + 8 + 9 Defer r/w +10 +11 +12 +13 +14 +15 +Screen 99 not modified + 0 \ backup emptybuf readblk 20Oct86 + 1 + 2 | : backup ( bufaddr -- ) dup 6+ @ 0< + 3 IF 2+ dup @ 1+ \ buffer empty if file = -1 + 4 IF input push output push standardi/o + 5 BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + 6 WHILE ." write " diskerr + 7 REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ; + 8 + 9 : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; +10 +11 | : readblk ( blk file addr -- blk file addr ) +12 dup emptybuf +13 input push output push standardi/o >r +14 BEGIN over offset @ + over r@ 8 + -rot 1 r/w +15 WHILE ." read " diskerr REPEAT r> ; +Screen 100 not modified + 0 \ take mark updates? core? 10Mar86 19Nov87 + 1 + 2 | : take ( -- bufaddr) prev + 3 BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + 4 buffers lock dup backup ; + 5 + 6 | : mark ( blk file bufaddr -- blk file ) + 7 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off + 8 buffers unlock ; + 9 +10 | : updates? ( -- bufaddr / flag) +11 prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; +12 +13 : core? ( blk file -- addr /false ) (core? 2drop false ; +14 +15 +Screen 101 not modified + 0 \ block & buffer manipulation 20Oct86 18Nov87 + 1 + 2 : (buffer ( blk file -- addr ) + 3 BEGIN (core? take mark REPEAT ; + 4 + 5 : (block ( blk file -- addr ) + 6 BEGIN (core? take readblk mark REPEAT ; + 7 + 8 Code isfile@ ( -- addr ) user' isfile D lxi + 9 UP lhld D dad fetch jmp end-code +10 +11 : buffer ( blk -- addr ) isfile@ (buffer ; +12 +13 : block ( blk -- addr ) isfile@ (block ; +14 +15 \ : isfile@ ( -- addr ) isfile @ ; +Screen 102 not modified + 0 \ block & buffer manipulation 05Oct87 + 1 + 2 : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; + 3 + 4 Defer save-dos-buffers + 5 + 6 : save-buffers ( -- ) buffers lock + 7 BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers + 8 buffers unlock ; + 9 +10 : empty-buffers ( -- ) buffers lock prev +11 BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; +12 +13 : flush save-buffers empty-buffers ; +14 +15 +Screen 103 not modified + 0 \ Allocating buffers 10Oct87 + 1 $10000 Constant limit Variable first + 2 + 3 : allotbuffer ( -- ) + 4 first @ r0 @ - b/buf 2+ u< ?exit + 5 b/buf negate first +! first @ dup emptybuf + 6 prev @ over ! prev ! ; + 7 + 8 : freebuffer ( -- ) first @ limit b/buf - u< + 9 IF first @ backup prev +10 BEGIN dup @ first @ - WHILE @ REPEAT +11 first @ @ swap ! b/buf first +! THEN ; +12 +13 : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; +14 +15 | : init-buffers prev off limit first ! all-buffers ; +Screen 104 not modified + 0 \ endpoints of forget 01Jul86 + 1 + 2 | : |? ( nfa -- flag ) c@ $20 and ; + 3 | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + 4 name> under 1+ u< swap heap? or ; + 5 + 6 | : endpoints ( addr -- addr symb ) + 7 heap voc-link @ >r + 8 BEGIN r> @ ?dup \ through all Vocabs + 9 WHILE dup >r 4- >r \ link on returnstack +10 BEGIN r> @ >r over 1- dup r@ u< \ until link or +11 swap r@ 2+ name> u< and \ code under adr +12 WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap +13 r@ 2+ |? IF over r@ 2+ forget? +14 IF r@ 2+ (name> 2+ umax THEN \ then update symb +15 THEN REPEAT rdrop REPEAT ; +Screen 105 not modified + 0 \ remove, -words, -tasks 20Oct86 + 1 + 2 : remove ( dic sym thread - dic sym ) + 3 BEGIN dup @ ?dup \ unlink forg. words + 4 WHILE dup heap? + 5 IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + 6 IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + 7 + 8 | : remove-words ( dic sym -- dic sym ) + 9 voc-link BEGIN @ ?dup +10 WHILE dup >r 4- remove r> REPEAT ; +11 +12 | : remove-tasks ( dic -- ) up@ +13 BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin +14 IF dup @ 2+ @ over ! 2- +15 ELSE @ THEN REPEAT 2drop ; +Screen 106 not modified + 0 \ remove-vocs trim 20Oct86 07Oct87 + 1 + 2 | : remove-vocs ( dic symb -- dic symb ) + 3 voc-link remove thru.vocstack + 4 DO 2dup I @ -rot uwithin + 5 IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 6 2dup current @ -rot uwithin + 7 IF [ ' Forth 2+ ] Literal current ! THEN ; + 8 + 9 Defer custom-remove ' noop Is custom-remove +10 +11 | : trim ( dic symb -- ) +12 over remove-tasks remove-vocs remove-words +13 custom-remove heap swap - hallot dp ! 0 last ! ; +14 +15 +Screen 107 not modified + 0 \ deleting words from dict. 01Jul86 18Nov87 + 1 + 2 : clear here dup up@ trim dp ! ; + 3 + 4 : (forget ( adr --) dup heap? Abort" is symbol" + 5 endpoints trim ; + 6 + 7 : forget ' dup [ dp ] Literal @ u< Abort" protected" + 8 >name dup heap? + 9 IF name> ELSE 4- THEN (forget ; +10 +11 : empty [ dp ] Literal @ up@ trim +12 [ udp ] Literal @ udp ! ; +13 +14 +15 +Screen 108 not modified + 0 \ save bye stop? ?cr 18Nov87 + 1 + 2 : save here up@ trim + 3 voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL + 4 up@ origin $100 cmove ; + 5 + 6 : bye flush empty (bye ; + 7 + 8 | : end? key #cr = IF true rdrop THEN ; + 9 +10 : stop? ( -- flag ) key? IF end? end? THEN false ; +11 +12 : ?cr col c/l u> 0=exit cr ; +13 +14 +15 +Screen 109 not modified + 0 \ in/output structure 07Jun86 + 1 + 2 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; + 3 + 4 : Output: Create: Does> output ! ; + 5 0 Out: emit Out: cr Out: type Out: del + 6 Out: page Out: at Out: at? drop + 7 + 8 : row ( -- row) at? drop ; + 9 : col ( -- col) at? nip ; +10 +11 | : In: Create dup c, 2+ Does> c@ input @ + perform ; +12 +13 : Input: Create: Does> input ! ; +14 0 In: key In: key? In: decode In: expect drop +15 +Screen 110 not modified + 0 \ Alias only definitionen 18Nov87 + 1 + 2 Root definitions Forth + 3 + 4 : seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab. + 5 + 6 ' Only Alias Only + 7 ' Forth Alias Forth + 8 ' words Alias words + 9 ' also Alias also +10 ' definitions Alias definitions +11 +12 Host Target +13 +14 +15 +Screen 111 not modified + 0 \ 'restart 'cold 22Oct86 10Oct87 + 1 + 2 Defer 'restart ' noop Is 'restart + 3 + 4 | : (restart ['] (quit Is 'quit drvinit 'restart + 5 [ errorhandler ] Literal @ errorhandler ! + 6 ['] noop Is 'abort clearstack + 7 standardi/o interpret quit ; + 8 + 9 Defer 'cold ' noop Is 'cold +10 +11 | : (cold origin up@ $100 cmove $80 count +12 $50 umin >r tib r@ move r> #tib ! >in off blk off +13 init-vocabularys init-buffers flush 'cold +14 Onlyforth page &24 spaces logo count type cr (restart ; +15 +Screen 112 not modified + 0 \ cold bootsystem 20Oct86 + 1 + 2 Code cold here >cold ! + 3 s0 lhld 6 D lxi D dad origin D lxi $3F C mvi + 4 [[ D ldax A M mov H inx D inx C dcr 0= ?] + 5 ' (cold >body IP lxi + 6 Label bootsystem + 7 s0 lhld 6 D lxi D dad UP shld + 8 user' s0 D lxi D dad + 9 M E mov H inx M D mov xchg sphl +10 user' r0 D lxi UP lhld D dad +11 M E mov H inx M D mov xchg RP shld +12 $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker ) +13 Next +14 end-code +15 +Screen 113 not modified + 0 \ restart boot 20Oct86 + 1 + 2 Code restart here >restart ! + 3 ' (restart >body IP lxi bootsystem jmp end-code + 4 + 5 Label boot here >boot ! \ find link to Main: + 6 s0 lhld 6 D lxi D dad H B mvx origin D lxi + 7 [[ [[ xchg H inx H inx M E mov H inx M D mov + 8 D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx + 9 6 lhld 0 L mvi ' limit >body shld +10 -$1100 D lxi D dad r0 shld \ set initial RP +11 -$400 D lxi D dad s0 shld \ set initial SP +12 6 D lxi D dad xchg B H mvx +13 D M mov H dcx E M mov \ set link to Maintask +14 >cold 2- jmp +15 end-code +Screen 114 not modified + 0 \ "search 05Mar88 + 1 + 2 Label notfound H pop H pop + 3 IPsave lhld H IP mvx False H lxi hpush jmp + 4 + 5 Code "search ( text tlen buf blen -- addr tf / ff ) + 6 IP H mvx IPsave shld D pop H pop xthl + 7 H A mov L ora notfound jz + 8 E A mov L sub A C mov D A mov H sbb A B mov notfound jc + 9 B inx D pop xthl M A mov xthl H push xchg +10 Label scanfirst +11 A E mov ?capital call E D mov +12 [[ M E mov H inx B A mov C ora notfound jz B dcx +13 ?capital call E A mov D cmp 0= ?] +14 B D mvx B pop xchg xthl xchg H push B push D push +15 +Screen 115 not modified + 0 \ "search part 2 27Nov87 + 1 + 2 Label match + 3 B dcx B A mov C ora 0<> ?[ + 4 D inx D ldax D push A E mov ?capital call E D mov + 5 M E mov H inx ?capital call E A mov D cmp D pop + 6 match jz H pop B pop D pop + 7 M A mov xthl B push H B mvx xchg scanfirst jmp ]? + 8 D pop D pop H pop D pop H dcx H push + 9 IPsave lhld H IP mvx True H lxi hpush jmp +10 end-code +11 +12 +13 +14 +15 +Screen 116 not modified + 0 \ Rest of Standard-System 04Oct87 07Oct87 + 1 + 2 2 +load \ Operating System + 3 + 4 Host ' Transient 8 + @ Transient Forth Context @ 6 + ! + 5 + 6 Target Forth also definitions + 7 + 8 Vocabulary Assembler Assembler definitions + 9 Transient Assembler +10 >Next Constant >Next +11 hpush Constant hpush +12 dpush Constant dpush +13 +14 Target Forth also definitions +15 : forth-83 ; \ last word in Dictionary +Screen 117 not modified + 0 \ System patchup 04Oct87 + 1 + 2 $EF00 r0 ! + 3 $EB00 s0 ! + 4 s0 @ 6 + origin 2+ ! \ link Maintask to itself + 5 + 6 \ s0 und r0 werden beim Booten neu an die Speichergroesse + 7 \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask + 8 + 9 here dp ! +10 +11 Host Tudp @ Target udp ! +12 Host Tvoc-link @ Target voc-link ! +13 Host move-threads +14 +15 +Screen 118 not modified + 0 \ System dependent Load-Screen 20Nov87 + 1 + 2 1 +load \ CP/M interface + 3 + 4 2 4 +thru \ Character IO + 5 + 6 5 7 +thru \ Default Disk IO + 7 + 8 8 +load \ Postlude + 9 +10 \ 9 +load \ Index +11 +12 +13 +14 +15 +Screen 119 not modified + 0 \ CP/M-Interface 05Oct87 + 1 Vocabulary Dos Dos definitions also + 2 Label >bios pchl + 3 Code biosa ( arg fun -- res ) + 4 1 lhld D pop D dcx D dad D dad D dad + 5 D pop IP push D IP mvx >bios call + 6 Label back + 7 IP pop 0 H mvi A L mov Hpush jmp end-code + 8 + 9 Code bdosa ( arg fun -- res ) +10 H pop D pop IP push L C mov 5 call back jmp +11 end-code +12 +13 : bios ( arg fun -- ) biosa drop ; +14 : bdos ( arg fun -- ) bdosa drop ; +15 +Screen 120 not modified + 0 \ Character-IO Constants Character input 05Oct87 + 1 + 2 Target Dos also + 3 + 4 $08 Constant #bs $0D Constant #cr + 5 $0A Constant #lf $1B Constant #esc + 6 $09 Constant #tab $7F Constant #del + 7 $07 Constant #bel $0C Constant #ff + 8 + 9 : con! ( c -- ) 4 bios ; +10 : (key? ( -- ? ) 0 2 biosa 0= not ; +11 : getkey ( -- c ) 0 3 biosa ; +12 +13 : (key ( -- c ) BEGIN pause (key? UNTIL getkey ; +14 +15 +Screen 121 not modified + 0 \ Character output 07Oct87 UH 27Feb88 + 1 + 2 | Code ?ctrl ( c -- c' ) H pop L A mov + 3 $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code + 4 + 5 : (emit ( c -- ) ?ctrl con! pause ; + 6 + 7 : (cr #cr con! #lf con! ; + 8 : (del #bs con! bl con! #bs con! ; + 9 : (at? ( -- row col ) 0 0 ; +10 +11 : tipp ( addr len -- ) 0 ?DO count emit LOOP drop ; +12 +13 Output: display [ here output ! ] +14 (emit (cr tipp (del noop 2drop (at? ; +15 +Screen 122 not modified + 0 \ Line input 04Oct87 + 1 + 2 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ; + 3 + 4 : (decode ( addr pos1 key -- addr pos2 ) + 5 #bs case? IF backspace exit THEN + 6 #del case? IF backspace exit THEN + 7 #cr case? IF dup span ! space exit THEN + 8 dup emit >r 2dup + r> swap c! 1+ ; + 9 +10 : (expect ( addr len -- ) span ! 0 +11 BEGIN span @ over u> WHILE key decode REPEAT 2drop ; +12 +13 Input: keyboard [ here input ! ] +14 (key (key? (decode (expect ; +15 +Screen 123 not modified + 0 \ Default Disk Interface: Constants and Primitives 18Nov87 + 1 + 2 $80 Constant b/rec b/blk b/rec / Constant rec/blk + 3 + 4 Dos definitions + 5 ' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb + 6 + 7 : dos-error? ( n -- f ) $FF = ; + 8 + 9 $5C Constant fcb +10 : reset ( -- ) 0 &13 bdos ; +11 : openfile ( fcb -- f ) &15 bdosa dos-error? ; +12 : closefile ( fcb -- f ) &16 bdosa dos-error? ; +13 : dma! ( dma -- ) &26 bdos ; +14 : rec@ ( fcb -- f ) &33 bdosa ; +15 : rec! ( fcb -- f ) &34 bdosa ; +Screen 124 not modified + 0 \ Default Disk Interface: open and close 20Nov87 + 1 + 2 Target Dos also Defer drvinit Dos definitions + 3 + 4 | Variable opened + 5 : default ( -- ) opened off + 6 fcb 1+ c@ bl = ?exit $80 count here place #tib off + 7 fcb dup dosfcb> dup isfile ! fromfile ! + 8 openfile Abort" default file not found!" opened on ; + 9 ' default Is drvinit +10 +11 : close-default ( -- ) opened @ not ?exit +12 fcb closefile Abort" can't close default-file!" ; +13 ' close-default Is save-dos-buffers +14 +15 +Screen 125 not modified + 0 \ Default Disk Interface: read/write 14Feb88 + 1 + 2 Target Dos also + 3 + 4 | : rec# ( 'dosfcb -- 'rec# ) &33 + ; + 5 + 6 : (r/w ( adr blk file r/wf -- flag ) >r + 7 dup 0= Abort" no Direct Disk IO supported! " >dosfcb + 8 swap rec/blk * over rec# 0 over 2+ c! ! + 9 r> rot b/blk bounds +10 DO I dma! 2dup IF rec@ drop +11 ELSE rec! IF 2drop true endloop exit THEN THEN +12 over rec# 0 over 2+ c! 1 swap +! +13 b/rec +LOOP 2drop false ; +14 +15 ' (r/w Is r/w +Screen 126 not modified + 0 \ Postlude 20Nov87 + 1 + 2 Defer postlude + 3 + 4 | : (bye ( -- ) postlude 0 0 bdos ; + 5 + 6 | : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ; + 7 + 8 : .size ( -- ) base push decimal + 9 cr ." Size: &" #pages u. ." Pages" ; +10 +11 ' .size Is postlude +12 +13 +14 +15 +Screen 127 not modified + 0 \ index findex 20Nov87 + 1 + 2 | : range ( from to -- to+1 from ) + 3 2dup > IF swap THEN 1+ swap ; + 4 + 5 : index ( from to --) + 6 range DO cr I 4 .r I space block c/l type + 7 stop? IF LEAVE THEN LOOP ; + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/cpm/STARTUP.FB.src b/sources/cpm/STARTUP.FB.src new file mode 100644 index 0000000..39448bc --- /dev/null +++ b/sources/cpm/STARTUP.FB.src @@ -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 \ diff --git a/sources/cpm/TARGET.FB.src b/sources/cpm/TARGET.FB.src new file mode 100644 index 0000000..63a038f --- /dev/null +++ b/sources/cpm/TARGET.FB.src @@ -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 +14 0 | Constant +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 , 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 , 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 case? IF ." forward" exit THEN + 6 - Abort" type unknown" ." resolved " ; + 7 + 8 | : .does-type ( cfa.does -- ) @ + 9 case? IF ." forward-define" exit THEN +10 - 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 @ = 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 @ = + 6 IF drop >name space .name ." exists" ?cr rdrop exit THEN + 7 r> swap >r 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 @ = IF 2+ ! exit THEN swap resolve ; +13 +14 ' Is> ( -- ) dup @ there rot ! T , H ; \ forward link +15 ' 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 : - cfa) H g' dup @ - 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 -2 H 2swap ; + 8 immediate restrict + 9 | : (repeat T 2 ?pairs 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 diff --git a/sources/cpm/TASKER.FB.src b/sources/cpm/TASKER.FB.src new file mode 100644 index 0000000..772b405 --- /dev/null +++ b/sources/cpm/TASKER.FB.src @@ -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 diff --git a/sources/cpm/TERMINAL.FB.src b/sources/cpm/TERMINAL.FB.src new file mode 100644 index 0000000..d95c095 --- /dev/null +++ b/sources/cpm/TERMINAL.FB.src @@ -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 diff --git a/sources/cpm/TIMES.FB.src b/sources/cpm/TIMES.FB.src new file mode 100644 index 0000000..44da075 --- /dev/null +++ b/sources/cpm/TIMES.FB.src @@ -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 diff --git a/sources/cpm/TOOLS.FB.src b/sources/cpm/TOOLS.FB.src new file mode 100644 index 0000000..af3f5fb --- /dev/null +++ b/sources/cpm/TOOLS.FB.src @@ -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 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 \ 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 ! ; +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 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 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 off ; \ clears trap range + 8 + 9 : endloop \ stop tracing loop +10 'ip @ 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