From 52d0ec8091ad73d381c9b6922ada94d30a48cea3 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Thu, 18 Aug 2022 13:29:55 +0200 Subject: [PATCH] AmstradCPC Sources / CP/M fixes --- 8080/AmstradCPC/AMSDOS.SCR | 1 + 8080/AmstradCPC/ASS8080.SCR | 1 + 8080/AmstradCPC/ASSTRAN.SCR | 1 + 8080/AmstradCPC/ATARI.SCR | 1 + 8080/AmstradCPC/COPY.SCR | 1 + 8080/AmstradCPC/DISASS.SCR | 1 + 8080/AmstradCPC/DOUBLE.SCR | 1 + 8080/AmstradCPC/EDITOR.SCR | 1 + 8080/AmstradCPC/FILEINT.SCR | 1 + 8080/AmstradCPC/GRAFDEMO.SCR | 1 + 8080/AmstradCPC/GRAFIK.SCR | 1 + 8080/AmstradCPC/HASHCASH.SCR | 1 + 8080/AmstradCPC/INSTALL.SCR | 1 + 8080/AmstradCPC/KERNEL.COM | Bin 0 -> 13440 bytes 8080/AmstradCPC/MATHE.SCR | 1 + 8080/AmstradCPC/PORT8080.SCR | 1 + 8080/AmstradCPC/PORTZ80.SCR | 1 + 8080/AmstradCPC/PRIMED.SCR | 1 + 8080/AmstradCPC/PRINTER.SCR | 1 + 8080/AmstradCPC/READ.ME | 123 +++++++++++++++++++++++++++++++++++ 8080/AmstradCPC/RELOCATE.SCR | 1 + 8080/AmstradCPC/SAVESYS.SCR | 1 + 8080/AmstradCPC/SEE.SCR | 1 + 8080/AmstradCPC/SIMPFILE.SCR | 1 + 8080/AmstradCPC/SOURCE.SCR | 1 + 8080/AmstradCPC/STARTUP.SCR | 1 + 8080/AmstradCPC/TASKER.SCR | 1 + 8080/AmstradCPC/TERMINAL.SCR | 1 + 8080/AmstradCPC/TIMES.SCR | 1 + 8080/AmstradCPC/TOOLS.SCR | 1 + 8080/AmstradCPC/TURTDEMO.SCR | 1 + 8080/AmstradCPC/TURTLE.SCR | 1 + 8080/AmstradCPC/VDOS62KX.SCR | 1 + 8080/AmstradCPC/VOLKS4TH.COM | Bin 0 -> 29952 bytes 8080/AmstradCPC/XINOUT.SCR | 1 + 8080/CPM/startup.fb | 2 +- 8080/CPM/volks4th.com | Bin 29952 -> 25088 bytes 37 files changed, 156 insertions(+), 1 deletion(-) create mode 100644 8080/AmstradCPC/AMSDOS.SCR create mode 100644 8080/AmstradCPC/ASS8080.SCR create mode 100644 8080/AmstradCPC/ASSTRAN.SCR create mode 100644 8080/AmstradCPC/ATARI.SCR create mode 100644 8080/AmstradCPC/COPY.SCR create mode 100644 8080/AmstradCPC/DISASS.SCR create mode 100644 8080/AmstradCPC/DOUBLE.SCR create mode 100644 8080/AmstradCPC/EDITOR.SCR create mode 100644 8080/AmstradCPC/FILEINT.SCR create mode 100644 8080/AmstradCPC/GRAFDEMO.SCR create mode 100644 8080/AmstradCPC/GRAFIK.SCR create mode 100644 8080/AmstradCPC/HASHCASH.SCR create mode 100644 8080/AmstradCPC/INSTALL.SCR create mode 100644 8080/AmstradCPC/KERNEL.COM create mode 100644 8080/AmstradCPC/MATHE.SCR create mode 100644 8080/AmstradCPC/PORT8080.SCR create mode 100644 8080/AmstradCPC/PORTZ80.SCR create mode 100644 8080/AmstradCPC/PRIMED.SCR create mode 100644 8080/AmstradCPC/PRINTER.SCR create mode 100644 8080/AmstradCPC/READ.ME create mode 100644 8080/AmstradCPC/RELOCATE.SCR create mode 100644 8080/AmstradCPC/SAVESYS.SCR create mode 100644 8080/AmstradCPC/SEE.SCR create mode 100644 8080/AmstradCPC/SIMPFILE.SCR create mode 100644 8080/AmstradCPC/SOURCE.SCR create mode 100644 8080/AmstradCPC/STARTUP.SCR create mode 100644 8080/AmstradCPC/TASKER.SCR create mode 100644 8080/AmstradCPC/TERMINAL.SCR create mode 100644 8080/AmstradCPC/TIMES.SCR create mode 100644 8080/AmstradCPC/TOOLS.SCR create mode 100644 8080/AmstradCPC/TURTDEMO.SCR create mode 100644 8080/AmstradCPC/TURTLE.SCR create mode 100644 8080/AmstradCPC/VDOS62KX.SCR create mode 100644 8080/AmstradCPC/VOLKS4TH.COM create mode 100644 8080/AmstradCPC/XINOUT.SCR diff --git a/8080/AmstradCPC/AMSDOS.SCR b/8080/AmstradCPC/AMSDOS.SCR new file mode 100644 index 0000000..0d69633 --- /dev/null +++ b/8080/AmstradCPC/AMSDOS.SCR @@ -0,0 +1 @@ +\ Calling ROM fuer Standard 3" Laufwerk Amsdos UH 03Dec86 Dieses File enthaelt die Definitionen der Schnittstelle fuer Firmware-Aufrufe unter dem 38K-CP/M, das mit den Standard 3" Floppylaufwerken und ohne Speichererweiterung gefahren wird. Bei anderen Systemkonfigurationen (Vortex-Laufwerke und/oder Speichererweiterung) kann es sein, dass die Firmware-Aufrufe anders organisiert sein muessen. (Siehe VDOS62KX.SCR) Dieses File wird von dem Grafikpaket geladen, falls der entsprechende Kommentar in GRAFIK.SCR richtig gesetzt ist. \ Calling ROM fuer Standard 3" Laufwerk Amsdos UH 29Nov86 Assembler definitions Variable 'start Create jumprom \ Startaddr in 'start, returns like a subroutineAssembler H push 'start lhld xthl ret end-code ' noop Alias +org immediate \ No newline at end of file diff --git a/8080/AmstradCPC/ASS8080.SCR b/8080/AmstradCPC/ASS8080.SCR new file mode 100644 index 0000000..ce1c1b4 --- /dev/null +++ b/8080/AmstradCPC/ASS8080.SCR @@ -0,0 +1 @@ +\ VolksForth 8080 Assembler UH 09Mar86 Ideen lieferten: John Cassady Mike Perry Klaus Schleisiek Bernd Pennemann Dietrich Weineck \ VolksForth 8080 Assembler Load Screen UH 03Jun86Onlyforth Assembler also definitions hex 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr OnlyForth \ Vektorisierte Erzeugung UH 03Jun86Variable >codes | Create nrc ] c, , c@ here allot ! c! [ : nonrelocate ( -- ) nrc >codes ! ; nonrelocate | : >exec ( n -- n+2 ) Create dup c, 2+ does> c@ >codes @ + perform ; 0 | >exec >c, | >exec >, | >exec >c@ | >exec >here | >exec >allot | >exec >! | >exec >c! drop \ Register und Definierende Worte UH 09Mar86 7 Constant A 0 Constant B 1 Constant C 2 Constant D 3 Constant E 0 Constant I 1 Constant I' 2 Constant W 3 Constant W' 0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L 6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S | : 1MI Create >c, does> C@ >c, ; | : 2MI Create >c, does> C@ + >c, ; | : 3MI Create >c, does> C@ swap 8 * + >c, ; | : 4MI Create >c, does> C@ >c, >c, ; | : 5MI Create >c, does> C@ >c, >, ; \ Mnemonics UH 09Mar8600 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc 0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc 2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa 80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr 03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call 2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo EA 5MI jpe F2 5MI jp FA 5MI jm \ Spezial Mnemonics und Spruenge UH 09Mar86DA Constant C0= D2 Constant C0<> D2 Constant CS C2 Constant 0= CA Constant 0<> E2 Constant PE F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ; : mov 8 * 40 + + >c, ; : mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ; : [[ ( -- addr ) >here ; \ BEGIN : ?] ( addr opcode -- ) >c, >, ; \ UNTIL : ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF : ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE : ]? ( addr -- ) >here swap >! ; \ THEN : ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE : ]] ( addr -- ) jmp ; \ AGAIN : ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT \ Macros UH 14May86: end-code context 2- @ context ! ; : ;c: 0 recover call end-code ] ; : Next >next jmp ; : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ; \ Definierende Worte UH 06Aug86Forth definitions : Code ( -- ) Create here dup 2- ! Assembler ; : ;Code ( -- ) 0 ?pairs compile [ ' does> >body 2+ @ , ] reveal [compile] [ Assembler ; immediate : >label ( adr -- ) here | Create swap , 4 hallot >here 4 - heap 4 cmove heap last @ (name> ! dp ! does> ( -- adr ) @ State @ IF [compile] Literal THEN ; : Label [ Assembler ] >here >label Assembler ; UH 14May86 % VolksForth 8080 Assembler Shadow-Screens UH 09Mar86 % VolksForth 8080 Assembler UH 03Jun86 Der 8080 Assembler wurde von John Cassady, in den Forth Dimensions veroeffentlicht und von Mike Perry im F83 implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat und auch Befehle zur strukturierten Assemblerprogrammierung. Um ein Wort in Assembler zu definieren wird das definierende Wort Code benutzt, es kann, muss aber nicht mit end-code beendetwerden. Wie der Assembler arbeitet ist ein interessantes Beispiel fuer die Maechtigkeit von Create does>. Am Anfang werden die Befehle in Klassen eingeteilt und fuer jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic des Befehls spaeter interpretiert wird, kompiliert er den entsprechenden Opcode. % Vektorisierte Erzeugung UH 09Mar86Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren. Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler Schaltet Assembler in den In-Line Modus. Definierendes Wort fuer Erzeugungs-Operator-Namen. Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden aktuellen Erzeugungsoperator aus. Mit diesen Erweiterungen kann der Assembler auch fuer den Target-Compiler benutzt werden. % Register und Definierende Worte UH 09Mar86 Die 8080 Register werden definiert. Es sind einfach Konstanten die Information fuer die Mnemonics hinterlassen. Einige Register der Forth-Maschine: IP ist BC, W ist DE Definierende Worte fuer die Mnemonics. Fast alle 8080 Befehle fallen in diese 5 Klassen. % Mnemonics UH 09Mar86Die 8080 Mnemonics werden definiert. % Spezial Mnemonics und Spruenge UH 09Mar86Vergleiche des 8080 not folgt einem Vergleich, wenn er invertiert werden soll. die Mnemonics, die sich nicht in die Klassen MI1 bis MI5 einteilen lassen. Die strukturierten Assembler-Anweisungen. Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungenzu den strukturierten Anweisungen in Forth entstehen. Es findet keine Absicherung der Kontrollstrukturen statt, sodasssie auch beliebig missbraucht, werden koennen. Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig. % Macros UH 17May86end-code beendet eine Code-Definition ;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten. Next Assembliert einen Sprung zum Adress-Interpretierer. rpush Das angegebene Register wird auf den Return-Stack gelegt. rpop Das angegebene Register wird vom Return-Stack genommen. rpush und rpop benutzen das HL Register. mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register Bewegt Registerpaare HL BC DE % Definierende Worte UH 17May86Code leitet eine Code-Definition ein. ;code ist das Low-Level-Aequivalent von does> >label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert Label erzeugt ein Label auf dem Heap, mit dem Wert von here \ No newline at end of file diff --git a/8080/AmstradCPC/ASSTRAN.SCR b/8080/AmstradCPC/ASSTRAN.SCR new file mode 100644 index 0000000..4e1447f --- /dev/null +++ b/8080/AmstradCPC/ASSTRAN.SCR @@ -0,0 +1 @@ +\\ Transinient Assembler 11Nov86 Dieses File enthaelt Befehle, die den Assembler vollstaendig in den Heap laden, so dass er schliesslich mit clear wieder vergessen werden kann. Dadurch ist es nicht notwendig in einer Anwendung den ganzen Assembler im Speicher lassen zu muessen, nur weil einige primitive Worte in Assembler geschrieben sind. \ Internal Assembler UH 22Oct86 Onlyforth here $C00 hallot heap dp ! include ass8080.scr dp ! \ No newline at end of file diff --git a/8080/AmstradCPC/ATARI.SCR b/8080/AmstradCPC/ATARI.SCR new file mode 100644 index 0000000..cf39370 --- /dev/null +++ b/8080/AmstradCPC/ATARI.SCR @@ -0,0 +1 @@ +\ Anpassung an C64 und Atari-Graphic UH 03Dec86 Dieses File enthaelt im wesentlichen Umbenennungen der Grafik- routinen, da die Grafikpakete auf dem C64 und dem Atari zum Teil andere Namen verwenden, als die AMSTRAD Programmierer sie sich ausgedacht haben. Um die Atari und C64 Grafik-Demos weitgehend uebernehmen zu koennen wird also dieses Schicht zusaetzlich vom File GRAFDEMO.SCR geladen. \ Anpassung an C64 und Atari-Graphic UH 05Sep86 ' move Alias set ' line Alias draw ' mover Alias rset ' liner Alias rdraw : line ( x1 y1 x2 y2 -- ) set draw ; | Create cur 4 allot : cur.x ( -- addr ) cursor@ cur 2! cur 2+ ; : cur.y ( -- addr ) cursor@ cur 2! cur ; : home ( -- ) 0 0 move ; : exorwrite 1 access ; : overwrite 3 access ; --> \ Anpassung an C64 und Atari-Graphic UH 05Sep86 ' test Alias get.pixel ( x y -- p ) : put.pixel ( x y p -- ) pen plot ; : clip.window ( x1 y1 x2 y2 -- ) rot heigth width ; : unplot ( x y -- ) paper@ put.pixel ; 05Sep86 05Sep86 \ No newline at end of file diff --git a/8080/AmstradCPC/COPY.SCR b/8080/AmstradCPC/COPY.SCR new file mode 100644 index 0000000..30357c5 --- /dev/null +++ b/8080/AmstradCPC/COPY.SCR @@ -0,0 +1 @@ +\ Copy und Convey 19Nov87 Dieses File enthaelt Definitionen, die urspruenglich im Kern enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern klein zu halten. copy kopiert einen Screen convey kopiert einen Bereich von Screens \ moving blocks 20Oct86 19Nov87| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; | : fromblock ( blk -- adr ) fromfile @ (block ; | : (copy ( from to -- ) dup isfile@ core? IF prev @ emptybuf THEN full? IF save-buffers THEN offset @ + isfile@ rot fromblock 6 - 2! update ; | : blkmove ( from to quan --) save-buffers >r over r@ + over u> >r 2dup u< r> and IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN save-buffers 2drop ; : copy ( from to --) 1 blkmove ; : convey ( [blk1 blk2] [to.blk --) swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ; \ No newline at end of file diff --git a/8080/AmstradCPC/DISASS.SCR b/8080/AmstradCPC/DISASS.SCR new file mode 100644 index 0000000..08ae90c --- /dev/null +++ b/8080/AmstradCPC/DISASS.SCR @@ -0,0 +1 @@ +\\ Z80-Disassembler 08Nov86 Dieses File enthaelt einen Z80-Disassembler, der assemblierten Code in Standard Zilog-Z80 Mnemonics umsetzt. Benutzung: TOOLS ALSO \ Schalte Disassembler-Vokabular an addr DIS \ Disassembliere ab Adresse addr xxxx displace ! \ Beruecksichte bei allen Adressen einen \ Versatz von xxxx. \ Wird gebraucht, wenn ein Assemblerstueck \ nicht an dem Platz disassembliert wird, \ an dem es ablaeuft. \ Z80-Disassembler Load Screen 08Nov86 Onlyforth Tools also definitions hex ' Forth | Alias F: immediate ' Tools | Alias T: immediate 1 $10 +THRU cr .( Disassembler geladen. ) cr OnlyForth \\ Fragen Anregungen & Kritik an: U. Hoffmann Harmsstrasse 71 2300 Kiel 1 \ Speicherzugriff und Ausgabe 07Jul86internal \needs Case: : Case: Create: Does> swap 2* + perform ; Variable index Variable address Variable offset Variable oldoutput external Variable displace displace off internal ' pad Alias str1 ( -- addr ) : str2 ( -- addr ) str1 $40 + ; : byte ( -- b ) address @ displace @ + c@ ; : word ( -- w ) address @ displace @ + @ ; : .byte ( byte -- ) 0 <# # #s #> type ; : .word ( addr -- ) 0 <# # # # #s #> type ; \ neue Bytes lesen Byte-Fraktionen 07Jul86 : next-byte output push oldoutput @ output ! byte .byte space 1 address +! ; : next-word next-byte next-byte ; : f ( -- b ) byte $40 / ; : g ( -- b ) byte 8 / 7 and ; : h ( -- b ) byte 7 and ; : j ( -- b ) g 2/ ; : k ( -- b ) g 1 and ; \\ 76543210 ffggghhh jjk \ Select" 08Nov86 : scan/ ( limit start -- limit start' ) over swap DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ; : select ( n addr len -- addr' len' ) bounds rot 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN LOOP under scan/ nip over - ; : (select" ( n -- ) "lit count select type ; : select" ( -- ) compile (select" ," ; immediate : append ( c str -- ) under count + c! dup c@ 1+ swap c! ; \ StringOutput 07Jul86 Variable $ : $emit ( c -- ) $ @ append pause ; : $type ( adr len -- ) 0 ?DO count $emit LOOP drop ; : $cr ( -- ) $ @ off ; : $at? ( -- row col ) 0 $ @ c@ ; Output: $output $emit $cr $type noop $cr 2drop $at? ; \ Register 07Jul86 : reg ( n -- ) dup 5 = IF index @ negate index ! THEN select" B/C/D/E/H/L/$/A" ; : double-reg ( n -- ) select" BC/DE/%/SP" ; : double-reg2 ( n -- ) select" BC/DE/%/AF" ; : num ( n -- ) select" 0/1/2/3/4/5/6/7" ; : cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ; : arith ( n -- ) select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ; \ no-prefix Einteilung der Befehle in Klassen 07Jul86 : 00xxx000 g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN select" nop/ex AF,AF'/djnz ?/jr ?" ; : 00xxx001 k IF ." add %," j double-reg exit THEN ." ld " j double-reg ." ,&" ; : 00xxx010 ." ld " g select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)" ; : 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ; \ no-prefix 07Jul86 : 00xxx100 ." inc " g reg ; : 00xxx101 ." dec " g reg ; : 00xxx110 ." ld " g reg ." ,#" ; : 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ; : 01xxxxxx ." ld " g reg ." ," h reg ; : 10xxxxxx g arith h reg ; \ no-prefix 07Jul86 : 11xxx000 ." ret " g cond ; : 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN ." pop " j double-reg2 ; : 11xxx010 ." JP " g cond ." ,&" ; : 11xxx011 g select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ; : 11xxx100 ." call " g cond ; : 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ; : 11xxx110 g arith ." #" ; : 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ; \ no-prefix 07Jul86 Case: 00xxxhhh 00xxx000 00xxx001 00xxx010 00xxx011 00xxx100 00xxx101 00xxx110 00xxx111 ; Case: 11xxxhhh 11xxx000 11xxx001 11xxx010 11xxx011 11xxx100 11xxx101 11xxx110 11xxx111 ; : 00xxxxxx h 00xxxhhh ; : 11xxxxxx h 11xxxhhh ; Case: ffxxxxxx 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ; \ no-prefix 07Jul86 : get-offset index @ 0> IF byte offset ! next-byte THEN ; : no-prefix f ffxxxxxx next-byte get-offset ; \ CB-Prefix 07Jul86 : CB-00xxxxxx g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ; : CB-01xxxxxx ." bit " g num ." ," h reg ; : CB-10xxxxxx ." res " g num ." ," h reg ; : CB-11xxxxxx ." set " g num ." ," h reg ; case: singlebit CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ; : CB-prefix get-offset f singlebit next-byte ; \ ED-Prefix 30Sep86: ED-01xxx000 ." in (C)," g reg ; : ED-01xxx001 ." out (C)," g reg ; : ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN ." HL," j double-reg ; : ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN ." (&)," j double-reg ; : ED-01xxx100 ." neg" ; : ED-01xxx101 k IF ." reti" exit THEN ." retn" ; : ED-01xxx110 g select" im 0/-/im 1/im 2" ; : ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ; : ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ; Case: ED-01xxxhhh ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011 ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ; : ED-01xxxxxx h ED-01xxxhhh ; \ ED-Prefix 07Jul86 Case: extended noop ED-01xxxxxx ED-10xxxxxx noop ; : ED-prefix get-offset f extended next-byte ; \ Disassassemblieren eines einzelnen Befehls 30Sep86 : index-register ( n -- ) index ! next-byte ; : get-instruction ( -- ) index off str1 $ ! cr byte $DD = IF 1 index-register ELSE byte $FD = IF 2 index-register THEN THEN byte $76 case? IF next-byte ." halt" exit THEN $CB case? IF next-byte CB-prefix exit THEN $ED case? IF next-byte ED-prefix exit THEN drop no-prefix ; \ Adressierungsarten ausgeben 07Jul86 27Nov87: .index-register ( -- ) index @ abs select" HL/IX/IY" ; : offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ; : +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ; : .offset ( -- ) offset @ offset-sign extend under dabs <# # #s rot +- #> type ; : .index-register-offset index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ; : .inline-byte ( -- ) byte .byte next-byte ; : .inline-word ( -- ) word .word next-word ; : .displace ( -- ) byte offset-sign address @ + 1+ .word next-byte ; \ Hauptebene: dis 07Jul86: .char ( c -- ) Ascii % case? IF .index-register exit THEN Ascii $ case? IF .index-register-offset exit THEN Ascii # case? IF .inline-byte exit THEN Ascii & case? IF .inline-word exit THEN Ascii ? case? IF .displace exit THEN emit ; : instruction ( -- ) cr address @ .word 2 spaces output @ oldoutput ! $output get-instruction str2 $ ! cr str1 count 0 ?DO count .char LOOP drop oldoutput @ output ! $20 col - 0 max spaces str2 count type ; external : dis ( addr -- ) address ! BEGIN instruction stop? UNTIL ; \ No newline at end of file diff --git a/8080/AmstradCPC/DOUBLE.SCR b/8080/AmstradCPC/DOUBLE.SCR new file mode 100644 index 0000000..a7c6663 --- /dev/null +++ b/8080/AmstradCPC/DOUBLE.SCR @@ -0,0 +1 @@ +\\ Double words 11Nov86 Dieses File enthaelt Worte fuer 32-Bit Objekte. Im Kern bereits enthalten sind: 2@ 2! 2dup 2drop 2swap dnegate d+ Hier werden definiert: 2Variable 2Constant 2over d* \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86 : 2Variable Variable 2 allot ; : 2Constant Create , , does> 2@ ; Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi SP dad M D mov H dcx M E mov D push H dcx M D mov H dcx M E mov D push Next end-code --> \\ Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ d* d- 29Jun86 : d* ( d1 d2 -- d1*d2 ) rot 2over rot um* 2swap um* d+ 2swap um* d+ ; : d- ( d1 d2 -- d1-d2 ) dnegate d+ ; \ No newline at end of file diff --git a/8080/AmstradCPC/EDITOR.SCR b/8080/AmstradCPC/EDITOR.SCR new file mode 100644 index 0000000..6eedfcd --- /dev/null +++ b/8080/AmstradCPC/EDITOR.SCR @@ -0,0 +1 @@ +\ Full-Screen Editor UH 02Nov86 Dieses File enthaelt den Full-Screen Editor fuer die CP/M - volksFORTH-Version. Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- Funktion und des sichtbaren Laden von Screens (showload). Durch die integrierte Tastaturtabelle (keytable) laesst sich dieKommandobelegung der Tasten auf einfache Art und Weise aendern. Anregungen, Kritik und Verbesserungsvorschlaege bitte an: U. Hoffmann Harmsstrasse 71 2300 Kiel \ Load Screen for the Editor UH 03Nov86 UH 27Nov87 Onlyforth cr 1 $1E +thru Onlyforth \ String primitves 27Nov87 : delete ( buffer size count -- ) over umin dup >r - 2dup over r@ + -rot cmove + r> bl fill ; : insert ( string length buffer size -- ) rot over umin dup >r - over dup r@ + rot cmove> r> cmove ; : replace ( string length buffer size -- ) rot umin cmove ; \ usefull definitions and Editor vocabulary UH 27Nov87 : blank ( addr len -- ) bl fill ; : ?enough ( n --) depth 1- > abort" Not enough Parameters" ; : ?abort( ( f -- ) IF [compile] .( true abort" !" THEN [compile] ( ; Vocabulary Editor ' Forth | Alias F: immediate ' Editor | Alias E: immediate Editor also definitions \ move cursor with position-checking 23Nov86 | : c ( n --) \ checks the cursor position r# @ + dup 0 b/blk uwithin not Abort" There is a border!" r# ! ; \\ : c ( n --) \ goes thru the screens r# @ + dup b/blk 1- > IF 1 scr +! THEN dup 0< IF -1 scr +! THEN b/blk mod r# ! ; : c ( n --) \ moves cyclic thru the screen r# @ + b/blk mod r# ! ; \ calculate addresses UH 31Oct86 | Code *line ( l -- adr ) H pop H dad H dad H dad H dad H dad H dad Hpush jmp end-code | Code /line ( n -- c l ) H pop L A mov $3F ani A E mov 0 D mvi L A mov ral A L mov H A mov ral A H mov L A mov ral A L mov H A mov ral A H mov L A mov ral 3 ani H L mov A H mov dpush jmp end-code \\ | : *line ( l -- adr ) c/l * ; | : /line ( n -- c l ) c/l /mod ; \ calculate addresses UH 01Nov86 | : top ( -- ) r# off ; | : cursor ( -- n ) r# @ ; | : 'start ( -- adr ) scr @ block ; | : 'end ( -- adr ) 'start b/blk + ; | : 'cursor ( -- adr ) 'start cursor + ; | : position ( -- c l ) cursor /line ; | : line# ( -- l ) position nip ; | : col# ( -- c ) position drop ; | : 'line ( -- adr ) 'start line# *line + ; | : 'line-end ( -- adr ) 'line c/l + 1- ; | : #after ( -- n ) c/l col# - ; | : #remaining ( -- n ) b/blk cursor - ; | : #end ( -- n ) b/blk line# *line - ; \ move cursor directed UH 01Nov86 | : curup c/l negate c ; | : curdown c/l c ; | : curleft -1 c ; | : curright 1 c ; | : +tab \ 1/4 line forth cursor $10 / 1+ $10 * cursor - c ; | : -tab \ 1/8 line back cursor 8 mod negate dup 0= 8 * + c ; | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; | : #after c ; \ show border UH 27Nov87&15 | Constant dx 1 | Constant dy | : horizontal ( row -- row' ) dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ; | : vertical ( row -- row' ) l/s 0 DO dup dx 1- at Ascii | emit row dx c/l + at Ascii | emit 1+ LOOP ; | : border dy 1- horizontal vertical horizontal drop ; | : edit-at ( -- ) position swap dy dx d+ at ; Forth definitions : updated? ( -- f) scr @ block 2- @ 0< ; \ display screen UH 02Nov86 UH 27Nov87Editor definitions | Variable isfile' | Variable imode | : .updated ( -- ) 7 0 at updated? IF 4 spaces ELSE ." not " THEN ." updated" ; | : redisplay ( line# -- ) dup dy + dx at *line 'start + c/l type ; | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ; | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at imode @ IF ." insert " exit THEN ." overwrite" ; | : .screen l/s 0 DO I redisplay LOOP ; | : .all .title .screen ; \ check errors UH 02Nov86 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip Abort" You would lose a line" ; | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > IF line# redisplay true Abort" You would lose a char" THEN ; | : ?end 1 ?fit ; \ programmer's id UH 02Nov86 $12 | Constant id-len Create id id-len allot id id-len erase | : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; | : ?stamp ( -- ) updated? IF stamp THEN ; | : get-id ( -- ) id c@ ?exit id on cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at id id-len 2 /string expect rvsoff span @ id 1+ c! ; \ update screen-display UH 02Dec86 | : emptybuf prev @ 2+ dup on 4+ off ; | : undo emptybuf .all ; | : modified updated? ?exit update .updated ; | : linemodified modified line# redisplay ; | : screenmodified modified l/s line# ?DO I redisplay LOOP ; | : .modified ( -- ) dy l/s + 4+ 0 at scr @ . updated? not IF ." un" THEN ." modified" ?stamp ; \ leave editor UH 02Dec86 UH 23Feb88| Variable (pad (pad off | : memtop ( -- adr) sp@ $100 - ; | Create char 1 allot ( | Variable imode ) imode off | : setimode imode on .title ; | : clrimode imode off .title ; | : flipimode ( -- ) imode @ 0= imode ! .title ; | : done ( -- ) ['] (quit is 'quit ['] (error errorhandler ! quit ; | : update-exit ( -- ) .modified done ; | : flushed-exit ( -- ) .modified save-buffers done ; \ handle lines UH 01Nov86 | : (clear-line 'line c/l blank ; | : clear-line (clear-line linemodified ; | : clear> 'cursor #after blank linemodified ; | : delete-line 'line #end c/l delete screenmodified ; | : backline curup delete-line ; | : (insert-line ?bottom 'line c/l over #end insert (clear-line ; | : insert-line (insert-line screenmodified ; \ handle characters UH 01Nov86 | : delete-char 'cursor #after 1 delete linemodified ; | : backspace curleft delete-char ; | : (insert-char ?end 'cursor 1 over #after insert ; | : insert-char (insert-char bl 'cursor c! linemodified ; | : putchar ( --) char c@ imode @ IF (insert-char THEN 'cursor c! linemodified curright ; \ stack lines UH 31Oct86 | Create lines 4 allot \ { 2+pointer | 2base } | : 'lines ( -- adr) lines 2@ + ; | : @line 'lines memtop u> Abort" line buffer full" 'line 'lines c/l cmove c/l lines +! ; | : copyline @line curdown ; | : line>buf @line delete-line ; | : !line c/l negate lines +! 'lines 'line c/l cmove ; | : buf>line lines @ 0= Abort" line buffer empty" ?bottom (insert-line !line screenmodified ; \ stack characters UH 01Nov86 | Create chars 4 allot \ { 2+pointer | 2base } | : 'chars ( -- adr) chars 2@ + ; | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" 'cursor c@ 'chars c! 1 chars +! ; | : copychar @char curright ; | : char>buf @char delete-char ; | : !char -1 chars +! 'chars c@ 'cursor c! ; | : buf>char chars @ 0= Abort" char buffer empty" ?end (insert-char !char linemodified ; \ switch screens UH 03Nov86 UH 27Nov87 | Variable r#' r#' off | Variable scr' scr' off ( | Variable isfile' ) isfile@ isfile' ! | : associate \ switch to alternate screen isfile' @ isfile@ isfile' ! isfile ! scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ; | : n ?stamp 1 scr +! .all ; | : b ?stamp -1 scr +! .all ; | : a ?stamp associate .all ; \ shadow screens UH 03Nov86 Variable shadow shadow off | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; | : >shadow ?stamp \ switch to shadow screen (shadow dup scr @ u> not IF negate THEN scr +! .all ; \ load and show screens UH 06Mar88 ' name >body &10 + | Constant 'name | : showoff ['] exit 'name ! curoff rvsoff ; | : show ( -- ) blk @ 0= IF showoff exit THEN >in @ 1- r# ! curoff edit-at curon stop? IF showoff true Abort" Break! " THEN blk @ scr @ - IF blk @ scr ! rvsoff curoff .all rvson curon THEN ; | : showload ( -- ) ?stamp save-buffers ['] show 'name ! curon rvson ['] .status >body push ['] noop is .status scr @ scr push scr off r# push r# @ (load showoff ; \ find strings UH 01Nov86 | Variable insert-buffer | Variable find-buffer | : 'insert ( -- addr ) insert-buffer @ ; | : 'find ( -- addr ) find-buffer @ ; | : .buf ( addr -- ) count type ." |" &80 col - spaces ; | : get ( addr -- ) >r at? r@ .buf 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN at r> .buf ; | : get-buffers dy l/s + 2+ dx 1- 2dup at ." find: |" 'find get swap 1+ swap 2- at ." ? replace: |" 'insert get ; \ search for string UH 02Nov86 UH 27Nov87 | : skip ( addr -- addr' ) 'find c@ + ; | : find? ( -- addr T | F ) 'find count 'cursor #remaining "search ; | : "find ( -- r# scr ) find? IF skip 'start - scr @ exit THEN ?stamp capacity scr @ 1+ ?DO 'find count I dup 5 5 at 4 .r block b/blk "search IF skip I block - I endloop exit THEN stop? Abort" Break! " LOOP true Abort" not found!" ; \ replace strings UH 03Nov86 UH 27Nov87| : replace? ( -- f ) dy l/s + 3+ dx 3 - at key dup #cr = IF line# redisplay true Abort" Break!" THEN capital Ascii R = ; | : "mark ( -- ) r# push 'find count dup negate c edit-at rvson type rvsoff ; | : (replace 'insert c@ 'find c@ - ?fit 'find c@ negate c 'cursor #after 'find c@ delete 'insert count 'cursor #after insert 'insert c@ c modified ; | : "replace get-buffers BEGIN "find dup scr @ - swap scr ! IF .all THEN r# ! "mark replace? IF (replace THEN line# redisplay REPEAT ;\ Control-Characters and special keys CPCs UH 04Dec86Forth definitions : Ctrl ( -- c ) name 1+ c@ $1F and state @ IF [compile] Literal THEN ; immediate $7F Constant #del Editor definitions \ Definition der Spezialtasten $F0 | Constant #up $F1 | Constant #down $F2 | Constant #left $F3 | Constant #right $E0 | Constant #copy $FC | Constant #esc | ' 4+ | Alias &s ( key -- key' ) | : &c ( key -- key' ) 8 + ; \ Try a Screen-Editor for CPCs UH 04Dec86 Create keytable #up c, #left c, #down c, #right c, #up &s c, #left &s c, #down &s c, #right &s c, Ctrl Q c, Ctrl Z c, Ctrl H c, Ctrl H c, #del c, Ctrl P c, #copy c, Ctrl D c, Ctrl T c, Ctrl I c, Ctrl O c, Ctrl C c, Ctrl E c, #cr c, #right &c c, #left &c c, #up &c c, #down &c c, Ctrl F c, Ctrl U c, Ctrl X c, #esc c, Ctrl L c, Ctrl W c, Ctrl N c, Ctrl B c, Ctrl A c, Ctrl R c, here keytable - Constant #keys \ Try a screen Editor UH 28Nov86 Create: actiontable curup curleft curdown curright line>buf char>buf buf>line buf>char copyline copychar backspace backspace backspace delete-char insert-char delete-line insert-line setimode clrimode clear-line clear> +tab -tab top >""end "replace undo update-exit flushed-exit showload >shadow n b a mark ; here actiontable - 2/ 1- #keys - ?abort( # of actions) \ find keys UH 01Nov86 | Code findkey ( key -- addr/default ) H pop L A mov keytable H lxi #keys $100 * D lxi [[ M cmp 0= ?[ actiontable H lxi 0 D mvi D dad D dad M E mov H inx M D mov D push next ]? H inx E inr D dcr 0= ?] ' putchar H lxi hpush jmp end-code \\ | : findkey ( key -- adr/default ) #keys 0 DO dup keytable F: I + c@ = IF drop E: actiontable F: I 2* + @ endloop exit THEN LOOP drop ['] putchar ; \ allocate buffers UH 01Nov86 c/l 2* | Constant cstack-size | : nextbuf ( adr -- adr' ) cstack-size + ; | : ?clearbuffer pad (pad @ = ?exit pad dup (pad ! nextbuf dup find-buffer ! 'find off nextbuf dup insert-buffer ! 'insert off nextbuf dup 0 chars 2! nextbuf 0 lines 2! ; \ enter and exit the editor, editor's loop UH 02Nov86| Variable jingle jingle on | : bell 07 con! jingle off ; | : clear-error jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; | : fullquit BEGIN ?clearbuffer edit-at key dup char c! findkey execute clear-error REPEAT ; | : fullerror ( string --) jingle @ IF bell THEN dy l/s + 1+ dx $16 + at rvson count type rvsoff &80 col - spaces scr @ capacity 1- min 0 max scr ! .title quit ; | : install ( -- ) ['] fullquit Is 'quit ['] fullerror errorhandler ! ; \ enter and exit the Editor UH 02Nov86 Forth definitions : v ( -- ) E: 'start drop get-id install ?clearbuffer page curoff border .all quit ; : l ( scr -- ) 1 ?enough scr ! E: top F: v ; \ savesystem UH 27Nov87 : savesystem \ save image E: id off (pad off savesystem ; | : >find ?clearbuffer >in push bl word count 'find 1+ place bl 'find 1+ dup >r count dup >r + c! r> 2+ 'find c! bl r> c! ; : view ( --) >find ' >name 4- @ (view ?dup 0= Abort" hand made" scr ! E: top curdown find? 0= IF ." From Scr # " scr @ u. true Abort" wrong file" THEN skip 'start - 1- r# ! v ; \ No newline at end of file diff --git a/8080/AmstradCPC/FILEINT.SCR b/8080/AmstradCPC/FILEINT.SCR new file mode 100644 index 0000000..c969775 --- /dev/null +++ b/8080/AmstradCPC/FILEINT.SCR @@ -0,0 +1 @@ +\ CP/M 2.2 File-Interface (3.80a) UH 05Oct87 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. Damit ist Zugriff auf normale CP/M-Files moeglich. Wenn ein File mit USE benutzt wird, beziehen sich alle Worte, die mit dem Massenspeicher arbeiten, auf dieses File. Benutzung: USE \ benutze ein schon existierendes File FILE \ erzeuge ein Forthfile mit dem Namen . MAKE \ Erzeuge ein File mit und ordne \ es dem aktuellen Forthfile zu. MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen . INCLUDE \ Lade File mit Forthnamen ab Screen 1 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M) \ CP/M 2.2 File-Interface load-Screen UH 18Feb88OnlyForth 2 load \ view numbers for this file 3 4 thru \ DOS File Functions 5 $11 thru \ Forth File Functions $12 $16 thru \ User Interface File source.scr \ Define already existing Files File fileint.scr File startup.scr ' (makeview Is makeview ' remove-files Is custom-remove ' file-r/w Is r/w ' noop Is drvinit \ include startup.scr \ load Standard System \ Build correct view-numbers for this file UUH 19Nov87 | : fileintview ( -- ) $400 blk @ + ; ' fileintview Is makeview \ File Control Blocks UH 18Feb88Dos definitions also | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ; &11 Constant filenamelen 0 2 | Fcbyte nextfile immediate 1 Fcbyte drive ' drive | Alias >dosfcb filenamelen 3 - Fcbyte filename 3 Fcbyte extension &21 + \ ex, s1, s2, rc, d0, ... dn, cr 2 Fcbyte record \ r0, r1 1+ \ r2 2 Fcbyte opened 2 Fcbyte fileno 2 Fcbyte filesize \ in 128-Byte-Records 4 Fcbyte position Constant b/fcb \ dos primitives UH 10Oct87 ' 2- | Alias body> ' 2- | Alias dosfcb> : drive! ( drv -- ) $0E bdos ; : search0 ( dosfcb -- dir ) $11 bdosa ; : searchnext ( dosfcb -- dir ) $12 bdosa ; : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ; : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ; : createfile ( dosfcb -- f ) $16 bdosa dos-error? ; : size ( dos -- size ) dup $23 bdos dosfcb> record @ ; : drive@ ( -- drv ) 0 $19 bdosa ; : killfile ( dosfcb -- ) $13 bdos ; \ File sizes UH 05Oct87 : (capacity ( fcb -- n ) \ filecapacity in blocks filesize @ rec/blk u/mod swap 0= ?exit 1+ ; : in-range ( block fcb -- ) (capacity u< not Abort" beyond capacity!" ; Forth definitions : capacity ( -- n ) isfile@ (capacity ; Dos definitions \ (open UH 18Feb88 : (open ( fcb -- ) dup opened @ IF drop exit THEN dup position 0. rot 2! dup >dosfcb openfile Abort" not found!" dup opened on dup >dosfcb size swap filesize ! ; : (make ( fcb -- ) dup >dosfcb killfile dup >dosfcb createfile Abort" directory full!" dup position 0. rot 2! dup filesize off opened on offset off ; : file-r/w ( buffer block fcb f -- f ) over 0= Abort" no Direct Disk IO supported! " >r dup (open 2dup in-range r> (r/w ; \ Print Filenames UH 10Oct87 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN fcb dosfcb> case? IF ." DEFAULT" exit THEN body> >name .name ; : .drive ( fcb -- ) drive c@ ?dup 0=exit [ Ascii A 1- ] Literal + emit Ascii : emit ; : .dosfile ( fcb -- ) dup filename 8 -trailing type Ascii . emit extension 3 type ; \ Print Filenames UH 10Oct87 : tab ( -- ) col &59 > IF cr exit THEN &20 col &20 mod - 0 max spaces ; : .fcb ( fcb -- ) dup fileno @ 3 u.r tab dup .file tab dup .drive dup .dosfile tab dup opened @ IF ." opened" ELSE ." closed" THEN 3 spaces base push decimal (capacity 3 u.r ." kB" ; \ Filenames UH 05Oct87 : !name ( addr len fcb -- ) dup >r filename filenamelen bl fill over 1+ c@ Ascii : = IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r> ELSE 0 THEN r@ drive c! r> dup filename 2swap filenamelen 1+ min bounds ?DO I c@ Ascii . = IF drop dup extension ELSE I c@ over c! 1+ THEN LOOP 2drop ; : !fcb ( fcb -- ) dup opened off name count rot !name ; \ Print Directory UH 18Nov87 | Create dirbuf b/rec allot dirbuf b/rec erase | Create fcb0 b/fcb allot fcb0 b/fcb erase | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ; | : (expand ( addr len -- ) false -rot bounds ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ; | : expand ( fcb -- ) \ expand * to ??? dup filename 8 (expand extension 3 (expand ; : (dir ( addr len -- ) fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0 BEGIN dup dos-error? not WHILE $20 * dirbuf + dosfcb> tab .dosfile fcb0 >dosfcb searchnext stop? UNTIL drop ; \ File List UH 10Oct87 User file-link file-link off | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ; Forth definitions : forthfiles ( -- ) file-link @ BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ; Dos definitions \ Close a file UH 10Oct87 ' save-buffers >body $0C + @ | Alias backup | : filebuffer? ( fcb -- fcb bufaddr/flag ) prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; | : flushfile ( fcb -- ) \ flush file buffers BEGIN filebuffer? ?dup WHILE dup backup emptybuf REPEAT drop ; : (close ( fcb -- ) \ close file in fcb dup flushfile dup opened dup @ 0= IF 2drop exit THEN off >dosfcb closefile Abort" not found!" ; \ Create fcbs UH 10Oct87 : !files ( fcb -- ) dup isfile ! fromfile ! ; ' r@ | Alias newfcb Forth definitions : File ( -- ) Create here >r b/fcb allot newfcb b/fcb erase last @ count $1F and newfcb !name #file newfcb fileno ! file-link @ newfcb nextfile ! r> file-link ! Does> !files ; : direct 0 !files ; \ flush buffers & misc. UH 10Oct87 UH 28Nov87Dos definitions : save-files ( -- ) file-link BEGIN @ ?dup WHILE dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ; ' save-files Is save-dos-buffers \ : close-files ( -- ) file-link \ BEGIN @ ?dup WHILE dup (close REPEAT ; Forth definitions : file? isfile@ .file ; \ print current file : list ( n -- ) 3 spaces file? list ; \ words for viewing UH 10Oct87 Forth definitions | $200 Constant viewoffset \ max. %512 kB files : (makeview ( -- n ) \ calc. view filed for a name blk @ dup 0= ?exit loadfile @ ?dup IF fileno @ viewoffset * + THEN ; : (view ( blk -- blk' ) \ select file and leave block dup 0=exit viewoffset u/mod file-link BEGIN @ dup WHILE 2dup fileno @ = UNTIL !files drop ; \ not found: direct access \ FORGETing files UH 10Oct87 | : remove? ( dic symb addr -- dic symb addr f ) dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; | : remove-files ( dic symb -- dic symb ) \ flush files ! isfile@ remove? nip IF direct THEN fromfile @ remove? nip IF fromfile off THEN file-link BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT file-link remove ; \ print a list of all buffers UH 20Oct86 : .buffers prev BEGIN @ ?dup WHILE stop? abort" stopped" cr dup u. dup 2+ @ dup 1+ IF ." Block: " over 4+ @ 5 .r ." File : " [ Dos ] .file dup 6 + @ 0< IF ." updated" THEN ELSE ." Buffer empty" drop THEN REPEAT ; \ File Interface User words UH 11Oct87 | : same ( addr -- ) >in ! ; : open isfile@ (open offset off ; : close isfile@ (close ; : assign close isfile@ !fcb open ; : make isfile@ dup !fcb (make ; | : isfile? ( addr -- addr f ) \ is adr a fcb? file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ; : use >in @ name find \ create a fcb if not present IF isfile? IF execute drop exit THEN THEN drop dup same File same ' execute open ; \ File Interface User words UH 25May88 : makefile >in @ File dup same ' execute same make ; : emptyfile isfile@ >dosfcb createfile ; : from isfile push use ; : loadfrom ( n -- ) isfile push fromfile push use load close ; : include 1 loadfrom ; : eof ( -- f ) isfile@ dup filesize @ swap record @ = ; : files " *.*" count (dir ; : files" Ascii " word count 2dup upper (dir ; ' files Alias dir ' files" Alias dir" \ extend Files UH 20Nov87 | : >fileend isfile@ >dosfcb size drop ; | : addblock ( n -- ) \ add block n to file dup buffer under b/blk bl fill isfile@ rec/blk over filesize +! false file-r/w IF close Abort" disk full!" THEN ; : more ( n -- ) open >fileend capacity swap bounds ?DO I addblock LOOP close open close ; : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ; 0 Drive: a: Drive: b: Drive: c: Drive: d: 5 + Drive: j: drop \ save memory-image as disk-file UH 29Nov86 Forth definitions : savefile ( from count -- ) \ filename isfile push makefile bounds ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!" b/rec +LOOP close ; \ Status UH 10OCt87 : .blk ( -- ) blk @ ?dup 0=exit dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ; ' .blk Is .status \ No newline at end of file diff --git a/8080/AmstradCPC/GRAFDEMO.SCR b/8080/AmstradCPC/GRAFDEMO.SCR new file mode 100644 index 0000000..5dcc137 --- /dev/null +++ b/8080/AmstradCPC/GRAFDEMO.SCR @@ -0,0 +1 @@ +\ Grafik Demo UH 03Dec86Dieses File enthaelt im Wesentlichen die Definitionen der Grafikdemo vom C64 und vom Atari. Start mit INCLUDE GRAFDEMO.SCR An diesem Beispiel zeigt sich, dass sich mit volksFORTH relativ leicht Programme von einem auf den anderen Rechner uebertragen lassen, auch wenn die Basis (hier das Grafik-Paket) unterschied-lich ist. Natuerlich muss auf spezielle Eigenschaften des LINE-A-Grafic Pakets des Atari verzichtet werden. (z.B. gestrichelte Linien zeichen) Ist die Basis dagegen gleich, wie z.B der Kern aller volksFORTH Systeme, ist eine Uebernahme von Programmen gar kein Problem mehr. \ Demo Loadscreen 05Sep86 \needs Graphics include grafik.scr Onlyforth Graphics also definitions \needs exorwrite include atari.scr \ Atari Grafic-Name Layer \needs 2over include double.scr 1 $0A +thru \ clear moire \ muster kaleidos boxes \ poly lines \ tri.up tri.dn 25feb86 | : yscale [ decimal ] 400 640 */ [ hex ] ; : tri.dn ( dim -- ) >r cur.x @ cur.y @ 2dup r@ yscale - swap r@ - swap 2swap 2over set 2dup r@ yscale - swap r@ + swap draw 2dup r> yscale + draw 2swap draw set ; : tri.up ( dim -- ) >r cur.x @ cur.y @ 2dup r@ yscale - 2swap 2over set 2dup r@ yscale + swap r@ + swap draw 2dup r@ yscale + swap r> - swap draw 2swap draw set ; \ diamond UH 05Sep86 : diamond ( size -- ) >r cur.x @ cur.y @ 2dup swap r@ - swap 2swap 2over set 2dup r@ yscale - draw 2dup swap r@ + swap draw 2dup r> yscale + draw 2swap draw set ; | : big.diamond exorwrite &319 0 &639 &200 &319 &399 0 &200 4 polygon ; \ some usefull definitions 05Sep86 | : center &320 &200 set ; \ | : wrap #esc con! Ascii v con! ; wrap | : logo &117 0 DO ." volksFORTH 83 " LOOP ; | : wait BEGIN pause key? UNTIL &25 0 at getkey #cr = abort" stopped" ; | : titel &21 &24 at ." *** v o l k s F O R T H *** " &22 &31 at ." Line-A Graphic " ; \ patterns example 04Sep86\\ : muster page overwrite 1 pat.mask ! $10 0 DO patterns I 2* + @ pattern ! $10 I $10 * + dup $80 $80 rectangle LOOP 6 pat.mask ! $10 0 DO patterns I 2* + @ pattern ! $110 I $10 * dup >r + $110 r> - $80 $80 rectangle LOOP 1 pat.mask ! wait ; \ kaleidoskop UH 05Sep86 | : kaleid exorwrite home center \ patterns &30 + @ pattern ! 2 0 DO $40 1 DO $140 0 DO I diamond J 2* +LOOP 2 +LOOP LOOP ; : kaleidos page big.diamond kaleid wait ; : kaleid1 page logo kaleid wait ; : diamonds $10 0 DO \ patterns I 2* + @ pattern ! page big.diamond wait LOOP ; \ polygon example 05Sep86 | : (poly ( x y -- ) 2dup >r &100 + r> &10 + 2dup >r &10 + r> &90 + 2dup >r &30 - r> &20 + 2dup >r &50 - r> &35 - 2dup >r &30 - r> &85 - 6 polygon ; \\ : poly page invtrans &10 0 DO patterns I 5 + 2* + @ pattern ! I I * &5 * I &30 * (poly LOOP &10 0 DO patterns I 5 + 2* + @ pattern ! &510 I I * &5 * - I &30 * (poly LOOP wait ; \ moire 27feb86 : moire page curoff exorwrite &640 0 DO I &399 &639 I - 0 line 3 +loop &399 0 DO &639 &398 I - 0 I line 2 +loop titel wait ; \ boxes 05Sep86 : boxes page &162 0 DO I I set I I box &639 I 2* - I set I I box I &399 I 2* - set I I box &639 I 2* - &399 I 2* - set I I box 2 +LOOP wait ; \ linien 27feb86 | : (lines ( abstand -- ) exorwrite &640 0 DO &640 0 DO I &399 J 0 line dup +LOOP dup +LOOP drop ; : lines page home curoff &45 (lines &90 (lines BEGIN &45 (lines key $FF and $0D = UNTIL &25 0 at ; \ moire punkte muster 05Sep86 : kreis.moire page &320 0 DO &199 0 DO I dup * J dup * + &300 / 1 and IF &320 J + &200 I + 1 put.pixel &320 J - &200 I + 1 put.pixel &320 J - &200 I - 1 put.pixel &320 J + &200 I - 1 put.pixel THEN 2 +LOOP LOOP wait ; \ No newline at end of file diff --git a/8080/AmstradCPC/GRAFIK.SCR b/8080/AmstradCPC/GRAFIK.SCR new file mode 100644 index 0000000..69d60ad --- /dev/null +++ b/8080/AmstradCPC/GRAFIK.SCR @@ -0,0 +1 @@ +\ Grafik UH 03Dec86 Diese File enthaelt Definitionen, die die von der Firmware der AMSTRAD-ROMS vorgegebenen Grafikmoeglichkeiten zur Verfuegung stellt. Die Namen der Worte sind an die im Schneider-Handbuch angege- benen Bezeichnungen angelehnt. Da je nach Systemkonfiguration die Schnittstelle zur Firmware anders aussieht, muss der entsprechende Systemteil geladen werden. Dies geschieht durch auskommentieren auf dem LOAD- Screen (Screen 1 von GRAFIK.SCR). Zur Zeit sind zwei Systemkonfigurationen unterstuetzt: 1) Standard 3" Laufwerk mit 38K-CP/M 2) Vortex-X Laufwerk mit 62K-CP/M Sie koennen als Beispiel fuer andere Systemteile dienen. \ Line Graphics Loadscreen UH 03Dec86 Onlyforth include vdos62kx.scr \ Vortex X-Laufwerk 62K-CP/M \ include amsdos.scr \ original Schneider 3" (Amsdos) 38K-CP/M 1 $08 +thru Onlyforth \ Calling ROM UH 29Nov86 Onlyforth Assembler also definitions Create rom IP push jumprom call IP pop ret end-code : getstart ( -- ) W inx xchg M E mov H inx M D mov xchg 'start shld ; \ Calling Operating-System UH 29Nov86Onlyforth Vocabulary OS Assembler also OS also definitions : Sys ( addr -- ) +org Constant ;code ( -- ) getstart rom call Next end-code : >Sys ( addr -- ) Sys ;code ( n -- ) getstart H pop L A mov rom call Next end-code : Sys> ( addr -- ) Sys ;code ( -- n ) getstart rom call A L mov 0 H mvi Hpush jmp end-code : >>Sys> ( addr -- ) Sys ;code ( x y -- n ) getstart H pop D pop rom call A L mov 0 H mvi Hpush jmp end-code \ Calling Operating-System UH 29Nov86 : >>Sys ( addr - ) Sys ;code ( x y -- ) getstart H pop D pop rom call Next end-code : Sys>> ( addr - ) Sys ;code ( -- x y ) getstart rom call dpush jmp end-code \ Graphic-calls UH 29Nov86Onlyforth Vocabulary Graphics OS also Graphics also definitions $BBBA Sys init $BBBD Sys reset $BBC0 >>Sys move $BBC3 >>Sys mover $BBC6 Sys>> cursor@ $BBC9 >>Sys origin $BBCC Sys>> origin@ $BBCF >>Sys width $BBD2 >>Sys heigth $BBD5 Sys>> width@ $BBD8 Sys>> heigth@ $BBDB Sys clearwindow $BBDE >Sys pen $BBE1 Sys> pen@ $BBE4 >Sys paper $BBE7 Sys> paper@ $BBEA >>Sys plot $BBED >>Sys plotr $BBF0 >>Sys> test $BBF3 >>Sys> testr $BBF6 >>Sys line $BBF9 >>Sys liner $BC59 >Sys access \ Farbwahl Graphic UH 29Nov86 Code (ink ( col1 col2 pen -- ) $BC32 +org H lxi 'start shld H pop L A mov H pop D pop IP push L B mov E C mov jumprom call IP pop Next end-code : ink ( colour -- ) dup pen@ (ink ; Code (ink@ ( pen -- col1 col2 ) $BC35 +org H lxi 'start shld H pop L A mov IP push jumprom call D pop 0 H mvi B L mov H push C L mov D IP mvx Hpush jmp end-code : ink@ ( -- col ) pen@ (ink@ drop ; \ Randfarben UH 29Nov86 Code border ( colour -- ) $BC38 +org H lxi 'start shld H pop IP push L B mov L C mov jumprom call IP pop Next end-code Code border@ ( -- colour ) $BC3B +org H lxi 'start shld IP push jumprom call 0 H mvi C L mov IP pop Hpush jmp end-code \ Schneider Farben 05Sep86\\ 0 Constant schwarz &13 Constant weiss 1 Constant blau &14 Constant pastellblau 2 Constant hellblau &15 Constant orange 3 Constant rot &16 Constant rosa 4 Constant magenta &17 Constant pastellmagenta 5 Constant hellviolett &18 Constant hellgruen 6 Constant hellrot &19 Constant seegruen 7 Constant purpur &20 Constant hellesblaugruen 8 Constant hellmagenta &21 Constant limonengruen 9 Constant gruen &22 Constant pastellgruen &10 Constant blaugruen &23 Constant pastellblaugruen &11 Constant himmelblau &24 Constant hellgelb &12 Constant gelb &25 Constant pastellgelb &26 Constant leuchtendweiss \ polygon box rectangle UH 29Nov86 : polygon ( x1 y1 x2 y2 ... xn yn n -- ) -rot 2dup >r >r move 1 DO line LOOP r> r> line ; : box ( width heigth -- ) 0 over liner over 0 liner 0 swap negate liner negate 0 liner ; : rectangle ( x1 y1 width heigth -- ) 2swap move box ; \ No newline at end of file diff --git a/8080/AmstradCPC/HASHCASH.SCR b/8080/AmstradCPC/HASHCASH.SCR new file mode 100644 index 0000000..a456b88 --- /dev/null +++ b/8080/AmstradCPC/HASHCASH.SCR @@ -0,0 +1 @@ +\ HashCash Suchalgorithmus UH 11Nov86 Ein Algorithmus, der die Dictionarysuche beschleunigt: Zuerst wird uebr das gesucht Wort gehasht und in in einer Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normalgesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchenherunter. Hinzu kommen die Worte: cash, hash-thread, erase-cash, 'cash, und found? Im Kernal neudefiniert oder gepatched werden muessen: (find, hide, reveal, forget-words (find und (forget benutzen jejweils die alten Worte. Sie muessenumbenannt oder in die neuen Worte eingebettet werden. \ Hash Cash fuer volksFORTH UH 11Nov86 Create cash $200 allot ' Forth >body Constant hash-thread : erase-cash ( -- ) cash $200 erase ; erase-cash 1 3 +thru patch (find ( patch forget-words ) ' forget-words \ forget-words dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen dup ' (forget >body $12 + ! \ Adresse, sodass das automa- dup ' empty >body 8 + ! \ tische Patchen nicht klappt. ' save >body 4+ ! patch hide patch reveal forget (patch save \ 'cash found? hfind UH 23Oct86 : 'cash ( nfa -- 'cash ) count $1F and under bounds ?DO I c@ + LOOP $FF and 2* cash + ; : found? ( str nfa -- f ) count rot count rot over = IF swap -text 0= exit THEN drop 2drop false ; : (find ( str thread -- str false | nfa true ) dup hash-thread - IF (find exit THEN drop dup 'cash @ 2dup found? IF nip true exit THEN drop hash-thread (find dup 0= ?exit over dup 'cash ! ; \ Kernal changes UH 23Oct86 ' hide >body @ | Alias last? : hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ; : reveal last? IF dup dup 'cash ! 2- current @ ! THEN ; ' clear >body 6 + @ | Alias forget-words | : forget-words erase-cash forget-words ; : .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ; \ patching UH 23Oct86 : (patch ( new old -- ) ['] cash 0 DO i @ over = IF cr I u. over I ! THEN LOOP 2drop ; : patch \ name >in @ ' swap >in ! dup >name 2- context push context ! ' (patch ; \ No newline at end of file diff --git a/8080/AmstradCPC/INSTALL.SCR b/8080/AmstradCPC/INSTALL.SCR new file mode 100644 index 0000000..95552da --- /dev/null +++ b/8080/AmstradCPC/INSTALL.SCR @@ -0,0 +1 @@ +\\ Install Editor Dieses File enthaelt einen Installer fuer den Editor. Es werden nacheinander die Tasten erfragt, die einen bestimmten Befehl ausloesen sollen. Damit ist es moeglich, die Tastatur an die individuellen Beduerfnisse anzupassen. \ install Editor UH 17Nov86 Onlyforth Editor also save warning on : tab &20 col &20 mod - spaces ; : .key ( c -- ) dup $7E > IF ." $" u. exit THEN dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; : install \ install editor's keyboard page ." Entsprechende Tasten druecken. (Blank uebernimmt.)" #keys 0 ?DO cr I 2* actiontable + @ >name .name tab ." : " I keytable + dup c@ .key tab ." -> " key dup bl = IF drop dup c@ THEN dup .key swap c! LOOP ; --> \ define action-names UH 28Nov86: :a ( addr -- adr' ) dup @ Alias 2+ ; actiontable :a up :a left :a down :a right :a push-line :a push-char :a pull-line :a pull-char :a copy-line :a copy-char :a backspace :a backspace :a backspace :a delete-char :a insert-char :a delete-line :a insert-line :a insert-on :a overwrite-on :a erase-line :a clear-to-right :a new-line :a +tab :a -tab :a home :a to-end :a search :a undo :a update-exit :a flushed-exit :a showload :a shadow-screen :a next-Screen :a back-Screen :a alter-Screen :a mark-screen drop warning off install empty UH 17Nov86 \ No newline at end of file diff --git a/8080/AmstradCPC/KERNEL.COM b/8080/AmstradCPC/KERNEL.COM new file mode 100644 index 0000000000000000000000000000000000000000..c97e1371bdf18fb23b30475f03e0829683a62655 GIT binary patch literal 13440 zcmbt5d3;pW)i39*GudV`Stf6?%#vlYOm>S1Bur)|WXvQp%tE9@kYy5sfnX9uNJ6XD zQY%>NQr8xRPb^j23KA+Vg`|K$LkWtlw%Se+tc?W|Y^~ao@0|A%iw#VGpxx(Bt-@K;#wy3$M)@-A?#axSx-RATsyZh1%4 zTu@bG?p?QhWfc2%b$4`|S9Y&o+h^|ExGrj5*<-f%M0@*|_w<>~bFNVMuR=J}cw2YZ zExir?V7Sq7ZMC^4dRv*fy6oDD8_!7T)SO#2+-yd** z0QZ344|*4PTPEa$H~}642vxM1Bms5;1hJ$Q-~|A8pv{yZzq%%q(y$0!{=>j zYBL!H(6VfV#*jsjSvC}y?_ezqGkc^IM93$ArIw9-j&m2`Yls?{-^>>KKxy_+-Et!v zvm(F&5=2-w7?{77MGhc>1npF}Y(@kG5W;QjowdRHScOGBCA~A?E$p4a+GnU6GTnyI zGl;E$AF&Xe|LQbY1?^++4!VQ>z-fZo2vxy+gXKIoc*B1oXp61k3jB|(5NT=ggs?>e zpRs%$VI^^~fqlb&VU?a7CsfQMXdXe2D^M+Da-!!3k1G=P%;91q)u4rPP7HX0C@#&- zTx_$gy&IwN;N-wHe<>GRTfpFgu8xSu6zQe`M{~s=fi>Fm4z>l~%%S%MX)}z#a%0boq!(8l~&4xI!GglB_ z#|F#$DyD53JrRD(L5by4qJP&0+ve}m7>V#Vjw8m!^D(6gJQr$p24p^V7AKYjdY*Mh z0!4i6oKm&$TpiYD^Td?-JOPuTg6BxYTlg`=DnWpUXM_ImQmmg<>Wg@`#T!`5$Ho-= zcAk&4xIMvdAb>jPU_H+{u*dxfID3xPs)H>&7x228cJi^J+0*ON!Q(s^^!t26av{H! zeVQ*}3;AquCz~wRBt4g`;TcW`KjV2MML1irRmC7IBY%LcNxCCh#cmMxa15u1(>z~A z>(vT0vV~`6Z|-R=+1$GXRpHqPw1-8W>{(%r1 zDDN07Czt{56XF~{7RF+O4|Wec-l2eY2ttczfivtmD8x!e9uZPupCGzb(3?o{kq4L6 zGLN^`GC%CDWuEN7X{N$a0o)~@2o`~vz4TVwqIHL2nd7m+d%6d{({Tt9(%>TjDogZY z%!WgxfmVd7l3c8*Rig;iC1q4q>xClJl+=nbJ;%_x8?huPr8Jl&LZxG|h!Z0^L8Rm8 zz?xdU3Hv#2L+pP|QNMKP7P)XR;+c@Arqbb?BH!Tjg|Nmj>99?Vt58c%h;fw@avZ{* z5#y>RWWdtT#JK7SnZ?q}VqDFH%wcIn1P3A#sZkO9Eq@eawNo2xBD`Eg>Qe#V zD8sRe9+seD?rteoq~d164g}O5kYWS- zzvz;^MOzPsh@PuYTNW(>%oi_~PSTxkPHRH&ZEa)S!x8)%f zTsLy3CJXM>u!#9Aftn=+vK=AbmX}osA!Wmh8o_fz*wf3LIwINdwuW;f@X|DJxj&hFMT_lLIIfNJenL&8OcirMC(sIi)y7>f#S<|) z!I!k*%$@82%Wy;TPS(eFv4gyk-z60C1FR8sZc6-C<(KrYktc1+aN$gbq0f-q7{7y~ zb5@mv)lw#I|^=o_kde*P(Ti+91MV+nOX{9Tb z6Sxz2vhK-sV>znx@vp)j&WBTxaS9BV2N2KKHamk&LvmEN9Zw^{UWpeAOQ`oY49QcXMf-6F#kz|9Hn zaHFSXNdALnw|Gs$MVw9n^e4DIr~!v$0!@h`VjKC3@u!s@_a}JjJ?Iw>$(n?{3gm?Z zPiv#shxmIDf3K+0pAs)mNq82A;o@#UuwTuQSiP{TOG|(>-8iJmH#~D_;p3sTf z_Y$b#^8`<%CG16oMraoTv5j9 zUnFLpWbpSO{U#3oJn@(vzLUsCnu~vvI2JqX9vpox@m$C4Zu}X$UUQO(bSW0D2#zK~ zb1}IN&q^e|7A?oTj*>ui;?C>BPWB;TD?6IFQ)wGR4i>@3iE-FxG?AQ(BCsSuRq@x7 zVnuj#il7{8&j*kAcH*lJPBo$VgHoPo}Ov52^ znu=jwk`QSwZ}z+IPP(b{(Ae4W!S4?|dU{>bKy-DwbY^r}(%89M@Vm9`(DFlPuty1O zO5&9cs`v8;jZc}l#0>HcxQx4!4zRS4R9uLUw`da>@_4AFRXl|UrWBq};%Gc_j7Bv( z*_VoC9u1=3UL`HQtqcQ>S$a92$$={^IdRlQ-K^ z4DloPCKoROMHM?>W3r$i*1m8BQ&TdI{}KO<yrYQJw(CN4a zug_PmQ|5{UaO`?ruPuILmTqRIu~t z)opS4n*)jt*r~X~TiG2PX~Rl5q~mO1Z$0VeN_bDl)hd<0>;5b1{eJ=~;jcQj*4v^E zv_Q|+`hvCj0o?&k_3?Qv0Z{Q{URhzI~zxkEn?RwmZSM}BK9AdbfEpPuP#&HGXeZ&~m zi{+tk(A%=$OFeqgK4P4Z7E@vP_E4VH@<=Hp-FE9Vy<^EG|o0lD{ zfz%Wc8@*wtZ(hpSXkH2hD>YD=!bbua2QEw*3&m2?&^j;0wqDyvB;^`dkiy$r{XzHI z6jjvY$BO;>%<;41=kRyq!`-((*>U=@6n0~kUw?a5KtC2cGjcM;=58h_dp-ph_LC6@eAuO(7gK}?%wod2f|OJ*sOkitp8#ErY9Gin-(_;N5{_HYQy%)6nTRU zPu97VubF39Itx~%NIt*Qjk2xeD`vsv6d~k~1nER9#?6?e=n)NCYp*@I;5^%-|3KNh zS&(etXh}n|(a@E`aI@fA10Qe(N%+w*Ff?Q5&-FfZ9d@#B>9?XIK`z8jHYV*7n)Q>o z{jDQpD?JdP01PAfYI%ylMK22*TS#?O07e(L9#A1knK;#qa@(zxE5lDJMGwV z%s`bd4TrFd4oB*Ftj`81^)7pv(rVPrcM!ywI!u5Qx}0g0;#8-d2p26h6yi~w4RccK z%Vr>IA784oZAd0&ye@p0mzJz9eKssjt#8AIpj7`A^B~1!`!TY!%Q+t8}@G6d*XI+D^3ol$+Yobq;{lnX$HwbQ%Pb@ zv0JcF1>T!RhM2ZUt-qOiQtC)6OoQ|@W^7E${a`e}7w zOc&IN;9AmW@#Hnf)sda&m{ASG&4;JcIiE8Wro)25oKA<9z{BZWqt}faH=0gUh>AP7 z3#J_$iO_s_CtV177I{d5s9B56Up4+C{TSvfBf*fD{N<^1+C7!XAm7GC(7EVB))5&) zhQ{06>~VV)2{B0X^D_uMFGE8A8MUknrNJP5lb}urXJ}pM;sx<&yP7s;=p{u)(ajsD zB%%{mX9$goT^y2sj8dk0=_PEoScuX_+T+K_#l7OwJhk-0JINa|?f`-j@$Y7!p>+n- zt_DdU+vtR&89YI83r}V=vB}6Ta-Gx&ppbts<75VfFefvJ;<5Bej@F7=WI9QE$UwTi z9^T6k>~max;^j`37@Q;1p!Hxg9(MaZp;}T3rAC7^`jqa3PH$v57tA&CbvU$}cEts) z#<+nYd6|)7n$zMkBXxH{)ab@NKxdvR{YKmk?}F*tcZ?0li!0S17{yj+um!D_y30RP zDA81C*WSt|b`C8SSq@n*)h=wbRnI#+*Dc1XbCK)n`xsNXt&a5gP@~B+3im4Ov39j3=%I zPvWXfWplKek0PoAvB4^O+tf%;KRi+w4H^RSUAu@ds3wbj#vq3OOQ(IB-Bu09p zJxJbwoBtm<|EYnjY2Qu!P;`U;O5WFUId%aGyaH}#& zRPk8Pa5aIU7_}cmP!TmMN|d0SupxPi7_;&#dzSa!Ohc?T@orCpI>wavr0L3X#xdva zh38GM2ybEh|KZGf;e<&6n{Vie484by&OocqHkhYO(+2Umr!+GIT z6Ni~djBQWhCZI8TO#0HAw&==Ll^Ji6R^Fnp;W8rZ6;GKamA#_A#w;%E58*^$^a|;x&u29?dFwzAD>^^-&!O?l%11!<8CG^+wuy>TzopuiQpGn#C}gcrAB5 z?99R}xIavQ>&jltx*qmrasCz`k~?MkM0_5CdX>p6s5vT2#>2_ci< z9%y)E9b7iDKirUhP5<}xH>CPo~~T!t#E2@KghdVsVY zr%ZE^ZS83LE@&OuwAwedel410+Xa&YM{I&Q**v+6)6{7550{?Ae4$0FW8N#J^!zfp z&n9ZmPmyJzW7o!QWd->F8rdrc?=*&yXin5~*otX?v^Z+zbyWAw(2>pCao+B?vtwh2 z<@33IgQ6<-4gW3skcrYTs82SZ&wcs$m)WtA_p{H~oE(2VB}ab!cw){NL2QPRsq8UK za$|@dky_x_*%R4Vim99T zQO%G?(gN8zafPa9m%x3A_M2esImebvM{YL`$*XfHWNU#qPKS3SK4+nE3yjN(T#N|QLshj|u z&k+=FJ$TTRmm7f3ax@sdd4hqU2hYS}^PPsD<|J@TF1c^C9eFvV#YPIUXl|X7e56e}q1&HJGgJHTv!J9shDt8Jue0OkKJ|c4rIX{6 zI<3A@TgxKueV;g9LYgVr-MO-_vwJOGT`QV^;X?31u283VI7`f^`7jR4M0HE|rh^X- zJU+a^JbDX=W{hj8QBoRXn_hi)n|XMfx&O7(4#0LI9UoHkOLWb;zKxh*g@9QsqnIcX zI%v8dC`G$dnRghTHGeA*2{jT!D3wLQ|5kRNc`Hjv(l8t{^O!oOoWbe*H_RHt8|FXb z?_%_3$)hE2b}@dUc8y^V_o6uk?MxW{WaiW^vrx>oi+{oSMj+L~WAcs&QDE30m@EV> zvT)(XU_^2H`F3RL1+B^Q0v>*9tivw<*;;v}wawykIM873#!!D!3He`C2HIp1P^$#O zxTHPk2X>(cxJ#(Vq*4SPu%H1@T1r^*5h*cEEsNj`s~&(vrpA$z3OAZX zoE2JGbN4MZ4jN$*9JL54?m^R-Wf6R8;q40}UhMgA%eV9?DD?kCpoB<5%0;hSqZTSw+l_I+Zl9w%awF!PTU7@RJbq325gQ z!3ry{)P`h#{)UWOtU+r95^057t!&7JuLR-r zNh!#e&BK_lG>!Oei(!rp>U|TknOO|WZ9FD}D7VmVE5?|5F?87k1%jt@JLZrjrq8Ad z&yf6*jy$Qa!)6=T==YKQijUYPxkqd$5_sUh4o}-)u5Czu#P*1dPVm>^fDLRYPlW>E zJYplKp1>z;TuAYxDQF`9!trDDw!RL3w#8w03S*Ziw_y~D>D1e&F+}osDjEb8@e8C& zhRZffsL)sx;aCE;Jl0)?rtdy}ke|@}(q_+V<3F;UvbAA&@(hyNC2X-#4qypfn+Jqw zF9ug{;p5cNqa{^T-!m0$cLpus*8Us&sfX4by)se9_RChQ0Pf` za#FbvzL5EzmHJ-F+m1Q@JUl-a(1v&5gb040{et$xy!@mFOk^y;rO`gs-~w-i&+{~R z`$eMQ@+{1+)mGtc6x(erqZb%Af-4{MLg*P%d3io678hRFkTq>$$&w0qDRCatmgFc& zOlLk>oF>#{w52z~ntXhwG1H|lpX@@c1Rs^qRTbIx&*=flAslBZ{3u`WhA5HMX3AO$ z$MU5HR0nEei(!_+Z}T}cZj0zp(Pt_AC7-V^ua7iL$P%{{K38hKCcJOP>nyXGJcXBs z%L;6pf1!N8qI@5S9a{!sfnay}gPyv11xh+kpEMK59*UhioH<@Rkw2PIFdQuy8zT*W zZsaelHLZYV`_l031v9xf6=l3Qt$^}!@&*%j8^>oICDw`jktGEypsGN!yS4F zlbV9oth>iz#)nqj_$H|jP0p_!=$5Y*C}|R$lqjwem#@IrP-OI0z+(mCboYa%|3P~1 z6tKZ^3;{1x6Z;#`k)iY8XDGg=gos63%}ijT;{*Hzt%Tu2uZ&#Vr?Gvzc(K5u)uSR6 zHuQA%Ma^dmMD6dV<|>`1#Hnwr#nR#!=ZSLG*&4iy)#8=rXl%azA7mx7>1G4sOD`f+P_X+ z%J0LrO9h05UKl$|IDiIHC4K-+$R2JdOOv>i|7^ZWNevQ{(6-MogD%EaLAVfa0C0PU zj)b2${JAB(NL;~*VyvjE(<|C8DWRWyqJ3MOF(F-$& z+aGeMl+Y{qd38IyWKU2Urh#~^gIxJXp&I;N!X5i`>Zo1iKs$`u6O~<>A)#W^NQAFN zzAVF4P9kTCW9{&Top10dp2i>S+9HPQfZ`(F=WX_e>5)bU%q`*@@NQIzu{z-TqIe~S zoLOnG2y;)k)w_haf^2aG=Gx*4UKfHzlN`0sSTr)p(8YW@`yFsYkrr<#Jy#QO7sVCq z!p8&_Z5cz|E)}Q(LFHZOm`W%XbiYY;@(%XkAT$J#dt8~&SBoW__9FTwH8hDkM&k8} z=tkHc?lW8=A@SyA?(M z084#H0(0aQO2AXb9AGIK@a_~rO~n?iksXzHpzu1>3mz-QixNNOH-G0KQ@Xo!cPS~XE_kh!t#hH_*y8vw zZ>wbG$Wl|Xp^$${mn|ykg*NU3MfElzo7TW@OGWju=yZk&^A8^=99#pEgY)1i|E!c* z12zY^f}fSb8Yp*g;l%;ZXQkMAwu8l23!jw=Yrx~+0?q{pmev41W_4mW?HXuvu+DJZ zXQc^ipxuE_16zmWE(iIbYv5J~>+)kBy30WU?SIX2;;K2`;SiK3tY1xWVtR_tJJ=@A z;wKz9!y^t3i*-*paE@aR0dGn$bNhq?M|#hJ&x8UVSNI8suoj>1av>!FJ|(`MMaF3@ zeD27jgvn^uT1Y6%SMny$VL78LU&&o`XRifYSstZ@auHl!R&rIE#FE_&;|{5i65meM z*C&yPx9-o)x6ZC^Et?XpC=@&j#guqI?9W|e-H;KqrsR^p-VMGoz7W}f(K$)`521-w zB>~eNlr9WBpxKI-ZwJ_S@WIX1H>8)c;)|<_zE}2PRx5e~#w|7-PtIV6 zM^ry7D^86gpGlt(msCd%N8<3Mvbcw5z~oV>!RYwsdhLumGmgGh?MPJxV|g*(TFIc7 zbt}AIhVPk`70xM-yRmHK@(c-gGtwSco}q5~#c*?Z|I7I0ZY~y>GRE3aq-QQ>TGQk7 z%)c_N>Qu&W>cqECBV1f8ruanaFBiB`I09OS^{f6YC3KH}UuowY|hWb?j z+zz@5)>e<+xWwEJ{aAJdC*(vdZ^5z;{ZcKKAFSYPo{(!oHeqEuR>IEu30Z@c=dpr^ zZbJSBR$j(RJyk@k9Krq#*gpZwZ&siHv{;7ZqvA~!40k*Hv4XeL`Jh;1uUJ%Z5*Be*JAykr=Xw^f|4cnm)TYei}}<01JD1hm`ESI{pt+=30L9%$t4cn~+j zw<@`?H-NV}6cl1MO;@ah8^p(r@NgwLw)kvgvC+{~d1K|1l|7aBL!odl&W%*OmFuab zE5}W+r&7cL)tj3;D(G@fU`|$^XAfRg-lmij(5$s%9;DAku}HCl{Kp2o+BD)-SF%Fu z4@gVZ9vHnMCWc5DaFfX;^Y&}UdCcZtP>kRvuvbaQwR%711730DRsOT$d}UP?!}UYB z3S$nuTbq!-$@IgTD*D@ia(pX6G7uHf4|rNA;Gu5GO%+cnL%va^aryiq%;%~Nx|xPQRdMcS zCrXAvl2sC)S8+I>`2?{vDMaI|38LUw2{HivRiZn%h;qXRP0iKe%oSY&kX?=U(GAXs z4`(#5`V;YmD!Qa^x6y^FqQ9be;r@Y+8u0QBU5nG`;r$suZ&t;u8JMVBzP_u^+)jx^ z%G|Z%A8o9%%&Vq!-vGF(6P5Wpt{P$o_mGgly-@Wr_Rn0od~IQ$d1Y63ZNLgl+-{p}d;2WB8-K38y>M?6uuycV`dUcKqqR#q9N)d)Kd9r-V-yGrbnSyDC4) z$N!;vyAlX>;mzqzwvA6Nn5}KsUWa)urg|2-M_MMOT7!<2j>)T5yk=pG=+{y<_^Y0~ zk=i7;zKTL}HKN!IA682Ne<dyJ|@KX(z~2Anm_Ppl@HY5k;DWa5LOq z!QfKkk zWL5N$HmhyHZ1IHbfIhfb!#7g$a6&G{+P`afw^}Q~+B-FpVgd1QVCaUjmf2tatK=i) zRYixd6MwbeTvWN?SEIWRkDfbx#5wx&!=p7v_S;h~Yp>P3t^Ip#B|;{SR1o}zBcm@L g8U2V5tFAvXI(GC|e>$T7?%^}ny>WE^Fq|0uU%DQAlK=n! literal 0 HcmV?d00001 diff --git a/8080/AmstradCPC/MATHE.SCR b/8080/AmstradCPC/MATHE.SCR new file mode 100644 index 0000000..e33ab02 --- /dev/null +++ b/8080/AmstradCPC/MATHE.SCR @@ -0,0 +1 @@ +\ Mathematics calculating sin & cos nach FD IV 1 6UH 03Dec86 Dieses File enthaelt Definitionen zur Berechnung von Integer-Sinus und -Cosinus. Sie werden z.B. von der Turtle-Grafik benutzt. \ Mathematics calculating sin & cos nach FD IV 1 6 05Sep86 Create sintab decimal 0000 , 0175 , 0349 , 0523 , 0698 , 0872 , 1045 , 1219 , 1392 , 1564 , 1736 , 1908 , 2079 , 2250 , 2419 , 2588 , 2756 , 2924 , 3090 , 3256 , 3420 , 3584 , 3746 , 3907 , 4067 , 4226 , 4384 , 4540 , 4695 , 4848 , 5000 , 5150 , 5299 , 5446 , 5592 , 5736 , 5878 , 6018 , 6157 , 6293 , 6428 , 6561 , 6691 , 6820 , 6947 , 7071 , 7193 , 7314 , 7431 , 7547 , 7660 , 7771 , 7880 , 7986 , 8090 , 8192 , 8290 , 8387 , 8480 , 8572 , 8660 , 8746 , 8829 , 8910 , 8988 , 9063 , 9135 , 9205 , 9272 , 9336 , 9397 , 9455 , 9511 , 9563 , 9613 , 9659 , 9703 , 9744 , 9781 , 9816 , 9848 , 9877 , 9903 , 9925 , 9945 , 9962 , 9976 , 9986 , 9994 , 9998 , 10000 , : sintable ( deg -- sine*10000 ) 2* sintab + @ ; --> \ sin 05Sep86 : s180 ( deg -- sine*10000 ) dup 90 > IF 180 swap - ( reflect ) THEN sintable ; : sin ( deg -- sine*10000 ) 360 mod dup 180 > IF 180 - s180 negate exit THEN s180 ; : cos ( deg -- cosine*10000 ) 90 + sin ; hex \ No newline at end of file diff --git a/8080/AmstradCPC/PORT8080.SCR b/8080/AmstradCPC/PORT8080.SCR new file mode 100644 index 0000000..c0bf563 --- /dev/null +++ b/8080/AmstradCPC/PORT8080.SCR @@ -0,0 +1 @@ +\ 8080-Portzugriff UH 11Nov86 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit Adressen anzusprechen. Der Code ist leider selbstmodifizierend, da beim 8080 die Portadresse im Code ausdruecklich angegeben werden muss. Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen, kann auch das File portz80.scr benutzt werden, indem die Z80-IO-Befehle (16Bit-Adressen) benutzt werden. \ 8080-Portzugriff pc@, pc! 15Jul86 ' 0 | Alias patch Code pc@ ( addr -- c ) H pop L A mov here 4 + sta patch in 0 H mvi A L mov Hpush jmp end-code Code pc! ( c addr -- ) H pop L A Mov here 6 + sta H pop L A mov patch out Next end-code \ No newline at end of file diff --git a/8080/AmstradCPC/PORTZ80.SCR b/8080/AmstradCPC/PORTZ80.SCR new file mode 100644 index 0000000..1e11c85 --- /dev/null +++ b/8080/AmstradCPC/PORTZ80.SCR @@ -0,0 +1 @@ +\ Z80-Portzugriff UH 05Nov86 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit Adressen anzusprechen. Einige Komputer, so die der Schneider Serie dekodieren ihre Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit Adressen angesprochen werden muessen. Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen. \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86 Assembler definitions | : Z80-io ( base -- ) \ define special Z80-io instruction Create c, Does> ( reg -- ) $ED c, c@ swap 8 * + c, ; $40 Z80-io (c)in $41 Z80-io (c)out Forth definitions --> \ store and fetch values with 16-bit port-adresses UH 05Nov86 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr H pop IP push H B mvx L (c)in 0 H mvi IP pop hpush jmp end-code Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr H pop D pop IP push H B mvx E (c)out IP pop Next end-code \ No newline at end of file diff --git a/8080/AmstradCPC/PRIMED.SCR b/8080/AmstradCPC/PRIMED.SCR new file mode 100644 index 0000000..e4194d3 --- /dev/null +++ b/8080/AmstradCPC/PRIMED.SCR @@ -0,0 +1 @@ +\\ Primitivst Editor zur Installation UH 17Nov86 Da zur Installationszeit der Full-Screen Editor noch nicht funtionsfaehig ist, muessen die zu aendernden Screens auf eine andere Weise ge{nder werden: mit dem primitivst Editor PRIMED, der nur ein Benutzer wort enthaelt: Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen, dann mit "ll NEW" den Screen aendern. Es koennen immer nur ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW. Nach jeder Eingabe von RETURN wird die eingegebene Zeile in den Screen uebernommen, und der ganze Screen zur Kontrolle nocheinmal ausgegeben. \ primitivst Editor PRIMED UH 17Nov86 | : !line ( adr count line# -- ) scr @ block swap c/l * + dup c/l bl fill swap cmove update ; : new ( n -- ) l/s 1+ swap ?DO cr I . pad c/l expect span @ 0= IF leave THEN pad span @ I !line cr scr @ list LOOP ; \ PRIMED Demo-Screen Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender Eingabe dieses Textes Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit "0 NEW" erzeugt. Ulrich Hoffmann \ No newline at end of file diff --git a/8080/AmstradCPC/PRINTER.SCR b/8080/AmstradCPC/PRINTER.SCR new file mode 100644 index 0000000..b642433 --- /dev/null +++ b/8080/AmstradCPC/PRINTER.SCR @@ -0,0 +1 @@ +\\ Printer Interface 08Nov86 Dieses File enthaelt das Printer Interface zwischen volksFORTH und dem Drucker. Damit ist es moeglich Source-Texte auf bequeme Art und Weise in uebersichtlicher Form auszudrucken (6 auf eine Seite). In Verbindung mit dem Multitasker ist es moeglich, auch Texte imHintergrund drucken zu lassen und trotztdem weiterzuarbeiten. \ Printer Interface Epson RX80 18Aug86\ angepasst auf M 130i 07dec85we Onlyforth Variable shadow capacity 2/ shadow ! \ s. Editor Vocabulary Printer Printer definitions also | Variable printsem printsem off 01 +load 04 0C +thru \ M 130i - Printer \ 01 03 +thru 06 0C +thru \ Fujitsu - Printer Onlyforth \ Printer p! and controls UH 02Nov87 | : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ; : p! ( n --) BEGIN pause stop? IF printsem unlock true abort" stopped! " THEN ready? UNTIL [ Dos ] 5 bios ; | : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ; 07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET 1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF 0F | ctrl: (+17cpi 12 | ctrl: (-17cpi \ Printer Escapes 24dec85 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; \ Printer Escapes 29jan86 Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii P on: (10cpi Ascii P off: (12cpi : 10cpi (-17cpi (10cpi ; : 12cpi (-17cpi (12cpi ; : 17cpi (10cpi (+17cpi ; : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Escapes 16Jul86 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark Ascii 4 esc: +cursive Ascii 5 esc: -cursive Ascii M esc: 12cpi Ascii P | esc: (-12cpi : 10cpi (-12cpi (-17cpi ; : 17cpi (-12cpi (+17cpi ; ' 10cpi Alias pica ' 12cpi Alias elite \ Printer Escapes 16Jul86 | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii p on: +prop Ascii p off: -prop : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Output 04Jul86 : prinit ; \ initializing Printer | Variable pcol pcol off | Variable prow prow off | : pemit ( 8b --) p! 1 pcol +! ; | : pcr ( --) RET LF 1 prow +! pcol off ; | : pdel ( --) DEL pcol @ 1- 0 max pcol ! ; | : ppage ( --) FF prow off pcol off ; | : pat ( row col --) over prow @ < IF ppage THEN swap prow @ - 0 ?DO pcr LOOP dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; | : pat? ( -- row col) prow @ pcol @ ; | : ptype ( adr len --) dup pcol +! bounds ?DO I c@ p! LOOP ; \ Printer output 28Jun86 | Output: >printer pemit pcr ptype pdel ppage pat pat? ; Forth definitions : print >printer normal ; : printable? ( char -- f) bl Ascii ~ uwithin ; \ Variables and Setup 23Oct86 Printer definitions $00 | Constant logo | Variable pageno | Create scr#s $0E allot \ enough room for 6 screens | : header ( -- ) 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV " 5 spaces file? -dark 1 pageno +! 17cpi ; \ Print 2 screens across on a page 03dec85 | : text? ( scr# -- f) block dup c@ printable? IF b/blk -trailing nip 0= THEN 0= ; | : pr ( scr# --) dup capacity 1- u> IF drop logo THEN 1 scr#s +! scr#s dup @ 2* + ! ; | : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r pad $101 bl fill swap block r@ + pad c/l cmove block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ; | : 2scr ( scr#1 scr#2 --) cr cr $1E spaces +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark cr l/s 0 DO 2dup I 2pr LOOP 2drop ; \ Printer 6 screens on a page 03dec85 | : pr-start ( --) scr#s off 1 pageno ! ; | : pagepr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ; | : shadowpr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ; | : pr-flush ( -- f) scr#s @ dup \ any screens left over? IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN 0<> ; \ Printer 6 screens on a page 23Nov86Forth definitions : pthru ( first last --) printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN LOOP pr-flush IF pagepr THEN printsem unlock ; : document ( first last --) isfile@ IF capacity 2/ shadow ! THEN printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr I shadow @ + pr THEN scr#s @ 6 = IF shadowpr THEN LOOP pr-flush IF shadowpr THEN printsem unlock ; : listing ( --) 0 capacity 2/ 1- document ; \ Printerspool 03Nov86 \needs Task \\ | Input: noinput 0 false drop 2drop ; $100 $200 noinput Task spooler keyboard : spool ( from to -- ) isfile@ spooler 3 pass isfile ! pthru stop ; \ No newline at end of file diff --git a/8080/AmstradCPC/READ.ME b/8080/AmstradCPC/READ.ME new file mode 100644 index 0000000..3d9232c --- /dev/null +++ b/8080/AmstradCPC/READ.ME @@ -0,0 +1,123 @@ +[nderungen im CP/M-volksFORTH von Version 3.80 zu Version 3.80a UH 04M{r88 +============================================================================= + +Die Unvertr{glichkeit des urspr}nglichen CP/M-volksFORTHs mit CP/M+ und die +damit verbundene Vielzahl von unterschiedlichen Versionen hat eine allgmeine +]berarbeitung des CP/M-volksFORTHs notwendig gemacht. +Bei dieser Gelegenheit wurden gleich einige Fehler beseitigt und einige +neue Funktionen eingef}hrt. + +1. [nderungen im Kern (SOURCE.SCR) + + - Die Terminal-Ein- und Ausgabe wurde auf ein Mindestma~ begrenzt, + soda~ auch unmittelbar mit dem Kern gearbeitet werden kann. + Es gibt keinen Zeileneditor f}r die Eingabezeile mehr, dieser wurde + zusammen mit der "Terminal:" Funktion in das File XINOUT.SCR ausgelagert. + + - Der Kern enth{lt kein Fileinterface mehr, sondern arbeitet nur in dem + File, da~ bei Aufruf in der Kommandozeile mit angegeben wird (default- + file). Typischerweise wird mit diesem Mechanismus zuerst das + File-Interface geladen. + + - Direkter Diskettezugriff wird im Kern nicht mehr unterst}tzt, da er + unter CP/M+ nicht problemlos zu implementieren ist. Au~erdem kann + in Ermangelung eines CP/M+ Systems der Code hier nicht getestet werden. + Diskettenzugriff findet nur noch }ber das BDOS statt. + + - Zahlreiche Funktionen des Kerns wurden neu }berarbeitet und in Code + geschrieben, als wichtige neue Funktion des Kerns ist "search hinzu- + gekommen, das eine schnelle Suche mit Ber}cksichtigung der Gro~/Klein- + schreibung erm|glicht. + + - Die Funktion CAPITALIZE ist durch die {hnliche Funktion UPPER ersetzt + worden. Das EXIT in NAME verschiebt sich dadurch. + + - Der Kern gibt beim Verlassen eine Gr|~enangabe in (256 Byte)-Seiten aus. + Diese Angabe kann direkt benutzt werden, um mit dem CP/M SAVE Kommando + das System auf Diskette zu schreiben. (Forth: SAVE nicht vergessen! ) + + - SAVE-BUFFERS ist um ein defered Wort SAVE-DOS-BUFFERS erweitert worden. + Damit sollte der l{stige CP/M+ Fehler ausgeschaltet sein. + + - Das defered Wort POSTLUDE regelt die letzte Handlung des Systems vor dem + CP/M Warmstart (Cursor anschalten, Bildschirm l|schen oder Systemgr|~e + ausgeben...) + + - Die Kommandozeile des Aufrufs wird in den TIB kopiert und kann dort + interpretiert werden. Das \ffnen des default-Files l|scht allerdings den + TIB wieder, soda~ diese Funktion erst ausgenutzt werden kann, wenn das + Fileinterface geladen ist. (DRVINIT |ffnet nicht mehr das default-File.) + + - Die Interpret-Loop wurde }berarbeitet und um das Wort PROMPT erweitert. + Das Sonderwort >INTERPRET ist weggefallen. Seine Funktion uebernimmt + jetzt das (normale) defered Wort PARSER. + + - Die Kontrollstruktur-Anweisungen (IF, WHILE ... ) sind jetzt auch inter- + aktiv verwendbar. + + - Diverse kleinere [nderungen haben stattgefunden. + + +2. [nderungen im Editor (EDITOR.SCR, STRING.SCR) + + - Das Markieren der Screens wurde korrigiert und geschieht jetzt auch + beim Suchen/Ersetzen und bei showload richtig. + + - VIEW wurde ge{ndert und sucht nun nach dem in Blanks eingerahmten Wort. + + - Es wird nun zus{tzlich das Associative File angezeigt. + + - Beim Suchen/Ersetzen wird die Screennummer hochgez{hlt, um eine Kontrolle + }ber das Suchen zu geben. + + - Die Textsuche ist nun schon im Kern definiert, die elementaren String- + funktionen sind mit in das EDITOR.SCR genommen worden. STRING.SCR ist + daher entfallen. + + +3. [nderungen im Multi-Tasker (TASKER.SCR) + + - Das Wort TASK wurde ge{ndert: Die Konstante ist nun vor der Task + definiert. Man kann also nun mit FORGET tats{chlich die Task + vergessen. + + - Der PAUSE/WAKE/STOP-Mechanismus wurde ge{ndert. In der benutzung ergibt + sich daraus keine [nderung. + + +4. [nderungen im Fileinterface (FILEINT.SCR) + + - Das Fileinterface wurde }berarbeitet und einige Fehler beseitigt. + Die Namen zahlreicher Worte haben sich ge{ndert, sind dadurch aber + systematischer geworden. Die Funktionen sind im Wesentlichen gleich + geblieben. + + +5. Terminal-Installation (Zusatz zu Anpassung von volksFORTH an den Computer) + + - Da der Kern kein Fileinterface mehr enth{lt, mu~ dies noch vor + dem Primitivst-Editor geladen werden. Es ergibt sich also die Kommando- + sequenz: + A> kernel fileint.scr + 1 load + use primed.scr 1 load + use terminal.scr + + +6. Erstellen eines Standard-Systems + + - Mit folgender Kommandosequenz wird aus KERNEL.COM das File + VOLKS4TH.COM gemacht: + + A> kernel fileint.scr + 1 load + include startup.scr + +7. Neue Files auf der Diskette + + - READ.ME dieses File + - XINOUT.SCR Terminalfunktionen und Zeileneditor f}r Eingabe + - COPY.SCR Die Funktionen COPY und CONVEY (fr}her im Kern). + + - STRING.SCR Entf{llt, da in EDITOR.SCR und SOURCE.SCR integriert. + \ No newline at end of file diff --git a/8080/AmstradCPC/RELOCATE.SCR b/8080/AmstradCPC/RELOCATE.SCR new file mode 100644 index 0000000..832e6bd --- /dev/null +++ b/8080/AmstradCPC/RELOCATE.SCR @@ -0,0 +1 @@ +\\ Relocate System 11Nov86 Dieses File enthaelt das Utility-Wort BUFFERS. Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen, die volksFORTH benutzt. Voreingestellt sind 4 Buffer. Benutzung: nn BUFFERS \ Relocate a system 16Jul86 | : relocate-tasks ( mainup -- ) up@ dup BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ; | : relocate ( stacklen rstacklen -- ) 2dup + b/buf + 2+ limit origin - u> abort" kills all buffers" over pad $100 + origin - u< abort" cuts the dictionary" dup udp @ $40 + u< abort" a ticket to the moon with no return ..." flush empty over + origin + origin $0A + ! \ r0 origin + dup relocate-tasks \ multitasking link 6 - origin 8 + ! \ s0 cold ; --> \ bytes.more buffers 29Jun86 | : bytes.more ( n+- -- ) up@ origin - + r0 @ up@ - relocate ; : buffers ( +n -- ) b/buf * 4+ limit r0 @ - swap - bytes.more ; \ No newline at end of file diff --git a/8080/AmstradCPC/SAVESYS.SCR b/8080/AmstradCPC/SAVESYS.SCR new file mode 100644 index 0000000..a07add8 --- /dev/null +++ b/8080/AmstradCPC/SAVESYS.SCR @@ -0,0 +1 @@ +\\ savesystem 11Nov86 Dieses File enthaelt das Utility-Wort SAVESYSTEM. Mit ihm kann man das gesamte System als File auf Disk schreiben. Achtung: Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM der Heap geloescht! Benutzung: SAVESYSTEM \ savsystem 05Nov86 : savesystem \ filename save $100 here over - savefile ; \\ Einfaches savesystem 18Aug86 | : message ( -- ) base push decimal cr ." ready for SAVE " here 1- $100 / u. ." VOLKS4TH.COM" cr ; : savesystem ( -- ) save message bye ; \ No newline at end of file diff --git a/8080/AmstradCPC/SEE.SCR b/8080/AmstradCPC/SEE.SCR new file mode 100644 index 0000000..d91fa7d --- /dev/null +++ b/8080/AmstradCPC/SEE.SCR @@ -0,0 +1 @@ +\ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86 Dieses File enthaelt einen Decompiler, der bereits kompilierte Worte wieder in Sourcetextform bringt. Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang erkannt und umgeformt. Ein Decompiler kann aber keine (Stack-) Kommentare wieder herzaubern, die Benutzung der Screens und dann view, wird daher staerkstens empfohlen. Denn: Es ist immernoch ein Fehler drin! Und um den zu korrigieren, ist der Sourcetext dem Objektkode doch vorzuziehen. Benutzung: see \ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86 Onlyforth Tools also definitions 1 13 +thru \\ Produces compilable Forth source from normal compiled Forth. These source blocks are based on the works of Henry Laxen, Mike Perry and Wil Baden volksFORTH version: U. Hoffmann \ detacting does> 01Jul86 internal ' does> 4+ @ Alias (;code ' Forth @ 1+ @ Constant (dodoes> : does? ( IP - f ) dup c@ $CD ( call ) = swap 1+ @ (dodoes> = and ; \ indentation. 04Jul86Variable #spaces #spaces off : +in ( -- ) 3 #spaces +! ; : -in ( -- ) -3 #spaces +! ; : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; \ case defining words 01Jul86 : Case: ( -- ) Create: Does> swap 2* + perform ; : Associative: ( n -- ) Constant Does> ( n - index ) dup @ -rot dup @ 0 DO 2+ 2dup @ = IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; \ branching 04Jul86 Variable #branches Variable #branch : branch-type ( n -- a ) 6 * pad + ; : branch-from ( n -- a ) branch-type 2+ ; : branch-to ( n -- a ) branch-type 4+ ; : branched ( adr type -- ) \ Make entry in branch-table. #branches @ branch-type ! dup #branches @ branch-from ! 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } \ branching 01Jul86 : branch-back ( adr type -- ) \ : make entry in branch-table & reclassify branch-type.) over swap branched 2+ dup dup @ + swap 2+ ( loop-start,-end.) 0 #branches @ 1- ?DO over I branch-from @ u> IF LEAVE THEN dup I branch-to @ = IF ['] while I branch-type ! THEN -1 +LOOP 2drop ; \ branching 01Jul86: forward? ( ip -- f ) 2+ @ 0> ; : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] if branched exit THEN ['] until branch-back ; : branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] else branched exit THEN ['] repeat branch-back ; : (loop)+ ( ip -- ip' ) dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; : string+ ( ip -- ip' ) 2+ count + even ; : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; \ classify each word 25Aug86Forth &15 Associative: execution-class ] clit lit ?branch branch (do (." (abort" (;code (" (?do (loop (+loop unnest (is compile [ Case: execution-class+ 3+ 4+ ?branch+ branch+ 2+ string+ string+ (;code+ string+ 2+ 4+ 4+ 0= 4+ 4+ 2+ ; Tools \ first pass 01Jul86 : pass1 ( cfa -- ) #branches off >body BEGIN dup @ execution-class execution-class+ dup 0= stop? or UNTIL drop ; \ identify branch destinations. 04Jul86: thru.branchtable ( -- limit start ) #branches @ 0 ; : ?.then ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< IF I branch-type @ dup ['] else = swap ['] if = or IF -in ." THEN " ind-cr LEAVE THEN THEN THEN LOOP ; : ?.begin ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< not IF I branch-type @ dup ['] repeat = swap ['] until = or IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN LOOP ; ( put "BEGIN" and "THEN" where used.) \ decompile each type of word 01Jul86 : .word ( ip -- ip' ) dup @ >name .name 2+ ; : .(word ( ip -- ip' ) dup @ >name ?dup 0= IF ." ??? " ELSE count $1f and swap 1+ swap 1- type space THEN 2+ ; : .inline ( val16b -- ) dup >name ?dup IF ." ['] " .name drop exit THEN . ; : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; : .string ( ip -- ip' ) .(word count 2dup type Ascii " emit space + even ?.then ; : .unnest ( ip -- 0 ) ." ; " 0= ; \ decompile each type of word 01Jul86 : .default ( ip -- ip' ) dup @ >name ?dup IF c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; : .compile ( ip -- ip' ) .word .word ?.then ; \ decompiling conditionals 04Jul86 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; 5 Associative: branch-class ' if , ' while , ' else , ' repeat , ' until , Case: .branch-class .if .else .else .repeat .repeat ; : .branch ( ip -- ip' ) #branch @ branch-type @ 1 #branch +! dup >name swap branch-class .branch-class ; \ decompile Does> ;code 04Jul86 : .(;code ( IP - IP' f) 2+ dup does? IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; \ classify word's output 01Jul86 Case: .execution-class .clit .lit .branch .branch .do .string .string .(;code .string .do .loop .loop .unnest .['] .compile .default ; \ decompile colon-definitions 04Jul86 : pass2 ( cfa -- ) #branch off >body BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class dup 0= stop? or UNTIL drop ; : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; : .immediate ( cfa - ) >name c@ dup ?ind-cr 40 and IF ." IMMEDIATE " THEN ?ind-cr 80 and IF ." RESTRICT" THEN ; : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; \ display category of word 01Jul86external Defer (see internal : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; : .user-variable ( cfa - ) ." USER " dup >name dup .name 3 spaces swap execute @ u. .name ." ! " ; : .defer ( cfa - ) ." deferred " dup >name .name ." Is " >body @ (see ; : .other ( cfa - ) dup >name .name dup @ over >body = IF drop ." is Code " exit THEN dup @ does? IF .does> exit THEN drop ." is unknown " ; \ decompiling variables and constants 01Jul86 : .constant ( cfa - ) dup >body @ u. ." CONSTANT " >name .name ; : .variable ( cfa - ) ." VARIABLE " dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; \ classify a word UH 25Jan88 5 Associative: definition-class ' quit @ , ' 0 @ , ' scr @ , ' base @ , ' 'cold @ , Case: .definition-class .: .constant .variable .user-variable .defer .other ; \ Top level of Decompiler 04Jul86 external : ((see ( cfa -) #spaces off cr dup dup @ definition-class .definition-class .immediate ; ' ((see Is (see Forth definitions : see ' (see ; \ No newline at end of file diff --git a/8080/AmstradCPC/SIMPFILE.SCR b/8080/AmstradCPC/SIMPFILE.SCR new file mode 100644 index 0000000..1fd4b38 --- /dev/null +++ b/8080/AmstradCPC/SIMPFILE.SCR @@ -0,0 +1 @@ +\\ Simple Files 11Nov86 Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es trotzdem wuenschenswert eine Art File-Struktur zu besitzen. Dieses File enthaelt eine einfache Implementation eines Filesystems. Der/die Programmierer/in muss selbst die Direktory auf dem laufenden halten: in ihr sind die Start-Bloecke des entsprechenden Diskettenteils gespeichert. Sogar eine Hierarchie von Direktories laesst sich so relisieren. Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64). \ simple files 12feb86 \needs search .( search missing) \\ | Variable (dir : dir (dir @ ; : root 0 (dir ! ; root | : read" ( -- n) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in push >in ! bl dir block b/blk (word number drop ; : load" read" dir + load ; : dir" read" (dir +! ; : list" read" dir + list ; \ 1 +load \ Only if file" is needed \ simple files 01feb86 | : snap ( n0 -- n1) $20 / 3 max $20 * ; : file" ( n --) Ascii " word count 2dup dir block b/blk search IF + nip ELSE drop dir block b/blk -trailing nip snap $20 + dup b/blk 1- > abort" directory full" 2dup + >r dir block + swap cmove r> THEN snap $18 + >r dir - extend under dabs <# # # # # base @ $0A = IF Ascii & ELSE Ascii $ THEN hold rot 0< IF Ascii - ELSE bl THEN hold #> r> dir block + swap cmove update ; \ dir load" 11feb86 \needs search .( search missing) \\ 0 Constant dir : load" ( -- ) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in @ blk @ rot >in ! dir blk ! bl word number drop -rot blk ! >in ! load ; \ No newline at end of file diff --git a/8080/AmstradCPC/SOURCE.SCR b/8080/AmstradCPC/SOURCE.SCR new file mode 100644 index 0000000..1ee646d --- /dev/null +++ b/8080/AmstradCPC/SOURCE.SCR @@ -0,0 +1 @@ +\\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87 Entwicklung des volksFORTH-83 von K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck, U. Hoffmann Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann Dieses File enthaelt den kompletten Sourcetext des Kern-Systems fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+.Mit Hilfe eines Target-Compilers wird daraus das volksFORTH- System erzeugt, daher finden sich an einigen Stellen Anweisungenan den Target-Compiler, die fuer das Verstaendnis des Systems nicht wichtig sind. Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- besondere die Bdos-Schnittstelle fuer Disk-IO im Kern. \ CP/M 2.2 volksForth Load Screen 27Nov87 Onlyforth $9000 displace ! Target definitions $100 here! 1 $74 +thru \ Standard 8080-System cr .( unresolved: ) .unresolved ( ' .blk is .status ) save-target KERNEL.COM \ FORTH Preamble and ID 04Oct87 Assembler nop 0 jmp here 2- >label >boot nop 0 jmp here 2- >label >cold nop 0 jmp here 2- >label >restart here dup origin! \ Hier beginnen die Kaltstartwerte der Benutzervariablen 6 rst 0 jmp end-code \ for multitasker $100 allot | Create logo ," volksFORTH-83 rev. 3.80a" \ Assembler Labels Next Forth-Register 29Jun86 Label dpush D push Label hpush H push Label >next IP ldax IP inx A L mov IP ldax IP inx A H mov Label >next1 M E mov H inx M D mov xchg pchl end-code Variable RP Variable UP \ IP in BC \ W in DE \ SP in SP Variable IPsave \ Assembler Macros 20Oct86Compiler Assembler also definitions Forth : Next T >next jmp [ Forth ] ; T hpush Forth Constant hpush T dpush Forth Constant dpush T >next Forth Constant >next : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld [ Forth ] ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld [ Forth ] ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ; Target \ recover ;c: noop 20Oct86 Create recover Assembler W pop IP rpush W IP mvx Next end-code Compiler Assembler also definitions Forth : ;c: 0 T recover call end-code ] [ Forth ] ; Target | Code di di Next end-code | Code ei ei Next end-code Code noop >next here 2- ! end-code \ User variables 04Oct87 Constant origin 8 uallot drop \ Multitasker \ Felder: entry link spare SPsave \ Laenge kompatibel zum 68000 und 6502 volksFORTH User s0 User r0 User dp User offset 0 offset ! User base $0A base ! User output User input User errorhandler \ pointer for Abort" -code User voc-link User udp \ points to next free addr in User \ manipulate system pointers 11Jun86 Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code Code sp! ( addr --) H pop sphl Next end-code Code up@ ( -- addr) UP lhld hpush jmp end-code Code up! ( addr --) H pop UP shld Next end-code \ manipulate returnstack 11Jun86 Code rp@ ( -- addr ) RP lhld hpush jmp end-code Code rp! ( addr -- ) H pop RP shld Next end-code Code >r ( 16b -- ) D pop D rpush Next end-code restrict Code r> ( -- 16b ) D rpop D push Next end-code restrict \ r@ rdrop exit unnest ?exit 07Oct87Code r@ ( -- 16b ) RP lhld M E mov H inx M D mov D push Next end-code Code rdrop RP lhld H inx H inx RP shld Next end-code restrict Code exit Label >exit IP rpop Next end-code Code unnest >exit here 2- ! Code ?exit ( flag -- ) H pop H A mov L ora >exit jnz Next end-code Code 0=exit ( flag -- ) H pop H A mov L ora >exit jz Next end-code \ : ?exit ( flag -- ) IF rdrop THEN ; \ execute perform 11Jun86 18Nov87 Code execute ( cfa -- ) H pop >Next1 jmp end-code Code perform ( 'cfa -- ) H pop M A mov H inx M H mov A L mov >Next1 jmp end-code \\ : perform ( addr -- ) @ execute ; \ c@ c! ctoggle 07Oct87 Code c@ ( addr -- 8b ) H pop M L mov 0 H mvi hpush jmp end-code Code c! ( 16b addr -- ) H pop D pop E M mov Next end-code Code flip ( 16b1 -- 16b2 ) H pop H A mov L H mov A L mov Hpush jmp end-code Code ctoggle ( 8b addr -- ) H pop D pop M A mov E xra A M mov Next end-code \\ : ctoggle ( 8b addr --) under c@ xor swap c! ; \ @ ! 2@ 2! 11Jun86 18Nov87 Code @ ( addr -- 16b ) H pop Label fetch M E mov H inx M D mov D push Next end-code Code ! ( 16b addr -- ) H pop D pop E M mov H inx D M mov Next end-code Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ +! drop swap 11Jun86 18Nov87 Code +! ( 16b addr -- ) H pop Label +store D pop M A mov E add A M mov H inx M A mov D adc A M mov Next end-code \ : +! ( n addr -- ) under @ + swap ! ; Code drop ( 16b -- ) H pop Next end-code Code swap ( 16b1 16b2 -- 16b2 16b1 ) H pop xthl hpush jmp end-code \ dup ?dup 16May86 Code dup ( 16b -- 16b 16b ) H pop H push hpush jmp end-code Code ?dup ( 16b -- 16b 16b / false) H pop H A mov L ora 0<> ?[ H push ]? hpush jmp end-code \\ : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; : dup ( 16b -- 16b 16b ) sp@ @ ; \ over rot nip under 11Jun86 Code over ( 16b1 16b2 - 16b1 16b2 16b1 ) D pop H pop H push dpush jmp end-code Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) D pop H pop xthl dpush jmp end-code Code nip ( 16b1 16b2 -- 16b2) H pop D pop hpush jmp end-code Code under ( 16b1 16b2 -- 16b2 16b1 16b2) H pop D pop H push dpush jmp end-code \\ : over >r swap r> swap ; : rot >r dup r> swap ; : nip swap drop ; : under swap over ; \ -rot pick roll -roll 11Jun86Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) H pop D pop xthl H push D push Next end-code Code pick ( n -- 16b.n ) H pop H dad SP dad M E mov H inx M D mov D push Next end-code : roll ( n -- ) dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; : -roll ( n -- ) >r dup sp@ dup 2+ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; \\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; \ double word stack manipulation 09May86Code 2swap ( 32b1 32b2 -- 32b2 32b1) H pop D pop xthl H push 5 H lxi SP dad M A mov D M mov A D mov H dcx M A mov E M mov A E mov H pop dpush jmp end-code Code 2drop ( 32b -- ) H pop H pop Next end-code Code 2dup ( 32b -- 32b 32b) H pop D pop D push H push dpush jmp end-code \\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; : 2drop ( 32b -- ) drop drop ; : 2dup ( 32b -- 32b 32b) over over ; \ + and or xor not 09May86Code + ( n1 n2 -- n3 ) H pop D pop D dad hpush jmp end-code Code or ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ora A H mov L A mov E ora A L mov hpush jmp end-code Code and ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ana A H mov L A mov E ana A L mov hpush jmp end-code Code xor ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D xra A H mov L A mov E xra A L mov hpush jmp end-code Code not ( 16b1 -- 16b2 ) H pop Label >not H A mov cma A H mov L A mov cma A L mov hpush jmp end-code \ - negate 16May86 Code - ( n1 n2 -- n3 ) D pop H pop L A mov E sub A L mov H A mov D sbb A H mov hpush jmp end-code Code negate ( n1 -- n2 ) H pop H dcx >not jmp end-code \\ : - ( n1 n2 -- n3 ) negate + ; \ dnegate d+ 10Mar86 18Nov87 Code dnegate ( d1 -- -d1 ) H pop Label >dnegate D pop A sub E sub A E mov 0 A mvi D sbb A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb A H mov dpush jmp end-code Code d+ ( d1 d2 -- d3) 6 H lxi SP dad M E mov C M mov H inx M D mov B M mov B pop H pop D dad xchg H pop L A mov C adc A L mov H A mov B adc A H mov B pop dpush jmp end-code \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code Code 2+ ( n1 -- n2 ) H pop H inx H inx hpush jmp end-code Code 3+ ( n1 -- n2 ) H pop H inx H inx H inx hpush jmp end-code Code 4+ ( n1 -- n2 ) H pop 4 D lxi D dad hpush jmp end-code | Code 6+ ( n1 -- n2 ) H pop 6 D lxi D dad hpush jmp end-code Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code Code 2- ( n1 -- n2 ) H pop H dcx H dcx hpush jmp end-code Code 4- ( n1 -- n2 ) H pop -4 D lxi D dad hpush jmp end-code \ number Constants 07Oct87-1 Constant true 0 Constant false 0 ( -- 0 ) Constant 0 1 ( -- 1 ) Constant 1 2 ( -- 2 ) Constant 2 3 ( -- 3 ) Constant 3 4 ( -- 4 ) Constant 4 -1 ( -- -1 ) Constant -1 Code on ( addr -- ) H pop $FF A mvi Label set A M mov H inx A M mov Next Code off ( addr -- ) H pop A xra set jmp end-code \ : on ( addr -- ) true swap ! ; \ : off ( addr -- ) false swap ! ; \ words for number literals 16May86 Code lit ( -- 16b ) IP ldax A L mov IP inx IP ldax A H mov IP inx hpush jmp end-code Code clit ( -- 8b ) IP ldax A L mov 0 H mvi IP inx hpush jmp end-code : Literal ( 16b -- ) dup $FF00 and IF compile lit , exit THEN compile clit c, ; immediate restrict \ comparision words 18Nov87Label (u< ( HL,DE -> HL u< DE c,z ) H A mov D cmp rnz L A mov E cmp ret Label (< ( HL,DE -> HL < DE c,z ) H A mov D xra (u< jp D A mov H cmp ret Label yes true H lxi hpush jmp Code u< ( u1 u2 -- flag ) D pop H pop Label uless (u< call yes jc Label no false H lxi hpush jmp Code < ( n1 n2 -- flag ) D pop H pop Label less (< call yes jc no jmp end-code Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code \ comparision words 18Nov87Code 0< ( n1 n2 -- flag ) H pop Label negative H dad yes jc no jmp end-code Code 0> ( n -- flag ) H pop H A mov A ora no jm L ora yes jnz no jmp end-code Code 0= ( n -- flag ) H pop Label zero= H A mov L ora yes jz no jmp end-code Code 0<> ( n -- flag ) H pop H A mov L ora yes jnz no jmp end-code Code = ( n1 n2 -- flag ) H pop D pop L A mov E cmp no jnz H A mov D cmp no jnz yes jmp end-code \\ comparision words high level 18Nov87: 0< ( n1 -- flag ) 8000 and 0<> ; : > ( n1 n2 -- flag ) swap < ; : 0> ( n -- flag ) negate 0< ; : 0<> ( n -- flag ) 0= not ; : u> ( u1 u2 -- flag ) swap u< ; : = ( n1 n2 -- flag ) - 0= ; : uwithin ( u1 [low up[ -- flag ) over - -rot - u> ; | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; : min ( n1 n2 -- n3 ) 2dup > minimax ; : max ( n1 n2 -- n3 ) 2dup < minimax ; : umax ( u1 u2 -- u3 ) 2dup u< minimax ; : umin ( u1 u2 -- u3 ) 2dup u> minimax ; : extend ( n -- d ) dup 0< ; : dabs ( d -- ud ) extend IF dnegate THEN ; : abs ( n -- u) extend IF negate THEN ; \ uwthin double number comparison words 18Nov87 Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl (u< call cs ?[ H pop no jmp ]? D pop (u< call yes jc no jmp end-code Code d0= ( d -- flag ) H pop H A mov L ora H pop no jnz zero= jmp end-code : d= ( d1 d2 -- flag ) rot = -rot = and ; : d< ( d1 d2 -- flag ) rot 2dup = IF 2drop u< exit THEN > nip nip ; \\ : d0= ( d -- flag ) or 0= ; \ minimum maximum 18Nov87 Code umax ( u1 u2 -- u3 ) H pop D pop (u< call Label minimax cs ?[ xchg ]? hpush jmp end-code Code umin ( u1 u2 -- u3 ) H pop D pop (u< call cmc minimax jmp end-code Code max ( n1 n2 -- n3 ) H pop D pop (< call minimax jmp end-code Code min ( n1 n2 -- n3 ) H pop D pop (< call cmc minimax jmp end-code \ sign extension absolute values 18Nov87 Code extend ( n -- d ) H pop H push negative jmp end-code Code abs ( a -- u ) H pop H A mov A ora hpush jp H dcx >not jmp end-code Code dabs ( d -- ud ) H pop H A mov A ora hpush jp >dnegate jmp end-code \ branch ?branch 20Nov87 Code branch ( -- ) Label >branch IP H mvx M E mov H inx M D mov H dcx D dad H IP mvx Next end-code Code ?branch ( fl -- ) H pop H A mov L ora >branch jz IP inx IP inx Next end-code \\ : branch r> dup @ + >r ; \ loop primitives 11Jun86 20Nov87 Code bounds ( start count -- limit start ) H pop D pop D dad H push D push Next end-code Code endloop RP lhld 6 D lxi D dad RP shld next end-code restrict \\ dodo puts "index | limit | adr.of.DO" on return-stack : bounds ( start count -- limit start ) over + swap ; | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; : (do ( limit start -- ) over - dodo ; restrict : (?do ( limit start -- ) over - ?dup IF dodo THEN r> dup @ + >r drop ; restrict \ loop primitives 20Nov87 Code (do ( limit start -- ) H pop D pop Label >do L A mov E sub A L mov H A mov D sbb A H mov H push IP inx IP inx RP lhld H dcx IP M mov H dcx IP' M mov H dcx D M mov H dcx E M mov D pop H dcx D M mov H dcx E M mov RP shld Next end-code restrict Code (?do ( limit start -- ) H pop D pop H A mov D cmp >do jnz L A mov E cmp >do jnz >branch jmp end-code restrict \ (loop (+loop 14May86 20Nov87 Code (loop RP lhld M inr 0= ?[ H inx M inr >next jz ]? Label doloop RP lhld 4 D lxi D dad M IP' mov H inx M IP mov Next end-code restrict Code (+loop RP lhld D pop M A mov E add A M mov H inx M A mov D adc A M mov rar D xra doloop jp Next end-code restrict \ loop indices 06May86 20Nov87 Code I ( -- n ) RP lhld Label >I M E mov H inx M D mov D push H inx M E mov H inx M D mov H pop D dad hpush jmp end-code Code J ( -- n ) RP lhld 6 D lxi D dad >I jmp end-code \ interpretive conditionals UH 25Jan88 | Create: remove>> r> rp! ; | : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp! swap >r remove>> >r swap >r dup >r swap cmove r> ; | Variable saved-dp 0 saved-dp ! | Variable level 0 level ! | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit 1 level ! here saved-dp ! ] ; | : -level ( -- ) state @ 0= Abort" unstructured" level @ 0=exit -1 level +! level @ ?exit compile unnest [compile] [ saved-dp @ here over dp ! over - >>r >r ; \ resolve loops and branches UH 25Jan88 : >mark ( -- addr ) here 0 , ; : +>mark ( acf -- addr ) +level , >mark ; : >resolve ( addr -- ) here over - swap ! -level ; : mark 1 ; immediate : THEN abs 1 ?pairs >resolve ; immediate : ELSE 1 ?pairs ['] branch +>mark swap >resolve -1 ; immediate : BEGIN mark -2 2swap ; immediate | : (reptil resolve REPEAT ; : REPEAT 2 ?pairs compile branch (reptil ; immediate : UNTIL 2 ?pairs compile ?branch (reptil ; immediate \ Loops UH 25Jan88 : DO ['] (do +>mark 3 ; immediate : ?DO ['] (?do +>mark 3 ; immediate : LOOP 3 ?pairs compile (loop compile endloop >resolve ; immediate : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; immediate Code LEAVE RP lhld 4 D lxi D dad M E mov H inx M D mov H inx RP shld xchg H dcx M D mov H dcx M E mov D dad H IP mvx Next end-code restrict \\ Returnstack: calladr | index limit | adr of DO : LEAVE endloop r> 2- dup @ + >r ; restrict \ um* 16May86Label (um* 0 H lxi ( 0=Teil-Produkt ) 4 C mvi ( Schleifen-Zaehler ) [[ H dad ( Schiebe HL 24 bits nach links ) ral cs ?[ D dad 0 aci ]? H dad ral cs ?[ D dad 0 aci ]? C dcr 0= ?] ret Code um* ( u1 u2 -- ud ) D pop H pop B push H B mov L A mov (um* call H push A H mov B A mov H B mov (um* call D pop D C mov B dad 0 aci L D mov H L mov A H mov B pop dpush jmp end-code \ m* * 2* 2/ 16May86 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap dup 0< IF negate r> not >r THEN um* r> IF dnegate THEN ; : * ( n1 n2 - prod ) um* drop ; Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code Code 2/ ( n -- n/2 ) H pop H A mov rlc rrc rar A H mov L A mov rar A L mov hpush jmp end-code \\ : 2* ( n -- 2*n ) 2 * ; : 2/ ( n -- n/2 ) 2 / ; \ um/mod 14May86Label usl0 A E mov H A mov C sub A H mov E A mov B sbb cs ?[ H A mov C add A H mov E A mov D dcr rz Label usla H dad ral usl0 jnc A E mov H A mov C sub A H mov E A mov B sbb ]? L inr D dcr usla jnz ret Label usbad -1 H lxi B pop H push hpush jmp Code um/mod ( d1 n1 -- rem quot ) IP H mvx B pop D pop xthl xchg L A mov C sub H A mov B sbb usbad jnc H A mov L H mov D L mov 8 D mvi D push usla call D pop H push E L mov usla call A D mov H E mov B pop C H mov B pop D push hpush jmp end-code \ m/mod 16May86 : m/mod ( d n -- mod quot) dup >r abs over 0< IF under + swap THEN um/mod r@ 0< IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; \ /mod / mod */mod */ u/mod ud/mod 16May86 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; : / ( n1 n2 -- quot ) /mod nip ; : mod ( n1 n2 -- rem ) /mod drop ; : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; : */ ( n1 n2 n3 -- quot ) */mod nip ; : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r um/mod r> ; \ cmove cmove> 16May86 18Nov87 Code cmove ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove [[ B A mov C ora 0= not ?[[ M A mov H INX D stax D inx B dcx ]]? IPsave lhld H IP mvx Next end-code Code cmove> ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove> B dad H dcx xchg B dad H dcx xchg [[ B A mov C ora 0= not ?[[ M A mov H dcx D stax D dcx B dcx ]]? IPsave lhld H IP mvx Next end-code \ move place count 17Oct86 18Nov87 Code move ( from to quan -- ) IP H mvx Ipsave shld B pop D pop H pop Label domove (u< call (cmove jnc (cmove> jmp end-code | Code (place ( addr len to -- len to ) IP H mvx Ipsave shld D pop B pop H pop B push D push D inx domove jmp end-code : place ( addr len to -- ) (place c! ; Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi H inx H push D push Next end-code \ fill erase 18Nov87 Code fill ( addr quan 8b -- ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora 0<> ?[[ E M mov H inx B dcx ]]? IPsave lhld H IP mvx Next end-code : erase ( addr quan --) 0 fill ; \\ : fill ( addr quan 8b -- ) swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; : count ( adr -- adr+1 len ) dup 1+ swap c@ ; : move ( from to quan -- ) >r 2dup u< IF r> cmove> exit THEN r> cmove ; : place ( addr len to --) over >r rot over 1+ r> move c! ; \ here allot , c, pad compile 11Jun86 18Nov87 Code here ( -- addr ) user' dp D lxi UP lhld D dad fetch jmp end-code Code allot ( n -- ) user' dp D lxi UP lhld D dad +store jmp end-code : , ( 16b -- ) here ! 2 allot ; : c, ( 8b -- ) here c! 1 allot ; : pad ( -- addr ) here $42 + ; : compile r> dup 2+ >r @ , ; restrict \ : here ( -- addr ) dp @ ; \ : allot ( n -- ) dp +! ; \ input strings 11Jun86 Variable #tib 0 #tib ! Variable >tib here >tib ! $50 allot Variable >in 0 >in ! Variable blk 0 blk ! Variable span 0 span ! : tib ( -- addr ) >tib @ ; : query ( -- ) tib $50 expect span @ #tib ! >in off blk off ; \\ scan skip /string 16May86 18Nov87 : scan ( addr0 len0 char -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT rdrop ; : skip ( addr len del -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT rdrop ; : /string ( addr0 len0 +n - addr1 len1 ) over umin rot over + -rot - ; \ skip scan 18Nov87Label done H push B push IPsave lhld H IP mvx Next Code skip ( addr len del -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jnz H inx B dcx ]] end-code Code scan ( addr len chr -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jz H inx B dcx ]] end-code Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl L A mov E sub A L mov H A mov D sbb A H mov Hpush jmp end-code \ capitalize ohne Umlaute !! 16May86UH 25Jan88Variable caps 0 caps ! Label ?capital caps lda A ana rz Label (capital ( e --> A,E ) E A mov Ascii a cpi rc Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret Code capital ( char -- char') D pop (capital call D push Next end-code Code upper ( addr len -- ) D pop E D mov H pop D inr [[ D dcr >next jz M E mov (capital call E M mov H inx ]] end-code \\ : capital ( char -- char') dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; \ (word 16May86 Code (word ( char adr0 len0 -- addr ) IP H mvx IPsave shld B pop B dcx D pop >in lhld D dad xchg xthl xchg H push >in lhld C A mov L sub A L mov B A mov H sbb A H mov cs ?[ B inx C A mov >in sta B A mov >in 1+ sta D pop H pop D push ][ H inx H B mvx H pop [[ B A mov C ora 0<> ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]? H push [[ B A mov C ora 0<> ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]? xchg H pop xthl E A mov L sub A L mov D A mov H sbb A H mov \ (word Part2 16May86 B A mov C ora 0<> ?[ H inx ]? >in shld ]? H pop E A mov L sub A C mov D A mov H sbb A B mov H push user' dp D lxi UP lhld D dad M A mov H inx M H mov A L mov D pop H push C M mov H inx [[ B A mov C ora 0<> ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi IPsave lhld H IP mvx Next end-code \\ : (word ( char adr0 len0 -- addr ) rot >r over swap >in @ /string r@ skip over swap r> scan >r rot over swap - r> 0<> - >in ! over - here dup >r place bl r@ count + c! r> ; \ source word parse name 20Oct86UH 25Jan88 Variable loadfile : source ( -- addr len ) blk @ ?dup IF loadfile @ (block b/blk exit THEN tib #tib @ ; : word ( char -- addr ) source (word ; : parse ( char -- addr len ) >r source >in @ /string over swap r> scan >r over - dup r> 0<> - >in +! ; : name ( -- addr ) bl word dup count upper exit ; \ state Ascii ," "lit (" " 18Nov87 Variable state 0 state ! : Ascii ( char -- n ) bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate Code "lit RP lhld M E mov H inx M D mov H dcx D push D ldax D inx E add A M mov H inx D A mov 0 aci A M mov Next end-code : ," Ascii " parse here over 1+ allot place ; : (" "lit ; restrict : " compile (" ," align ; immediate restrict \ : "lit r> r> under count + even >r >r ; restrict \ ." ( .( \ \\ hex decimal 07Oct87 : (." "lit count type ; restrict : ." compile (." ," align ; immediate restrict : ( ascii ) parse 2drop ; immediate : .( ascii ) parse type ; immediate : \ >in @ negate c/l mod >in +! ; immediate : \\ b/blk >in ! ; immediate : \needs name find nip 0=exit [compile] \ ; : hex $10 base ! ; : decimal $0A base ! ; \ number conversion: digit? 16May86 18Nov87 Code digit? ( char -- n true : false ) user' base D lxi UP lhld D dad D pop E A mov Ascii 0 sui no jc $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc Ascii A Ascii 9 - 1- sui ]? M cmp no jnc 0 H mvi A L mov H push yes jmp end-code \\ : digit? ( char -- digit true/ false ) dup Ascii 9 > IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN Ascii 0 - dup base @ u< dup ?exit nip ; \ number conversion: accumulate convert 11Jun86 | : end? ( -- flag ) >in @ 0= ; | : char ( addr0 -- addr1 char ) count -1 >in +! ; | : previous ( addr0 -- addr0 char ) 1- count ; : accumulate ( +d0 adr digit - +d1 adr ) swap >r swap base @ um* drop rot base @ um* d+ r> ; : convert ( +d1 addr0 -- +d2 addr2 ) 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; \ number conversion: ?nonum punctuation? 07Oct87 | : ?nonum ( flag -- exit if true ) 0=exit rdrop 2drop drop rdrop false ; | : punctuation? ( char -- flag ) Ascii , over = swap Ascii . = or ; \ number conversion: fixbase? 07Oct87 | : fixbase? ( char - char false / newbase true ) capital Ascii & case? IF $0A true exit THEN Ascii $ case? IF $10 true exit THEN Ascii H case? IF $10 true exit THEN Ascii % case? IF 2 true exit THEN false ; \ number conversion: ?num ?dpl 07Oct87 Variable dpl -1 dpl ! | : ?num ( flag -- exit if true ) 0=exit rdrop drop r> IF dnegate THEN rot drop dpl @ 1+ ?dup ?exit drop true ; | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; \ number conversion: number? number 11Jun86 : number? ( string - string false / n 0< / d 0> ) base push >in push dup count >in ! dpl on 0 >r ( +sign) 0.0 rot end? ?nonum char Ascii - case? IF rdrop true >r end? ?nonum char THEN fixbase? IF base ! end? ?nonum char THEN BEGIN digit? 0= ?nonum BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL previous punctuation? 0= ?nonum dpl off end? ?num char REPEAT ; : number ( string -- d ) number? ?dup 0= Abort" ?" 0< IF extend THEN ; \ hide reveal immediate restrict 11Jun86 Variable last 0 last ! | : last? ( -- false / acf true) last @ ?dup ; : hide last? IF 2- @ current @ ! THEN ; : reveal last? IF 2- current @ ! THEN ; : Recursive reveal ; immediate restrict | : flag! ( 8b --) last? IF under c@ or over c! THEN drop ; : immediate $40 flag! ; : restrict $80 flag! ; \ clearstack hallot heap heap? 04Sep86 Code clearstack user' s0 D lxi UP lhld D dad M E mov H inx M D mov xchg sphl Next end-code : hallot ( quan -- ) s0 @ over - swap sp@ 2+ dup rot - dup s0 ! 2 pick over - di move clearstack ei s0 ! ; : heap ( -- addr ) s0 @ 6 + ; : heap? ( addr -- flag ) heap up@ uwithin ; | : heapmove ( from -- from ) dup here over - dup hallot heap swap cmove heap over - last +! reveal ; \ Does> ; 11Jun86 20Nov87 Label (dodoes> IP rpush IP pop W inx W push Next end-code : (;code r> last @ name> ! ; : Does> compile (;code $CD ( 8080-Call ) c, compile (dodoes> ; immediate restrict \ ?head | alignments 20Oct86 18Nov87 Variable ?head 0 ?head ! : | ?head @ ?exit -1 ?head ! ; \ machen nichts beim 8080: : even ( addr -- addr1 ) ; immediate : align ( -- ) ; immediate : halign ( -- ) ; immediate Variable warning 0 warning ! | : exists? warning @ ?exit last @ current @ (find nip 0=exit space last @ .name ." exists " ?cr ; \ warning Create 20Oct86 18Nov87 Defer makeview ' 0 Is makeview : (create ( string -- ) align here swap count $1F and here 4+ place makeview , current @ @ , here last ! here c@ 1+ allot align exists? ?head @ IF 1 ?head +! dup , \ Pointer to Code halign heapmove $20 flag! dup dp ! THEN drop reveal 0 , ;Code W inx W push Next end-code : Create name count 1 $20 uwithin not Abort" invalid name" 1- (create ; \ nfa? 30Jun86 Code nfa? ( thread cfa -- nfa / false ) D pop H pop [[ M A mov H inx M H mov A L mov H ora Hpush jz H push H inx H inx H push D push M A mov H inx $1F ani A E mov 0 D mvi D dad D pop xthl M A mov H pop $20 ani 0<> ?[ M A mov H inx M H mov A L mov ]? H A mov D cmp 0= ?[ L A mov E cmp ]? H pop 0= ?] H inx H inx Hpush jmp end-code \\ : nfa? ( thread cfa -- nfa / false) >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ = UNTIL 2+ rdrop ; \ >name name> >body .name 30Jun86 07Oct87 : >name ( cfa -- nfa / false ) voc-link BEGIN @ dup WHILE 2dup 4 - swap nfa? ?dup IF -rot 2drop exit THEN REPEAT nip ; Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani A E mov 0 D mvi D dad hpush jmp end-code \ : (name> ( nfa -- cfa ) count $1F and + ; : name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ; : >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ; : .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN count $1F and type ELSE ." ???" THEN space ; \ : ; Constant Variable 07Nov87 : Create: Create hide current @ context ! 0 ] ; : : Create: ;Code IP rpush W inx W IP mvx Next end-code : ; 0 ?pairs compile unnest [compile] [ reveal ; immediate restrict : Constant ( n -- ) Create , ;Code W inx xchg M E mov H inx M D mov D push Next end-code : Variable Create 0 , ; \ uallot User Alias Defer 11Jun86 18Nov87: uallot ( quan -- offset ) even dup udp @ + $FF u> Abort" Userarea full" udp @ swap udp +! ; : User Create 2 uallot c, ;Code W inx W ldax A E mov 0 D mvi UP lhld D dad hpush jmp end-code : Alias ( cfa -- ) Create last @ dup c@ $20 and IF -2 allot ELSE $20 flag! THEN (name> ! ; | : crash true Abort" crash" ; : Defer Create ['] crash , ;Code W inx xchg M E mov H inx M D mov xchg >next1 jmp end-code \ vp current context also toss 11Jun86 Create vp $10 allot Variable current : context ( -- adr ) vp dup @ + 2+ ; | : thru.vocstack ( -- from to ) vp 2+ context ; \ "Only Forth also Assembler" gives \ vp: countword = 6 | Only | Forth | Assembler | : also vp @ $0A > Error" Vocabulary stack full" context @ 2 vp +! context ! ; : toss vp @ IF -2 vp +! THEN ; \ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87 : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! Does> context ! ; \ | Name | Code | Thread | Coldthread | Voc-link | Vocabulary Forth Vocabulary Root : Only vp off Root also ; : Onlyforth Only Forth also definitions ; \ definitions order words 10Oct87 20Nov87 | : init-vocabularys voc-link @ BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; : definitions context @ current ! ; | : .voc ( adr -- ) @ 2- >name .name ; : order vp 4+ context DO I .voc -2 +LOOP 2 spaces current .voc ; : words context @ BEGIN @ dup stop? 0= and WHILE ?cr dup 2+ .name space REPEAT drop ; \ found -text 11Jun86| : found ( nfa -- cfa n ) dup c@ >r (name> r@ $20 and IF @ THEN -1 r@ $80 and IF 1- THEN r> $40 and IF negate THEN ; \\ : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1r count $1F and strlen ! string ! BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ = IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN THEN drop REPEAT string @ 1- false ; \ (find 11Jun86 Code (find ( str thr - str false/ NFA true ) H pop D pop IP push D ldax $1F ani A C mov D inx Label findloop M A mov H inx M H mov A L mov H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]? H push H inx H inx M A mov $1F ani C cmp 0<> ?[ H pop findloop jmp ]? D push H inx C B mov B inr [[ B dcr 0<> ?[[ D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]? H inx D inx ]]? D pop H pop H inx H inx IP pop H push yes jmp end-code \\ HL: thread, nfa DE: string C: strlen B: counter \ find ' [compile] ['] nullstring? 18Nov87 : find ( string -- cfa n / string false ) context dup @ over 2- @ = IF 2- THEN BEGIN under @ (find IF nip found exit THEN over vp 2+ u> WHILE swap 2- REPEAT nip false ; : ' ( -- cfa ) name find ?exit Error" ?" ; : [compile] ' , ; immediate restrict : ['] ' [compile] Literal ; immediate restrict : nullstring? ( string -- string false / true ) dup c@ 0= dup 0=exit nip ; \ notfound 17Oct86UH 25Jan88 : no.extensions ( string -- ) state @ IF Abort" ?" THEN Error" ?" ; Defer notfound ' no.extensions Is notfound \ interpret interpreter compiler parser UH 25Jan88Defer parser : interpret ( -- ) BEGIN ?stack name nullstring? ?exit parser REPEAT ; | : interpreter ( str -- ) find ?dup IF 1 and IF execute exit THEN Error" compile only" THEN number? ?exit notfound ; ' interpreter Is parser | : compiler ( str -- ) find ?dup IF 0> IF execute exit THEN , exit THEN number? ?dup IF 0> IF swap [compile] Literal THEN [compile] Literal exit THEN notfound ; \ [ ] UH 25Jan88 : [ ['] interpreter Is Parser state off ; immediate : ] ['] compiler Is Parser state on ; \ Is 09May86UH 25Jan88 : (is r> dup 2+ >r @ ! ; | : def? ( cfa -- ) @ [ ' notfound @ ] Literal - Abort" not deferred" ; : Is ( adr -- ) ' dup def? >body state @ IF compile (is , exit THEN ! ; immediate \ ?stack 30Jun86| : stackfull ( -- ) depth $20 > Abort" tight stack" reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN true Abort" Dictionary full" ; Code ?stack UP lhld user' dp D lxi D dad M E mov H inx M D mov 0 H lxi SP dad L A mov E sub H A mov D sbb 0= ?[ ;c: stackfull ; Assembler ]? H push UP lhld user' s0 D lxi D dad M E mov H inx M D mov H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]? >next jnc ;c: true abort" Stack empty" ; \\ : ?stack sp@ here - 100 u< IF stackfull THEN sp@ s0 @ u> Abort" Stack empty" ; \ .status push load 20Oct86 Defer .status ' noop Is .status | Create: pull r> r> ! ; : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; restrict : (load ( blk offset -- ) isfile push loadfile push fromfile push blk push >in push >in ! blk ! isfile@ loadfile ! .status interpret ; : load ( blk --) ?dup 0=exit 0 (load ; \ +load thru +thru --> rdepth depth 20Oct86 : +load ( offset --) blk @ + load ; : thru ( from to --) 1+ swap DO I load LOOP ; : +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; : --> 1 blk +! >in off .status ; immediate : rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; : depth ( -- +n) sp@ s0 @ swap - 2/ ; \ quit (quit abort UH 25Jan88 : (prompt ( -- ) state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; Defer prompt ' (prompt Is prompt : (quit BEGIN prompt query interpret REPEAT ; Defer 'quit ' (quit Is 'quit : quit r0 @ rp! level off [compile] [ 'quit ; : standardi/o [ output ] Literal output 4 cmove ; Defer 'abort ' noop Is 'abort : abort end-trace clearstack 'abort standardi/o quit ; \ (error Abort" Error" 20Oct86 18Nov87 Variable scr 1 scr ! Variable r# 0 r# ! : (error ( string -- ) standardi/o space here .name count type space ?cr blk @ ?dup IF scr ! >in @ r# ! THEN quit ; ' (error errorhandler ! : (abort" "lit swap IF >r clearstack r> errorhandler perform exit THEN drop ; restrict | : (err" "lit swap IF errorhandler perform exit THEN drop ; restrict : Abort" compile (abort" ," align ; immediate restrict : Error" compile (err" ," align ; immediate restrict \ -trailing 30Jun86 18Nov87 Code -trailing ( addr n1 -- addr n2 ) D pop H pop H push D dad xchg D dcx Label -trail H A mov L ora hpush jz D ldax BL cpi hpush jnz H dcx D dcx -trail jmp end-code \\ : -trailing ( addr n1 -- addr n2) 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; \ space spaces 30Jun86 $20 Constant bl : space bl emit ; : spaces ( u --) 0 ?DO space LOOP ; \ hold <# #> sign # #s 17Oct86 | : hld ( -- addr) pad 2- ; : hold ( char -- ) -1 hld +! hld @ c! ; : <# hld hld ! ; : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; : sign ( n -- ) 0< IF Ascii - hold THEN ; : # ( +d1 -- +d2) base @ ud/mod rot 9 over < IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; \ print numbers 24Dec83 : d.r -rot under dabs <# #s rot sign #> rot over max over - spaces type ; : .r swap extend rot d.r ; : u.r 0 swap d.r ; : d. 0 d.r space ; : . extend d. ; : u. 0 d. ; \ .s list c/l l/s 05Oct87 : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; $40 Constant c/l \ Screen line length $10 Constant l/s \ lines per screen : list ( blk -- ) scr ! ." Scr " scr @ u. l/s 0 DO cr I 2 .r space scr @ block I c/l * + c/l -trailing type LOOP cr ; \ multitasker primitives 20Nov87 Code end-trace \ patch Next to its original state $0A A mvi ( IP ldax ) >next sta $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code Code pause >next here 2- ! end-code : lock ( addr -- ) dup @ up@ = IF drop exit THEN BEGIN dup @ WHILE pause REPEAT up@ swap ! ; : unlock ( addr -- ) dup lock off ; Label wake H pop H dcx UP shld 6 D lxi D dad M A mov H inx M H mov A L mov sphl H pop RP shld IP pop Next end-code \ buffer mechanism 20Oct86 07Oct87 User isfile 0 isfile ! \ addr of file control block Variable fromfile 0 fromfile ! Variable prev 0 prev ! \ Listhead | Variable buffers 0 buffers ! \ Semaphor $408 Constant b/buf \ physikalische Groesse $400 Constant b/blk \\ Struktur eines Buffers: 0 : link 2 : file 4 : blocknummer 6 : statusflags 8 : Data ... 1 Kb ... Statusflag bits : 15 1 -> updated file : -1 -> empty buffer, 0 -> no fcb, direct access else addr of fcb ( system dependent ) \ search for blocks in memory 30Jun86| Variable pred \ DE:blk BC:file HL:bufadr Label thisbuffer? ( Zero = this buffer ) H push H inx H inx M A mov C cmp 0= ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret Code (core? ( blk file -- adr\blk file ) IP H mvx Ipsave shld user' offset D lxi UP lhld D dad M E mov H inx M D mov B pop H pop H push B push D dad xchg prev lhld thisbuffer? call 0= ?[ \ search for blocks in memory 30Jun86 Label blockfound D pop D pop 8 D lxi D dad H push ' exit @ jmp ]? [[ pred shld M A mov H inx M H mov A L mov H ora 0= ?[ IPsave lhld H IP mvx Next ]? thisbuffer? call 0= ?] xchg pred lhld D ldax A M mov H inx D inx D ldax A M mov D dcx prev lhld xchg E M mov H inx D M mov H dcx prev shld blockfound jmp end-code \ (core? 29Jun86\\ | : this? ( blk file bufadr -- flag ) dup 4+ @ swap 2+ @ d= ; | : (core? ( blk file -- dataaddr / blk file ) BEGIN over offset @ + over prev @ this? IF rdrop 2drop prev @ 8 + exit THEN 2dup >r offset @ + >r prev @ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN dup r> r> 2dup >r >r rot this? 0= WHILE nip REPEAT dup @ rot ! prev @ over ! prev ! rdrop rdrop REPEAT ; \ (diskerr 29Jul86 07Oct87 : (diskerr ." error! r to retry " key $FF and capital Ascii R = not Abort" aborted" ; Defer diskerr ' (diskerr Is diskerr Defer r/w \ backup emptybuf readblk 20Oct86 | : backup ( bufaddr -- ) dup 6+ @ 0< IF 2+ dup @ 1+ \ buffer empty if file = -1 IF input push output push standardi/o BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w WHILE ." write " diskerr REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ; : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; | : readblk ( blk file addr -- blk file addr ) dup emptybuf input push output push standardi/o >r BEGIN over offset @ + over r@ 8 + -rot 1 r/w WHILE ." read " diskerr REPEAT r> ; \ take mark updates? core? 10Mar86 19Nov87 | : take ( -- bufaddr) prev BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL buffers lock dup backup ; | : mark ( blk file bufaddr -- blk file ) 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off buffers unlock ; | : updates? ( -- bufaddr / flag) prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; : core? ( blk file -- addr /false ) (core? 2drop false ; \ block & buffer manipulation 20Oct86 18Nov87 : (buffer ( blk file -- addr ) BEGIN (core? take mark REPEAT ; : (block ( blk file -- addr ) BEGIN (core? take readblk mark REPEAT ; Code isfile@ ( -- addr ) user' isfile D lxi UP lhld D dad fetch jmp end-code : buffer ( blk -- addr ) isfile@ (buffer ; : block ( blk -- addr ) isfile@ (block ; \ : isfile@ ( -- addr ) isfile @ ; \ block & buffer manipulation 05Oct87 : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; Defer save-dos-buffers : save-buffers ( -- ) buffers lock BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers buffers unlock ; : empty-buffers ( -- ) buffers lock prev BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; : flush save-buffers empty-buffers ; \ Allocating buffers 10Oct87$10000 Constant limit Variable first : allotbuffer ( -- ) first @ r0 @ - b/buf 2+ u< ?exit b/buf negate first +! first @ dup emptybuf prev @ over ! prev ! ; : freebuffer ( -- ) first @ limit b/buf - u< IF first @ backup prev BEGIN dup @ first @ - WHILE @ REPEAT first @ @ swap ! b/buf first +! THEN ; : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; | : init-buffers prev off limit first ! all-buffers ; \ endpoints of forget 01Jul86 | : |? ( nfa -- flag ) c@ $20 and ; | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? name> under 1+ u< swap heap? or ; | : endpoints ( addr -- addr symb ) heap voc-link @ >r BEGIN r> @ ?dup \ through all Vocabs WHILE dup >r 4- >r \ link on returnstack BEGIN r> @ >r over 1- dup r@ u< \ until link or swap r@ 2+ name> u< and \ code under adr WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap r@ 2+ |? IF over r@ 2+ forget? IF r@ 2+ (name> 2+ umax THEN \ then update symb THEN REPEAT rdrop REPEAT ; \ remove, -words, -tasks 20Oct86 : remove ( dic sym thread - dic sym ) BEGIN dup @ ?dup \ unlink forg. words WHILE dup heap? IF 2 pick over u> ELSE 3 pick over 1+ u< THEN IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; | : remove-words ( dic sym -- dic sym ) voc-link BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; | : remove-tasks ( dic -- ) up@ BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin IF dup @ 2+ @ over ! 2- ELSE @ THEN REPEAT 2drop ; \ remove-vocs trim 20Oct86 07Oct87 | : remove-vocs ( dic symb -- dic symb ) voc-link remove thru.vocstack DO 2dup I @ -rot uwithin IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP 2dup current @ -rot uwithin IF [ ' Forth 2+ ] Literal current ! THEN ; Defer custom-remove ' noop Is custom-remove | : trim ( dic symb -- ) over remove-tasks remove-vocs remove-words custom-remove heap swap - hallot dp ! 0 last ! ; \ deleting words from dict. 01Jul86 18Nov87 : clear here dup up@ trim dp ! ; : (forget ( adr --) dup heap? Abort" is symbol" endpoints trim ; : forget ' dup [ dp ] Literal @ u< Abort" protected" >name dup heap? IF name> ELSE 4- THEN (forget ; : empty [ dp ] Literal @ up@ trim [ udp ] Literal @ udp ! ; \ save bye stop? ?cr 18Nov87 : save here up@ trim voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL up@ origin $100 cmove ; : bye flush empty (bye ; | : end? key #cr = IF true rdrop THEN ; : stop? ( -- flag ) key? IF end? end? THEN false ; : ?cr col c/l u> 0=exit cr ; \ in/output structure 07Jun86 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; : Output: Create: Does> output ! ; 0 Out: emit Out: cr Out: type Out: del Out: page Out: at Out: at? drop : row ( -- row) at? drop ; : col ( -- col) at? nip ; | : In: Create dup c, 2+ Does> c@ input @ + perform ; : Input: Create: Does> input ! ; 0 In: key In: key? In: decode In: expect drop \ Alias only definitionen 18Nov87 Root definitions Forth : seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab. ' Only Alias Only ' Forth Alias Forth ' words Alias words ' also Alias also ' definitions Alias definitions Host Target \ 'restart 'cold 22Oct86 10Oct87 Defer 'restart ' noop Is 'restart | : (restart ['] (quit Is 'quit drvinit 'restart [ errorhandler ] Literal @ errorhandler ! ['] noop Is 'abort clearstack standardi/o interpret quit ; Defer 'cold ' noop Is 'cold | : (cold origin up@ $100 cmove $80 count $50 umin >r tib r@ move r> #tib ! >in off blk off init-vocabularys init-buffers flush 'cold Onlyforth page &24 spaces logo count type cr (restart ; \ cold bootsystem 20Oct86 Code cold here >cold ! s0 lhld 6 D lxi D dad origin D lxi $3F C mvi [[ D ldax A M mov H inx D inx C dcr 0= ?] ' (cold >body IP lxi Label bootsystem s0 lhld 6 D lxi D dad UP shld user' s0 D lxi D dad M E mov H inx M D mov xchg sphl user' r0 D lxi UP lhld D dad M E mov H inx M D mov xchg RP shld $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker ) Next end-code \ restart boot 20Oct86 Code restart here >restart ! ' (restart >body IP lxi bootsystem jmp end-code Label boot here >boot ! \ find link to Main: s0 lhld 6 D lxi D dad H B mvx origin D lxi [[ [[ xchg H inx H inx M E mov H inx M D mov D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx 6 lhld 0 L mvi ' limit >body shld -$1100 D lxi D dad r0 shld \ set initial RP -$400 D lxi D dad s0 shld \ set initial SP 6 D lxi D dad xchg B H mvx D M mov H dcx E M mov \ set link to Maintask >cold 2- jmp end-code \ "search 05Mar88 Label notfound H pop H pop IPsave lhld H IP mvx False H lxi hpush jmp Code "search ( text tlen buf blen -- addr tf / ff ) IP H mvx IPsave shld D pop H pop xthl H A mov L ora notfound jz E A mov L sub A C mov D A mov H sbb A B mov notfound jc B inx D pop xthl M A mov xthl H push xchg Label scanfirst A E mov ?capital call E D mov [[ M E mov H inx B A mov C ora notfound jz B dcx ?capital call E A mov D cmp 0= ?] B D mvx B pop xchg xthl xchg H push B push D push \ "search part 2 27Nov87 Label match B dcx B A mov C ora 0<> ?[ D inx D ldax D push A E mov ?capital call E D mov M E mov H inx ?capital call E A mov D cmp D pop match jz H pop B pop D pop M A mov xthl B push H B mvx xchg scanfirst jmp ]? D pop D pop H pop D pop H dcx H push IPsave lhld H IP mvx True H lxi hpush jmp end-code \ Rest of Standard-System 04Oct87 07Oct87 2 +load \ Operating System Host ' Transient 8 + @ Transient Forth Context @ 6 + ! Target Forth also definitions Vocabulary Assembler Assembler definitions Transient Assembler >Next Constant >Next hpush Constant hpush dpush Constant dpush Target Forth also definitions : forth-83 ; \ last word in Dictionary \ System patchup 04Oct87 $EF00 r0 ! $EB00 s0 ! s0 @ 6 + origin 2+ ! \ link Maintask to itself \ s0 und r0 werden beim Booten neu an die Speichergroesse \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask here dp ! Host Tudp @ Target udp ! Host Tvoc-link @ Target voc-link ! Host move-threads \ System dependent Load-Screen 20Nov87 1 +load \ CP/M interface 2 4 +thru \ Character IO 5 7 +thru \ Default Disk IO 8 +load \ Postlude \ 9 +load \ Index \ CP/M-Interface 05Oct87Vocabulary Dos Dos definitions also Label >bios pchl Code biosa ( arg fun -- res ) 1 lhld D pop D dcx D dad D dad D dad D pop IP push D IP mvx >bios call Label back IP pop 0 H mvi A L mov Hpush jmp end-code Code bdosa ( arg fun -- res ) H pop D pop IP push L C mov 5 call back jmp end-code : bios ( arg fun -- ) biosa drop ; : bdos ( arg fun -- ) bdosa drop ; \ Character-IO Constants Character input 05Oct87 Target Dos also $08 Constant #bs $0D Constant #cr $0A Constant #lf $1B Constant #esc $09 Constant #tab $7F Constant #del $07 Constant #bel $0C Constant #ff : con! ( c -- ) 4 bios ; : (key? ( -- ? ) 0 2 biosa 0= not ; : getkey ( -- c ) 0 3 biosa ; : (key ( -- c ) BEGIN pause (key? UNTIL getkey ; \ Character output 07Oct87 UH 27Feb88 | Code ?ctrl ( c -- c' ) H pop L A mov $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code : (emit ( c -- ) ?ctrl con! pause ; : (cr #cr con! #lf con! ; : (del #bs con! bl con! #bs con! ; : (at? ( -- row col ) 0 0 ; : tipp ( addr len -- ) 0 ?DO count emit LOOP drop ; Output: display [ here output ! ] (emit (cr tipp (del noop 2drop (at? ; \ Line input 04Oct87 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ; : (decode ( addr pos1 key -- addr pos2 ) #bs case? IF backspace exit THEN #del case? IF backspace exit THEN #cr case? IF dup span ! space exit THEN dup emit >r 2dup + r> swap c! 1+ ; : (expect ( addr len -- ) span ! 0 BEGIN span @ over u> WHILE key decode REPEAT 2drop ; Input: keyboard [ here input ! ] (key (key? (decode (expect ; \ Default Disk Interface: Constants and Primitives 18Nov87 $80 Constant b/rec b/blk b/rec / Constant rec/blk Dos definitions ' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb : dos-error? ( n -- f ) $FF = ; $5C Constant fcb : reset ( -- ) 0 &13 bdos ; : openfile ( fcb -- f ) &15 bdosa dos-error? ; : closefile ( fcb -- f ) &16 bdosa dos-error? ; : dma! ( dma -- ) &26 bdos ; : rec@ ( fcb -- f ) &33 bdosa ; : rec! ( fcb -- f ) &34 bdosa ; \ Default Disk Interface: open and close 20Nov87 Target Dos also Defer drvinit Dos definitions | Variable opened : default ( -- ) opened off fcb 1+ c@ bl = ?exit $80 count here place #tib off fcb dup dosfcb> dup isfile ! fromfile ! openfile Abort" default file not found!" opened on ; ' default Is drvinit : close-default ( -- ) opened @ not ?exit fcb closefile Abort" can't close default-file!" ; ' close-default Is save-dos-buffers \ Default Disk Interface: read/write 14Feb88 Target Dos also | : rec# ( 'dosfcb -- 'rec# ) &33 + ; : (r/w ( adr blk file r/wf -- flag ) >r dup 0= Abort" no Direct Disk IO supported! " >dosfcb swap rec/blk * over rec# 0 over 2+ c! ! r> rot b/blk bounds DO I dma! 2dup IF rec@ drop ELSE rec! IF 2drop true endloop exit THEN THEN over rec# 0 over 2+ c! 1 swap +! b/rec +LOOP 2drop false ; ' (r/w Is r/w \ Postlude 20Nov87 Defer postlude | : (bye ( -- ) postlude 0 0 bdos ; | : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ; : .size ( -- ) base push decimal cr ." Size: &" #pages u. ." Pages" ; ' .size Is postlude \ index findex 20Nov87 | : range ( from to -- to+1 from ) 2dup > IF swap THEN 1+ swap ; : index ( from to --) range DO cr I 4 .r I space block c/l type stop? IF LEAVE THEN LOOP ; \ No newline at end of file diff --git a/8080/AmstradCPC/STARTUP.SCR b/8080/AmstradCPC/STARTUP.SCR new file mode 100644 index 0000000..dc51604 --- /dev/null +++ b/8080/AmstradCPC/STARTUP.SCR @@ -0,0 +1 @@ +\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth ( 10.02.89/KK ) include ass8080.scr include xinout.scr \ Erweiterte Ein- u. Ausgabe include terminal.scr save \ Terminal include copy.scr cr .( copy und convey geladen.) cr include savesys.scr cr .( Savesystem geladen.) cr include editor.scr cr .( Editor geladen.) cr include tools.scr cr .( Tools geladen.) cr include see.scr cr .( Decompiler geladen.) cr include tasker.scr cr .( Multitasker geladen.) cr include printer.scr cr .( Printer Interface geladen.) cr include relocate.scr cr .( Relocating geladen. ) cr .( May the volksFORTH be with you ...) cr decimal caps on editor.scr scr off r# off ( savesystem volks4th.com ) \ UH 22Oct86 \ No newline at end of file diff --git a/8080/AmstradCPC/TASKER.SCR b/8080/AmstradCPC/TASKER.SCR new file mode 100644 index 0000000..c148f80 --- /dev/null +++ b/8080/AmstradCPC/TASKER.SCR @@ -0,0 +1 @@ +\\ Multitasker 11Nov86 Dieses File enthaelt den Multitasker des volksFORTHs. Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt die Kontrolle ueber den Prozessor solange, bis sie sie ausdruecklich abgibt. Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet auf den Massenspeicher und auf den Drucker zugreifen. In Verbindung mit dem Printer-Interface ist es moeglich Files im Hintergrund auszudrucken. (SPOOL) \ Multitasker Loadscreen 27Jun86 20Nov87 Onlyforth \needs multitask 1 +load 02 05 +thru \ Tasker \ stop singletask multitask 28Aug86 20Nov87 Code stop UP lhld 0 ( nop ) M mvi Label taskpause IP push RP lhld H push UP lhld 6 D lxi D dad xchg H L mov SP dad xchg E M mov H inx D M mov UP lhld H inx pchl end-code : singletask [ ' pause @ ] Literal ['] pause ! ; : multitask [ taskpause ] Literal ['] pause ! ; \ pass activate 28Aug86 : pass ( n0 ... nr-1 Taddr r -- ) BEGIN [ rot ( Trick !! ) ] swap $F7 over c! \ awake Task ( rst 6 ) r> -rot \ Stack: IP r addr 8 + >r \ s0 of Task r@ 2+ @ swap \ Stack: IP r0 r 2+ 2* \ bytes on Taskstack incl. r0 & IP r@ @ over - \ new SP dup r> 2- ! \ into Ssave swap bounds ?DO I ! 2 +LOOP ; restrict : activate ( Taddr -- ) 0 [ -rot ( Trick !! ) ] REPEAT ; restrict \ sleep wake taskerror 28Aug86 20Nov87 : sleep ( Taddr -- ) $00 ( nop ) swap c! ; : wake ( Taddr -- ) $F7 ( rst 6 ) swap c! ; | : taskerror ( string -- ) standardi/o singletask ." Task error : " count type multitask stop ; \ Task 20Nov87 : Task ( rlen slen -- ) 0 Constant here 2- >r \ addr of task constant here -rot \ here for Task dp even allot even \ allot dictionary area here r@ ! \ set task constant addr up@ here $100 cmove \ init user area here dup $C300 , \ nop-jmp opcode to sleep task up@ 2+ dup @ , ! \ link task r> , \ spare used for pointer to header dup 6 - dup , , \ ssave and s0 2dup + , \ here + rlen = r0 rot , \ dp under + dp ! 0 , \ allot rstack ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; \ rendezvous 's tasks 27Jun86 20Nov87 : rendezvous ( semaphoraddr -- ) dup unlock pause lock ; | : statesmart state @ IF [compile] Literal THEN ; : 's ( Taddr -- adr.of.tasks.userarea ) ' >body c@ + statesmart ; immediate : tasks ( -- ) ." Main " cr up@ dup 2+ @ BEGIN 2dup - WHILE dup 4+ @ body> >name .name dup c@ 0= ( nop ) IF ." sleeping" THEN cr 2+ @ REPEAT 2drop ; \ No newline at end of file diff --git a/8080/AmstradCPC/TERMINAL.SCR b/8080/AmstradCPC/TERMINAL.SCR new file mode 100644 index 0000000..1a93705 --- /dev/null +++ b/8080/AmstradCPC/TERMINAL.SCR @@ -0,0 +1 @@ +\\ Terminal-Anpassung 11Nov86 In diesem File wird volksFORTH an das benutzte Terminal angepasst. Ueber folgende Faehigkeiten muss das Terminal verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt werden koennen: curon, curoff \ Ein- bzw. Ausschalten des Cursors curleft, currite \ Cursor nach links bzw. rechts bewegen rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellungdark \ Loeschen des Bildschirms locate \ Positionieren des Cursors auf eine \ bestimmte Position auf dem Bildschirm \ Schneider CPC464-Terminal Anpassung UH 18Mar87 | : CPCcuron ( -- ) 3 con! ; | : CPCcuroff ( -- ) 2 con! ; | Variable reverse reverse off | : CPCrvson ( -- ) reverse @ ?exit reverse on $18 con! ; | : CPCrvsoff ( -- ) reverse @ 0= ?exit reverse off $18 con! ; | : CPCdark ( -- ) $0C con! ; | : CPClocate ( row col -- ) $1F con! 1+ con! &24 min 1+ con! ; Terminal: schneider CPCcuron CPCcuroff CPCrvson CPCrvsoff CPCdark CPClocate ; schneider page .( CPC-464 Terminal installiert. ) cr cr \ No newline at end of file diff --git a/8080/AmstradCPC/TIMES.SCR b/8080/AmstradCPC/TIMES.SCR new file mode 100644 index 0000000..c4c42c3 --- /dev/null +++ b/8080/AmstradCPC/TIMES.SCR @@ -0,0 +1 @@ +\\ Times Often: interactive loops 11Nov86 Dieses File enthaelt die Definitionen der beiden Utility-Worte TIMES, OFTEN, die interaktiv benutzt werden koennen, was normalerweise mit BEGIN WHILE ... nicht moeglich ist. Benutzung: nur interaktiv! a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal, \ oder bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt, a b ... often \ Wiederhole die Befehlsfolge "a b ..." \ so oft, bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt. \ Times, Often 02feb86 also Forth definitions : often stop? ?exit >in off ; | Variable #times #times off : times ( n --) ?dup IF #times @ 2+ u< stop? or IF #times off exit THEN 1 #times +! ELSE stop? ?exit THEN >in off ; toss definitions \ No newline at end of file diff --git a/8080/AmstradCPC/TOOLS.SCR b/8080/AmstradCPC/TOOLS.SCR new file mode 100644 index 0000000..fceccbb --- /dev/null +++ b/8080/AmstradCPC/TOOLS.SCR @@ -0,0 +1 @@ +\\ Tools 11Nov86Dieses File enthaelt die wichtigsten Werkzeuge zur Programm- entwicklung: - den einfachen Decompiler - der DUMP-Befehl - den Tracer Der einfache Decompiler wird benutzt, um neue Defining-Words zu ueberpruefen. Der automatische Decompiler kann ja dafuer nicht benutzt werden, da ihm diese Strukturen unbekannt sind. (Benutzung: addr und dann, je nach Art: S N D L C oder B) DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP) Der Tracer erlaubt Einzelschrittausfuehrung von Worten. Er ist unentbehrliches Hilfsmittel bei der Fehlersuche. (Benutzung: DEBUG und END-TRACE) \ Loadscreen for simple decompiler and tracer 11Nov86 Onlyforth Vocabulary Tools Tools also definitions 01 05 +thru 06 +load \ Tracer Onlyforth : internal \ start headerless definitions 1 ?head ! ; : external \ end headerless definitions ?head off ; \ Tools for decompiling 22feb86 | : ?: dup 4 u.r ." :" ; | : @? dup @ 6 u.r ; | : c? dup c@ 3 .r ; : s ( adr - adr+ ) ?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ; : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ; : d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; \ Tools for decompiling 22feb86 : l ( adr - adr+2 ) ?: 5 spaces @? 2+ ; : c ( adr - adr+1) 1 d ; : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; \\ : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; \ General Dump Utility - Output UH 07Jun86 | : .2 ( n -- ) 0 <# # # #> type space ; | : .6 ( d -- ) <# # # # # # # #> type ; | : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ; | : emit. ( char -- ) $7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ; | : dln ( addr --- ) cr dup 6 u.r 2 spaces 8 2dup d.2 space over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ; | : ?.n ( n1 n2 -- n1 ) 2dup = IF ." \/" drop ELSE 2 .r THEN space ; | : ?.a ( n1 n2 -- n1 ) 2dup = IF ." V" drop ELSE 1 .r THEN ; \ .head UH 03Jun86 | : .head ( addr len -- addr' len' ) swap dup -$10 and swap $0F and cr 8 spaces 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP space $10 0 DO I ?.a LOOP rot + ; \ Dump and Fill Memory Utility UH 25Aug86 Forth definitions : dump ( addr len -- ) base push hex .head bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; Tools definitions : du ( addr -- addr+$40 ) dup $40 dump $40 + ; : dl ( line# -- ) c/l * scr @ block + c/l dump ; Forth definitions \ Trace Loadscreen 29Jun86 Onlyforth \needs Tools Vocabulary Tools Tools also definitions 1 8 +thru Onlyforth \ clear \ don't forget END-TRACE after using DEBUG \ Variables do-trace UH 04Nov86 | Variable Wsave \ Variable for saving W | Variable \ end of trace trap range | Variable 'ip \ holds IP (preincrement!) | Variable nest? \ True if NEST shall be performed | Variable newnext \ Address of new Next for tracing | Variable #spaces \ for indenting nested trace | Variable tracing \ true if trace mode active \ install Tracer UH 18Nov87 Tools definitions | Code do-trace \ patch Next to new definition $C3 A mvi ( jmp ) >next sta newnext lhld >next 1+ shld Next end-code \ throw status on Return-Stack 29Jun86 | Create: npull rp@ count 2dup + even rp! r> swap cmove ; : npush ( addr len --) r> -rot over >r rp@ over 1+ - even dup rp! place npull >r >r ; | : oneline .status space query interpret -&82 allot rdrop ( delete quit from tracenext ) ; \ reenter tracer 04Nov86 | Code (step true H lxi tracing shld IP rpop Wsave lhld H W mvx Label fnext xchg M E mov H inx M D mov xchg pchl end-code | Create: nextstep (step ; | : (debug ( addr --) \ start tracing at addr dup ! ; \ check trace conditions 04Nov86 Label tracenext tracenext newnext ! IP ldax IP inx A L mov IP ldax IP inx A H mov xchg tracing lhld H A mov L ora fnext jz nest? 1+ lda A ana 0= ?[ lhld H A mov IP cmp fnext jc 0= ?[ L A mov IP' cmp fnext jc ]? ][ A xra nest? 1+ sta ]? \ low byte still set \ one trace condition satisfied W H mvx Wsave shld false H lxi tracing shld \ tracer display UH 25Jan88 ;c: nest? @ IF nest? off r> ip> push r THEN r@ nextstep >r input push output push standardi/o cr #spaces @ spaces dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces >name .name $1C col - 0 max spaces .s state push blk push >in push ['] 'quit >body push [ ' parser >body ] Literal push span push #tib push tib #tib @ npush r0 push rp@ r0 ! &82 allot ['] oneline Is 'quit quit ; \ DEBUG with errorchecking 28Nov86 | : traceable ( cfa -- cfa' ) recursive dup @ ['] : @ case? ?exit ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN ['] r/w @ case? IF >body traceable exit THEN dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN drop >name .name ." can't be DEBUGged" quit ; also Forth definitions : debug ( -- ) \ reads a word ' traceable (debug Tools nest? off #spaces off tracing on do-trace ; \ misc. words for tracing 28Nov86Tools definitions : nest \ trace next high-level word executed 'ip @ 2- @ traceable drop nest? on ; : unnest \ ends tracing of actual word off ; \ clears trap range : endloop \ stop tracing loop 'ip @ is curvleft ] ( size order -- ) dup 0= IF 2drop exit THEN 1- &90 right 2dup curvright over forward &90 left 2dup curvleft over forward 2dup curvleft &90 left over forward curvright &90 right ; : hilbert ( size order -- ) page 0 0 setxy 0 setheading pendown curvright ; \ No newline at end of file diff --git a/8080/AmstradCPC/TURTLE.SCR b/8080/AmstradCPC/TURTLE.SCR new file mode 100644 index 0000000..3c63275 --- /dev/null +++ b/8080/AmstradCPC/TURTLE.SCR @@ -0,0 +1 @@ +\ Turtle-Graphic UH 03Dec86 Dieses File enthaelt die Definitionen fuer eine LOGO-aehnliche Turtle-Grafik. (Siehe volksFORTH-Handbuch.) \ Turtle-Graphic 05Sep86 \needs Graphics include grafik.scr \needs sin include mathe.scr 1 $05 +thru \ Turtle Variables UH 05Sep86 Onlyforth Graphics also definitions | Variable direction &90 ( degrees ) direction ! | Variable pendown? pendown? on : heading ( -- deg ) direction @ ; : seth ( deg -- ) &360 mod direction ! ; : lt ( deg -- ) heading + seth ; : rt ( deg -- ) negate lt ; \ Turtle moves 10Oct86| : scale ( trig len -- len' ) &10000 */ &5 + &10 / ; : fd ( n -- ) heading cos over scale heading sin rot scale pendown? @ IF liner ELSE mover THEN ; : bk ( n -- ) negate fd ; : xcor ( -- x ) cursor@ drop ; : ycor ( -- y ) cursor@ nip ; : setx ( x -- ) ycor move ; : sety ( y -- ) xcor swap move ; ' move Alias setxy \ Turtle writes 05Sep86 : pd ( -- ) pendown? on ; : pu ( -- ) pendown? off ; : home ( -- ) &320 &200 setxy &90 seth pd ; : ts ( -- pen papercolour pencolour ) pendown? @ paper@ (ink drop pen@ (ink drop ; \ Farben setzen UH 05Sep86 ' ink Alias pc : bg ( color -- ) dup paper@ (ink ; ' clearwindow Alias cs : fullscreen ; : splitscreen ; \ long Names 05Sep86 ' pc Alias pencolor ' bg Alias background ' cs Alias clearscreen ' seth Alias setheading ' rt Alias right ' lt Alias left ' fd Alias forward ' bk Alias back ' pd Alias pendown ' pu Alias penup ' ts Alias turtlestate \ No newline at end of file diff --git a/8080/AmstradCPC/VDOS62KX.SCR b/8080/AmstradCPC/VDOS62KX.SCR new file mode 100644 index 0000000..b39ccfd --- /dev/null +++ b/8080/AmstradCPC/VDOS62KX.SCR @@ -0,0 +1 @@ +\ Calling ROM fuer x-Laufwerk 62K-CP/M UH 03Dec86 Dieses File enthaelt die Definitionen der Schnittstelle fuer Firmware-Aufrufe unter dem 62K-CP/M, das mit dem Vortex-X Floppylaufwerken und Speichererweiterung gefahren wird. Bei anderen Systemkonfigurationen (Standard 3" Laufwerke oder ohne Speichererweiterung) kann es sein, dass die Firmware- Aufrufe anders organisiert sein muessen. (Siehe AMSDOS.SCR) Dieses File wird von dem Grafikpaket geladen, falls der entsprechende Kommentar in GRAFIK.SCR richtig gesetzt ist. \ Calling ROM fuer x-Laufwerk 62K-CP/M UH 29Nov86 Assembler definitions $F4DB | Constant systementry $004F Constant 'start Create jumprom \ Startaddr+3 in 'start, returns like a subrout.Assembler systementry call $57 c, end-code ' 3+ Alias +org UH 29Nov86 UH 29Nov86 UH 29Nov86 UH 29Nov86 UH 29Nov86 \ No newline at end of file diff --git a/8080/AmstradCPC/VOLKS4TH.COM b/8080/AmstradCPC/VOLKS4TH.COM new file mode 100644 index 0000000000000000000000000000000000000000..ce2aa6ed52bb8d869ae3506815603254fcf3611b GIT binary patch literal 29952 zcmdtL33$}i`9J!d^Ic~WlF0&@Oh}kyvOzK-1VUI7W-=2pFv$#)Ng@!zgiJ!nBtZy* zvWQ!;Em~`}YSkYVDlN6N6*MX;W%((n1r4pXwQ7yBsI;uMZk7B$@Au3Aw!i-FbMJGX z=RVI3Wagaryk|e>J@0l-goDoU!ogD|!olg|KRak&Im?ziL3l=Z{)ejs!6fXR&|0=5 z=fX0Z@SXame%rtP)@=y&g$b*vBm16Ab!; zwa$9C&l7CP7^Sd(Fs;d7?eKZ)=eA^66lM~|MykWAGOH*y1ZFwJY(bcMu$ZYVj{w<~ z;?NgpyUHd5H887A9Oq+tvWMc?*NQ_q063V&8bvV}nAIy{1c0Ei4vJ@Q00IDnaD#Yj zW$LKQO_w!O6g33<`VQ(9cp6f zlIpp}Q{5QyOqYfZPGlxFUQz>|AeKvAoiwz;-q8nW9CJ#nde$Oos5f6ghvQf?;@Q2@ z(BMiG9>+Q*smA9G+>D~beLBJol3E?|&z|k`+y|@;Ppk%BJiAje%=(Emgw9hhaY5wGzFZz15%JJ&zKfj25*y+8CrWoX^_&h_I7mcs5<433{EgG1|o(6{bK zojPc%qSSk4J42p*%23h42b5Iyw4%B>=yxdbfgdcc6n@lPDLmR&DLm4NW~Q=33Ue2o zQ?eCd>Z0rIP0RNWrJo*J|LwkYcXsXv!btY9!X^|YsY7;DF_M{7R#r3yF&?$3Y+_Lf zMR~kHWs{03)uALwpnlgPr0AiMtU_fI9P?E)jLHe397iW&JbE4SIc@;fi@z8v8^Qecq5kGxdq4 zP7!TMV_&FJHDDtF%NIB(UONPcC+O6d+^{MPFH^EjCgC;nuzHvIr1+XSMf0h^!xUMkrL+4rRyt#cHZ+#wrn9X8RPND+);;rOM0@&xUP3zC4d~1_ z0Dbz^DC8AQES*vLA%S8@f7T2$KSjaopFa@M*6qQ^!A32Eozc|BW^bt0Tc2daHb85S zWf_OiutDB%gff_H6y2pW%Zw;)h%ycWHqOZ0GY70K@&)Z~{4P@jDT7r4ID>!{$^|Xk zqzMH|n|4xsNQ=l3?9kDy!6-G>Ij>odx~Qse8Bb$aMzekbd+YDx;HrbS8b`D58bx6K zlt6Ww4%q^TxBfW}A*4+9q*3u)6Y|u%UpIpO{9Maq|7{eVu7>x})@LphGuk4V>@B0@ z2Jm7Oc<}d17W>4gxPs35>RO}ex-JlzqI7p17E2bpWK^qoirqv*YQ$-XgfT45q`3Sb zUJcVt*z!858pBFWn^3zC$M-xF4jS4D`~b2skLk8Tw|^;+`Tjj2(osZgKoQQlLHdZH zUT3<+G*n?oh3#e!%*U zafezSe-_QjXKUl#9#FsmD}jbp71$Q}Y}_$D$35{Lmj`^|fYlhkTZin7_cYgfeZb!h z{M{-qe^|XVtYI$>ShL~_WQx&7GzmtOq?*nQQ$@dtuL*hr9%qPWea)J1jn+!jxZq4krBjPjAhvgtZdxmgrTw6 zI%C;*#KyZ5hSsTxV>;K5q4Rq2y6<d-KTRguxTt_-t<3-@5-z5t8ZY#6tiC>NK_v&Mn{a> z#HSJn_}2u(_yOz11R~AF%#bMR7#9<$zu@f><#Dk*=P@ok&zM9u4w(uPd8YD2xsfAn z0he`~UaUJ&X>`YOZc+D$w!nP(#RPLWIW78S) z-Nb`WC!XP;!Tm!oy_s_G!^9GHEKv^loYmMqe@%>lA1q;)&@9mRkkvf2Xp~^r3H*3w zHcK^LpKrWbZz~Ew-7fP=d)&babF8J~S-x2Yr$C!`i|PO=DP=yhRO<HH6Ls1p?N-<7nZIpj)jB8w3d%tbo5g?=6Bq{D;i|#< zEM>nmZ>sj!1#}v)O=pKUi(4h4h7;I+vt$o>U7>WVFoC^mmMZng-^~*s9=Enb+FlY_ z)gHF#Qt_(gB`YB$|3CVfz&>x^lq}v@=1*Ev7DyT#dh_7XWV^eLR@pC-(ZOFNql1qopFsQt#PNan zPHOks`}=Nsq!aMhlI=PEq@lI<`)_(=_KE0nBXM-_#PxQhUr4sDwqs|VNSLh19B>9{@q;l)sYB*3l6+ttwu!$_+6+d5Scq-nkhWc^OS*vRuVCI3soq(K z3?25Wlmgje_9veNX_&&+rpOH;NH@e&Okww>c$^K@UN6T>R9htC9*B64)d+iQij)H$ z{k0U%+7!KMO@VZK(@}xg{weH03M7^^HS*SPsCPIusf!(p_E$-k@89kMZQYe zk1!aH)RTx$Wm@WOg(Z5b#XQSF5KHO-0=#C=W9Ow5U@J~#(^Fj~F$mA& zOLevkSZOf!DyMQsCi1RNWs6c>El5bruS+5^bSk?cRcWdBc-&wuZcWL}ipV)qTPh`N zN)>B8*HAU)x4{1p=*Ow5+f(hWBbg*cGjZ@VwmVgELunMMdNVc2tW%r8wQrTa9nmhC z-aeapDG8ys)V;^Rj0k-v!1nWY9mN=863xd{-nId2vueTcOlPmAnw-_ujdhJaOa)MM zhVL!5Rid-7MdqP1I5P>^I#R9n*OQtHy+Q%MOVt_wk*ev_;b!dP0c(!*hFG8&~U_?1RW)kyEsi3tFSjtxQi&(egv_*(Rfaj%`v;iYZ!dEN%O-T^m5H}%_ z1HU_x4q}=j9{*kHQLS@i!ALgh%hdOfiQ?I&bHnD5t4C7G+au4ZJViDA9(-CAvy4)B zL(rE|6*6(nhAKMeCEMJBgo0XSF;F)O}_-9brYOID7Z6iUQER<%d28$QO)~=p=V_K4?uTijh zr%8$EWXsZ&TK!xcu>K6IjC1KlVy0Sv)kf6gXBfrZ>SHpctYv>nT%C3cBN!F_oirS@ z&H&GvqA7GXI@zH#nV^`$qiJ)+L<|?PPFw;gkbjVNG>t@IdnAx*GMVSBn|cnkU}eU_Uu#@hBmE@WTy5CvC4j zlTN1^1mwNx>z^MwaDTe4k*ZoxB=w+BNL!bXkYfa#29~S|qfcG(VC+tV<0WWtA&kem7W` zOpuToR$-MXilq?NFV%1RZhs;c_!f;5{o zTU9<_(*~^V>F))>RO1PDkv&el%nsj0qZ7pC`VqhqIKm`s$yA&?Do{~ zI)>FpGA?)LG<5D>_KOVG1S<@Ly3sqM|A?FQvezdPw^!XJpf5Qx);dOS<)8xCDgV>Khps z^tqzEmeEqk-++!%UZSqlJ3W5iw4%;>wT5x~p!O_!7rjn1NyIz}a`kLV-O>8obY|v z47EQ_93I&Va$m@%FB=sya%TT~MyLjmwN1?vRk%)x(*^jeE)cZ?x^=AX0 zF3ue*0`UpFEApJDnFd;y<_f<~(lD?khU6HV@4|dp`QSs9GtSiW7;aLm? zMG%^kN-dk#%X8(8?TE_hsmMx!%5hTYDHbWGEFW%adbVlw(;|fqZC8m9BiGNqWuv z%ou7J&;N8bR@y@#a&i4#olE=q1|J?pj8AHme1lqBRm^?Adb)@xQ=+?TNq<*gFHF}u zB@mOR!_q-+$!@y-2kU-xV72W?H&bnpYbjCF6Nhek;qAL@2kx@1 zeesxsA)ShjYtZRSxMz9)jZm<%fK4qSnW(X0Uql7`rRn+(-4=?sqL9kv-$4%J{CTt$?ZoLg>;i@PQFnDq4k8*4EcO$w4(Vu|wGk$K97PnBBxa z&6W%2HF}Zr>+IW;lCkJN$D(gyVvbxu@O>F^IZZ4hN8(7-sC8m(+&T5zW9&JEI2O}| zBi8KqsmCzw-;LYmq2 zIbuUKyaWWHnSDEl1?@a|e~wb9o9YLw!JK}3*t{6R+AK%E{oUf2fSw?HFNbs{Tcsc2 zo0suSNiLy8so0n7BS5hoU(S$3oX7-1imtz@UGY{pEG~CRR z>@Vw$(BV&VZ?;m{~8`4nSX-anNs{&!*d%%Xi*t z6Xvs4y9{Lz=@vTd;~-PdXA!%iL$EuyK!>ae{dT^12CPq+iIZBuHrSY6BqN*qsVjlvPXM7eZu*(;P%W469H7BYLT=q|z0celJ= zK5zVuy)d^${@DJ8y#?aQ<0xvovdK<5fQ4*IE+a&Xe8kuySLPC^Emv$L7^zD+WK}M6 zmk^*bmw3U2Y*VfQ@gv5~dWHvcS)-mz(H6EHMWRJ~6Hr|sUH2NNn(oz4;H}aVxw}<5 zfeH8NT(NpQCSaD(!iI81-}r{}Rx`qX%awfI1}u77JXxty1C)Q?%b~m%bGJappNsu- z24{FD8bt8B3(uHN<>n>SK#?&UU88xLgbrTIzQ{Gg`bA5j+A}Y&(o_a(l-QS3LLL~` zvg$nOg}@n7xHS)ir5XksI!)(_bdoACN}Pn+k{BgT=*puLXD%oiP3g6)Cl78Ku`K<0 zbS?}P!Ks8yRdlw0K@KGQQO_dwUwMkRffQLS8KW1mSMszPkOQvR+OcX8`$L|D!>uWl z{{Hi{u@UjN)P^vYtU z<|~EO{-CF7X1=b@OG=0dvipZlyp(==-1)pCY551j`GbQ*;ZGd=NX!|TPpy6Gz?%G+ z?v10I9yc*MO0s z{oof!z9xl8wrQep9*U0R_zmU|h7VjBv9^yPeT#ZFKiiZ9LaMA@(bXTeeVDJB{yaQG z&pfOS-@FWJfnB;EO23Bg|Y_+ zBrkjqj*wl_Hjx@}G4H2&yd*9pCg5z34F(y;+F7Uo7644|fOUF)fkOOSm?amgh3Jhg zdrZ&&MZvKGen^B_exXw6;wzLAdi11!prA0DRjBe6IjgfUX*3sv9tV73p%N=ATv%F2 zs4ENQXd&T3FCZQ4TZKwvz#Y}AY&@HXK~fV{qI@0f!9p{6m^s}31_v(*T*25G9qg&X zcs(Hsgjolp@{a;8{9eS2eL8%okdHtIJ5o48pQTt49Ghw)d=tiHF?x9cBTFOJ!M-e% zYkWGV@lK&>tRQu=absnlx6T{Frul6rn=w|dfo&8r*89(QvN>bpbQv<%)8JU>o-ozh z6+?ce+6G;lA%CwD9D6~c6sn7ArZsdnkM@2iyJoBj7D~_61-Qo=^0&j8AlpADsJI{L4Z6}9om1U_?UFu22jRlN z1yl-VS=U2#+y;H+i8QXPJeo#g)MhYZe8gHXVw=T&tUZFz(r(7m-y>2UT7g;CHeKK; z5%!3r40wB(pc&(`O%{Qcf2Nv`a6D2oRRwE!tx+`%48H+&#ebo3UF_qr(Akk?i<3{9 zq)Ac6Gy&>Q(u-}@R21-{9;U`paePpTZH>sP>E)<=MNQ}YIB)dsaobQ4$$taZxo7|< z&@`rn(4x>-hRumM{D>9aD$&NHsUjhVG$N|$=rF0kNwVBME`D@}$%b5KOgJ@U%0&|J z&e3N~yTGG!*$}CaD!-AcOPI^p&tX(0E_#wG2R6^)a}l)=NuKx|`#wH1r5`N&l^wzhcFBpTb_ zI_@gvN9HEopc`Qi6~j>CC;jFh9dwlLDBe*_1S`T`EEcP(ad2#MoXXv-e z{;@ez)zu3v(s7;i&c!hGus;;5+*vfLVS@hQxIThCOmj#c?DEfwg&t;iunWZL#*~g4;^ukK>KfPJbzUiZ*eHP3+t68o{u*17Y=c*Xa2(uwD4tzgkaUf z4zzL5p}f;q`!h+pqxz7n|r!vN|09yVZol+6|SN`Sh9)P;e2 zjhkV7+avx74mVd@NH30#8&@{=dnKnvH-j6nY_gjfi3gJ$3rhrPIonhsQK_d&#-$pF zXG)4UBvcW@G2+0*62tv5FmY5|7(M+(k}1Z{oCa@Id9bWh$bK>}XMzAO>w5NH3H+J$ z9!?)`xVGfrrC1T}I+T4{cSF7D*#mXs*FJ|2cilKeC=qgM#wH18({n}{l7xSz=kTVS zzOD!$hLXw_&9{u?m6(A@qzjK$*%g+n{j}DJwCqK^W{SD5d(s2f1Fe5!ZeefmM z+#^|~`(a0evUoMiE|uXK)8MQth1#j^h%6kOR=S#1mr9gxz&f^+7W!&79{`|%zUqKA z%v>tkUEszwVGUc0aCPv!bp*nj5cYvDH6i?iQpxUVs6KDaKx7LdA*buS)riP15W%K9 zZ@n3j=MZsGL`CFfgc!YmfiUm-gJzzbgURNqeYuH~(vg!#Uj0^+TyGl=%K7?O_HKR1Nc))rK03G&|rSwe+-ADj=pqjT}Bi_hv zpCE<20a$ZLD1@@LhU19>-b-^dS9ql10Wjh<~hsY10BzSE63l zJ1C1&4@j@Tgop%zn~q#M-hS&i32puv{Sdr~6_#ljHJ2ayfae{feV>=c&;8q6L0Zc~ zWso^wTRU&vD6C~YWpp=SJbWc+4TM!3`D|IKiMTpl*v5c>!M^}C;9B;*GO?x_Gv9)I zKP{872kAW90+Y&!>oJCF+3qsUAMn(Zz(d&*=axQFM)1RB#%iCx0s35?V2&lcUnaTh zoLCttnw1yvMVW;5%pyqkT)oh^i3HJcatN}Htu0gC!6woT6Qv>(>pGS>5%%aBXQK}- znmO^Dy0eUo^c{9GsOt1941@b|GbO4{v3OaWYkSt&^UZ097Sv!TIL2jfog!O>68etP!k z(te_5mG#gTpSL<#KRY`~t|jH+d22CZUr&q6<^+&Px zbRSrW8YRj~&?t-2k0-{_IwQjuKF?d@1XsBrN_FM3I|yU4tDK2ad$|_Fag~drbbYz; zvi90l9w$n-l!MQO1m<>?+ePW#a)s8l2eEuqP_F2i{jTytQTin>iblj$K2DTgD5o*i z%@(fmVo~~SIkua=Z7{0RJLQVr3Vk^z&_GMlC*>+XYf5RYB+(j|q)X){4y1u1cru5l zOomz8>2@@D<`FcN?<7eonrv(i!bv=qFfx`vNjj~XR&fpsP(e6eX_9-zDUk$ZwNH{5K6eCjF!t$ zY&=>pvh>1a&0Ft)hx2UIb$D`{t|c(Hg>UTZZMQ9H#a*ec{u{AVWGTH|yHZrR@bF|o zQl$4L%Y`)h)Xp6!{))Qh59KlEhj$>nMapR_o389$LVp)KJyO1YvPC{rPOP{hWmd?A zWQ(TaBIQp`rq8a)(4)8O8?i5{M$aygzghgD@^dPc_bMYkO_3rM`Vw;J8``J4MEvjD znJ$9lRa7V+Pu?b;nJ7rA^i+jh!bfw9N(aLT(rmcBSa_k6;?AMRXF`{vwQWoOm3bOeK(JyxS#6M(K$u zayBE9d5F_)i07rXp{tU?~Ig3Kp&~6nzFDw zQGG^NM;3riQU-YVkSuD1f#R-ml2Hjvek6%1=@ChGG)ktaQg*a|J22zqGteR@PbGz% z@c;48|NRyag&0S@R?+Jet%_*o{p#H^DQPWw_pg~&Ad?8LAQq8m7`ReCx>}Y^qh+#e znjo2^?@k5h71S;UOGJu%2VP;Xcae3 zr`1Xd1u{M>xF>Q_Jf}v=>0G~xmCh3^335zwE~@TleZ-wJlf^`Gf3qwNQu%-Gvq>!OFVA>3}0ewa%lJomkC#E+A%(<%vNWu;NqDsh}} zA)S*1|6!#>W({u4_2{U-tmH1dm%(J;^;BkLpVcedU#WWQtBK7dOY3j-Ebmu}9zRs` z)J5VNEHZH)Bxs~apH}J%7*i{xisMSgSSU=(k=#|e2<1%B*FPQpv8A}K5bD!>I#9xeU{X-+1?hhEHx*=4I6D*Dy`7kF@+ty1 zk}B0#!G}MHCjV(>b5%-(MJJnNTwYQ|g!1gnKh31>rAj}n;_MPsLIv{2a6Q%eQD}zC zDfKs1%sK5?l^~=_?^ZDvf(8UXs$$g$G6XMHF*kxDf|sh;90ZNRNXa-$qkYc@pUmbP zDv4~5LH)u+nhZafmaAIKIeTi*C@FQ8R04@E=02SR`nUtGrTk=XozW&maY6nYh<=2~5Dk3>vg+36KZ$ zAA|JrEV5w-LyZAm!dtV1Xq=a@(Q;IHJ&Mi063v1zJS++pUV@@IWRppoSCf(Mw=jT)9$7(mFivA9jY)e{8-BzK3D+THFYT zNKD)8jH~z82R*R1=ys8ZocBA4vHUlk;r&iBDUn|Db*J#UlfCXlKzZG%z3w!O7a|4McHUTn30)5)hWU3{cd_2(54#>dspggx0ylKm*F6@V8v7 z0R>R-UY7y-Aq5xf+SA{2Mn$dnoV?4I0X53Mfyk>`ql4q$Qr>g^51=6wDQS zy3!pq_tK{*HqWe-sw6mX+1#kpo&){?M4La7wmNHleF8b zSrDPalJ-3UqTn|q?I8dW`lF=%q*|=5bMADFm$YA2iwz+_D_I0)BcB0?{NmJdT)9v2t z+9+ws6s+Fsx>M3J-C{$dYp?4b31(Tb!G++1k~R?t_0GMnA4^)LTf8QS;Ljw@>lXbK z{I#To+-O>0uj^S!TkMvwqplfrF-cqI7QOYsK^I2-1_}ZyO4==MG{QaTGD_NJ1gilB zL-v4M4EO_suKkj>)h&^LKInQ$(ssH<7~2M2htPjQMrkto@0NUSs>Fo;qZy5%)2`p4 z`)=l~KkfRnq@AQLc~84umb7ySRwH;+(!QeJA^4W0DIW9=!S^IB$%Eb@cv8|vd(b-s z&q!K<2fah^ACgw)5vv0TUXrw#9;u<$=f331k+fP5?$7vqmt03M03OMw!^cV5btpRI zyyPmAw1`JUJ1@DWN!n_UIHxXf$#qcDZbh(u!6nxLNxRF#<{PxO;=s$o6 zy^Y=j81P?meIRMiP|$P9^@*e%KsrjgAZbSss=MU+Qr7-}HkQsjZ+%;kwIMVNSEA2b zk0J6m539!RqTrVv+?_seJ%FHGLzkw{TVF-kT*Cs`{~sVYx(1i9&s#4bSOAPlV1J2l zSqyq0p^>7hhLOPH;ZYX?`MUdkZ% zNA8uXXj!wx>D4%Px2Rogp=a!Da#2>ask0@nHTi53m8fX`*>aHkr&X~|PsH`8yFlIu z_K`w~Dut?;U&p*|wuCJTr7t0FbkR*6Lfhot=(5N>6hr;aY>Xu?#Z)MbHMng8Ou~TN zt<7;l-%Y#@i36l<+$EiW@l4fTpY4hI@N*yOV$1NTZ;#<=AI(-OeNO1lN%PiaX-~Jn zxBZa%gS1ml@*h8%My^~((@3Hq$7HfBM%fJRYQ}FOshU(PM~gY-98pVU8x&uy=^Af6 z_8~tM7dQnTjUMeAXI&IN75*;#Lq7uPqiPm?$~YkDCzSqFMQUoEt7XjeX{{V=YM>kUo2n#bB*EZ%x;4liP*!)*pFA(|5cg ztOEnq+r7=uDp=%uqu&+E554b5WzhPIrmfzn1>uL@gXphldf6)%k{y!P=N6R^b9KZ& z08VC0Vi$kty#O^nH!#ed5EH;f(^=qfd&Umrydcem(L*w&%;6S|N4(@M!^^x@PZ>KW zYS;K7lAeXJ^_ZS*1rkYbK)*B`nnL$<$!b8?S;&Qt28|lB8MkyvOtQcRu@#c(cBL5$ z?ief#7ton27=#nUcp|aGPS%MXm$6``pHrc9%%L0=%Ers#X4UEaJ%{4XQ`;Q4J?Qoe zj;ole=UlOpq-YmO81Y z)%4-qsNL&qZOroZbuHPx49ZAfd~BET9o<(e!~i<8zR`R^-?>*lIGd{oI=73Z@S;j) zFS=e&-+X!8;-kAkxA@+L&ey_|2}GLQTYTrP08_Mho{Bp=CrdFirNDp2NCC7izSL)I zsIIN|;Nn;Co!aYtH~Q}IJ?Pu%8}L!vkNR*MBru=1+vyW1Leh1#-R>(*)g9HG zZ4X!0{A2jCm`+_G9Rm3+(OL}`S_?@4CiKMxW9vxE@J=E3#0nR-$nH91-LAYNJ*H=P zr;uD_=%P9q)5!4Frfn0+%{&*bFndJ0VMx0)SvaPW_sAKgLaDE#-Ks(p!_&-Aa@5!D zP_m@W0X_6Q|}JdoJCipiS8@1BjBMbojM z-h``jA%Bq9P*^YUXlz0@ejt1(92ZUqCxuhON5aQZdC4dUy5Pr>*VeIn@szHD^6UTVAA?JkGCHd2qJPhWYC0>}Hj`=SSAVgct7ZTh+PL7HD08 z`(6Eb%Z>8S0JiQ~TsUB*EjKT96CB+Q*;TmbDkd-UE4=p)j@~?f^Ze732CP5Ip~I~} z-l8Vv^Lt~-p{3y!VH^B+T5a%jY!9!+1>oI12kHV4R0v@S8M1 z7WsJK{lFQ}WdWkooqmlwFuK7{@-Zg%@u$!-h0?!+7Xj#0OwrJkR!93hS`dezAXRbo z7tY9JNrLSqs`jJe3s88C@_wMz@v>h)=u|FQP+*m;NYN5DIj-1AXtPt9;ljQ1UerVV z^Kkuo9+Zs)hUx{L&UW3^`H~FdI?b|Dja|LC=0>j_o)i(ogN7?~pI54m zj}d92w$CFk*?k_;n8xT>7q`M z&BrF>2e!|n&G7GemMm>uL3wtl*Q1W})?^_rSrC}lP2=~kKLgfhgLL^?&}WSN!s&V| zWv2m_gx~7Td^XsEqvqM*yDFKF&7NLtP}_}tt5(>&Zm3`*m}oqw!`BClRn*H?$Fsqm zK{EJ!>acj}bft>O8I@~*zv<&!)!@`CYM&Pm8ozEHVa;!#KJw7T-24D>U009c@xVoF zp&9yo(PDWdw|yR&HB`(8Th*JDs`d1>cXf1y+mEAczIcjsA1T^ap>%n`x@O+H>Y!f5 zntA6ghv>LkGjEr~Q(_KT!|IM4a>XL&s{!jB4S#Lm-|rOi5KU2;zDrX>VLdH1P#-As z^YG+A8`58@@6%Iy17#t~?F~{cpWGI>P@k$pYC{}@^6pSys^_^k2HN!0$AhVW`s8}x zQ~ouf4tr`KB5|yj8d@a2Bqd=@h{Nv;=v{?qJz)KH=pcwArq%CAE-WJ5VgR~M(N+P%Tr z&{ukwFy4A2${S;inBLf|{yIc9AiXKHY_D!gYM@1$-bmbPc_VL%r;&OyVD&We(Kx23 zOmA$FsIQb#-WYAj)rIK|c|5o#^sPo3Ct3)6G0-Lt7xrVO$-CqL^3pOo(6|fVyQIB{ z6TRPyc#J-B>=;%om9LZI!5!-NaxO@GAs-JO`$p{LMuMj#?+z*rwNAIcnKvPgf$Km%-AX6oq!DG-S+^fV2K5xA{h1@Dmiffy8Nnh7mbO$DKvEb&go10FG zWFBZ%smWj0&YpL+maK1P;pQfy7OD&W@!i?D%*8uP-nyv*kL{8y-mhz&L6i4vEe+=J z;5&uG>i3$crn9vs@38u$t;%}X#(fcY>*VlzIfwCm4z(S&(QtfZySeG=AlYdRbu}7TRT!CX?58h=wmCK)XA&Zg%hAtwtI<_HQZ4Qv=ro z9v)Bdmz&8D^Fp(LvzP||q9&ftfscbi-D3sEHWT(0{`^NoOHZuVQrMMd%A!9lwSBi~H&(U8d~{FCuzdgBnTW zObscJi6xjl&*Ys2>PjhN(JkuQcIEmYeN#FS5emOlKUVK5kqyFo$Uk2vLpL@5zL~Ey zBKx%HX|*|nw03U1rurI+{oop+!m8;l7|blm^XIv%LqX7zTT{qkOMeC6YK4X+`KxO# z`xu_Lo&z6o9={jxdlA3y85AL~d{JXQ0Pq&RsZv@za0&{j(%1RAc7% zrBq|0D3AE+%g?`1Mq2(EpO(N3$?3^+=gW5Fff_DXuqJPqALp#5OUKbNdIK8+YXWx$ zE`~NVCN@6Ucsg`LXrpSd)J$I5h8FMTO-PG8rGgki@*JUcFgTANbHnPl7mzpdu)1vl9e#q8 zm7F=>0BxlJ9`0Q5;|10Q&5o~YE9N7K~d zx992=eZ8H!OChHLoP<*I4a%JhjUm6^7nSS2Q!nVT%VO}xH-)!^KL~#m{v^CD{8@M> zDs`EJjXJw!NWHL7)^j{KT3Ml-`}0&7-M6Rb30Ug)TMTYe?pS13 ziv{c~UAVorh4bWueYZ?Zv6#BEh33uG0@}989%!M=V(ObMhH9G3CtE1?Ns9rVL{tq` z;R7=YQ?v~v zwZ%MOz)DgUat+W&huRA%rb3y1ZNHt@uTc=(=apjpmy6|ZiISTZYZ*^Qe+745=x!nv z$`j*}XlUYTJM=LpDW9%$oWnIaGKnQFQzn7E)%2SA@PP@{>(DDk62HTI6)c8!P)BRQ zKtZRJTGm23O(?71Vr0;L_gZT6NU*fM*U}LUo8|~~gd9Ez`|}p&#vN(u`K-!Cx>&v54QY45de~xyWUCok&j0 z#L1ab*DV5X8NC{QH{A{rBha)Y;)J5dJQedxi})q+0qc{temmWK9#(&eS2*ag!1Tp< zs4!>uB0Mw_eKvdC1B*h}(%T`YKMtj*Ev8{FkRMvK3nwbAAo337t`V8)qky6T`eW&* z$L(GO_x+N^(|)$-rw8s^Jnmt*?7#4K$>IaIEWYtYe2?3*Xx+0E|Ni3j&*A&vgNuJv z_OnH8-8l~|!kqxL0axN5Uql2jM|gbEIXwID=%T~6hww}K{b`GLBD6!@x#$A!T;YZ1 z#hb+|7Yrvkb|NQjqsP!D@;%m9Iq4KHFGAX0Dca~OGUT4zM{rF(c13DR+eZcwh1}n!;2;6p25GWJq1rs*x)&2QRiz@djmcD_nFvTtz0d2nZ8<7;`Du zDBL34D%>XAF5Dq}OV|`8)^WljNF%gGA8on)UXu@moJNHnsLR%!{b|e~+9OtswA&G*bLD|}T2wR+ z^nx9U4q6)&O!TU+EwznLG>sdT>HkKVGZBlGNj-L4RVo|7OSR&gN=?GTga59JUjDUR zYQ0h{btlFg(Bx2zKjcH_q=a{+@c6|@T%XZddoD~hgVOZd`JfblVvt-$zQPh-ov|&p zlF!;B;8ys(?XA+6?U`y~dn}Hp7jqM%@x$$O;*dvk&N!3^_C-g-`8?gm9~F!>DBENe zbgyAj>Qh~&%kSRU_O$bChuaC8yI99++|wRQO>J9jz0^7*TC;{&D)t7?skOyYsg731ow?li7jmGvG^ZYv0R0<^>pAsOD=wTa>Fc1@4W_rCO|~|04wuL9 z^22*Jg6oeWQF|`Gyhr&k8Pjk|(i$O#^9Lv_X_Tu~Dg+hXmyxiPFcjV&l8h;xKr%h# zrRT%FY&|C&@Nl8}iCj8gST-I}Av9xqxI=$qCt3wu$-OI~Rlv)idO^Hm>ZMPv()}ir z;R}s?q`O(7?}&A`v4ovi|o#?GZFZwQ0JG2wUmDMTOK zmKHBe(ILz-c`2NM{DF;2@ea^r;U%zH`inrgqIo(pmEM5>-2O4MtX^tr!1F4Qs8Jm$ ziyXKj+yxC6!~x5erAEBY8Nyq%JnfF9u{6>0!qVFVaK9rCI7R!6T2x+s!lThNKg1Jm!xabUjdWj2;_B(OMb5#BmOn1NlSK0--SKV<*8UEt5F|@Mm)zj< zcyRLLItZDg30T=BHS4!LP%($m+cm#fnw2^t)Cw<8{Ur-%nn`dyymZ4-IG$Jd0luif!5a5nh?cu zsmoOWgk@R8xz#9X%P4ojGMO3;IQC3kD~yMe9CNXxX>cph6e8<%ByN@b*uslZJiXn; zFPms9BjND!uHMc`4nkK=uj{sFgEC`TTmbJAgAL+q%d=F7#$!Cs3Sp(tFRT)75LOFo zgd3x4YeY;ywSIruWwoRx7_7frrbY{RaCBc!U(c)-&iT;wqQuw*PzE1J7Qof0t~`=o zQiV^K{WOn6X=Bu-JKOg8vTV}_F#F1Mk(4}9=!ritLM>84H&&z7*e$|^rm9=5>b|+E zdqh=t2D8rTX1Si?v#aDGFR&^&|m3@9UFF>{~?Up8tpOUkoyHvJ*w_Bbt zenKfC6J+ZHlrS0LGTHi*Zn>cm{wW)}L$dYP-Ez?!h+!ML>t*YU-Liv6{Ic~`q>$^% zhVI$2^$$qlky_b$yc_O|{BhF_-IHYN`EJc|IbJSX4H0=l8NAvybk}X@4#?Id#7hw$ zu#S$bL`P+7HXs#I$Z{PrF_McvRpT5Rk*%Ico`?QoNO}ZDkM0Eg`^I4L-tJKUNAMOM ztXN@cENX@cKN4wHtoKD^2Ssk9$YT+uNdL<@k%&XF{xYIC^w@0_dm%y|ijhczVtqA& zLBea)w^8Ixl!oW70+Gma#rgqCqsVO(IUB+I9pLwA_f{{6U`bp5iKj$;{`%RZ1CV;C zm5Md7N5h3ayyohJVuDspkmK5WaAi1HN6_6@pwoMldi*gY;_TBSB|Xn}KhX`Rg|wa~ zl%-nd_2B6(x;_e}(^dR$LN{309?rrxbuU3|BVy}%xZ13tdtDDPu%ysh*F!sZz}nNj z5vef@pS%$m^n8;f4D?v^7?}j=NvV5!bbec=G6+Kxnou6)rAI?Jk59QNP9=lQM%`C* z5DDE}wPA7G-g8fnxp!;NK+k{oNWCy}T0dAO>w9a!I<9v?4?!w>O*(|MpfG$!)gbzv z58YD1O(%Z%WiRg~Ifh1w44*i;>FTDfzR&iT?np1ayVIGA+r5-hXuI+!$?zA+VD`50 ztC_RIE5nhH41L8Gpt2MS3qt(=nxZp$cC9Ez-5U#Ikcc@lh?tppl}G zL;-q*X=(2cbvbe^@1?Vkgd0B6bQ*G13n?l#i%)@!8VuwEV3F@GB;SFj%w#;eyKq}H zOsXt`a7?=PM(vn{R|!(ItWEYuB7f<|4FJ7=qe(WW;Eu>&@je?jug1fjES$`fq zn^e>LlRom|y4RGA&NkLmsIKkciQyKAmr(!FZAjo-GiIh zt1iLk{J%eN(eAX^s$o3DJ6>qP|J4Kw2bE{Cug_eWxzgTmzg~cY)7}Zj>%(32XCWV3 z_Smw28=?Q7{aHvs7-1cGJ)SPaj-bss=K2@azbqv)vuinVuLh-{KR$LXg)?oBEfZn@ z?p$YCFKoCh3{W6Vzc!N)y*)#ZE)m~IZ_0Ac(S NtI15iJa;YOKZrdmx|qEA7!|K zOGf(cF3^8lD;{Hx{?$yMOjK7e)F^~QZy2R4S%t^I`=;7=J6XPsi-(>+7|x?&@EP#YnHsty%feM%u3YtRI}>XivX-`2wLKKQCbhdPEpxxZJL^tfC?9Ulrfv z_swmX6sj%3E4jjqrhXv?KpY-$UDFKH4KoZg4V8u}!z=<|Sciubqr?1->^8lK9jpGm Gi2nmQPc>Bl literal 0 HcmV?d00001 diff --git a/8080/AmstradCPC/XINOUT.SCR b/8080/AmstradCPC/XINOUT.SCR new file mode 100644 index 0000000..5c47ef5 --- /dev/null +++ b/8080/AmstradCPC/XINOUT.SCR @@ -0,0 +1 @@ +\ Erweiterte I/O-Funktionen 3.80a UH 08Oct87 Dieses File enthaelt Definitionen, die eine erweiterte Bild- schirmdarstellung ermoeglichen: - Installation eines Terminals mit Hilfe des Wortes "Terminal:" - Editieren von Eingabezeilen In der Version 3.80a sind diese Teile aus dem Kern genommen worden, um diesen einfacher zu gestalten. \ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87 1 3 +thru \ Erweiterte Ausgabe 4 6 +thru \ Erweiterte Eingabe ' curon Is postlude \ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87| Variable terminal : Term: ( off -- off' ) Create dup c, 2+ Does> c@ terminal @ + perform ; : Terminal: Create: Does> terminal ! ; 0 Term: curon Term: curoff Term: rvson Term: rvsoff Term: dark Term: locate drop : curleft ( -- ) at? 1- at ; : currite ( -- ) at? 1+ at ; Terminal: dumb noop noop noop noop noop 2drop ; dumb \ Erweiterte Ausgabe: Schneider 25 Zeilen UH 06Mar88 &80 Constant c/row &25 Constant c/col | Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col : (at ( row col -- ) c/row 1- min swap c/col 1- min swap 2dup 'at 2! locate ; : (at? ( -- row col ) 'at 2@ ; : (page ( -- ) 0 0 'at 2! dark ; : (type ( addr len -- ) dup 'col +! 0 ?DO count (emit LOOP drop ; : (emit ( c -- ) 1 'col +! (emit ; \ Erweiterte Ausgabe: UH 04Mar88 : (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ; : (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ; ' (emit ' display 2+ ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! \ Erweiterte Eingabe UH 08OCt87| Variable maxchars | Variable oldspan oldspan off | : redisplay ( addr pos -- ) at? 2swap under + span @ rot - type space at ; | : del ( addr pos1 -- ) dup >r + dup 1+ swap span @ r> - 1- cmove -1 span +! ; | : ins ( addr pos1 -- ) dup >r + dup dup 1+ span @ r> - cmove> bl swap c! 1 span +! ; | : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ; | : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ; | : (back ( a p1 -- a p2 ) 1- curleft (del ; | : (recall ( a p1 -- a p2 ) ?dup ?exit oldspan @ span ! 0 2dup redisplay ; \ Tastenbelegung fuer Zeilen-Editor Schneider UH 08Oct87: (decode ( addr pos1 key -- addr pos2 ) &243 case? IF dup span @ < 0=exit currite 1+ exit THEN &242 case? IF dup 0=exit curleft 1- exit THEN &224 case? IF dup span @ = ?exit (ins exit THEN #bs case? IF dup 0=exit (back exit THEN #del case? IF dup 0=exit (back exit THEN $10 case? IF span @ 2dup < and 0=exit (del exit THEN &252 case? IF (recall exit THEN #cr case? IF span @ dup maxchars ! oldspan ! dup at? rot span @ - - at space exit THEN dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ; : (expect ( addr len -- ) maxchars ! span off 0 BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ; \ Patch UH 08Oct87 : (key ( -- char ) curon BEGIN pause (key? UNTIL curoff getkey ; ' (key ' keyboard 2+ ! ' (decode ' keyboard 6 + ! ' (expect ' keyboard 8 + ! \ No newline at end of file diff --git a/8080/CPM/startup.fb b/8080/CPM/startup.fb index 0026e26..a68c375 100644 --- a/8080/CPM/startup.fb +++ b/8080/CPM/startup.fb @@ -1 +1 @@ -\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr include see.fb cr .( Decompiler loaded) cr include tasker.fb cr .( Multitasker loaded) cr include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86 \ No newline at end of file +\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O \ include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr \ include see.fb cr .( Decompiler loaded) cr \ include tasker.fb cr .( Multitasker loaded) cr \ include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86 \ No newline at end of file diff --git a/8080/CPM/volks4th.com b/8080/CPM/volks4th.com index ccf8f4bbfe837472292dac04a7dd01c03ad02c47..a7d206065fadcd17c4db8d08ffbfe926e83f9aba 100644 GIT binary patch delta 6696 zcmZ8m3wRUPl^)I9(a6^V$qzsl2K>avvBA8`%fVCerW2Y+V*U$t9LPN;5(2zEvC8Qg?!70U1@}%*eGh>rv z<-U=y>}#b&3(GM*?}Lww>m^0(n^#8WlvZ=D$<1udB0ivmBf6dk%2@dp$IRA- zzJ?VIyBqQw-d1RX@pAQd9j(C+s+Gn?!I9pj`7B$h7`vBm2lipn(wS}bi?e_S>GTD*c%B$W{AuTk)0s|u+I=3GekN=baM0^ zpUpSn6&Q{#7j5E%mjQIUXp<(qHb8Zv%|GE~0X2&@dBV#9>JV*;#p@PXrOYDUCE8jn z;y;UQ3n-EKuVRW-G>iLfkyErO@*|?He!@$DaZt1cC%inMpNY1n39lW{FGWs^fHTA| zh-?HLApEUpiy%sS@5sv+D?O*PJaLjQGURiLfcAzp^Z%Kw=AUC*ss-Sa z&^JUbq-x`UsUmUpL492OCqi|J^(*7zbwax&RtEGjp}i6p4oc&qKk`XQ2V&}9HGY~ zHVo(_p{G#^o_|Z|YoG-52SVSHIH}1uE-oSTU5Sh6pj}1i`=|w2ODLQ2lZb}heMsmG zKWWtw|Ao*zKNr^2aq&$;OA*TB;{Os_?PtSHBGR|xF}w+P=O^lq7x zG=QHFdcRB}^{Jr0Mk*ro8#0l6!C;Ma8m0gusz-eVq5HwN?yHfO5&C19gFtJfwS@j$ z<{Fx`8flc!=KzM{Sn~11CTg++6y_CvZolr(;We>NsXDB(wRAq z4FS8Aiagy5mY8zOV(Kv?d3q?o1zV>rE+JpUtmNtQ0k)$f?JYHhKLps?&a`*h_BM!M z%NI+<0l}jGJsRL@vB8G{50CAII<~VG+k5!iOdoSVVLEgP1HuW}!{^r_uN>6i`h<)^ zZ5`K%txm{jw9}xmAdr`$@j7muv^MP>5PI3~$(!p27NGH~btELW!ua1`fvxRyZyg`T zO`7)Bvi~LjSbW1@#vc`p03w%wsFvMpGWXXJNJ`Bj9uS%ux)Yih#^-kp6_t|{%ez)Q4A%u^m@ zr+>=q4B?!QK~zh^D%?^U!#STpDJ7|Jm3d&`3^SXV@V=&S&KDJ~+z0(Uue1oi$nfz0 zJ@s5=KdYQ4cPZ%VfN&O*V{DEm+@znYh*xp zh*HMmZe03Ps?rPvHaO?31d`mOK%Ya<^crbg3YVEvYv9VIaN7GvWsu-TN2i^prKf?E z`*9<1d~c3owE_7-jtzNTa~np)mT1{wxQPu4I*VsY)x zoecuGv-aJKg6=G&*-RPVlQl@TgYWMsF5wcFKw;hu>e4yt>yuEJCx?NJ!VCI@!(a@D0OfxbJ5t1LJd1W9?L+?MuMD!rv2R2R~ZCf6!i zFmEhzllA z4|9OSMRYT(?5Bf6!jN#qj+XP~*u8CLUyz_*T*^;^sE9WiE1HUmO~J9XiAH=eInov} zgV-Kqro_(#VRt$hs5{|fbN^?P@mSORd5%9cWypR-SHotrgH4PjeKvNxGXq*+GdBCf zCW8&##;yq&OG1k(dO|{2)`C6>c43@XBs){OHaTmsJgtScAqU1PsR8)Pns#C*( zC96!)B_Im>(NJPNPSPa{og*J0{v%%Od|Xpnrr1Sa4@c=nnkbZSk^ZQP{5 z*l=6ud3@S?L;I5uGCkhVuHHg}8I0nwD|(Nwf8dW^5JYFQ|8g_L-XF5sQIshXiq|^*_`LrnM-% z541u4R05r@hB?Yv^Z8%Mm?Ja9n5^){QrHPpT+>-0&q306~#T=T|NQJb*6Nf)J6vh zE`4ou7@osq9mtP>ybk2)9JScftZA#Y4U*v@;oC*mh_(5W;WM9=XjqD(At$@q*cJ6| zJO<7&x@7o7w2ViGdmP`f_O`)3e+81q&fJV% z;+jBe5iq>9$_rYha=a3+#hX#%<7m;msIpc$+FYkpnhlfT^W~F*GltG8l{#Z>tju#W z`q}x|AG3lQj2ZXE3fXkb_~qf1aPwG`5s%$k;dI3;n=m$+m&XB8qBTx{!^Ct^lT zOFp}%#b|F?lCqMr68d~rI0${dTvf*Jt-c0>&%%?VdAD$}$S!`lJ9%f}y6hZB_?iRz zc%aDg=0ETEKX-Uv16wNxGtjbe|ZM^}KQQAL(PDDf#^@8+h8SEwq5Kme7ZG@S#b22+E#eI zbvBcimne?CI$FgR=g&HJd#bH4M~4e^!n+er`i?d$%b#{HiwqJdqR7)QY0DzRq^qrr zAB+vdWL*^y?+1Kv3J*Yrod?E%Pz6uiK9iH?t#PUPP}^1WQa#i*2uHNFdM;Q!yu)@E zA8PxP&opmtdqKmc6eE3PdD|Ltqzy|bTp(wL}aEFJ-GK4at9ae3D><9P_P(yIJIdPoW!yP#ees^)Y0~>R> z>*6*k?adw%=EPCd;x^Ih$Ec3W?0s?LtMN7Se;B{FI0z*HR7eP+h+0D*f@=Q?jgz0p zjaTBEY))foXHLr5iDiY!u;REv7n!O!w1zk5+=n~x?F-(A&#@;94(3Xo=x7!=`h6Ua zMZ!Ed1H7L#t0H@DBF_4wSY^RC3_t2Lzh*!ur#e|bjAX2&bSAFJ1Lat({HT*5Tim%n z=;T7{;kBrYFXQn|CC(qYYU441M9$YJ=B0uP)n4>qyo%1H-&+cTx^ z@}Pg4Bc9Bh{wCgh$?EA~rsb&@L}8Bke}GKmr(gLE`&81{es9Ut{Xg=OW)T1Y delta 11638 zcmZuX3t&{$m3Q8|?~_Mh1`=TMAYt->86X1z)5cFE%r}{2GV?N@d>|hZG9k&#Bq0g5 zR@=c{yU+^QGL>2?QsWkd3SEQ7N)fH7_yY=db*pGgZApa|4Y>X#d(L|^$hw;l-uc~g z&pr2^d(XM=ZG29*@w~2>9JMVaN5_|tqc<)6_-Nfw4*ZaJ$@p^{2$9H94#@Q;`M>BlR%q(Qel^Bl|E$S`3gl*7M!(5Jh1nl39juFqqK)($488%mQVL&lV4 z%y|R5!s83&e3DcQMqSpy9>a)EXFQlW<7t+8al^smGpBOQ{<+CB@+tblhLH^iADweu zhW?EWt;`$qsS^PDESNjR?eV(6ZcX4PD@h7h1s=U#PJU4#C00N_vB z#FIAZq%D&be`V9zCS-xI;(yz8_6ZsKXT?dI&M_hD0LrlIoD(twP?lZinvhw5a_u?~ z2m)lbGaj=hxXi9=&;-lvOal;6(hYn?6Roqe9wjB)Y}Zvy$P@&+?KGICj>IDgvz!+FQ{ ze}vyj*v^7ZD(D)dXb8EBM~(Jo{B#MB0&E|#ea9Oj#}G(`%)?%aInD;P|K+J zBvJvapyG258dR{mPpNnkx(gxvE*0MbZHj-t{m)b!N6@w3{&y-~0>!n7{q|3&_@#q& z+Ca0Jih`51Ih{xB8>u)0LB|pMW-8`7*>J%#e)X6G-<&^z*R2*?qB^<0eWq+QE`<*Q89;fWbzyl}@>NxO#lX{)l ziv%73JHnw0_Se7xPR8TAV1J8>=WtA(3-%YN_yK^91i&Y#_&JUbz}KnByI_0(zC*?7 zE*Kwx=cqW>1>*zoA{EUp7$1NiQE|D8btnK{q2kRh8m#gB}Kb;x$bzMP6N7Yl}7u_tb%;n3$ccX7)O)USRC)qKk`sH} zthX`E(hKjXQOSw_>Sk829+SsanVoK?qGe1@^Bw{ec< zgqT;!-sHG(Ox`W@Fsoe)D|gRB<_(q9=W2xUe_V>KdC_0V1#pp$$ra2xSIoZ4Y34TC z!)}E10zwsxUzJ=_Ng*l~O>m>#%jpFa+vMD6H*y-37X4vm4!EvyOfKWYZoOaxQ4}Fm z5UZ2ZDra9Wo~(4;geM5v_l?X~48_LDSwEQfw^9`OdnLcZYqPt&V{*jMW9-Z^a$60@ zgyigTTe79HI3dz1F2x_WO|8O4I^J6)HF|syK-!_U%0@I)Jzn8hT=@!ll^iE0)I$*e zt5}Kub3}cRP>!jVk=9gkAy=Rly!N$&YIjxopkk!NFRL<8%Hy+nL2`$zZuYyY@PuQe zm#a8OIN2?|26-gbD7!iZVv1rKLYY?bO%?iNt8NR@m8=%FSB=w@z*=Mvp5Y?mZrG}J8H zFZrbmSn;g%KFGLgJ<#V~XnBd&EQ7;M%Bp59j=-3FpJ#;P%150oDraFewHTbZGIjv( zH(~)jE$m4C#IvDnq`Hjns>b8CjNf<_ZV+sqKWJ1glXg^((5~sDV2LKnOOE8q>fG!G zk6t*(W{Fv$%zP=6n7IOKORldrw!Bz}AHaxFS1VZC zA!66BTF+Sp=^v9gmxA<{8fvL=HI2#dSM|*Qq$FSZZ1T&h>EIq6pY6>|uS_ir`m0Eq zpk;@K-{Gpi`UB~lmfZ0~&G8_8xk1_vKDa0~({m*_QRq^mVZe*e*O?bhPi5~Go-VW$ z{k~A6?I}4|k|nM_SAqh+@RDp=vHTm|cdGJfH1-wBl*O+>5+&DS%d7A7ViV@3sn9) z5P!0}cHttcUkJDqugw90*vxIuxI+(tH>1(d*}XPj&6wO(Xf+_E&!7BlZ85XapM0-& zuKs|Z*LuBo?!KmdP04KE(rKB>*@f!Q(PGA^BDul8cb-d^Z|F&O~)SjmW?YVbt z3Mf~yL<6VS3-Fjf4V7pDNEc`7kML&hgqTXRH4YkHSs3H=3vjF3S)i3C+ZE(a$a>fi zbr1_?uBa{<^_%rYb-43piMKDZe#;892mCXA7N8Z^)z%f)Y2)iqjGU#esO}<f7ixGqVR!c0q@n=h(sw@Qjr zNnWSSFJS^tsr=v6jZh|#C2}a7m(2y&4i=hF=P_Yj(KB^fqJ)gYb;-@jlI-(!>A0O4 zSRX*g`IO|#%7U5bbsV&tA20eD>?|hItDH}Ab@|NWfuyCbaPb!bIH(Oyb#lDi9^S~| zY8jIsuEPj11QGrs&`dMw7s*@dmL$FiOau-JpHBbKYV_cih3#W-D8Sw{e}v`=X6|jF zT=+np=6?--U$y1ox=i|j<(WE^+7$!?Qqbk1UIh<`i_%y2Tk0;uGAUPGfTO*y=;6Ab z@cEKJ^0Ju?eN*$Y#dv>bPghT*(-KUU1ZF1=*S#&wRQowx_rX=&d!Dgq5W4FYb>TIJ_NrrVRJJR(_%--D${yfn_z$X_ zQRNnFoshQ%uo*Z{`KG^7Rk$UjiD2WsLPo0jbIKl-`(B_Cs9tV6$Yb}1LtTZ9N{niq zWQ3aOVVHY#|KX5Ee-)xDl*2*7J|=${Itp7Bw)-sfWpImFeYU_5>* z8)C8VD4&JKi|){m7kwDIq)rYEA66rjhE<~>0*~;>`z(aEYg7JV^6p?xVryVas3MH^ zr+d6LobE9ZZV)~U<-(HQB0{%oyW0n^?Y2>Arim~NM7TAqb^C)bnm#7~Agm4jw8}|@ zn<)+qIk$#!rp^{jPbo{NgNVcjhHrf@a5(gG7`=jlqXiE}Ma1$OnAp?vM=4)FLUEDs z^`r0{r3~OZ0cQYD2e>AkmP&KAWnl^K749y$M73pV37!`2&b|hf>XDH(vQ`f?Mm8e-34@MCOFNEo)4kgk0ij=<~}eBjiD2auWo`35YhH9IZdc)&kZbpgmt! z-BtH~)$_&qaIPG!PnL!Ya*duZtG*wQJnvU&y3bf9h1cp)+51&eawu$09Ie0B0g(pH zik{TdXjlomgYNb$QQ2hO!*41?HCx!2^$`2rhBDZf4zYRx)`3;cRXDWi5F4ZI)(3&F zcBuwju7LX;%I9TET|IrBH{uC;`-XFqMwttrz*+&|Tjb;w*#QhK#76#+@ z12~0GHEx1YQSwG3?qh=V`Xr&o8N2G7$=e#{=_{IOA>^tPa)RW{*jS(3+fbb7YvKwa zd4no;9+79<*EGfE2zmUzkj?IOg>puf=aj?Bt4dk;*>Es?CcHF!DEwFmfA@r54c!vD zKV%B^hUV7&LHUO=rRkoaJLC&JP~TYJRX@-?wT6&IoOu^e|8D*72fE zg?+2uPN+x0l2v!r;iP4RV)V178^9{eZgGOJAv$z$)mM$P#93~bWyyo9+vvHvwsA_b z%JBH!E&MVACuU|q+sY?}U8}SW{)tt%!4sM{qrFK7MLr}f8C+@b%T-HOHCVr_x~=Z} zYLmPfS*vxho$eKW=to7R%IwvI&YQ7pwUkQLLatgo`aTdo4Spc}%7?ZtSyemzMN?N{ zMV8U9p+PV3hOR<k9}>piZ9F?r`|9A$So5>3BnPM#%5?rn1TtKB8h* zQ{9b6$#dj+@&Y+VUL-G(ms4q?L^i4kurAxw%&9Hzoy(PWmv+CEd}vh(KhQi}cvo}s z?NxH(XU#g_m^{$@z2<|$rb06}LQmzi$+<9tO!m{wIww|IMsA?l2uVp79Nc#`>jg|a zPkel>p(L^^rph^HDhBon{ClK(AR%zM$FivvuoX87hXtCK=`(z+~h5* z%NScr^4F_x$m?ktF4Q<8f{^8XRi%8lCCN8;B>vEXeXBf3^w6G*(ls>A#Ea5|D%K3W zz~x8wnr5t*;YtGwn?2c6T2bvxXn9`??#poFJr(+T4HTpFf)>UZ#-tE#iDIqlRS}Yt zt&G!qGv=}Lr{QdEvtWJ|YyE1YPM=uXb8}l7|6A*dqsy(#qCY0Lwd6AUT9f-*@^qJz zueQvwRJP?$P8OVPU1Vc?h3>)v8?)&7)=qbNxB|`Gv829rX5y7rT;mek zFR|+`EIQkI`{OS+x83-9>qE~z+qUSX*1~TeezUpl*4D9dEt;H;6yo_T4Ap zdGv+0UoU^XwIf>ad}}@-(C6_e^I9v$VF7uq^#kES_LbHbO~>F5_5q>0?Ja=z3U9Su zqFdNQY)9LcS?mP3@2~I|C@8hQ1x<0eoJ>C18k#x1Z4~G+c9a>VSz_Qe!=$jREm_c3 zvUKyBbL^zB(mF!5^0`88rhjFy0vn+k@BIZDPb3xc=Hwl1HzXphoYQ3wSB}ZOd7IaC zw{uEI0kWP9k|8pj3e+j& z88uKRSmgi5RYFH@czm&zvC zfw#a3Nr}A!@zkxAkt>Ba5BLIROny(h$igVx#^L`MGkGKz5&=9M;Pg%qGoQg-gj!>_ z@S~|1Z&?4PS2Lag{QPN;8MH%Xv;(7kOdjnhSD*X9meGz;YUU7n8X&9>aJ~^g2KZiK zUuqOy&d8mF_GZ-%H*7Px(B-}a2sS{nP(r+5#nXUkL;BHFGvLPnM>8|Yq;M?rqJ*8D z7BG0x$}!lv@Wu!sGgl7xk!H@n7H?N3g?Q%44qS}#)X!Dte4YQ(6hFaS6+p{B?>Mbm ztc@=hDkp8^Xt%xt>lB`x5YMs2F#d0K=t-71DM0NafmgH778Dyv_I7E%^cw6fPt1G8 z(AiN8wNlgCTi50a``7MY`vm;u0;OCyA>#kw%>>xKuj2!u0!A=GkFR}yE!MTq7l)y% zi<4Rviq71vI{doM?UEPvGW3g=L(kj@7<$di;k{BZV55MUxk=%tnYggf6PHBPW+30} zfHE^w!Sylmd?s`U6w#aH#> zjC^&vq_Hv>TfQ_EN z7E_y?!JT98E7E2j^;;sj!p)s&ycvo~eG31m(`YE;S3-SXun07|c})yz%$rOnQY!}S zOJEN&fk+fr_QG(mGikNMU#q~2+ZNN`JGFKnbz*lBK|3xr+TT0VTzf~GTnsUx(Z30p z{TeLIMKkRkA9WT(6r?3TN_5&&=(jpJ63;xA`O{2hsywx`<5c9I@cSqD#fAr9R&i$c z3I`yd&^1PGcGvu_^w{+s`BIiP6;8h^xWZH{2&$ub^-f+Lb7x05;)-0?bzRrz5&ZFY zMIwpMBN<&8UAIRLMvg@`rMkl9_~TArhqfed?fPm-o=+`F3oO}U;AeI2QcXCO(+o!W zI^V5BqEMP4@R z88TJK5FzVO!ptSGXB?-OtB^6EW{?anFFV83Gh}k~cScO-SmdI6d9rxjITpE7fVrVB z+SmWBKD8q=w8g%mox|^g_iMh83H7FosJ8_?SPXp4UbRi)D}!+XjL8#nD5rVOGjlpS zGS(em_uje{>mutmfw9@MOzSucx&G)8$ z6tV?tT&YXPx7vw@rVpv>pCU&{;_1|xga?y$Z=6Z4S5GO%*x3y)O#RA%?nPeao8);& zT>b{obe`l~h~02usBjRl!uJ^CFT16n$5#pE4)llBvXz+>dZ2!XywZ5QJEJ!24SCYM zgWYK!YdqhbxKn{I72rA=GO&-m946P>02JLkW+J%1<3Uk6?GTGov=hJE3Qd zI3@=Q-t5lHo*HT&ike{I^beYDG+~YMQTHR=@M6w*M-SD;v0Hc#-eg6DEo{WFjl0bd zF&u)bqz14_f#~kgM+~?JlcQS=H82XCsIBlN#e?itpu?Gp1KA3nSd=B;6(oFV0myeD zfj!LNn~bfXBiREr66Un%MBey#j}(A(#UG+Y4z1Y*wuJr zaj)GB0=;>dd%1a6FA~GO99j)@h@9H?o<38lwFcHTxHkdsH}C87Rh~`UwnS`2SO$mCa6TW6ieZ5g0MFnM1 z7G6chqe48INW`O4c{Ou^?b;qL;BX5Z^Zh$i5QGGl*l9Ra@XVs7@PM#5iZ#}|+pr_vTNVJrb=fy+_40`L;R$K>kR1FE5Zpp>O3_p6llSdrp!*cxJ-JQSOsaCzZ{V`U7|$!IzJ z{x5%Nqft@icFQ19=Ruy{` zvGXzfnqy}y5#;4hV&Esm6?ilT2pi`XD*?ZhB#+MrnVvUPF35?=8l_25_3L{FUe`GE`> ze`TyWelGgQXqK4iir)#!1UV7saYf?W%xkma@+c&>aVKN4Tj_xt!?0AdgpJ9KeVgMz zNyxE2NhRS41#dOFpcMa}J_Bz)wL4kume?OM1@G_c6T;xW%GfbDs^KJ8+Sf%)zJAlx z*v`HY*oM~?Wr**ABzsT{ee)`_1Bp?;o4e-t(B3XNGvu4cfno5rbxXB>L0j8 zXegIsdxf2SmuL@6>zKUFg0<0IeVEE??{rRx>7)&>hp9eTd)Rmn-1gpDt-OL6f~)0uBQ#k9YJ#i2&1wT`yUZ%H zPm`jfG^PF;?Tb^|4XXBwk`%>4G4ZvI^aJPxtt0(Fx}(Pj1g|F;f*eB)Y3QRtcxHgm z-&%JI_XrsrR)bUJ-1S0Gf$K9@U_!1NTEi(}uh%s0f80dK`8DDa$jd_EAP^n}!p8NY z#qAtkpKyhMa$zwcBkOsm3!H;3;L@ajy#x&$HEvCb0BsJeXFb^dy?KNjUJut6?h3$; z0d`_NBz|hi5CBRYP%f{}RF6jZ_7rXofLH`Xeo&}Tl>*)b3g2BXC9X;VZ3f7^wMI~E z0nBd4{RHrr*JQxQO>RGIok01QrSO%@;546q3EoJ++j2-Zf&BYCh}FSNAJ~eywXYHl zI{?J?LA7!k_wN8?c<`FaX59a8KzcHenf6+DET0Nc~J8EyiMws0fOToxNwL=5@5#x`}Z|mzzz@*)_TUSsfdS0>bbNR?GyUzWmh7DDC22zH8{J+KCD;DURzJ?2 zmfW}ICFZf=